aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats')
-rw-r--r--gcc/testsuite/ada/acats/elabd.lst5
-rw-r--r--gcc/testsuite/ada/acats/floatstore.lst1
-rw-r--r--gcc/testsuite/ada/acats/norun.lst2
-rw-r--r--gcc/testsuite/ada/acats/overflow.lst17
-rwxr-xr-xgcc/testsuite/ada/acats/run_acats.sh71
-rwxr-xr-xgcc/testsuite/ada/acats/run_all.sh407
-rw-r--r--gcc/testsuite/ada/acats/run_test.exp13
-rw-r--r--gcc/testsuite/ada/acats/stackcheck.lst6
-rw-r--r--gcc/testsuite/ada/acats/support/acats26.lst4332
-rw-r--r--gcc/testsuite/ada/acats/support/checkfil.ada197
-rw-r--r--gcc/testsuite/ada/acats/support/enumchek.ada65
-rw-r--r--gcc/testsuite/ada/acats/support/f340a000.a149
-rw-r--r--gcc/testsuite/ada/acats/support/f340a001.a75
-rw-r--r--gcc/testsuite/ada/acats/support/f341a00.a216
-rw-r--r--gcc/testsuite/ada/acats/support/f390a00.a94
-rw-r--r--gcc/testsuite/ada/acats/support/f392a00.a200
-rw-r--r--gcc/testsuite/ada/acats/support/f392c00.a267
-rw-r--r--gcc/testsuite/ada/acats/support/f392d00.a103
-rw-r--r--gcc/testsuite/ada/acats/support/f393a00.a245
-rw-r--r--gcc/testsuite/ada/acats/support/f393b00.a101
-rw-r--r--gcc/testsuite/ada/acats/support/f3a2a00.a81
-rw-r--r--gcc/testsuite/ada/acats/support/f460a00.a90
-rw-r--r--gcc/testsuite/ada/acats/support/f730a000.a107
-rw-r--r--gcc/testsuite/ada/acats/support/f730a001.a76
-rw-r--r--gcc/testsuite/ada/acats/support/f731a00.a66
-rw-r--r--gcc/testsuite/ada/acats/support/f940a00.a97
-rw-r--r--gcc/testsuite/ada/acats/support/f954a00.a134
-rw-r--r--gcc/testsuite/ada/acats/support/fa11a00.a73
-rw-r--r--gcc/testsuite/ada/acats/support/fa11b00.a110
-rw-r--r--gcc/testsuite/ada/acats/support/fa11c00.a112
-rw-r--r--gcc/testsuite/ada/acats/support/fa11d00.a78
-rw-r--r--gcc/testsuite/ada/acats/support/fa13a00.a171
-rw-r--r--gcc/testsuite/ada/acats/support/fa13b00.a106
-rw-r--r--gcc/testsuite/ada/acats/support/fa21a00.a127
-rw-r--r--gcc/testsuite/ada/acats/support/fb20a00.a101
-rw-r--r--gcc/testsuite/ada/acats/support/fb40a00.a81
-rw-r--r--gcc/testsuite/ada/acats/support/fc50a00.a92
-rw-r--r--gcc/testsuite/ada/acats/support/fc51a00.a99
-rw-r--r--gcc/testsuite/ada/acats/support/fc51b00.a62
-rw-r--r--gcc/testsuite/ada/acats/support/fc51c00.a112
-rw-r--r--gcc/testsuite/ada/acats/support/fc51d00.a82
-rw-r--r--gcc/testsuite/ada/acats/support/fc54a00.a132
-rw-r--r--gcc/testsuite/ada/acats/support/fc70a00.a117
-rw-r--r--gcc/testsuite/ada/acats/support/fc70b00.a133
-rw-r--r--gcc/testsuite/ada/acats/support/fc70c00.a100
-rw-r--r--gcc/testsuite/ada/acats/support/fcndecl.ada50
-rw-r--r--gcc/testsuite/ada/acats/support/fd72a00.a84
-rw-r--r--gcc/testsuite/ada/acats/support/fdb0a00.a144
-rw-r--r--gcc/testsuite/ada/acats/support/fdd2a00.a149
-rw-r--r--gcc/testsuite/ada/acats/support/fxa5a00.a121
-rw-r--r--gcc/testsuite/ada/acats/support/fxaca00.a144
-rw-r--r--gcc/testsuite/ada/acats/support/fxacb00.a107
-rw-r--r--gcc/testsuite/ada/acats/support/fxacc00.a115
-rw-r--r--gcc/testsuite/ada/acats/support/fxc6a00.a162
-rw-r--r--gcc/testsuite/ada/acats/support/fxe2a00.a90
-rw-r--r--gcc/testsuite/ada/acats/support/fxf2a00.a96
-rw-r--r--gcc/testsuite/ada/acats/support/fxf3a00.a330
-rw-r--r--gcc/testsuite/ada/acats/support/impbit.adb6
-rw-r--r--gcc/testsuite/ada/acats/support/impdef.a385
-rw-r--r--gcc/testsuite/ada/acats/support/impdefd.a69
-rw-r--r--gcc/testsuite/ada/acats/support/impdefe.a58
-rw-r--r--gcc/testsuite/ada/acats/support/impdefg.a90
-rw-r--r--gcc/testsuite/ada/acats/support/impdefh.a102
-rw-r--r--gcc/testsuite/ada/acats/support/lencheck.ada60
-rw-r--r--gcc/testsuite/ada/acats/support/macro.dfs300
-rw-r--r--gcc/testsuite/ada/acats/support/macrodef.adb11
-rw-r--r--gcc/testsuite/ada/acats/support/macrosub.ada548
-rw-r--r--gcc/testsuite/ada/acats/support/repbody.ada330
-rw-r--r--gcc/testsuite/ada/acats/support/repspec.ada149
-rw-r--r--gcc/testsuite/ada/acats/support/spprt13s.tst67
-rw-r--r--gcc/testsuite/ada/acats/support/tctouch.ada265
-rw-r--r--gcc/testsuite/ada/acats/support/tsttests.dat38
-rw-r--r--gcc/testsuite/ada/acats/support/widechr.a294
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a22006b.ada38
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a22006c.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a22006d.ada41
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a26007a.tst48
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a27003a.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a29003a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a2a031a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a33003a.ada49
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a34017c.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a35101b.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a35402a.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a35801f.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a35902c.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a38106d.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a38106e.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a49027a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a49027b.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a49027c.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a54b01a.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a54b02a.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a55b12a.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a55b13a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a55b14a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a71004a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a73001i.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a73001j.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74105b.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74106a.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74106b.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74106c.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74205e.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a74205f.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83009a.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83009b.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83a02a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83a02b.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83a06a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83a08a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83c01c.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83c01h.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a83c01i.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a85007d.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a85013b.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a87b59a.ada250
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a95001c.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a95074d.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a97106a.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/a/a99006a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/a/aa2010a.ada199
-rw-r--r--gcc/testsuite/ada/acats/tests/a/aa2012a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ac1015b.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ac3106a.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ac3206a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ac3207a.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7001b.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7001c0.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7001c1.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7001d0.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7001d1.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7006a.ada47
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7101a.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7101c.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7102a.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7103a.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7103c.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7104a.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7201a.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7203b.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad7205b.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ad8011a.tst64
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ada101a.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae2113a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae2113b.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae3002g.ada47
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae3101a.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae3702a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/a/ae3709a.ada56
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23001a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23003a.tst104
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23003b.tst103
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23003g.tst129
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23003i.tst71
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006a.ada48
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006b.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006c.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006d.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006e.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006f.ada57
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c23006g.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24002d.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24003a.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24003b.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24003c.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24106a.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24202d.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24203a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24203b.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24207a.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c24211a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c250001.aw167
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c250002.aw213
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c25001a.ada211
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c25001b.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c26006a.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c26008a.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a001a.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a001b.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a001c.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a002a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a008a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/c2/c2a021b.ada44
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32001a.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32001b.ada249
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32001c.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32001d.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32001e.ada253
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32107a.ada363
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32107c.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32108a.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32108b.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32111a.ada282
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32111b.ada282
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32112b.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32113a.ada534
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32115a.ada338
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c32115b.ada376
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c330001.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c330002.a326
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c332001.a226
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340001.a470
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34001a.ada186
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34001c.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34001d.ada209
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34001f.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34002a.ada265
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34002c.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34003a.ada260
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34003c.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34004a.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34004c.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005a.ada410
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005c.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005d.ada425
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005f.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005g.ada423
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005i.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005j.ada482
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005l.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005m.ada353
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005o.ada277
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005p.ada405
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005r.ada346
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005s.ada404
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005u.ada408
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34005v.ada336
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006a.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006d.ada238
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006f.ada228
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006g.ada199
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006j.ada311
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34006l.ada345
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007a.ada181
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007d.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007f.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007g.ada350
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007i.ada213
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007j.ada258
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007m.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007p.ada283
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007r.ada218
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007s.ada299
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007u.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34007v.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34008a.ada226
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009d.ada226
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009f.ada256
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009g.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009j.ada225
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34009l.ada270
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34011b.ada343
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34012a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014a.ada256
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014c.ada259
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014e.ada257
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014g.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014h.ada208
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014n.ada256
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014p.ada258
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014r.ada257
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014t.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34014u.ada212
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c34018a.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340a01.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340a02.a221
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a01.a117
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a02.a145
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a03.a140
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a04.a141
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35003a.ada234
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35003b.ada217
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35003d.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35102a.ada364
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c352001.a270
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c354002.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c354003.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502a.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502b.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502c.ada318
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502d.tst84
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502e.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502f.tst89
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502g.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502h.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502i.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502j.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502k.ada174
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502l.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502m.ada177
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502n.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502o.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35502p.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503b.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503c.ada543
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503d.tst97
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503e.ada212
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503f.tst132
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503g.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503h.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503k.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503l.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503o.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35503p.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35504a.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35504b.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35505c.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35505e.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35505f.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507a.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507b.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507c.ada360
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507e.ada194
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507g.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507h.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507i.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507j.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507k.ada224
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507l.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507m.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507n.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507o.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35507p.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508a.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508b.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508c.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508e.ada192
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508g.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508h.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508k.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508l.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508o.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35508p.ada131
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35703a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35704a.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35704b.ada62
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35704c.ada62
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35704d.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35801d.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35902d.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35904a.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35904b.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a02a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a05a.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a05d.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a05n.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a05q.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a07a.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a07d.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c35a08b.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c360002.a268
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36104a.ada359
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36104b.ada421
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36172a.ada250
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36172b.ada161
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36172c.ada58
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36174a.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36180a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36202c.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36203a.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36204a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36204b.ada229
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36204c.ada221
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36204d.ada598
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205a.ada212
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205b.ada169
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205c.ada165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205d.ada180
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205e.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205f.ada165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205g.ada165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205h.ada166
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205i.ada167
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205j.ada180
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205k.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36205l.ada288
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36301a.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36301b.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36302a.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36304a.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c36305a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37002a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37003a.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37003b.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37005a.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37006a.ada272
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37008a.ada270
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37008b.ada232
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37009a.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37010a.ada140
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37010b.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371001.a388
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371002.a364
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371003.a474
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37102b.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37103a.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37105a.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37107a.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37108b.ada247
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37206a.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37207a.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37208a.ada172
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37208b.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37209a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37209b.ada194
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37210a.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37211a.ada242
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37211b.ada495
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37211c.ada426
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37211d.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37211e.ada233
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213b.ada241
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213d.ada240
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213f.ada379
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213h.ada457
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213j.ada320
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213k.ada324
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37213l.ada329
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37215b.ada203
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37215d.ada202
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37215f.ada313
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37215h.ada345
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37217a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37217b.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37217c.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37304a.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37305a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37306a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37309a.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37310a.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37312a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37402a.ada253
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37403a.ada186
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37404a.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37404b.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37405a.ada161
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c37411a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380001.a128
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380002.a72
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380003.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380004.a385
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38002a.ada420
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38002b.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38005a.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38005b.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38005c.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38006a.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38102a.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38102b.ada56
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38102c.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38102d.ada54
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38102e.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38104a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38107a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38107b.ada194
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108b.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108c0.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108c1.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108c2.ada47
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108d0.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38108d1.ada47
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c38202a.ada197
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900010.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900011.am253
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390002.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390003.a419
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390004.a404
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900050.a157
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900051.a137
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900052.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900053.am191
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900060.a159
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900061.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900062.a137
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900063.am138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390007.a374
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390010.a216
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390011.a250
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006a.ada207
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006b.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006c0.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006c1.ada41
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006d.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006e.ada213
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006f0.ada44
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006f1.ada42
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006f2.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006f3.ada49
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39006g.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39007a.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39007b.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39008a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39008b.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c39008c.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a010.a127
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a011.am218
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a020.a90
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a021.a133
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a022.am179
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a030.a188
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a031.am167
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c391001.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c391002.a493
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392002.a349
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392003.a453
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392004.a189
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392005.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392008.a401
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392010.a512
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392011.a299
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392013.a179
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392014.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392a01.a265
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392c05.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392c07.a190
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d01.a324
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d02.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d03.a248
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393001.a407
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393007.a157
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393008.a204
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393009.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393010.a306
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393011.a220
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393012.a221
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a02.a213
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a03.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a05.a166
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a06.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b12.a131
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b13.a105
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b14.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0001.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0002.a142
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0003.a144
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0004.a115
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0005.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0006.a163
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0007.a234
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0008.a150
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0009.a219
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0010.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0011.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a00120.a83
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a00121.a76
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a00122.am113
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0013.a347
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0014.a453
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0015.a267
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a1001.a315
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a1002.a251
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2001.a460
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2002.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2003.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2a01.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2a02.a396
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c410001.a303
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41101d.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41103a.ada239
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41103b.ada366
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41104a.ada240
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41105a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41107a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41201d.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41203a.ada241
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41203b.ada378
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41204a.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41205a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41206a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41207a.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41301a.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303b.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303c.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303e.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303f.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303g.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303i.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303j.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303k.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303m.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303n.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303o.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303q.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303r.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303s.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303u.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303v.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41303w.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41304a.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41304b.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41306a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41306b.ada217
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41306c.ada215
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41307d.ada255
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41309a.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41320a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41321a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41322a.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41323a.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41324a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41325a.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41326a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41327a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41328a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41401a.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41402a.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c41404a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c420001.a110
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c42006a.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c42007e.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43003a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43004a.ada350
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43004c.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c431001.a464
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43103a.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43103b.ada186
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43104a.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43105a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43105b.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43106a.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43107a.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43108a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432001.a512
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432002.a764
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432003.a594
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432004.a319
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204a.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204c.ada192
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204e.ada179
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204f.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204g.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204h.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43204i.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205b.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205c.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205d.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205e.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205g.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205h.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205i.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205j.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43205k.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43206a.ada242
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43207b.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43207d.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43208a.ada208
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43208b.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43209a.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43210a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43211a.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43212a.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43212c.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214b.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214c.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214d.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214e.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43214f.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43215a.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43215b.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43222a.ada49
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c43224a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c433001.a303
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c44003d.ada188
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c44003f.ada143
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c44003g.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c450001.a434
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45112a.ada233
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45112b.ada234
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45113a.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45114b.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c452001.a707
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45201a.ada242
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45201b.ada236
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45202b.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45210a.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45211a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220a.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220b.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220c.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220d.ada200
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220e.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45220f.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45231a.ada252
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45231b.dep265
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45231c.dep265
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45231d.tst274
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45232b.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45242b.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45251a.ada178
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45252a.ada200
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45252b.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45253a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45262a.ada214
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45262b.ada219
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45262c.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45262d.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45264a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45264b.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45264c.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45265a.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45271a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45272a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45273a.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45274a.ada222
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45274b.ada229
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45274c.ada187
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45281a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45282a.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45282b.ada347
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45291a.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c453001.a236
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45303a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45304a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45304b.dep111
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45304c.dep110
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45322a.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45323a.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45331a.ada357
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45342a.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45343a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45344a.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45345b.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45347a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45347b.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45347c.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45347d.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45411a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45411b.dep123
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45411c.dep123
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45411d.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45413a.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45431a.ada212
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c455001.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45502b.dep291
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45502c.dep295
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45503a.ada310
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45503b.dep327
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45503c.dep331
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504a.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504b.dep117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504c.dep119
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504d.ada214
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504e.dep234
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45504f.dep234
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45505a.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45523a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531a.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531b.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531c.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531d.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531e.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531f.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531g.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531h.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531i.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531j.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531k.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531l.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531m.dep189
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531n.dep160
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531o.dep189
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45531p.dep159
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532a.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532b.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532c.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532d.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532e.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532f.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532g.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532h.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532i.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532j.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532k.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532l.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532m.dep157
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532n.dep163
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532o.dep161
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45532p.dep155
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45534b.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45536a.dep158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c456001.a91
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45611a.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45611b.dep141
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45611c.dep141
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45613a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45613b.dep97
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45613c.dep97
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45614a.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45614b.dep128
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45614c.dep125
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45631a.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45631b.dep116
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45631c.dep122
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45632a.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45632b.dep94
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45632c.dep94
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45651a.ada246
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45662a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45662b.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c45672a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460001.a300
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460002.a330
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460004.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460005.a260
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460006.a378
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460007.a239
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460008.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460009.a467
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460010.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460011.a210
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460012.a93
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460013.a188
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460014.a289
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46011a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46013a.ada260
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46014a.ada287
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46021a.ada210
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46024a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46031a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46032a.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46033a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46041a.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46042a.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46043b.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46044b.ada235
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46051a.ada414
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46051b.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46051c.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46052a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46053a.ada139
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c46054a.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460a01.a408
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460a02.a413
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47002a.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47002b.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47002c.ada212
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47002d.ada273
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47003a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47004a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47005a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47006a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47007a.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47008a.ada299
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47009a.ada254
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c47009b.ada282
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004a.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004b.ada140
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004c.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004d.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004e.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48004f.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48005a.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48005b.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48006a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48006b.ada236
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48007a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48007b.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48007c.ada162
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48008a.ada345
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48008c.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009b.ada255
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009c.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009d.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009e.ada224
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009f.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009g.ada209
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009h.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009i.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48009j.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48010a.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48011a.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c48012a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490001.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490002.a239
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490003.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49020a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49021a.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49022a.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49022b.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49022c.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49023a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49024a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49025a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c49026a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a005b.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a006a.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a007a.tst47
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a010a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a010b.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a011a.ada334
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a012b.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a013a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c4a014a.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c51004a.ada261
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005a.ada177
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005b.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005c.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005d.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005e.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52005f.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52008a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52008b.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52009a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52009b.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52010a.ada186
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52011a.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52011b.ada180
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52101a.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52102a.ada251
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52102b.ada278
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52102c.ada280
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52102d.ada307
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103a.ada385
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103b.ada139
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103c.ada178
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103f.ada338
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103g.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103h.ada175
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103k.ada393
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103l.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103m.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103p.ada344
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103q.ada143
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103r.ada181
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52103x.ada241
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104a.ada343
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104b.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104c.ada178
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104f.ada292
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104g.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104h.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104k.ada347
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104l.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104m.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104p.ada292
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104q.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104r.ada190
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104x.ada222
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c52104y.ada174
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c53007a.ada139
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c540001.a410
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a03a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a04a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a07a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a13a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a13b.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a13c.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a13d.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a22a.ada68
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a23a.ada49
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a24a.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a24b.ada58
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42a.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42b.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42c.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42d.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42e.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42f.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c54a42g.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b03a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b04a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b05a.ada170
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b06a.ada313
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b06b.ada188
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b07a.dep126
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b07b.dep126
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b10a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b11a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b11b.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b15a.ada207
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55b16a.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55c02a.ada49
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c55c02b.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c56002a.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c57003a.ada334
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c57004a.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c57004b.ada162
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58004c.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58004d.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58004g.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58005a.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58005b.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58005h.ada172
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58006a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c58006b.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c59002a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c59002b.ada209
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c59002c.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61008a.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61009a.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61010a.ada246
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c620001.a340
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c620002.a509
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62002a.ada190
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62003a.ada234
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62003b.ada301
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62004a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62006a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c631001.a134
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c640001.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64002b.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64004g.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005b.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005c.ada330
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005d0.ada219
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005da.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005db.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005dc.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c641001.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103b.ada379
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103c.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103d.ada187
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103e.ada219
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103f.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104a.ada215
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104b.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104c.ada200
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104d.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104e.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104f.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104g.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104h.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104i.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104j.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104k.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104l.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104m.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104n.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104o.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105b.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105c.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105d.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106a.ada351
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106b.ada237
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106c.ada309
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106d.ada280
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64107a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64108a.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109b.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109c.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109d.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109e.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109f.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109g.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109h.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109i.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109j.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109k.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109l.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64201b.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64201c.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64202a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c650001.a412
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c65003a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c65003b.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002c.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002d.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002e.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002f.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002g.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002a.ada426
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002b.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002c.ada548
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002d.ada354
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002e.ada348
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67003f.ada319
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005b.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005c.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005d.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c72001b.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c72002a.ada229
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730001.a437
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730002.a383
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730003.a283
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730004.a327
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c73002a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730a01.a176
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730a02.a252
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c731001.a407
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74004a.ada375
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74203a.ada263
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74206a.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74207b.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74208a.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74208b.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74209a.ada224
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74210a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74211a.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74211b.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74302a.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74302b.ada308
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74305a.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74305b.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74306a.ada279
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74307a.ada58
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74401d.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74401e.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74401k.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74401q.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74402a.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74402b.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74406a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74407b.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c74409b.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760001.a390
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760002.a489
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760007.a247
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760009.a533
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760010.a418
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760011.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760012.a256
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760013.a108
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761001.a117
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761002.a245
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761003.a447
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761004.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761005.a288
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761006.a446
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761007.a419
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761010.a447
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761011.a410
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761012.a151
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83007a.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83012d.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83022a.ada338
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83022g0.ada165
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83022g1.ada189
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83023a.ada194
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83024a.ada185
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83024e0.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83024e1.ada220
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83025a.ada283
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83025c.ada345
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83027a.ada188
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83027c.ada157
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83028a.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83029a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83030a.ada234
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83030c.ada263
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83031a.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83031c.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83031e.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83032a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83033a.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83051a.ada397
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83b02a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83b02b.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83e02a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83e02b.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83e03a.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01b.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada57
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03a.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03b.ada157
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c840001.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c84002a.ada267
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c84005a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c84008a.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c84009a.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85004b.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005a.ada391
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005b.ada366
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005c.ada416
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005d.ada378
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005e.ada397
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005f.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85005g.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006a.ada681
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006b.ada699
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006c.ada778
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006d.ada712
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006e.ada702
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006f.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85006g.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85007a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85007e.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85009a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85011a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85013a.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85014a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85014b.ada192
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85014c.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85017a.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85018a.ada140
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85018b.ada288
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c85019a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854001.a277
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854002.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854003.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86003a.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004b0.ada44
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004b1.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004b2.ada46
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004c0.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004c1.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86004c2.ada45
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86006i.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c86007a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87a05a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87a05b.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b02a.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b02b.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b03a.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b04a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b04b.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b04c.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b05a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b06a.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b07a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b07b.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b07c.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b07d.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b07e.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b08a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b09a.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b09c.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b10a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b11a.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b11b.ada57
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b13a.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b14a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b14b.ada90
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b14c.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b14d.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b15a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b16a.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b17a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b18a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b18b.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b19a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b23a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b24a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b24b.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b26b.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b27a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b28a.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b29a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b30a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b31a.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b32a.ada199
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b33a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b34a.ada68
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b34b.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b34c.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b35c.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b38a.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b39a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b40a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b41a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b42a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b43a.ada60
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b44a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b45a.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b45c.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b47a.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b48a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b48b.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b50a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b54a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b57a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b62a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b62b.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b62c.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c87b62d.tst105
-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.ada280
-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.ada205
-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
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1003a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1004a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1005a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1006a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada33
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada41
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada45
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada41
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada45
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada37
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada37
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada39
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada39
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada31
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada31
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada30
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada39
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada43
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada33
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada33
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11001.a276
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11002.a238
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11003.a290
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110040.a90
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110041.a118
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110042.am130
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110050.a99
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110051.am224
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11006.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11007.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11008.a216
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11009.a246
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11010.a254
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11011.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11012.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11013.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11014.a302
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11015.a312
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11016.a321
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11017.a246
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11018.a366
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11019.a306
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11020.a238
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11021.a245
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11022.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada31
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada58
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1106a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1108a.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca1108b.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11a01.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11a02.a156
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11b01.a208
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11b02.a169
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c01.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c02.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c03.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d010.a119
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d011.a79
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d012.a73
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d013.am256
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d02.a393
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d03.a174
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13001.a370
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13002.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13003.a256
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13a01.a320
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13a02.a301
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140230.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140231.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140232.am139
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140233.a68
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140280.a77
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140281.a67
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140282.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140283.am91
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca15003.a161
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca200020.a70
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca200021.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca200022.am64
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada40
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada39
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada38
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada139
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada43
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada39
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada36
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada43
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009d.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada43
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada45
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca2011b.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca21001.a152
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada42
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada42
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada43
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada50
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada34
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada51
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada46
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada45
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada35
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada40
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5004a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada56
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca5006a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb10002.a128
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1001a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1004a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1005a.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1010a.ada179
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1010c.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb1010d.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20001.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20003.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20004.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20005.a210
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20006.a217
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20007.a196
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb2004a.ada245
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb2005a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb2006a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb2007a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20a02.a155
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb3003a.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb3003b.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb3004a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40005.a339
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4001a.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4002a.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4003a.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4004a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4005a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4006a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4007a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4008a.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4009a.ada114
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb4013a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a01.a135
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a020.a95
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a021.am103
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a030.a105
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a031.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a04.a119
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41001.a213
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41002.a283
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41003.a358
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41004.a324
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb5001a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb5001b.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb5002a.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1004a.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1005b.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1010a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1010b.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1018a.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1104c.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1107b.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1111a.ada322
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1204a.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1207b.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1220a.ada174
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1221a.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1221b.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1221c.ada195
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1221d.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1222a.ada290
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1223a.ada297
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1224a.ada558
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1225a.tst350
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1226b.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1227a.ada289
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1301a.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1302a.ada174
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1304a.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1304b.ada166
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1307a.ada54
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1307b.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1308a.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1310a.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1311a.ada480
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc1311b.ada332
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc2002a.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc30001.a219
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc30002.a349
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3004a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3007a.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3007b.ada397
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3011a.ada131
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3011d.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3012a.ada247
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3015a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3016b.ada396
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3016c.ada192
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3016f.ada186
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3016i.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3017b.ada470
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3017c.ada336
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019a.ada173
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada174
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada300
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada331
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada457
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3106b.ada207
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3120a.ada180
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3120b.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3121a.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3123a.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3125a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3125b.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3125c.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3125d.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3126a.ada188
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3127a.ada143
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3128a.ada358
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3203a.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3207b.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3220a.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3221a.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3222a.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3223a.ada114
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3224a.ada313
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3225a.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3230a.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3231a.ada177
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3232a.ada179
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3233a.ada175
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3234a.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3235a.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3236a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3240a.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3305a.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3305b.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3305c.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3305d.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3601a.ada251
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3601c.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3602a.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3603a.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3605a.ada381
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3606a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3606b.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc3607b.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc40001.a403
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50001.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50a01.a313
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50a02.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51001.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51002.a198
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51003.a187
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51004.a181
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51006.a224
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51007.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51008.a124
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51a01.a193
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51b03.a258
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51d01.a262
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51d02.a244
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54001.a184
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54002.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54003.a234
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54004.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70001.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70002.a241
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70003.a212
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70a01.a208
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70a02.a193
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70b01.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70b02.a222
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70c01.a187
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70c02.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd10001.a300
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd10002.a1198
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009a.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009b.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009d.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009e.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009f.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009g.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009h.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009i.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009j.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009k.tst94
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009l.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009m.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009n.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009o.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009p.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009q.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009r.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009s.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009t.tst77
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009u.tst84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009v.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009w.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009x.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009y.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1009z.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst82
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst100
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd20001.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada215
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada213
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada221
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada226
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada220
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada139
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada272
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada263
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada131
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada193
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada217
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada235
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst101
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst134
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada214
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada54
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst140
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst87
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada214
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30001.a284
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30002.a207
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30003.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30004.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd300050.am154
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd300051.c57
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30011.a155
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30012.a173
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3014a.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3014c.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3014d.ada135
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3014f.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015a.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015c.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015e.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015f.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015g.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015h.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015i.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3015k.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd3021a.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd33001.a139
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd33002.a140
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd40001.a181
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4031a.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4041a.tst92
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4051a.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4051b.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4051c.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd4051d.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003b.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003c.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003d.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003e.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003f.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003g.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003h.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5003i.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011c.ada69
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011e.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011g.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011i.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011k.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011m.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011q.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5011s.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012a.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012b.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012e.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012f.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012i.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5012m.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013c.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013e.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013g.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013i.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013k.ada78
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013m.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5013o.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014c.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014e.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014g.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014i.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014k.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014m.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014o.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014t.ada86
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014v.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014x.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014y.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd5014z.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd70001.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7002a.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7007b.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7101d.ada53
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7101e.dep62
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7101f.dep62
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7101g.tst70
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7103d.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7202a.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7204b.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7204c.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd72a01.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd72a02.a225
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd7305a.ada52
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd90001.a234
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd92001.a229
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cda201a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cda201b.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cda201c.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cda201e.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdb0a01.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdb0a02.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd1001.a94
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2001.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a01.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a02.a345
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a03.a325
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cde0001.a324
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102a.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102b.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102c.tst140
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102d.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102e.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102f.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102g.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102h.tst136
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102i.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102j.ada66
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102k.ada248
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102l.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102m.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102n.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102o.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102p.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102q.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102r.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102s.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102t.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102u.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102v.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102w.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102x.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2102y.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2103a.tst142
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2103b.tst141
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2103c.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2103d.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2104a.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2104b.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2104c.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2104d.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2106a.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2106b.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2108e.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2108f.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2108g.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2108h.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2109a.ada83
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2109b.ada80
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2109c.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2110a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2110c.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111a.ada131
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111b.ada183
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111c.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111e.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111f.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111g.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2111i.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201b.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201c.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201d.dep145
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201e.dep155
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201f.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201g.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201h.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201i.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201j.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201k.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201l.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201m.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2201n.ada123
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2202a.ada143
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2203a.tst121
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2204a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2204b.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2204c.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2204d.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2205a.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2206a.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2208b.ada185
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401a.ada357
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401b.ada347
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401c.ada268
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401e.ada172
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401f.ada200
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401h.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401i.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401j.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401k.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2401l.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2402a.ada161
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2403a.tst121
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2404a.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2404b.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2405b.ada157
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2406a.ada199
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2407a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2407b.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2408a.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2408b.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2409a.ada113
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2409b.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2410a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2410b.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce2411a.ada207
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3002b.tst84
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3002c.tst69
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3002d.ada61
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3002f.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102a.ada151
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102b.tst184
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102d.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102e.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102f.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102g.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102h.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102i.ada63
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102j.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3102k.ada98
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3103a.ada216
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3104a.ada231
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3104b.ada120
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3104c.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3106a.ada226
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3106b.ada220
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3107a.tst135
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3107b.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3108a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3108b.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3110a.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3112c.ada81
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3112d.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3114a.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3115a.ada232
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3201a.ada71
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3202a.ada57
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3206a.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3207a.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3301a.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3302a.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3303a.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3304a.tst204
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3305a.ada182
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3306a.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3401a.ada105
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3402a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3402c.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3402d.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3402e.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403b.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403c.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403d.ada99
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403e.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3403f.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3404a.ada94
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3404b.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3404c.ada165
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3404d.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3405a.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3405c.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3405d.ada114
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3406a.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3406b.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3406c.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3406d.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3407a.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3407b.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3407c.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3408a.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3408b.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3408c.ada138
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3409a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3409b.ada76
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3409c.ada188
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3409d.ada140
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3409e.ada115
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3410a.ada89
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3410b.ada77
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3410c.ada205
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3410d.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3410e.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3411a.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3411c.ada146
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3412a.ada149
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3413a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3413b.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3413c.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3414a.ada204
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3601a.ada187
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3602a.ada189
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3602b.ada215
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3602c.ada202
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3602d.ada150
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3603a.ada217
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3604a.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3604b.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3605a.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3605b.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3605c.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3605d.ada192
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3605e.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3606a.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3606b.ada97
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3701a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704a.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704b.ada107
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704c.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704d.ada169
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704e.ada143
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704f.ada365
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704m.ada198
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704n.ada229
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3704o.ada161
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3705a.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3705b.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3705c.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3705d.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3705e.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3706c.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3706d.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3706f.ada119
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3706g.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3707a.ada130
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3708a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3801a.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3801b.ada108
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804a.ada157
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804b.ada147
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804c.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804d.ada153
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804e.ada154
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804f.ada206
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804g.ada167
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804h.ada161
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804i.ada141
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804j.ada137
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804m.ada157
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804o.ada121
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3804p.ada206
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3805a.ada162
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3805b.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806a.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806b.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806c.ada197
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806d.ada129
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806e.ada159
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806f.ada194
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806g.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3806h.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3809a.ada239
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3809b.ada239
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3810a.ada114
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3810b.ada122
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3815a.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3901a.ada106
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3902b.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3904a.ada117
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3904b.ada142
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3905a.ada145
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3905b.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3905c.ada202
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3905l.ada311
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906a.ada110
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906b.ada133
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906c.ada177
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906d.ada152
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906e.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3906f.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3907a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/ce/ce3908a.ada140
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3001.a507
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3002.a318
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3003.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3004.a235
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4001.a230
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4002.a182
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4003.a326
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4004.a431
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4005.a683
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4006.a319
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4007.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4008.a662
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4009.a619
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4010.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4011.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4012.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4013.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4014.a359
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4015.a580
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4016.a685
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4017.a337
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4018.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4019.a1027
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4020.a688
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4021.a311
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4022.a531
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4023.a585
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4024.a350
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4025.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4026.a526
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4027.a342
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4028.a331
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4029.a333
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4030.a414
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4031.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4032.a457
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4033.a405
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4034.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5011.a471
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5012.a536
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5013.a326
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5015.a342
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a328
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a426
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a434
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a413
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a474
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a400
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a551
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8001.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8002.a285
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8003.a214
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa9001.a287
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa9002.a482
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa001.a279
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa002.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa003.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa004.a260
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa005.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa006.a285
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa007.a263
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa008.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa009.a290
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa010.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa011.a266
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa012.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa013.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa014.a178
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa015.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa016.a462
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa017.a400
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa018.a277
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa019.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxab001.a272
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac001.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac002.a426
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac003.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac004.a310
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac005.a347
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaca01.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaca02.a360
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacb01.a264
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacb02.a421
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacc01.a299
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaf001.a199
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2001.a633
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2002.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2003.a255
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3001.a179
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3002.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3003.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30040.c172
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30041.am377
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3005.a396
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30060.c174
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30061.am404
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3007.a408
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3008.a226
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3009.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3010.a320
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3011.a282
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3012.a392
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30130.c86
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30131.c104
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb30132.am205
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3014.a254
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3015.a520
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3016.a516
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4001.a230
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4002.a308
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4003.a310
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4004.a443
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4005.a332
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4006.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4007.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4008.a248
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5001.a110
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5002.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5003.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf1001.a261
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2001.a755
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2002.a352
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2003.a363
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2004.a513
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2005.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a448
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3001.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3002.a231
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3003.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3004.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a267
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a429
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a266
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a302
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a337
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a289
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1001.a276
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1002.a198
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1003.a478
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1004.a360
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1005.a393
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2001.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2002.a468
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2003.a701
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2004.a499
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2005.a204
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2006.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2007.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2008.a948
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2009.a421
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2010.a892
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2011.a490
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2012.a438
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2013.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2014.a399
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2015.a686
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2016.a482
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2017.a296
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2018.a355
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2019.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2020.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2021.a386
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2022.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2023.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2024.a191
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh3001.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh3002.a343
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh30030.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh30031.am215
-rw-r--r--gcc/testsuite/ada/acats/tests/cz/cz1101a.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/cz/cz1102a.ada75
-rw-r--r--gcc/testsuite/ada/acats/tests/cz/cz1103a.ada232
-rw-r--r--gcc/testsuite/ada/acats/tests/d/d4a002a.ada54
-rw-r--r--gcc/testsuite/ada/acats/tests/d/d4a002b.ada56
-rw-r--r--gcc/testsuite/ada/acats/tests/d/d4a004a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/d/d4a004b.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/e/e28002b.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/e/e28005d.ada55
-rw-r--r--gcc/testsuite/ada/acats/tests/e/e52103y.ada132
-rw-r--r--gcc/testsuite/ada/acats/tests/e/eb4011a.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/e/eb4012a.ada59
-rw-r--r--gcc/testsuite/ada/acats/tests/e/eb4014a.ada87
-rw-r--r--gcc/testsuite/ada/acats/tests/e/ee3203a.ada168
-rw-r--r--gcc/testsuite/ada/acats/tests/e/ee3204a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/e/ee3402b.ada118
-rw-r--r--gcc/testsuite/ada/acats/tests/e/ee3409f.ada103
-rw-r--r--gcc/testsuite/ada/acats/tests/e/ee3412c.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140010.a51
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140011.am104
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140012.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140020.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140021.am98
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140022.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140030.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140031.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140032.am101
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140033.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140040.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140041.am108
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140042.a53
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140050.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140051.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140052.am110
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140053.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140060.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140061.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140062.am135
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140063.a70
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140070.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140071.a72
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140072.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140073.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140080.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140081.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140082.am106
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140083.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140090.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140091.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140092.am110
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140093.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140100.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140101.a89
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140102.am104
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140103.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140110.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140111.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140112.am103
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140113.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140120.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140121.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140122.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140123.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140130.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140131.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140132.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140133.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140140.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140141.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140142.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140143.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140150.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140151.a65
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140152.am101
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140153.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140160.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140161.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140162.am196
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140163.a67
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140170.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140171.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140172.am121
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140173.a75
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140180.a65
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140181.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140182.am118
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140183.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140190.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140191.a74
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140192.am107
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140193.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140200.a76
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140201.a71
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140202.am144
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140203.a71
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140210.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140211.am134
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140212.a74
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140220.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140221.am128
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140222.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140240.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140241.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140242.am104
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140243.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140250.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140251.am141
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140252.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140260.a98
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140261.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140262.am140
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140263.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140270.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140271.a93
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140272.am102
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140273.a58
2603 files changed, 0 insertions, 440786 deletions
diff --git a/gcc/testsuite/ada/acats/elabd.lst b/gcc/testsuite/ada/acats/elabd.lst
deleted file mode 100644
index e7a7d25..0000000
--- a/gcc/testsuite/ada/acats/elabd.lst
+++ /dev/null
@@ -1,5 +0,0 @@
-c731001
-c854002
-ca11018
-ca11019
-ca5006a
diff --git a/gcc/testsuite/ada/acats/floatstore.lst b/gcc/testsuite/ada/acats/floatstore.lst
deleted file mode 100644
index fe17469..0000000
--- a/gcc/testsuite/ada/acats/floatstore.lst
+++ /dev/null
@@ -1 +0,0 @@
-cxg2021
diff --git a/gcc/testsuite/ada/acats/norun.lst b/gcc/testsuite/ada/acats/norun.lst
deleted file mode 100644
index e9f64b4..0000000
--- a/gcc/testsuite/ada/acats/norun.lst
+++ /dev/null
@@ -1,2 +0,0 @@
-# Tests must be sorted in alphabetical order
-templat
diff --git a/gcc/testsuite/ada/acats/overflow.lst b/gcc/testsuite/ada/acats/overflow.lst
deleted file mode 100644
index fb76ef1..0000000
--- a/gcc/testsuite/ada/acats/overflow.lst
+++ /dev/null
@@ -1,17 +0,0 @@
-c45632a
-c45632b
-c45632c
-c45504a
-c45504b
-c45504c
-c45613a
-c45613b
-c45613c
-c45304a
-c45304b
-c45304c
-c46014a
-c460008
-c460011
-c4a012b
-cb20004
diff --git a/gcc/testsuite/ada/acats/run_acats.sh b/gcc/testsuite/ada/acats/run_acats.sh
deleted file mode 100755
index 1a2c050..0000000
--- a/gcc/testsuite/ada/acats/run_acats.sh
+++ /dev/null
@@ -1,71 +0,0 @@
-#!/bin/sh
-
-if [ "$testdir" = "" ]; then
- echo You must use make check or make check-ada
- exit 1
-fi
-
-# Provide which replacement.
-#
-# type -p is missing from Solaris 2 /bin/sh and /bin/ksh (ksh88), but both
-# ksh93 and bash have it.
-# type output format differs between ksh88 and ksh93, so avoid it if
-# type -p is present. Unfortunately, HP-UX /bin/sh ignores -p with type.
-# Fall back to whence which ksh88 and ksh93 provide, but bash does not.
-
-which () {
- path=`type -p $* 2>/dev/null` && { echo $path | awk '{print $NF}'; return 0; }
- path=`type $* 2>/dev/null` && { echo $path | awk '{print $NF}'; return 0; }
- path=`whence $* 2>/dev/null` && { echo $path; return 0; }
- return 1
-}
-
-# Set up environment to use the Ada compiler from the object tree
-
-host_gnatchop=`which gnatchop`
-host_gnatmake=`which gnatmake`
-ROOT=`${PWDCMD-pwd}`
-BASE=`cd $ROOT/../../..; ${PWDCMD-pwd}`
-
-PATH=$BASE:$ROOT:$PATH
-ADA_INCLUDE_PATH=$BASE/ada/rts
-LD_LIBRARY_PATH=$ADA_INCLUDE_PATH:$BASE:$LD_LIBRARY_PATH
-ADA_OBJECTS_PATH=$ADA_INCLUDE_PATH
-
-if [ ! -d $ADA_INCLUDE_PATH ]; then
- echo gnatlib missing, exiting.
- exit 1
-fi
-
-if [ ! -f $BASE/gnatchop ]; then
- echo gnattools missing, exiting.
- exit 1
-fi
-
-if [ ! -f $BASE/gnatmake ]; then
- echo gnattools missing, exiting.
- exit 1
-fi
-
-export PATH ADA_INCLUDE_PATH ADA_OBJECTS_PATH BASE LD_LIBRARY_PATH
-
-echo '#!/bin/sh' > host_gnatchop
-echo PATH=`dirname $host_gnatchop`:'$PATH' >> host_gnatchop
-echo unset ADA_INCLUDE_PATH ADA_OBJECTS_PATH GCC_EXEC_PREFIX >> host_gnatchop
-echo export PATH >> host_gnatchop
-echo exec gnatchop '"$@"' >> host_gnatchop
-
-chmod +x host_gnatchop
-
-echo '#!/bin/sh' > host_gnatmake
-echo PATH=`dirname $host_gnatmake`:'$PATH' >> host_gnatmake
-echo unset ADA_INCLUDE_PATH ADA_OBJECTS_PATH GCC_EXEC_PREFIX >> host_gnatmake
-echo export PATH >> host_gnatmake
-echo exec gnatmake '"$@"' >> host_gnatmake
-
-chmod +x host_gnatmake
-
-# Limit the stack to 16MB for stack checking
-ulimit -s 16384
-
-exec $testdir/run_all.sh ${1+"$@"}
diff --git a/gcc/testsuite/ada/acats/run_all.sh b/gcc/testsuite/ada/acats/run_all.sh
deleted file mode 100755
index 38ec4692..0000000
--- a/gcc/testsuite/ada/acats/run_all.sh
+++ /dev/null
@@ -1,407 +0,0 @@
-#!/bin/sh
-# Run ACATS with the GNU Ada compiler
-
-# The following functions are to be customized if you run in cross
-# environment or want to change compilation flags. Note that for
-# tests requiring checks not turned on by default, this script
-# automatically adds the needed flags to pass (ie: -gnato or -gnatE).
-
-# gccflags="-O3 -funroll-loops"
-# gnatflags="-gnatn"
-
-gccflags="-O2"
-gnatflags="-gnatws"
-
-# End of customization section.
-
-# Perform arithmetic evaluation on the ARGs, and store the result in the
-# global $as_val. Take advantage of shells that can avoid forks. The arguments
-# must be portable across $(()) and expr.
-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :
- eval 'as_fn_arith ()
- {
- as_val=$(( $* ))
- }'
-else
- as_fn_arith ()
- {
- as_val=`expr "$@" || test $? -eq 1`
- }
-fi # as_fn_arith
-
-display_noeol () {
- printf "$@"
- printf "$@" >> $dir/acats.sum
- printf "$@" >> $dir/acats.log
-}
-
-display () {
- echo "$@"
- echo "$@" >> $dir/acats.sum
- echo "$@" >> $dir/acats.log
-}
-
-log () {
- echo "$@" >> $dir/acats.sum
- echo "$@" >> $dir/acats.log
-}
-
-dir=`${PWDCMD-pwd}`
-
-if [ "$dir" = "$testdir" ]; then
- echo "error: srcdir must be different than objdir, exiting."
- exit 1
-fi
-
-GCC="$BASE/xgcc -B$BASE/"
-
-target_gnatchop () {
- $BASE/gnatchop --GCC="$BASE/xgcc" $*
-}
-
-target_gnatmake () {
- echo $BASE/gnatmake --GNATBIND=$BASE/gnatbind --GNATLINK=$BASE/gnatlink --GCC="$GCC" $gnatflags $gccflags $* -largs $EXTERNAL_OBJECTS --GCC="$GCC"
- $BASE/gnatmake --GNATBIND=$BASE/gnatbind --GNATLINK=$BASE/gnatlink --GCC="$GCC" $gnatflags $gccflags $* -largs $EXTERNAL_OBJECTS --GCC="$GCC"
-}
-
-target_gcc () {
- $GCC $gccflags $*
-}
-
-target_run () {
- eval $EXPECT -f $testdir/run_test.exp $*
-}
-
-clean_dir () {
- rm -f "$binmain" *.o *.ali > /dev/null 2>&1
-}
-
-find_main () {
- ls ${i}?.adb > ${i}.lst 2> /dev/null
- ls ${i}*m.adb >> ${i}.lst 2> /dev/null
- ls ${i}.adb >> ${i}.lst 2> /dev/null
- main=`tail -1 ${i}.lst`
-}
-
-EXTERNAL_OBJECTS=""
-# Global variable to communicate external objects to link with.
-
-rm -f $dir/acats.sum $dir/acats.log
-
-display "Test Run By $USER on `date`"
-
-display " === acats configuration ==="
-
-target=`$GCC -dumpmachine`
-
-display target gcc is $GCC
-display `$GCC -v 2>&1`
-display host=`gcc -dumpmachine`
-display target=$target
-display `type gnatmake`
-gnatls -v >> $dir/acats.log
-display ""
-
-if [ -n "$GCC_RUNTEST_PARALLELIZE_DIR" ]; then
- dir_support=$dir/../acats/support
-
- rm -rf $dir/run
- mv $dir/tests $dir/tests.$$ 2> /dev/null
- rm -rf $dir/tests.$$ &
- mkdir -p $dir/run
-
- cp -pr $dir/../acats/tests $dir/
-else
- dir_support=$dir/support
-
-display " === acats support ==="
-display_noeol "Generating support files..."
-
-rm -rf $dir/support
-mkdir -p $dir/support
-cd $dir/support
-
-cp $testdir/support/*.ada $testdir/support/*.a $testdir/support/*.tst $dir/support
-
-# Find out the size in bit of an address on the target
-target_gnatmake $testdir/support/impbit.adb >> $dir/acats.log 2>&1
-if [ $? -ne 0 ]; then
- display "**** Failed to compile impbit"
- exit 1
-fi
-target_run $dir/support/impbit > $dir/support/impbit.out 2>&1
-target_bit=`cat $dir/support/impbit.out`
-echo target_bit="$target_bit" >> $dir/acats.log
-
-case "$target_bit" in
- *32*)
- target_max_int="9223372036854775807"
- target_min_int="-9223372036854775808"
- ;;
- *64*)
- target_max_int="170141183460469231731687303715884105727"
- target_min_int="-170141183460469231731687303715884105728"
- ;;
- *)
- display "**** Unsupported bits per word"
- exit 1
-esac
-
-echo target_max_insn="$target_max_int" >> $dir/acats.log
-echo target_min_insn="$target_min_int" >> $dir/acats.log
-
-# Find out a suitable asm statement
-# Adapted from configure.ac gcc_cv_as_dwarf2_debug_line
-case "$target" in
- ia64*-*-* | s390*-*-*)
- target_insn="nop 0"
- ;;
- mmix-*-*)
- target_insn="swym 0"
- ;;
- *)
- target_insn="nop"
- ;;
-esac
-echo target_insn="$target_insn" >> $dir/acats.log
-
-sed -e "s,ACATS4GNATDIR,$dir,g" \
- < $testdir/support/impdef.a > $dir/support/impdef.a
-sed -e "s,ACATS4GNATDIR,$dir,g" \
- -e "s,ACATS4GNATBIT,$target_bit,g" \
- -e "s,ACATS4GNATINSN,$target_insn,g" \
- -e "s,ACATS4GNATMAXINT,$target_max_int,g" \
- -e "s,ACATS4GNATMININT,$target_min_int,g" \
- < $testdir/support/macro.dfs > $dir/support/MACRO.DFS
-sed -e "s,ACATS4GNATDIR,$dir,g" \
- < $testdir/support/tsttests.dat > $dir/support/TSTTESTS.DAT
-
-cp $testdir/tests/cd/*.c $dir/support
-cp $testdir/tests/cxb/*.c $dir/support
-grep -v '^#' $testdir/norun.lst | sort > $dir/support/norun.lst
-
-rm -rf $dir/run
-mv $dir/tests $dir/tests.$$ 2> /dev/null
-rm -rf $dir/tests.$$ &
-mkdir -p $dir/run
-
-cp -pr $testdir/tests $dir/
-
-for i in $dir/support/*.ada $dir/support/*.a; do
- host_gnatchop $i >> $dir/acats.log 2>&1
-done
-
-# These tools are used to preprocess some ACATS sources
-# they need to be compiled native on the host.
-
-host_gnatmake -q -gnatws macrosub.adb
-if [ $? -ne 0 ]; then
- display "**** Failed to compile macrosub"
- exit 1
-fi
-./macrosub > macrosub.out 2>&1
-
-gcc -c cd300051.c
-host_gnatmake -q -gnatws widechr.adb
-if [ $? -ne 0 ]; then
- display "**** Failed to compile widechr"
- exit 1
-fi
-./widechr > widechr.out 2>&1
-
-rm -f $dir/support/macrosub
-rm -f $dir/support/widechr
-rm -f $dir/support/*.ali
-rm -f $dir/support/*.o
-
-display " done."
-
-# From here, all compilations will be made by the target compiler
-
-display_noeol "Compiling support files..."
-
-target_gcc -c *.c
-if [ $? -ne 0 ]; then
- display "**** Failed to compile C code"
- exit 1
-fi
-
-target_gnatchop *.adt >> $dir/acats.log 2>&1
-
-target_gnatmake -c -gnato -gnatE *.ads >> $dir/acats.log 2>&1
-target_gnatmake -c -gnato -gnatE *.adb >> $dir/acats.log 2>&1
-
-display " done."
-display ""
-
-fi
-
-display " === acats tests ==="
-
-if [ $# -eq 0 ]; then
- chapters=`cd $dir/tests; echo [a-z]*`
-else
- chapters=$*
-fi
-
-glob_countn=0
-glob_countok=0
-glob_countu=0
-par_count=0
-par_countm=0
-par_last=
-
-for chapter in $chapters; do
- # Used to generate support once and finish after that.
- [ "$chapter" = "NONE" ] && continue
-
- display Running chapter $chapter ...
-
- if [ ! -d $dir/tests/$chapter ]; then
- display "*** CHAPTER $chapter does not exist, skipping."
- display ""
- continue
- fi
-
- cd $dir/tests/$chapter
- ls *.a *.ada *.adt *.am *.dep 2> /dev/null | sed -e 's/\(.*\)\..*/\1/g' | \
- cut -c1-7 | sort | uniq | comm -23 - $dir_support/norun.lst \
- > $dir/tests/$chapter/${chapter}.lst
- countn=`wc -l < $dir/tests/$chapter/${chapter}.lst`
- as_fn_arith $glob_countn + $countn
- glob_countn=$as_val
- for i in `cat $dir/tests/$chapter/${chapter}.lst`; do
-
- # If running multiple run_all.sh jobs in parallel, decide
- # if we should run this test in the current instance.
- if [ -n "$GCC_RUNTEST_PARALLELIZE_DIR" ]; then
- case "$i" in
- # Ugh, some tests have inter-test dependencies, those
- # tests have to be scheduled on the same parallel instance
- # as previous test.
- ce2108f | ce2108h | ce3112d) ;;
- # All others can be hopefully scheduled freely.
- *)
- as_fn_arith $par_countm + 1
- par_countm=$as_val
- [ $par_countm -eq 10 ] && par_countm=0
- if [ $par_countm -eq 1 ]; then
- as_fn_arith $par_count + 1
- par_count=$as_val
- if mkdir $GCC_RUNTEST_PARALLELIZE_DIR/$par_count 2>/dev/null; then
- par_last=1
- else
- par_last=
- fi
- fi;;
- esac
- if [ -z "$par_last" ]; then
- as_fn_arith $glob_countn - 1
- glob_countn=$as_val
- continue
- fi
- fi
-
- extraflags="-gnat95"
- grep $i $testdir/overflow.lst > /dev/null 2>&1
- if [ $? -eq 0 ]; then
- extraflags="$extraflags -gnato"
- fi
- grep $i $testdir/elabd.lst > /dev/null 2>&1
- if [ $? -eq 0 ]; then
- extraflags="$extraflags -gnatE"
- fi
- grep $i $testdir/floatstore.lst > /dev/null 2>&1
- if [ $? -eq 0 ]; then
- extraflags="$extraflags -ffloat-store"
- fi
- grep $i $testdir/stackcheck.lst > /dev/null 2>&1
- if [ $? -eq 0 ]; then
- extraflags="$extraflags -fstack-check"
- fi
- test=$dir/tests/$chapter/$i
- mkdir $test && cd $test >> $dir/acats.log 2>&1
-
- if [ $? -ne 0 ]; then
- display "FAIL: $i"
- failed="${failed}${i} "
- clean_dir
- continue
- fi
-
- target_gnatchop -c -w `ls ${test}*.a ${test}*.ada ${test}*.adt ${test}*.am ${test}*.dep 2> /dev/null` >> $dir/acats.log 2>&1
- main=""
- find_main
- if [ -z "$main" ]; then
- sync
- find_main
- fi
- binmain=`echo $main | sed -e 's/\(.*\)\..*/\1/g'`
- echo "BUILD $main" >> $dir/acats.log
- EXTERNAL_OBJECTS=""
- case $i in
- cxb30*) EXTERNAL_OBJECTS="$dir_support/cxb30040.o $dir_support/cxb30060.o $dir_support/cxb30130.o $dir_support/cxb30131.o";;
- ca1020e) rm -f ca1020e_func1.adb ca1020e_func2.adb ca1020e_proc1.adb ca1020e_proc2.adb > /dev/null 2>&1;;
- ca14028) rm -f ca14028_func2.ads ca14028_func3.ads ca14028_proc1.ads ca14028_proc3.ads > /dev/null 2>&1;;
- esac
- if [ "$main" = "" ]; then
- display "FAIL: $i"
- failed="${failed}${i} "
- clean_dir
- continue
- fi
-
- target_gnatmake $extraflags -I$dir_support $main >> $dir/acats.log 2>&1
- if [ $? -ne 0 ]; then
- display "FAIL: $i"
- failed="${failed}${i} "
- clean_dir
- continue
- fi
-
- echo "RUN $binmain" >> $dir/acats.log
- cd $dir/run
- if [ ! -x $dir/tests/$chapter/$i/$binmain ]; then
- sync
- fi
- target_run $dir/tests/$chapter/$i/$binmain > $dir/tests/$chapter/$i/${i}.log 2>&1
- cd $dir/tests/$chapter/$i
- cat ${i}.log >> $dir/acats.log
- egrep -e '(==== |\+\+\+\+ |\!\!\!\! )' ${i}.log > /dev/null 2>&1
- if [ $? -ne 0 ]; then
- grep 'tasking not implemented' ${i}.log > /dev/null 2>&1
-
- if [ $? -ne 0 ]; then
- display "FAIL: $i"
- failed="${failed}${i} "
- else
- log "UNSUPPORTED: $i"
- as_fn_arith $glob_countn - 1
- glob_countn=$as_val
- as_fn_arith $glob_countu + 1
- glob_countu=$as_val
- fi
- else
- log "PASS: $i"
- as_fn_arith $glob_countok + 1
- glob_countok=$as_val
- fi
- clean_dir
- done
-done
-
-display " === acats Summary ==="
-display "# of expected passes $glob_countok"
-display "# of unexpected failures `expr $glob_countn - $glob_countok`"
-
-if [ $glob_countu -ne 0 ]; then
- display "# of unsupported tests $glob_countu"
-fi
-
-if [ $glob_countok -ne $glob_countn ]; then
- display "*** FAILURES: $failed"
-fi
-
-display "$0 completed at `date`"
-
-exit 0
diff --git a/gcc/testsuite/ada/acats/run_test.exp b/gcc/testsuite/ada/acats/run_test.exp
deleted file mode 100644
index 07dec27..0000000
--- a/gcc/testsuite/ada/acats/run_test.exp
+++ /dev/null
@@ -1,13 +0,0 @@
-#!/usr/bin/expect -f
-
-if {[info exists env(DEJAGNU_TIMEOUT)]} {
- set timeout $env(DEJAGNU_TIMEOUT)
-} else {
- set timeout 300
-}
-
-spawn -noecho $argv
-expect timeout {
- send_user "Program timed out.\n"
- exit 1
-}
diff --git a/gcc/testsuite/ada/acats/stackcheck.lst b/gcc/testsuite/ada/acats/stackcheck.lst
deleted file mode 100644
index 1fdf555..0000000
--- a/gcc/testsuite/ada/acats/stackcheck.lst
+++ /dev/null
@@ -1,6 +0,0 @@
-c52103x
-c52104x
-c52104y
-cb1010a
-cb1010c
-cb1010d
diff --git a/gcc/testsuite/ada/acats/support/acats26.lst b/gcc/testsuite/ada/acats/support/acats26.lst
deleted file mode 100644
index d99145e..0000000
--- a/gcc/testsuite/ada/acats/support/acats26.lst
+++ /dev/null
@@ -1,4332 +0,0 @@
-a22006b.ada
-a22006c.ada
-a22006d.ada
-a26007a.tst
-a27003a.ada
-a29003a.ada
-a2a031a.ada
-a33003a.ada
-a34017c.ada
-a35101b.ada
-a35402a.ada
-a35801f.ada
-a35902c.ada
-a38106d.ada
-a38106e.ada
-a49027a.ada
-a49027b.ada
-a49027c.ada
-a54b01a.ada
-a54b02a.ada
-a55b12a.ada
-a55b13a.ada
-a55b14a.ada
-a71004a.ada
-a73001i.ada
-a73001j.ada
-a74105b.ada
-a74106a.ada
-a74106b.ada
-a74106c.ada
-a74205e.ada
-a74205f.ada
-a83009a.ada
-a83009b.ada
-a83a02a.ada
-a83a02b.ada
-a83a06a.ada
-a83a08a.ada
-a83c01c.ada
-a83c01h.ada
-a83c01i.ada
-a85007d.ada
-a85013b.ada
-a87b59a.ada
-a95001c.ada
-a95074d.ada
-a97106a.ada
-a99006a.ada
-aa2010a.ada
-aa2012a.ada
-acats25.lst
-ac1015b.ada
-ac3106a.ada
-ac3206a.ada
-ac3207a.ada
-ad7001b.ada
-ad7001c0.ada
-ad7001c1.ada
-ad7001d0.ada
-ad7001d1.ada
-ad7006a.ada
-ad7101a.ada
-ad7101c.ada
-ad7102a.ada
-ad7103a.ada
-ad7103c.ada
-ad7104a.ada
-ad7201a.ada
-ad7203b.ada
-ad7205b.ada
-ad8011a.tst
-ada101a.ada
-ae2113a.ada
-ae2113b.ada
-ae3002g.ada
-ae3101a.ada
-ae3702a.ada
-ae3709a.ada
-b22001a.tst
-b22001b.tst
-b22001c.tst
-b22001d.tst
-b22001e.tst
-b22001f.tst
-b22001g.tst
-b22001h.ada
-b22001i.tst
-b22001j.tst
-b22001k.tst
-b22001l.tst
-b22001m.tst
-b22001n.tst
-b23002a.ada
-b23004a.ada
-b23004b.ada
-b24001a.ada
-b24001b.ada
-b24001c.ada
-b24005a.ada
-b24005b.ada
-b24007a.ada
-b24009a.ada
-b24009b.ada
-b24104a.ada
-b24204a.ada
-b24204b.ada
-b24204c.ada
-b24204d.ada
-b24204e.ada
-b24204f.ada
-b24205a.ada
-b24206a.ada
-b24206b.ada
-b24211b.ada
-b25002a.ada
-b25002b.ada
-b26001a.ada
-b26002a.ada
-b26005a.ada
-b28001a.ada
-b28001b.ada
-b28001c.ada
-b28001d.ada
-b28001e.ada
-b28001f.ada
-b28001g.ada
-b28001h.ada
-b28001i.ada
-b28001j.ada
-b28001k.ada
-b28001l.ada
-b28001m.ada
-b28001n.ada
-b28001o.ada
-b28001p.ada
-b28001q.ada
-b28001r.ada
-b28001s.ada
-b28001t.ada
-b28001u.ada
-b28001v.ada
-b28001w.ada
-b29001a.ada
-b2a003a.ada
-b2a003b.ada
-b2a003c.ada
-b2a003d.ada
-b2a003e.ada
-b2a003f.ada
-b2a005a.ada
-b2a005b.ada
-b2a007a.ada
-b2a010a.ada
-b2a021a.ada
-b32101a.ada
-b32103a.ada
-b32104a.ada
-b32106a.ada
-b32201a.ada
-b32202a.ada
-b32202b.ada
-b32202c.ada
-b330001.a
-b33001a.ada
-b33101a.ada
-b33102a.ada
-b33102b.ada
-b33102c.ada
-b33102d.ada
-b33102e.ada
-b33201a.ada
-b33201b.ada
-b33201c.ada
-b33201d.ada
-b33201e.ada
-b33204a.ada
-b33205a.ada
-b33302a.ada
-b34001b.ada
-b34001e.ada
-b34002b.ada
-b34003b.ada
-b34004b.ada
-b34005b.ada
-b34005e.ada
-b34005h.ada
-b34005k.ada
-b34005n.ada
-b34005q.ada
-b34005t.ada
-b34006b.ada
-b34006e.ada
-b34006h.ada
-b34006k.ada
-b34007b.ada
-b34007e.ada
-b34007h.ada
-b34007k.ada
-b34007n.ada
-b34007q.ada
-b34007t.ada
-b34008b.ada
-b34009b.ada
-b34009e.ada
-b34009h.ada
-b34009k.ada
-b34011a.ada
-b34014b.ada
-b34014d.ada
-b34014f.ada
-b34014i.ada
-b34014m.ada
-b34014o.ada
-b34014q.ada
-b34014s.ada
-b34014v.ada
-b34014z.ada
-b35004a.ada
-b35101a.ada
-b35103a.ada
-b35103b.ada
-b35302a.ada
-b354001.a
-b35401a.ada
-b35401b.ada
-b35403a.ada
-b35501a.ada
-b35501b.ada
-b35506a.ada
-b35506b.ada
-b35506c.ada
-b35506d.ada
-b35701a.ada
-b35709a.ada
-b35901a.ada
-b35901c.ada
-b35901d.ada
-b35a01a.ada
-b35a08a.ada
-b360001.a
-b36001a.ada
-b36002a.ada
-b36101a.ada
-b36102a.ada
-b36103a.ada
-b36105c.dep
-b36171a.ada
-b36171b.ada
-b36171c.ada
-b36171d.ada
-b36171e.ada
-b36171f.ada
-b36171g.ada
-b36171h.ada
-b36171i.ada
-b36201a.ada
-b36307a.ada
-b370001.a
-b370002.a
-b37004a.ada
-b37004b.ada
-b37004c.ada
-b37004d.ada
-b37004e.ada
-b37004f.ada
-b37004g.ada
-b3710010.a
-b3710011.a
-b3710012.a
-b3710013.a
-b3710014.am
-b37101a.ada
-b37102a.ada
-b37104a.ada
-b37106a.ada
-b37201a.ada
-b37201b.ada
-b37203a.ada
-b37301i.ada
-b37301j.ada
-b37302a.ada
-b37303a.ada
-b37309b.ada
-b37310b.ada
-b37311a.ada
-b37401a.ada
-b37409b.ada
-b380001.a
-b38003a.ada
-b38003b.ada
-b38003c.ada
-b38003d.ada
-b38008a.ada
-b38008b.ada
-b38009a.ada
-b38009d.ada
-b38101a.ada
-b38101b.ada
-b38101c.ada
-b38103a.ada
-b38103b.ada
-b38103c0.ada
-b38103c1.ada
-b38103c2.ada
-b38103c3.ada
-b38103d.ada
-b38103e0.ada
-b38103e1.ada
-b38105a.ada
-b38105b.ada
-b38203a.ada
-b390001.a
-b391001.a
-b391002.a
-b391003.a
-b391004.a
-b392001.a
-b392002.a
-b392003.a
-b392004.a
-b392005.a
-b392006.a
-b392007.a
-b392008.a
-b392009.a
-b392010.a
-b392011.a
-b393001.a
-b393002.a
-b393003.a
-b393004.a
-b393005.a
-b393006.a
-b393007.a
-b3a0001.a
-b3a0002.a
-b3a0003.a
-b3a0004.a
-b3a2002.a
-b3a2003.a
-b3a2004.a
-b3a2005.a
-b3a2006.a
-b3a2007.a
-b3a2008.a
-b3a2009.a
-b3a2010.a
-b3a2011.a
-b3a2012.a
-b3a2013.a
-b3a2014.a
-b3a2015.a
-b3a2016.a
-b41101a.ada
-b41101c.ada
-b41201a.ada
-b41201c.ada
-b41202c.ada
-b41202d.ada
-b41324b.ada
-b41325b.ada
-b41327b.ada
-b420001.a
-b430001.a
-b43001m.ada
-b43002d.ada
-b43002e.ada
-b43002f.ada
-b43002g.ada
-b43002h.ada
-b43002i.ada
-b43002j.ada
-b43002k.ada
-b43005a.ada
-b43005b.ada
-b43005f.ada
-b43101a.ada
-b43102a.ada
-b43102b.ada
-b43105c.ada
-b43201a.ada
-b43201c.ada
-b43201d.ada
-b43202a.ada
-b43202c.ada
-b43209b.ada
-b43221a.ada
-b43221b.ada
-b43223a.ada
-b44001a.ada
-b44001b.ada
-b44002b.ada
-b44002c.ada
-b44004a.ada
-b44004b.ada
-b44004c.ada
-b44004d.ada
-b44004e.ada
-b45102a.ada
-b45116a.ada
-b45121a.ada
-b45204a.ada
-b45205a.ada
-b45206c.ada
-b45207a.ada
-b45207b.ada
-b45207c.ada
-b45207d.ada
-b45207g.ada
-b45207h.ada
-b45207i.ada
-b45207j.ada
-b45207m.ada
-b45207n.ada
-b45207o.ada
-b45207p.ada
-b45207s.ada
-b45207t.ada
-b45207u.ada
-b45207v.ada
-b45208a.ada
-b45208b.ada
-b45208c.ada
-b45208g.ada
-b45208h.ada
-b45208i.ada
-b45208m.ada
-b45208n.ada
-b45208s.ada
-b45208t.ada
-b45209a.ada
-b45209b.ada
-b45209c.ada
-b45209d.ada
-b45209e.ada
-b45209f.ada
-b45209g.ada
-b45209h.ada
-b45209i.ada
-b45209j.ada
-b45209k.ada
-b45221a.ada
-b45261a.ada
-b45261b.ada
-b45261c.ada
-b45261d.ada
-b45301a.ada
-b45301b.ada
-b45301c.ada
-b45302a.ada
-b45341a.ada
-b455002.a
-b45501a.ada
-b45501b.ada
-b45501c.ada
-b45522a.ada
-b45537a.ada
-b45601a.ada
-b45625a.ada
-b45661a.ada
-b460001.a
-b460002.a
-b460004.a
-b460005.a
-b460006.a
-b46002a.ada
-b46003a.ada
-b46004a.ada
-b46004b.ada
-b46004c.ada
-b46004d.ada
-b46004e.ada
-b46005a.ada
-b47001a.ada
-b480001.a
-b48001a.ada
-b48001b.ada
-b48002a.ada
-b48002b.ada
-b48002c.ada
-b48002d.ada
-b48002e.ada
-b48002g.ada
-b48003a.ada
-b48003b.ada
-b48003c.ada
-b48003d.ada
-b48003e.ada
-b490001.a
-b490002.a
-b49002a.ada
-b49004a.ada
-b49005a.ada
-b49007a.ada
-b49007b.ada
-b49008a.ada
-b49008c.ada
-b49009b.ada
-b49009c.ada
-b49010a.ada
-b49011a.ada
-b4a010c.ada
-b4a016a.ada
-b51001a.ada
-b51004b.ada
-b51004c.ada
-b52002a.ada
-b52002b.ada
-b52002c.ada
-b52002d.ada
-b52002e.ada
-b52002f.ada
-b52002g.ada
-b52004a.ada
-b52004b.ada
-b52004c.ada
-b52004d.dep
-b52004e.dep
-b53001a.ada
-b53001b.ada
-b53002a.ada
-b53002b.ada
-b53009a.ada
-b53009b.ada
-b53009c.ada
-b54a01b.ada
-b54a01f.ada
-b54a01g.ada
-b54a01l.ada
-b54a05a.ada
-b54a05b.ada
-b54a10a.ada
-b54a12a.ada
-b54a20a.ada
-b54a21a.ada
-b54a25a.ada
-b54a60a.ada
-b54a60b.ada
-b54b01b.tst
-b54b01c.ada
-b54b02b.ada
-b54b02c.ada
-b54b02d.ada
-b54b04a.ada
-b54b04b.ada
-b54b05a.ada
-b54b06a.ada
-b55a01a.ada
-b55a01d.ada
-b55a01e.ada
-b55a01j.ada
-b55a01k.ada
-b55a01l.ada
-b55a01n.ada
-b55a01o.ada
-b55a01t.ada
-b55a01u.ada
-b55a01v.ada
-b55b01a.ada
-b55b01b.ada
-b55b09b.ada
-b55b09c.dep
-b55b09d.dep
-b55b12b.ada
-b55b12c.ada
-b55b17a.ada
-b55b17b.ada
-b55b17c.ada
-b55b18a.ada
-b56001a.ada
-b56001d.ada
-b56001e.ada
-b56001f.ada
-b56001g.ada
-b56001h.ada
-b57001a.ada
-b57001b.ada
-b57001c.ada
-b57001d.ada
-b58001a.ada
-b58002a.ada
-b58002b.ada
-b58002c.ada
-b58003a.ada
-b58003b.ada
-b59001a.ada
-b59001c.ada
-b59001d.ada
-b59001e.ada
-b59001f.ada
-b59001g.ada
-b59001h.ada
-b59001i.ada
-b610001.a
-b61001f.ada
-b61005a.ada
-b61006a.ada
-b61011a.ada
-b62001a.ada
-b62001b.ada
-b62001c.ada
-b62001d.ada
-b63001a.ada
-b63001b.ada
-b63005a.ada
-b63005b.ada
-b63006a.ada
-b63009a.ada
-b63009b.ada
-b63009c0.ada
-b63009c1.ada
-b63009c2.ada
-b63009c3.ada
-b63103a.ada
-b64002a.ada
-b64002c.ada
-b64003a.ada
-b64004a.ada
-b64004b.ada
-b64004c.ada
-b64004d.ada
-b64004e.ada
-b64004f.ada
-b641001.a
-b64101a.ada
-b64201a.ada
-b65001a.ada
-b65002a.ada
-b65002b.ada
-b660001.a
-b660002.a
-b66001a.ada
-b66001b.ada
-b66001c.ada
-b66001d.ada
-b67001a.ada
-b67001b.ada
-b67001c.ada
-b67001d.ada
-b67001h.ada
-b67001i.ada
-b67001j.ada
-b67001k.ada
-b67004a.ada
-b71001a.ada
-b71001b.ada
-b71001c.ada
-b71001d.ada
-b71001f.ada
-b71001g.ada
-b71001h.ada
-b71001i.ada
-b71001j.ada
-b71001l.ada
-b71001m.ada
-b71001n.ada
-b71001o.ada
-b71001p.ada
-b71001r.ada
-b71001t.ada
-b71001u.ada
-b71001v.ada
-b7200010.a
-b7200011.a
-b7200012.a
-b7200013.a
-b7200014.a
-b7200015.a
-b7200016.a
-b730001.a
-b730002.a
-b730003.a
-b730004.a
-b730005.a
-b7300060.a
-b7300061.a
-b7300062.a
-b7300063.am
-b73001a.ada
-b73001b.ada
-b73001c.ada
-b73001d.ada
-b73001e.ada
-b73001f.ada
-b73001g.ada
-b73001h.ada
-b73004a.ada
-b73004b0.ada
-b73004b1.ada
-b73004b2.ada
-b7310010.a
-b7310011.a
-b7310012.a
-b7310013.a
-b7310014.a
-b7310015.a
-b7310016.am
-b731a01.a
-b731a02.a
-b740001.a
-b74001a.ada
-b74001b.ada
-b74101a.ada
-b74101b.ada
-b74103a.ada
-b74103d.ada
-b74103e.ada
-b74103g.ada
-b74103i.ada
-b74104a.ada
-b74105a.ada
-b74105c.ada
-b74201a.ada
-b74202a.ada
-b74202b.ada
-b74202c.ada
-b74202d.ada
-b74203b.ada
-b74203c.ada
-b74203d.ada
-b74203e.ada
-b74205a.ada
-b74207a.ada
-b74304a.ada
-b74304b.ada
-b74304c.ada
-b74404a.ada
-b74404b.ada
-b74409a.ada
-b810001.a
-b830001.a
-b8300020.a
-b8300021.a
-b8300022.a
-b8300023.a
-b8300024.a
-b8300025.am
-b83001a.ada
-b83003a.ada
-b83003b0.ada
-b83003b1.ada
-b83003b2.ada
-b83003b3.ada
-b83003b4.ada
-b83003c.ada
-b83004a.ada
-b83004b0.ada
-b83004b1.ada
-b83004b2.ada
-b83004b3.ada
-b83004c0.ada
-b83004c1.ada
-b83004c2.ada
-b83004d0.ada
-b83004d1.ada
-b83004d2.ada
-b83004d3.ada
-b83006a.ada
-b83006b.ada
-b83008a.ada
-b83008b.ada
-b83011a.ada
-b83023b.ada
-b83024b.ada
-b83024f0.ada
-b83024f1.ada
-b83024f2.ada
-b83024f3.ada
-b83026b.ada
-b83027b.ada
-b83027d.ada
-b83028b.ada
-b83029b.ada
-b83030b.ada
-b83030d.ada
-b83031b.ada
-b83031d.ada
-b83031f.ada
-b83032b.ada
-b83033b.ada
-b83041e.ada
-b83a01a.ada
-b83a01b.ada
-b83a01c.ada
-b83a05a.ada
-b83a06b.ada
-b83a06h.ada
-b83a07a.ada
-b83a07b.ada
-b83a07c.ada
-b83a08b.ada
-b83a09a.ada
-b83b01a.ada
-b83b02c.ada
-b83e01a.ada
-b83e01b.ada
-b83e01c.ada
-b83e01d.ada
-b83e01e0.ada
-b83e01e1.ada
-b83e01e2.ada
-b83e01e3.ada
-b83e01f0.ada
-b83e01f1.ada
-b83e01f2.ada
-b83e01f3.ada
-b83e01f4.ada
-b83e01f5.ada
-b83e01f6.ada
-b83e11a.ada
-b83f02a.ada
-b83f02b.ada
-b83f02c.ada
-b840001.a
-b84001a.ada
-b84002b.ada
-b84004a.ada
-b84005b.ada
-b84006a.ada
-b84007a.ada
-b84008b.ada
-b85001a.ada
-b85001b.ada
-b85001c.ada
-b85001d.ada
-b85001e.ada
-b85001f.ada
-b85001g.ada
-b85001h.ada
-b85001i.ada
-b85001j.ada
-b85001k.ada
-b85001l.ada
-b85002a.ada
-b85003a.ada
-b85003b.ada
-b85004a.ada
-b85008f.ada
-b85008g.ada
-b85008h.ada
-b85010a.ada
-b85010b.ada
-b85012a.ada
-b85013c.ada
-b85013d.ada
-b85015a.ada
-b8510010.a
-b8510011.a
-b8510012.am
-b854001.a
-b86001a0.ada
-b86001a1.ada
-b87b23b.ada
-b87b26a.ada
-b87b48c.ada
-b91001b.ada
-b91001c.ada
-b91001d.ada
-b91001e.ada
-b91001f.ada
-b91001g.ada
-b91002a.ada
-b91002b.ada
-b91002c.ada
-b91002d.ada
-b91002e.ada
-b91002f.ada
-b91002g.ada
-b91002h.ada
-b91002i.ada
-b91002j.ada
-b91002k.ada
-b91002l.ada
-b91003a.ada
-b91003b.ada
-b91003c.ada
-b91003d.ada
-b91003e.ada
-b91004a.ada
-b91005a.ada
-b92001a.ada
-b92001b.ada
-b940001.a
-b940002.a
-b940003.a
-b940004.a
-b940005.a
-b940006.a
-b940007.a
-b95001a.ada
-b95001b.ada
-b95001d.ada
-b95002a.ada
-b95003a.ada
-b95004a.ada
-b95004b.ada
-b95006a.ada
-b95006b.ada
-b95006c.ada
-b95006d.ada
-b95007a.ada
-b95007b.ada
-b95020a.ada
-b95020b0.ada
-b95020b1.ada
-b95020b2.ada
-b95030a.ada
-b95031a.ada
-b95032a.ada
-b95061a.ada
-b95061b.ada
-b95061c.ada
-b95061d.ada
-b95061e.ada
-b95061f.ada
-b95061g.ada
-b95062a.ada
-b95063a.ada
-b95064a.ada
-b95068a.ada
-b95070a.ada
-b95080a.ada
-b95080c.ada
-b95081a.ada
-b95082a.ada
-b95082b.ada
-b95082c.ada
-b95082d.ada
-b95082e.ada
-b95082f.ada
-b95083a.ada
-b95094a.ada
-b95094b.ada
-b95094c.ada
-b951001.a
-b952001.a
-b952002.a
-b952003.a
-b952004.a
-b954001.a
-b954003.a
-b954004.a
-b960001.a
-b96002a.ada
-b97102b.ada
-b97102c.ada
-b97102d.ada
-b97102f.ada
-b97102g.ada
-b97102h.ada
-b97102i.ada
-b97103a.ada
-b97103b.ada
-b97103d.ada
-b97103e.ada
-b97103f.ada
-b97103g.ada
-b97104a.ada
-b97104b.ada
-b97104c.ada
-b97104d.ada
-b97104e.ada
-b97104f.ada
-b97104g.ada
-b97107a.ada
-b97108a.ada
-b97108b.ada
-b97109a.ada
-b97110a.ada
-b97110b.ada
-b97111a.ada
-b97206a.ada
-b97306a.ada
-b99001a.ada
-b99001b.ada
-b99002a.ada
-b99002b.ada
-b99002c.ada
-b99003a.ada
-b9a001a.ada
-b9a001b.ada
-ba1001a0.ada
-ba1001a1.ada
-ba1001a4.ada
-ba1001ac.ada
-ba1001d.ada
-ba1010a0.ada
-ba1010a1.ada
-ba1010a2.ada
-ba1010a3.ada
-ba1010b0.ada
-ba1010b1.ada
-ba1010b2.ada
-ba1010b4.ada
-ba1010b5.ada
-ba1010b6.ada
-ba1010b7.ada
-ba1010b8.ada
-ba1010c0.ada
-ba1010c1.ada
-ba1010c2.ada
-ba1010c3.ada
-ba1010c4.ada
-ba1010c5.ada
-ba1010c6.ada
-ba1010d0.ada
-ba1010d1.ada
-ba1010d2.ada
-ba1010d3.ada
-ba1010e0.ada
-ba1010e1.ada
-ba1010e2.ada
-ba1010e3.ada
-ba1010e4.ada
-ba1010e5.ada
-ba1010e6.ada
-ba1010f0.ada
-ba1010f1.ada
-ba1010f3.ada
-ba1010f4.ada
-ba1010f5.ada
-ba1010f6.ada
-ba1010f7.ada
-ba1010f8.ada
-ba1010g0.ada
-ba1010g2.ada
-ba1010g3.ada
-ba1010g4.ada
-ba1010g5.ada
-ba1010h0.ada
-ba1010h2.ada
-ba1010i0.ada
-ba1010i1.ada
-ba1010i3.ada
-ba1010i4.ada
-ba1010j0.ada
-ba1010j1.ada
-ba1010j2.ada
-ba1010j4.ada
-ba1010j5.ada
-ba1010j6.ada
-ba1010j7.ada
-ba1010j8.ada
-ba1010k0.ada
-ba1010k1.ada
-ba1010k2.ada
-ba1010k3.ada
-ba1010k4.ada
-ba1010k5.ada
-ba1010k6.ada
-ba1010l0.ada
-ba1010l1.ada
-ba1010l2.ada
-ba1010l3.ada
-ba1010l4.ada
-ba1010l5.ada
-ba1010l6.ada
-ba1010m0.ada
-ba1010m1.ada
-ba1010m3.ada
-ba1010m4.ada
-ba1010m5.ada
-ba1010m6.ada
-ba1010m7.ada
-ba1010m8.ada
-ba1010n0.ada
-ba1010n2.ada
-ba1010n3.ada
-ba1010n4.ada
-ba1010n5.ada
-ba1010p0.ada
-ba1010p2.ada
-ba1010q0.ada
-ba1010q1.ada
-ba1010q3.ada
-ba1010q4.ada
-ba1011b0.ada
-ba1011b1.ada
-ba1011b2.ada
-ba1011b3.ada
-ba1011b4.ada
-ba1011b5.ada
-ba1011b6.ada
-ba1011b7.ada
-ba1011b8.ada
-ba1011c0.ada
-ba1011c1.ada
-ba1011c2.ada
-ba1011c3.ada
-ba1011c4.ada
-ba1011c5.ada
-ba1011c6.ada
-ba1011c7.ada
-ba1011c8.ada
-ba1020a0.ada
-ba1020a1.ada
-ba1020a2.ada
-ba1020a3.ada
-ba1020a4.ada
-ba1020a5.ada
-ba1020a6.ada
-ba1020a7.ada
-ba1020a8.ada
-ba1020b0.ada
-ba1020b1.ada
-ba1020b2.ada
-ba1020b3.ada
-ba1020b4.ada
-ba1020b5.ada
-ba1020b6.ada
-ba1020c0.ada
-ba1020c1.ada
-ba1020c2.ada
-ba1020c3.ada
-ba1020c4.ada
-ba1020c5.ada
-ba1020f0.ada
-ba1020f1.ada
-ba1020f2.ada
-ba11001.a
-ba11002.a
-ba11003.a
-ba11004.a
-ba11005.a
-ba11007.a
-ba11008.a
-ba11009.a
-ba11010.a
-ba11011.a
-ba11012.a
-ba1101a.ada
-ba1101b0.ada
-ba1101b1.ada
-ba1101b2.ada
-ba1101b3.ada
-ba1101b4.ada
-ba1101c0.ada
-ba1101c1.ada
-ba1101c2.ada
-ba1101c3.ada
-ba1101c4.ada
-ba1101c5.ada
-ba1101c6.ada
-ba1101e0.ada
-ba1101e1.ada
-ba1101f.ada
-ba1101g.ada
-ba1109a0.ada
-ba1109a1.ada
-ba1109a2.ada
-ba1110a0.ada
-ba1110a1.ada
-ba1110a2.ada
-ba1110a3.ada
-ba1110a4.ada
-ba1110a5.ada
-ba12001.a
-ba12002.a
-ba12003.a
-ba12004.a
-ba12005.a
-ba12007.a
-ba12008.a
-ba13b01.a
-ba13b02.a
-ba15001.a
-ba150020.a
-ba150021.a
-ba150022.a
-ba150023.a
-ba150024.a
-ba150025.a
-ba150026.a
-ba150027.a
-ba150028.a
-ba150029.am
-ba2001a.ada
-ba2001b.ada
-ba2001c.ada
-ba2001d.ada
-ba2001f0.ada
-ba2001f1.ada
-ba2001f2.ada
-ba2003b0.ada
-ba2003b1.ada
-ba2011a0.ada
-ba2011a1.ada
-ba2011a2.ada
-ba2011a3.ada
-ba2011a4.ada
-ba2011a5.ada
-ba2011a6.ada
-ba2011a7.ada
-ba2011a8.ada
-ba2011a9.ada
-ba2013a.ada
-ba2013b.ada
-ba21001.a
-ba21002.a
-ba210030.a
-ba210031.a
-ba210032.a
-ba210033.a
-ba210034.a
-ba210035.a
-ba210040.a
-ba210041.a
-ba210042.a
-ba210043.a
-ba210044.a
-ba210045.am
-ba21a01.a
-ba21a02.a
-ba3001a0.ada
-ba3001a1.ada
-ba3001a2.ada
-ba3001a3.ada
-ba3001b0.ada
-ba3001b1.ada
-ba3001c0.ada
-ba3001c1.ada
-ba3001e0.ada
-ba3001e1.ada
-ba3001e2.ada
-ba3001e3.ada
-ba3001f0.ada
-ba3001f1.ada
-ba3001f2.ada
-ba3001f3.ada
-ba3006a0.ada
-ba3006a1.ada
-ba3006a2.ada
-ba3006a3.ada
-ba3006a4.ada
-ba3006a5.ada
-ba3006a6.ada
-ba3006b0.ada
-ba3006b1.ada
-ba3006b2.ada
-ba3006b3.ada
-ba3006b4.ada
-bb10001.a
-bb20001.a
-bb2001a.ada
-bb2002a.ada
-bb2003a.ada
-bb2003b.ada
-bb2003c.ada
-bb3001a.ada
-bb3002a.ada
-bc1001a.ada
-bc1002a.ada
-bc1005a.ada
-bc1008a.ada
-bc1008b.ada
-bc1008c.ada
-bc1009a.ada
-bc1011a.ada
-bc1011b.ada
-bc1011c.ada
-bc1012a.ada
-bc1013a.ada
-bc1014a.ada
-bc1014b.ada
-bc1016a.ada
-bc1016b.ada
-bc1101a.ada
-bc1102a.ada
-bc1103a.ada
-bc1106a.ada
-bc1107a.ada
-bc1109a.ada
-bc1109b.ada
-bc1109c.ada
-bc1109d.ada
-bc1110a.ada
-bc1201a.ada
-bc1201b.ada
-bc1201c.ada
-bc1201d.ada
-bc1201e.ada
-bc1201f.ada
-bc1201g.ada
-bc1201h.ada
-bc1201i.ada
-bc1201j.ada
-bc1201k.ada
-bc1201l.ada
-bc1202a.ada
-bc1202c.ada
-bc1202e.ada
-bc1202f.ada
-bc1202g.ada
-bc1203a.ada
-bc1205a.ada
-bc1206a.ada
-bc1207a.ada
-bc1208a.ada
-bc1226a.ada
-bc1230a.ada
-bc1303a.ada
-bc1303b.ada
-bc1303c.ada
-bc1303d.ada
-bc1303e.ada
-bc1303f.ada
-bc1303g.ada
-bc1306a.ada
-bc2001b.ada
-bc2001c.ada
-bc2001d.ada
-bc2001e.ada
-bc2004a.ada
-bc2004b.ada
-bc30001.a
-bc3001a.ada
-bc3002a.ada
-bc3002b.ada
-bc3002c.ada
-bc3002d.ada
-bc3002e.ada
-bc3005a.ada
-bc3005b.ada
-bc3005c.ada
-bc3006a.ada
-bc3009c.ada
-bc3011b.ada
-bc3013a.ada
-bc3016g.ada
-bc3018a.ada
-bc3101a.ada
-bc3101b.ada
-bc3102a.ada
-bc3102b.ada
-bc3103b.ada
-bc3123c.ada
-bc3201a.ada
-bc3201b.ada
-bc3201c.ada
-bc3202a.ada
-bc3202b.ada
-bc3202c.ada
-bc3202d.ada
-bc3205c.ada
-bc3301a.ada
-bc3301b.ada
-bc3302a.ada
-bc3302b.ada
-bc3303a.ada
-bc3304a.ada
-bc3401a.ada
-bc3401b.ada
-bc3402a.ada
-bc3402b.ada
-bc3403a.ada
-bc3403b.ada
-bc3403c.ada
-bc3404a.ada
-bc3404b.ada
-bc3404c.ada
-bc3404d.ada
-bc3404e.ada
-bc3404f.ada
-bc3405a.ada
-bc3405b.ada
-bc3405d.ada
-bc3405e.ada
-bc3405f.ada
-bc3501a.ada
-bc3501b.ada
-bc3501c.ada
-bc3501d.ada
-bc3501e.ada
-bc3501f.ada
-bc3501g.ada
-bc3501h.ada
-bc3501i.ada
-bc3501j.ada
-bc3501k.ada
-bc3502a.ada
-bc3502b.ada
-bc3502c.ada
-bc3502d.ada
-bc3502e.ada
-bc3502f.ada
-bc3502g.ada
-bc3502h.ada
-bc3502i.ada
-bc3502j.ada
-bc3502k.ada
-bc3502l.ada
-bc3502m.ada
-bc3502n.ada
-bc3502o.ada
-bc3503a.ada
-bc3503c.ada
-bc3503d.ada
-bc3503e.ada
-bc3503f.ada
-bc3604a.ada
-bc3604b.ada
-bc3607a.ada
-bc40001.a
-bc40002.a
-bc50001.a
-bc50002.a
-bc50003.a
-bc50004.a
-bc51002.a
-bc51003.a
-bc51004.a
-bc51005.a
-bc51006.a
-bc51007.a
-bc51011.a
-bc51012.a
-bc51013.a
-bc51015.a
-bc51016.a
-bc51017.a
-bc51018.a
-bc51019.a
-bc51020.a
-bc51b01.a
-bc51b02.a
-bc51c01.a
-bc51c02.a
-bc53001.a
-bc53002.a
-bc54001.a
-bc54002.a
-bc54003.a
-bc54a01.a
-bc54a02.a
-bc54a03.a
-bc54a04.a
-bc54a05.a
-bc54a06.a
-bc70001.a
-bc70002.a
-bc70003.a
-bc70004.a
-bc70005.a
-bc70006.a
-bc70007.a
-bc70008.a
-bc70009.a
-bc70010.a
-bd1b01a.ada
-bd1b02b.ada
-bd1b03c.ada
-bd1b05e.ada
-bd1b06j.ada
-bd2001b.ada
-bd2a01h.ada
-bd2a02a.tst
-bd2a03a.ada
-bd2a03b.ada
-bd2a06a.ada
-bd2a25a.ada
-bd2a35a.ada
-bd2a45a.ada
-bd2a55a.ada
-bd2a55b.ada
-bd2a67a.ada
-bd2a77a.ada
-bd2a85a.ada
-bd2a85b.ada
-bd2b01c.ada
-bd2b02a.ada
-bd2b03a.ada
-bd2b03b.ada
-bd2b03c.ada
-bd2c01d.tst
-bd2c02a.tst
-bd2c03a.tst
-bd2d01c.ada
-bd2d01d.ada
-bd2d02a.ada
-bd2d03a.ada
-bd2d03b.ada
-bd3001a.ada
-bd3001b.ada
-bd3001c.ada
-bd3002a.ada
-bd3003a.ada
-bd3003b.ada
-bd3012a.ada
-bd3013a.ada
-bd4001a.ada
-bd4002a.ada
-bd4003a.ada
-bd4003b.ada
-bd4003c.ada
-bd4006a.tst
-bd4007a.ada
-bd4009a.ada
-bd4011a.ada
-bd5001a.ada
-bd5005a.ada
-bd5005d.ada
-bd5102a.ada
-bd5102b.ada
-bd5103a.ada
-bd5104a.ada
-bd7001a.ada
-bd7101h.ada
-bd7201c.ada
-bd7203a.ada
-bd7204a.ada
-bd7205a.ada
-bd7301a.ada
-bd7302a.ada
-bd8001a.tst
-bd8002a.tst
-bd8003a.tst
-bd8004a.tst
-bd8004b.tst
-bd8004c.tst
-bdb0a01.a
-bdd2001.a
-bdd2002.a
-bde0001.a
-bde0002.a
-bde0003.a
-bde0004.a
-bde0005.a
-bde0006.a
-bde0007.a
-bde0008.a
-bde0009.a
-bde0010.a
-be2101e.ada
-be2101j.ada
-be2114a.ada
-be2116a.ada
-be2208a.ada
-be3002a.ada
-be3002e.ada
-be3205a.ada
-be3301c.ada
-be3606c.ada
-be3703a.ada
-be3802a.ada
-be3803a.ada
-be3902a.ada
-be3903a.ada
-bxa8001.a
-bxac001.a
-bxac002.a
-bxac003.a
-bxac004.a
-bxac005.a
-bxc3001.a
-bxc3002.a
-bxc5001.a
-bxc6001.a
-bxc6002.a
-bxc6003.a
-bxc6a01.a
-bxc6a02.a
-bxc6a03.a
-bxc6a04.a
-bxd1001.a
-bxd1002.a
-bxe2007.a
-bxe2008.a
-bxe2009.a
-bxe2010.a
-bxe2011.a
-bxe2012.a
-bxe2013.a
-bxe2a01.a
-bxe2a02.a
-bxe2a03.a
-bxe2a04.a
-bxe2a05.a
-bxe2a06.a
-bxe4001.a
-bxf1001.a
-bxh4001.a
-bxh4002.a
-bxh4003.a
-bxh4004.a
-bxh4005.a
-bxh4006.a
-bxh4007.a
-bxh4008.a
-bxh4009.a
-bxh4010.a
-bxh4011.a
-bxh4012.a
-bxh4013.a
-c23001a.ada
-c23003a.tst
-c23003b.tst
-c23003g.tst
-c23003i.tst
-c23006a.ada
-c23006b.ada
-c23006c.ada
-c23006d.ada
-c23006e.ada
-c23006f.ada
-c23006g.ada
-c24002d.ada
-c24003a.ada
-c24003b.ada
-c24003c.ada
-c24106a.ada
-c24202d.ada
-c24203a.ada
-c24203b.ada
-c24207a.ada
-c24211a.ada
-c250001.aw
-c250002.aw
-c25001a.ada
-c25001b.ada
-c26006a.ada
-c26008a.ada
-c2a001a.ada
-c2a001b.ada
-c2a001c.ada
-c2a002a.ada
-c2a008a.ada
-c2a021b.ada
-c32001a.ada
-c32001b.ada
-c32001c.ada
-c32001d.ada
-c32001e.ada
-c32107a.ada
-c32107c.ada
-c32108a.ada
-c32108b.ada
-c32111a.ada
-c32111b.ada
-c32112b.ada
-c32113a.ada
-c32115a.ada
-c32115b.ada
-c330001.a
-c330002.a
-c332001.a
-c340001.a
-c34001a.ada
-c34001c.ada
-c34001d.ada
-c34001f.ada
-c34002a.ada
-c34002c.ada
-c34003a.ada
-c34003c.ada
-c34004a.ada
-c34004c.ada
-c34005a.ada
-c34005c.ada
-c34005d.ada
-c34005f.ada
-c34005g.ada
-c34005i.ada
-c34005j.ada
-c34005l.ada
-c34005m.ada
-c34005o.ada
-c34005p.ada
-c34005r.ada
-c34005s.ada
-c34005u.ada
-c34005v.ada
-c34006a.ada
-c34006d.ada
-c34006f.ada
-c34006g.ada
-c34006j.ada
-c34006l.ada
-c34007a.ada
-c34007d.ada
-c34007f.ada
-c34007g.ada
-c34007i.ada
-c34007j.ada
-c34007m.ada
-c34007p.ada
-c34007r.ada
-c34007s.ada
-c34007u.ada
-c34007v.ada
-c34008a.ada
-c34009a.ada
-c34009d.ada
-c34009f.ada
-c34009g.ada
-c34009j.ada
-c34009l.ada
-c34011b.ada
-c34012a.ada
-c34014a.ada
-c34014c.ada
-c34014e.ada
-c34014g.ada
-c34014h.ada
-c34014n.ada
-c34014p.ada
-c34014r.ada
-c34014t.ada
-c34014u.ada
-c34018a.ada
-c340a01.a
-c340a02.a
-c341a01.a
-c341a02.a
-c341a03.a
-c341a04.a
-c35003a.ada
-c35003b.ada
-c35003d.ada
-c35102a.ada
-c352001.a
-c354002.a
-c354003.a
-c35502a.ada
-c35502b.ada
-c35502c.ada
-c35502d.tst
-c35502e.ada
-c35502f.tst
-c35502g.ada
-c35502h.ada
-c35502i.ada
-c35502j.ada
-c35502k.ada
-c35502l.ada
-c35502m.ada
-c35502n.ada
-c35502o.ada
-c35502p.ada
-c35503a.ada
-c35503b.ada
-c35503c.ada
-c35503d.tst
-c35503e.ada
-c35503f.tst
-c35503g.ada
-c35503h.ada
-c35503k.ada
-c35503l.ada
-c35503o.ada
-c35503p.ada
-c35504a.ada
-c35504b.ada
-c35505c.ada
-c35505e.ada
-c35505f.ada
-c35507a.ada
-c35507b.ada
-c35507c.ada
-c35507e.ada
-c35507g.ada
-c35507h.ada
-c35507i.ada
-c35507j.ada
-c35507k.ada
-c35507l.ada
-c35507m.ada
-c35507n.ada
-c35507o.ada
-c35507p.ada
-c35508a.ada
-c35508b.ada
-c35508c.ada
-c35508e.ada
-c35508g.ada
-c35508h.ada
-c35508k.ada
-c35508l.ada
-c35508o.ada
-c35508p.ada
-c35703a.ada
-c35704a.ada
-c35704b.ada
-c35704c.ada
-c35704d.ada
-c35801d.ada
-c35902d.ada
-c35904a.ada
-c35904b.ada
-c35a02a.ada
-c35a05a.ada
-c35a05d.ada
-c35a05n.ada
-c35a05q.ada
-c35a07a.ada
-c35a07d.ada
-c35a08b.ada
-c360002.a
-c36104a.ada
-c36104b.ada
-c36172a.ada
-c36172b.ada
-c36172c.ada
-c36174a.ada
-c36180a.ada
-c36202c.ada
-c36203a.ada
-c36204a.ada
-c36204b.ada
-c36204c.ada
-c36204d.ada
-c36205a.ada
-c36205b.ada
-c36205c.ada
-c36205d.ada
-c36205e.ada
-c36205f.ada
-c36205g.ada
-c36205h.ada
-c36205i.ada
-c36205j.ada
-c36205k.ada
-c36205l.ada
-c36301a.ada
-c36301b.ada
-c36302a.ada
-c36304a.ada
-c36305a.ada
-c37002a.ada
-c37003a.ada
-c37003b.ada
-c37005a.ada
-c37006a.ada
-c37008a.ada
-c37008b.ada
-c37009a.ada
-c37010a.ada
-c37010b.ada
-c371001.a
-c371002.a
-c371003.a
-c37102b.ada
-c37103a.ada
-c37105a.ada
-c37107a.ada
-c37108b.ada
-c37206a.ada
-c37207a.ada
-c37208a.ada
-c37208b.ada
-c37209a.ada
-c37209b.ada
-c37210a.ada
-c37211a.ada
-c37211b.ada
-c37211c.ada
-c37211d.ada
-c37211e.ada
-c37213b.ada
-c37213d.ada
-c37213f.ada
-c37213h.ada
-c37213j.ada
-c37213k.ada
-c37213l.ada
-c37215b.ada
-c37215d.ada
-c37215f.ada
-c37215h.ada
-c37217a.ada
-c37217b.ada
-c37217c.ada
-c37304a.ada
-c37305a.ada
-c37306a.ada
-c37309a.ada
-c37310a.ada
-c37312a.ada
-c37402a.ada
-c37403a.ada
-c37404a.ada
-c37404b.ada
-c37405a.ada
-c37411a.ada
-c380001.a
-c380002.a
-c380003.a
-c380004.a
-c38002a.ada
-c38002b.ada
-c38005a.ada
-c38005b.ada
-c38005c.ada
-c38006a.ada
-c38102a.ada
-c38102b.ada
-c38102c.ada
-c38102d.ada
-c38102e.ada
-c38104a.ada
-c38107a.ada
-c38107b.ada
-c38108a.ada
-c38108b.ada
-c38108c0.ada
-c38108c1.ada
-c38108c2.ada
-c38108d0.ada
-c38108d1.ada
-c38202a.ada
-c3900010.a
-c3900011.am
-c390002.a
-c390003.a
-c390004.a
-c3900050.a
-c3900051.a
-c3900052.a
-c3900053.am
-c3900060.a
-c3900061.a
-c3900062.a
-c3900063.am
-c390007.a
-c390010.a
-c390011.a
-c39006a.ada
-c39006b.ada
-c39006c0.ada
-c39006c1.ada
-c39006d.ada
-c39006e.ada
-c39006f0.ada
-c39006f1.ada
-c39006f2.ada
-c39006f3.ada
-c39006g.ada
-c39007a.ada
-c39007b.ada
-c39008a.ada
-c39008b.ada
-c39008c.ada
-c390a010.a
-c390a011.am
-c390a020.a
-c390a021.a
-c390a022.am
-c390a030.a
-c390a031.am
-c391001.a
-c391002.a
-c392002.a
-c392003.a
-c392004.a
-c392005.a
-c392008.a
-c392010.a
-c392011.a
-c392013.a
-c392014.a
-c392a01.a
-c392c05.a
-c392c07.a
-c392d01.a
-c392d02.a
-c392d03.a
-c393001.a
-c393007.a
-c393008.a
-c393009.a
-c393010.a
-c393011.a
-c393012.a
-c393a02.a
-c393a03.a
-c393a05.a
-c393a06.a
-c393b12.a
-c393b13.a
-c393b14.a
-c3a0001.a
-c3a0002.a
-c3a0003.a
-c3a0004.a
-c3a0005.a
-c3a0006.a
-c3a0007.a
-c3a0008.a
-c3a0009.a
-c3a0010.a
-c3a0011.a
-c3a00120.a
-c3a00121.a
-c3a00122.am
-c3a0013.a
-c3a0014.a
-c3a0015.a
-c3a1001.a
-c3a1002.a
-c3a2001.a
-c3a2002.a
-c3a2003.a
-c3a2a01.a
-c3a2a02.a
-c410001.a
-c41101d.ada
-c41103a.ada
-c41103b.ada
-c41104a.ada
-c41105a.ada
-c41107a.ada
-c41201d.ada
-c41203a.ada
-c41203b.ada
-c41204a.ada
-c41205a.ada
-c41206a.ada
-c41207a.ada
-c41301a.ada
-c41303a.ada
-c41303b.ada
-c41303c.ada
-c41303e.ada
-c41303f.ada
-c41303g.ada
-c41303i.ada
-c41303j.ada
-c41303k.ada
-c41303m.ada
-c41303n.ada
-c41303o.ada
-c41303q.ada
-c41303r.ada
-c41303s.ada
-c41303u.ada
-c41303v.ada
-c41303w.ada
-c41304a.ada
-c41304b.ada
-c41306a.ada
-c41306b.ada
-c41306c.ada
-c41307d.ada
-c41309a.ada
-c41320a.ada
-c41321a.ada
-c41322a.ada
-c41323a.ada
-c41324a.ada
-c41325a.ada
-c41326a.ada
-c41327a.ada
-c41328a.ada
-c41401a.ada
-c41402a.ada
-c41404a.ada
-c420001.a
-c42006a.ada
-c42007e.ada
-c43003a.ada
-c43004a.ada
-c43004c.ada
-c431001.a
-c43103a.ada
-c43103b.ada
-c43104a.ada
-c43105a.ada
-c43105b.ada
-c43106a.ada
-c43107a.ada
-c43108a.ada
-c432001.a
-c432002.a
-c432003.a
-c432004.a
-c43204a.ada
-c43204c.ada
-c43204e.ada
-c43204f.ada
-c43204g.ada
-c43204h.ada
-c43204i.ada
-c43205a.ada
-c43205b.ada
-c43205c.ada
-c43205d.ada
-c43205e.ada
-c43205g.ada
-c43205h.ada
-c43205i.ada
-c43205j.ada
-c43205k.ada
-c43206a.ada
-c43207b.ada
-c43207d.ada
-c43208a.ada
-c43208b.ada
-c43209a.ada
-c43210a.ada
-c43211a.ada
-c43212a.ada
-c43212c.ada
-c43214a.ada
-c43214b.ada
-c43214c.ada
-c43214d.ada
-c43214e.ada
-c43214f.ada
-c43215a.ada
-c43215b.ada
-c43222a.ada
-c43224a.ada
-c433001.a
-c44003d.ada
-c44003f.ada
-c44003g.ada
-c450001.a
-c45112a.ada
-c45112b.ada
-c45113a.ada
-c45114b.ada
-c452001.a
-c45201a.ada
-c45201b.ada
-c45202b.ada
-c45210a.ada
-c45211a.ada
-c45220a.ada
-c45220b.ada
-c45220c.ada
-c45220d.ada
-c45220e.ada
-c45220f.ada
-c45231a.ada
-c45231b.dep
-c45231c.dep
-c45231d.tst
-c45232b.ada
-c45242b.ada
-c45251a.ada
-c45252a.ada
-c45252b.ada
-c45253a.ada
-c45262a.ada
-c45262b.ada
-c45262c.ada
-c45262d.ada
-c45264a.ada
-c45264b.ada
-c45264c.ada
-c45265a.ada
-c45271a.ada
-c45272a.ada
-c45273a.ada
-c45274a.ada
-c45274b.ada
-c45274c.ada
-c45281a.ada
-c45282a.ada
-c45282b.ada
-c45291a.ada
-c45303a.ada
-c45304a.ada
-c45304b.dep
-c45304c.dep
-c45322a.ada
-c45323a.ada
-c45331a.ada
-c45342a.ada
-c45343a.ada
-c45344a.ada
-c45345b.ada
-c45347a.ada
-c45347b.ada
-c45347c.ada
-c45347d.ada
-c45411a.ada
-c45411b.dep
-c45411c.dep
-c45411d.ada
-c45413a.ada
-c45431a.ada
-c455001.a
-c45502b.dep
-c45502c.dep
-c45503a.ada
-c45503b.dep
-c45503c.dep
-c45504a.ada
-c45504b.dep
-c45504c.dep
-c45504d.ada
-c45504e.dep
-c45504f.dep
-c45505a.ada
-c45523a.ada
-c45531a.ada
-c45531b.ada
-c45531c.ada
-c45531d.ada
-c45531e.ada
-c45531f.ada
-c45531g.ada
-c45531h.ada
-c45531i.ada
-c45531j.ada
-c45531k.ada
-c45531l.ada
-c45531m.dep
-c45531n.dep
-c45531o.dep
-c45531p.dep
-c45532a.ada
-c45532b.ada
-c45532c.ada
-c45532d.ada
-c45532e.ada
-c45532f.ada
-c45532g.ada
-c45532h.ada
-c45532i.ada
-c45532j.ada
-c45532k.ada
-c45532l.ada
-c45532m.dep
-c45532n.dep
-c45532o.dep
-c45532p.dep
-c45534b.ada
-c45536a.dep
-c456001.a
-c45611a.ada
-c45611b.dep
-c45611c.dep
-c45613a.ada
-c45613b.dep
-c45613c.dep
-c45614a.ada
-c45614b.dep
-c45614c.dep
-c45631a.ada
-c45631b.dep
-c45631c.dep
-c45632a.ada
-c45632b.dep
-c45632c.dep
-c45651a.ada
-c45662a.ada
-c45662b.ada
-c45672a.ada
-c460001.a
-c460002.a
-c460004.a
-c460005.a
-c460006.a
-c460007.a
-c460008.a
-c460009.a
-c460010.a
-c460011.a
-c460012.a
-c46011a.ada
-c46013a.ada
-c46014a.ada
-c46021a.ada
-c46024a.ada
-c46031a.ada
-c46032a.ada
-c46033a.ada
-c46041a.ada
-c46042a.ada
-c46043b.ada
-c46044b.ada
-c46051a.ada
-c46051b.ada
-c46051c.ada
-c46052a.ada
-c46053a.ada
-c46054a.ada
-c460a01.a
-c460a02.a
-c47002a.ada
-c47002b.ada
-c47002c.ada
-c47002d.ada
-c47003a.ada
-c47004a.ada
-c47005a.ada
-c47006a.ada
-c47007a.ada
-c47008a.ada
-c47009a.ada
-c47009b.ada
-c48004a.ada
-c48004b.ada
-c48004c.ada
-c48004d.ada
-c48004e.ada
-c48004f.ada
-c48005a.ada
-c48005b.ada
-c48006a.ada
-c48006b.ada
-c48007a.ada
-c48007b.ada
-c48007c.ada
-c48008a.ada
-c48008c.ada
-c48009a.ada
-c48009b.ada
-c48009c.ada
-c48009d.ada
-c48009e.ada
-c48009f.ada
-c48009g.ada
-c48009h.ada
-c48009i.ada
-c48009j.ada
-c48010a.ada
-c48011a.ada
-c48012a.ada
-c490001.a
-c490002.a
-c490003.a
-c49020a.ada
-c49021a.ada
-c49022a.ada
-c49022b.ada
-c49022c.ada
-c49023a.ada
-c49024a.ada
-c49025a.ada
-c49026a.ada
-c4a005b.ada
-c4a006a.ada
-c4a007a.tst
-c4a010a.ada
-c4a010b.ada
-c4a011a.ada
-c4a012b.ada
-c4a013a.ada
-c4a014a.ada
-c51004a.ada
-c52005a.ada
-c52005b.ada
-c52005c.ada
-c52005d.ada
-c52005e.ada
-c52005f.ada
-c52008a.ada
-c52008b.ada
-c52009a.ada
-c52009b.ada
-c52010a.ada
-c52011a.ada
-c52011b.ada
-c52101a.ada
-c52102a.ada
-c52102b.ada
-c52102c.ada
-c52102d.ada
-c52103a.ada
-c52103b.ada
-c52103c.ada
-c52103f.ada
-c52103g.ada
-c52103h.ada
-c52103k.ada
-c52103l.ada
-c52103m.ada
-c52103p.ada
-c52103q.ada
-c52103r.ada
-c52103x.ada
-c52104a.ada
-c52104b.ada
-c52104c.ada
-c52104f.ada
-c52104g.ada
-c52104h.ada
-c52104k.ada
-c52104l.ada
-c52104m.ada
-c52104p.ada
-c52104q.ada
-c52104r.ada
-c52104x.ada
-c52104y.ada
-c53007a.ada
-c540001.a
-c54a03a.ada
-c54a04a.ada
-c54a07a.ada
-c54a13a.ada
-c54a13b.ada
-c54a13c.ada
-c54a13d.ada
-c54a22a.ada
-c54a23a.ada
-c54a24a.ada
-c54a24b.ada
-c54a42a.ada
-c54a42b.ada
-c54a42c.ada
-c54a42d.ada
-c54a42e.ada
-c54a42f.ada
-c54a42g.ada
-c55b03a.ada
-c55b04a.ada
-c55b05a.ada
-c55b06a.ada
-c55b06b.ada
-c55b07a.dep
-c55b07b.dep
-c55b10a.ada
-c55b11a.ada
-c55b11b.ada
-c55b15a.ada
-c55b16a.ada
-c55c02a.ada
-c55c02b.ada
-c56002a.ada
-c57003a.ada
-c57004a.ada
-c57004b.ada
-c58004c.ada
-c58004d.ada
-c58004g.ada
-c58005a.ada
-c58005b.ada
-c58005h.ada
-c58006a.ada
-c58006b.ada
-c59002a.ada
-c59002b.ada
-c59002c.ada
-c61008a.ada
-c61009a.ada
-c61010a.ada
-c62002a.ada
-c62003a.ada
-c62003b.ada
-c62004a.ada
-c62006a.ada
-c631001.a
-c640001.a
-c64002b.ada
-c64004g.ada
-c64005a.ada
-c64005b.ada
-c64005c.ada
-c64005d0.ada
-c64005da.ada
-c64005db.ada
-c64005dc.ada
-c641001.a
-c64103b.ada
-c64103c.ada
-c64103d.ada
-c64103e.ada
-c64103f.ada
-c64104a.ada
-c64104b.ada
-c64104c.ada
-c64104d.ada
-c64104e.ada
-c64104f.ada
-c64104g.ada
-c64104h.ada
-c64104i.ada
-c64104j.ada
-c64104k.ada
-c64104l.ada
-c64104m.ada
-c64104n.ada
-c64104o.ada
-c64105a.ada
-c64105b.ada
-c64105c.ada
-c64105d.ada
-c64106a.ada
-c64106b.ada
-c64106c.ada
-c64106d.ada
-c64107a.ada
-c64108a.ada
-c64109a.ada
-c64109b.ada
-c64109c.ada
-c64109d.ada
-c64109e.ada
-c64109f.ada
-c64109g.ada
-c64109h.ada
-c64109i.ada
-c64109j.ada
-c64109k.ada
-c64109l.ada
-c64201b.ada
-c64201c.ada
-c64202a.ada
-c650001.a
-c65003a.ada
-c65003b.ada
-c66002a.ada
-c66002c.ada
-c66002d.ada
-c66002e.ada
-c66002f.ada
-c66002g.ada
-c67002a.ada
-c67002b.ada
-c67002c.ada
-c67002d.ada
-c67002e.ada
-c67003f.ada
-c67005a.ada
-c67005b.ada
-c67005c.ada
-c67005d.ada
-c72001b.ada
-c72002a.ada
-c730001.a
-c730002.a
-c730003.a
-c730004.a
-c73002a.ada
-c730a01.a
-c730a02.a
-c731001.a
-c74004a.ada
-c74203a.ada
-c74206a.ada
-c74207b.ada
-c74208a.ada
-c74208b.ada
-c74209a.ada
-c74210a.ada
-c74211a.ada
-c74211b.ada
-c74302a.ada
-c74302b.ada
-c74305a.ada
-c74305b.ada
-c74306a.ada
-c74307a.ada
-c74401d.ada
-c74401e.ada
-c74401k.ada
-c74401q.ada
-c74402a.ada
-c74402b.ada
-c74406a.ada
-c74407b.ada
-c74409b.ada
-c760001.a
-c760002.a
-c760007.a
-c760009.a
-c760010.a
-c760011.a
-c760012.a
-c760013.a
-c761001.a
-c761002.a
-c761003.a
-c761004.a
-c761005.a
-c761006.a
-c761007.a
-c761010.a
-c761011.a
-c761012.a
-c83007a.ada
-c83012d.ada
-c83022a.ada
-c83022g0.ada
-c83022g1.ada
-c83023a.ada
-c83024a.ada
-c83024e0.ada
-c83024e1.ada
-c83025a.ada
-c83025c.ada
-c83027a.ada
-c83027c.ada
-c83028a.ada
-c83029a.ada
-c83030a.ada
-c83030c.ada
-c83031a.ada
-c83031c.ada
-c83031e.ada
-c83032a.ada
-c83033a.ada
-c83051a.ada
-c83b02a.ada
-c83b02b.ada
-c83e02a.ada
-c83e02b.ada
-c83e03a.ada
-c83f01a.ada
-c83f01b.ada
-c83f01c0.ada
-c83f01c1.ada
-c83f01c2.ada
-c83f01d0.ada
-c83f01d1.ada
-c83f03a.ada
-c83f03b.ada
-c83f03c0.ada
-c83f03c1.ada
-c83f03c2.ada
-c83f03d0.ada
-c83f03d1.ada
-c840001.a
-c84002a.ada
-c84005a.ada
-c84008a.ada
-c84009a.ada
-c85004b.ada
-c85005a.ada
-c85005b.ada
-c85005c.ada
-c85005d.ada
-c85005e.ada
-c85005f.ada
-c85005g.ada
-c85006a.ada
-c85006b.ada
-c85006c.ada
-c85006d.ada
-c85006e.ada
-c85006f.ada
-c85006g.ada
-c85007a.ada
-c85007e.ada
-c85009a.ada
-c85011a.ada
-c85013a.ada
-c85014a.ada
-c85014b.ada
-c85014c.ada
-c85017a.ada
-c85018a.ada
-c85018b.ada
-c85019a.ada
-c854001.a
-c854002.a
-c854003.a
-c86003a.ada
-c86004a.ada
-c86004b0.ada
-c86004b1.ada
-c86004b2.ada
-c86004c0.ada
-c86004c1.ada
-c86004c2.ada
-c86006i.ada
-c86007a.ada
-c87a05a.ada
-c87a05b.ada
-c87b02a.ada
-c87b02b.ada
-c87b03a.ada
-c87b04a.ada
-c87b04b.ada
-c87b04c.ada
-c87b05a.ada
-c87b06a.ada
-c87b07a.ada
-c87b07b.ada
-c87b07c.ada
-c87b07d.ada
-c87b07e.ada
-c87b08a.ada
-c87b09a.ada
-c87b09c.ada
-c87b10a.ada
-c87b11a.ada
-c87b11b.ada
-c87b13a.ada
-c87b14a.ada
-c87b14b.ada
-c87b14c.ada
-c87b14d.ada
-c87b15a.ada
-c87b16a.ada
-c87b17a.ada
-c87b18a.ada
-c87b18b.ada
-c87b19a.ada
-c87b23a.ada
-c87b24a.ada
-c87b24b.ada
-c87b26b.ada
-c87b27a.ada
-c87b28a.ada
-c87b29a.ada
-c87b30a.ada
-c87b31a.ada
-c87b32a.ada
-c87b33a.ada
-c87b34a.ada
-c87b34b.ada
-c87b34c.ada
-c87b35c.ada
-c87b38a.ada
-c87b39a.ada
-c87b40a.ada
-c87b41a.ada
-c87b42a.ada
-c87b43a.ada
-c87b44a.ada
-c87b45a.ada
-c87b45c.ada
-c87b47a.ada
-c87b48a.ada
-c87b48b.ada
-c87b50a.ada
-c87b54a.ada
-c87b57a.ada
-c87b62a.ada
-c87b62b.ada
-c87b62c.ada
-c87b62d.tst
-c910001.a
-c910002.a
-c910003.a
-c91004b.ada
-c91004c.ada
-c91006a.ada
-c91007a.ada
-c92002a.ada
-c92003a.ada
-c92005a.ada
-c92005b.ada
-c92006a.ada
-c930001.a
-c93001a.ada
-c93002a.ada
-c93003a.ada
-c93004a.ada
-c93004b.ada
-c93004c.ada
-c93004d.ada
-c93004f.ada
-c93005a.ada
-c93005b.ada
-c93005c.ada
-c93005d.ada
-c93005e.ada
-c93005f.ada
-c93005g.ada
-c93005h.ada
-c93006a.ada
-c93007a.ada
-c93008a.ada
-c93008b.ada
-c940001.a
-c940002.a
-c940004.a
-c940005.a
-c940006.a
-c940007.a
-c940010.a
-c940011.a
-c940012.a
-c940013.a
-c940014.a
-c940015.a
-c940016.a
-c94001a.ada
-c94001b.ada
-c94001c.ada
-c94001e.ada
-c94001f.ada
-c94001g.ada
-c94002a.ada
-c94002b.ada
-c94002d.ada
-c94002e.ada
-c94002f.ada
-c94002g.ada
-c94004a.ada
-c94004b.ada
-c94004c.ada
-c94005a.ada
-c94005b.ada
-c94006a.ada
-c94007a.ada
-c94007b.ada
-c94008a.ada
-c94008b.ada
-c94008c.ada
-c94008d.ada
-c94010a.ada
-c94011a.ada
-c94020a.ada
-c940a03.a
-c95008a.ada
-c95009a.ada
-c95010a.ada
-c95011a.ada
-c95012a.ada
-c95021a.ada
-c95022a.ada
-c95022b.ada
-c95033a.ada
-c95033b.ada
-c95034a.ada
-c95034b.ada
-c95035a.ada
-c95040a.ada
-c95040b.ada
-c95040c.ada
-c95040d.ada
-c95041a.ada
-c95065a.ada
-c95065b.ada
-c95065c.ada
-c95065d.ada
-c95065e.ada
-c95065f.ada
-c95066a.ada
-c95067a.ada
-c95071a.ada
-c95072a.ada
-c95072b.ada
-c95073a.ada
-c95074c.ada
-c95076a.ada
-c95078a.ada
-c95080b.ada
-c95082g.ada
-c95085a.ada
-c95085b.ada
-c95085c.ada
-c95085d.ada
-c95085e.ada
-c95085f.ada
-c95085g.ada
-c95085h.ada
-c95085i.ada
-c95085j.ada
-c95085k.ada
-c95085l.ada
-c95085m.ada
-c95085n.ada
-c95085o.ada
-c95086a.ada
-c95086b.ada
-c95086c.ada
-c95086d.ada
-c95086e.ada
-c95086f.ada
-c95087a.ada
-c95087b.ada
-c95087c.ada
-c95087d.ada
-c95088a.ada
-c95089a.ada
-c95090a.ada
-c95092a.ada
-c95093a.ada
-c95095a.ada
-c95095b.ada
-c95095c.ada
-c95095d.ada
-c95095e.ada
-c951001.a
-c951002.a
-c953001.a
-c953002.a
-c953003.a
-c954001.a
-c954010.a
-c954011.a
-c954012.a
-c954013.a
-c954014.a
-c954015.a
-c954016.a
-c954017.a
-c954018.a
-c954019.a
-c954020.a
-c954021.a
-c954022.a
-c954023.a
-c954024.a
-c954025.a
-c954026.a
-c954a01.a
-c954a02.a
-c954a03.a
-c960001.a
-c960002.a
-c960004.a
-c96001a.ada
-c96004a.ada
-c96005a.ada
-c96005b.tst
-c96005d.ada
-c96005f.ada
-c96006a.ada
-c96007a.ada
-c96008a.ada
-c96008b.ada
-c97112a.ada
-c97113a.ada
-c97114a.ada
-c97115a.ada
-c97116a.ada
-c97117a.ada
-c97117b.ada
-c97117c.ada
-c97118a.ada
-c97120a.ada
-c97120b.ada
-c97201a.ada
-c97201b.ada
-c97201c.ada
-c97201d.ada
-c97201e.ada
-c97201g.ada
-c97201h.ada
-c97201x.ada
-c97202a.ada
-c97203a.ada
-c97203b.ada
-c97203c.ada
-c97204a.ada
-c97204b.ada
-c97205a.ada
-c97205b.ada
-c97301a.ada
-c97301b.ada
-c97301c.ada
-c97301d.ada
-c97301e.ada
-c97302a.ada
-c97303a.ada
-c97303b.ada
-c97303c.ada
-c97304a.ada
-c97304b.ada
-c97305a.ada
-c97305b.ada
-c97305c.ada
-c97305d.ada
-c97307a.ada
-c974001.a
-c974002.a
-c974003.a
-c974004.a
-c974005.a
-c974006.a
-c974007.a
-c974008.a
-c974009.a
-c974010.a
-c974011.a
-c974012.a
-c974013.a
-c974014.a
-c980001.a
-c980002.a
-c980003.a
-c99004a.ada
-c99005a.ada
-c9a003a.ada
-c9a004a.ada
-c9a007a.ada
-c9a009a.ada
-c9a009c.ada
-c9a009f.ada
-c9a009g.ada
-c9a009h.ada
-c9a010a.ada
-c9a011a.ada
-c9a011b.ada
-ca1003a.ada
-ca1004a.ada
-ca1005a.ada
-ca1006a.ada
-ca1011a0.ada
-ca1011a1.ada
-ca1011a2.ada
-ca1011a3.ada
-ca1011a4.ada
-ca1011a5.ada
-ca1011a6.ada
-ca1012a0.ada
-ca1012a1.ada
-ca1012a2.ada
-ca1012a3.ada
-ca1012a4.ada
-ca1012b0.ada
-ca1012b2.ada
-ca1012b4.ada
-ca1013a0.ada
-ca1013a1.ada
-ca1013a2.ada
-ca1013a3.ada
-ca1013a4.ada
-ca1013a5.ada
-ca1013a6.ada
-ca1014a0.ada
-ca1014a1.ada
-ca1014a2.ada
-ca1014a3.ada
-ca1020e0.ada
-ca1020e1.ada
-ca1020e2.ada
-ca1020e3.ada
-ca1022a0.ada
-ca1022a1.ada
-ca1022a2.ada
-ca1022a3.ada
-ca1022a4.ada
-ca1022a5.ada
-ca1022a6.ada
-ca11001.a
-ca11002.a
-ca11003.a
-ca110040.a
-ca110041.a
-ca110042.am
-ca110050.a
-ca110051.am
-ca11006.a
-ca11007.a
-ca11008.a
-ca11009.a
-ca11010.a
-ca11011.a
-ca11012.a
-ca11013.a
-ca11014.a
-ca11015.a
-ca11016.a
-ca11017.a
-ca11018.a
-ca11019.a
-ca11020.a
-ca11021.a
-ca11022.a
-ca1102a0.ada
-ca1102a1.ada
-ca1102a2.ada
-ca1106a.ada
-ca1108a.ada
-ca1108b.ada
-ca11a01.a
-ca11a02.a
-ca11b01.a
-ca11b02.a
-ca11c01.a
-ca11c02.a
-ca11c03.a
-ca11d010.a
-ca11d011.a
-ca11d012.a
-ca11d013.am
-ca11d02.a
-ca11d03.a
-ca13001.a
-ca13002.a
-ca13003.a
-ca13a01.a
-ca13a02.a
-ca140230.a
-ca140231.a
-ca140232.am
-ca140233.a
-ca140280.a
-ca140281.a
-ca140282.a
-ca140283.am
-ca15003.a
-ca200020.a
-ca200021.a
-ca200022.am
-ca2001h0.ada
-ca2001h1.ada
-ca2001h2.ada
-ca2001h3.ada
-ca2002a0.ada
-ca2002a1.ada
-ca2002a2.ada
-ca2003a0.ada
-ca2003a1.ada
-ca2004a0.ada
-ca2004a1.ada
-ca2004a2.ada
-ca2004a3.ada
-ca2004a4.ada
-ca2007a0.ada
-ca2007a1.ada
-ca2007a2.ada
-ca2007a3.ada
-ca2008a0.ada
-ca2008a1.ada
-ca2008a2.ada
-ca2009a.ada
-ca2009c0.ada
-ca2009c1.ada
-ca2009d.ada
-ca2009f0.ada
-ca2009f1.ada
-ca2009f2.ada
-ca2011b.ada
-ca21001.a
-ca3011a0.ada
-ca3011a1.ada
-ca3011a2.ada
-ca3011a3.ada
-ca3011a4.ada
-ca5003a0.ada
-ca5003a1.ada
-ca5003a2.ada
-ca5003a3.ada
-ca5003a4.ada
-ca5003a5.ada
-ca5003a6.ada
-ca5003b0.ada
-ca5003b1.ada
-ca5003b2.ada
-ca5003b3.ada
-ca5003b4.ada
-ca5003b5.ada
-ca5004a.ada
-ca5004b0.ada
-ca5004b1.ada
-ca5004b2.ada
-ca5006a.ada
-cb10002.a
-cb1001a.ada
-cb1004a.ada
-cb1005a.ada
-cb1010a.ada
-cb1010c.ada
-cb1010d.ada
-cb20001.a
-cb20003.a
-cb20004.a
-cb20005.a
-cb20006.a
-cb20007.a
-cb2004a.ada
-cb2005a.ada
-cb2006a.ada
-cb2007a.ada
-cb20a02.a
-cb3003a.ada
-cb3003b.ada
-cb3004a.ada
-cb40005.a
-cb4001a.ada
-cb4002a.ada
-cb4003a.ada
-cb4004a.ada
-cb4005a.ada
-cb4006a.ada
-cb4007a.ada
-cb4008a.ada
-cb4009a.ada
-cb4013a.ada
-cb40a01.a
-cb40a020.a
-cb40a021.am
-cb40a030.a
-cb40a031.am
-cb40a04.a
-cb41001.a
-cb41002.a
-cb41003.a
-cb41004.a
-cb5001a.ada
-cb5001b.ada
-cb5002a.ada
-cc1004a.ada
-cc1005b.ada
-cc1010a.ada
-cc1010b.ada
-cc1018a.ada
-cc1104c.ada
-cc1107b.ada
-cc1111a.ada
-cc1204a.ada
-cc1207b.ada
-cc1220a.ada
-cc1221a.ada
-cc1221b.ada
-cc1221c.ada
-cc1221d.ada
-cc1222a.ada
-cc1223a.ada
-cc1224a.ada
-cc1225a.tst
-cc1226b.ada
-cc1227a.ada
-cc1301a.ada
-cc1302a.ada
-cc1304a.ada
-cc1304b.ada
-cc1307a.ada
-cc1307b.ada
-cc1308a.ada
-cc1310a.ada
-cc1311a.ada
-cc1311b.ada
-cc2002a.ada
-cc30001.a
-cc30002.a
-cc3004a.ada
-cc3007a.ada
-cc3007b.ada
-cc3011a.ada
-cc3011d.ada
-cc3012a.ada
-cc3015a.ada
-cc3016b.ada
-cc3016c.ada
-cc3016f.ada
-cc3016i.ada
-cc3017b.ada
-cc3017c.ada
-cc3019a.ada
-cc3019b0.ada
-cc3019b1.ada
-cc3019b2.ada
-cc3019c0.ada
-cc3019c1.ada
-cc3019c2.ada
-cc3106b.ada
-cc3120a.ada
-cc3120b.ada
-cc3121a.ada
-cc3123a.ada
-cc3125a.ada
-cc3125b.ada
-cc3125c.ada
-cc3125d.ada
-cc3126a.ada
-cc3127a.ada
-cc3128a.ada
-cc3203a.ada
-cc3207b.ada
-cc3220a.ada
-cc3221a.ada
-cc3222a.ada
-cc3223a.ada
-cc3224a.ada
-cc3225a.ada
-cc3230a.ada
-cc3231a.ada
-cc3232a.ada
-cc3233a.ada
-cc3234a.ada
-cc3235a.ada
-cc3236a.ada
-cc3240a.ada
-cc3305a.ada
-cc3305b.ada
-cc3305c.ada
-cc3305d.ada
-cc3601a.ada
-cc3601c.ada
-cc3602a.ada
-cc3603a.ada
-cc3605a.ada
-cc3606a.ada
-cc3606b.ada
-cc3607b.ada
-cc40001.a
-cc50001.a
-cc50a01.a
-cc50a02.a
-cc51001.a
-cc51002.a
-cc51003.a
-cc51004.a
-cc51006.a
-cc51007.a
-cc51008.a
-cc51a01.a
-cc51b03.a
-cc51d01.a
-cc51d02.a
-cc54001.a
-cc54002.a
-cc54003.a
-cc54004.a
-cc70001.a
-cc70002.a
-cc70003.a
-cc70a01.a
-cc70a02.a
-cc70b01.a
-cc70b02.a
-cc70c01.a
-cc70c02.a
-cd10001.a
-cd10002.a
-cd1009a.ada
-cd1009b.ada
-cd1009d.ada
-cd1009e.ada
-cd1009f.ada
-cd1009g.ada
-cd1009h.ada
-cd1009i.ada
-cd1009j.ada
-cd1009k.tst
-cd1009l.ada
-cd1009m.ada
-cd1009n.ada
-cd1009o.ada
-cd1009p.ada
-cd1009q.ada
-cd1009r.ada
-cd1009s.ada
-cd1009t.tst
-cd1009u.tst
-cd1009v.ada
-cd1009w.ada
-cd1009x.ada
-cd1009y.ada
-cd1009z.ada
-cd1c03a.ada
-cd1c03b.ada
-cd1c03c.ada
-cd1c03e.tst
-cd1c03f.ada
-cd1c03g.ada
-cd1c03h.ada
-cd1c03i.ada
-cd1c04a.ada
-cd1c04d.ada
-cd1c04e.ada
-cd1c06a.tst
-cd20001.a
-cd2a21a.ada
-cd2a21c.ada
-cd2a21e.ada
-cd2a22a.ada
-cd2a22e.ada
-cd2a22i.ada
-cd2a22j.ada
-cd2a23a.ada
-cd2a23e.ada
-cd2a24a.ada
-cd2a24e.ada
-cd2a24i.ada
-cd2a24j.ada
-cd2a31a.ada
-cd2a31c.ada
-cd2a31e.ada
-cd2a32a.ada
-cd2a32c.ada
-cd2a32e.ada
-cd2a32g.ada
-cd2a32i.ada
-cd2a32j.ada
-cd2a51a.ada
-cd2a53a.ada
-cd2a53e.ada
-cd2a83c.tst
-cd2a91c.tst
-cd2b11a.ada
-cd2b11b.ada
-cd2b11d.ada
-cd2b11e.ada
-cd2b11f.ada
-cd2b15c.ada
-cd2b16a.ada
-cd2c11a.tst
-cd2c11d.tst
-cd2d11a.ada
-cd2d13a.ada
-cd30001.a
-cd30002.a
-cd30003.a
-cd30004.a
-cd300050.am
-cd300051.c
-cd3014a.ada
-cd3014c.ada
-cd3014d.ada
-cd3014f.ada
-cd3015a.ada
-cd3015c.ada
-cd3015e.ada
-cd3015f.ada
-cd3015g.ada
-cd3015h.ada
-cd3015i.ada
-cd3015k.ada
-cd3021a.ada
-cd33001.a
-cd33002.a
-cd40001.a
-cd4031a.ada
-cd4041a.tst
-cd4051a.ada
-cd4051b.ada
-cd4051c.ada
-cd4051d.ada
-cd5003a.ada
-cd5003b.ada
-cd5003c.ada
-cd5003d.ada
-cd5003e.ada
-cd5003f.ada
-cd5003g.ada
-cd5003h.ada
-cd5003i.ada
-cd5011a.ada
-cd5011c.ada
-cd5011e.ada
-cd5011g.ada
-cd5011i.ada
-cd5011k.ada
-cd5011m.ada
-cd5011q.ada
-cd5011s.ada
-cd5012a.ada
-cd5012b.ada
-cd5012e.ada
-cd5012f.ada
-cd5012i.ada
-cd5012m.ada
-cd5013a.ada
-cd5013c.ada
-cd5013e.ada
-cd5013g.ada
-cd5013i.ada
-cd5013k.ada
-cd5013m.ada
-cd5013o.ada
-cd5014a.ada
-cd5014c.ada
-cd5014e.ada
-cd5014g.ada
-cd5014i.ada
-cd5014k.ada
-cd5014m.ada
-cd5014o.ada
-cd5014t.ada
-cd5014v.ada
-cd5014x.ada
-cd5014y.ada
-cd5014z.ada
-cd70001.a
-cd7002a.ada
-cd7007b.ada
-cd7101d.ada
-cd7101e.dep
-cd7101f.dep
-cd7101g.tst
-cd7103d.ada
-cd7202a.ada
-cd7204b.ada
-cd7204c.ada
-cd72a01.a
-cd72a02.a
-cd7305a.ada
-cd90001.a
-cd92001.a
-cda201a.ada
-cda201b.ada
-cda201c.ada
-cda201e.ada
-cdb0a01.a
-cdb0a02.a
-cdd1001.a
-cdd2001.a
-cdd2a01.a
-cdd2a02.a
-cdd2a03.a
-cde0001.a
-ce2102a.ada
-ce2102b.ada
-ce2102c.tst
-ce2102d.ada
-ce2102e.ada
-ce2102f.ada
-ce2102g.ada
-ce2102h.tst
-ce2102i.ada
-ce2102j.ada
-ce2102k.ada
-ce2102l.ada
-ce2102m.ada
-ce2102n.ada
-ce2102o.ada
-ce2102p.ada
-ce2102q.ada
-ce2102r.ada
-ce2102s.ada
-ce2102t.ada
-ce2102u.ada
-ce2102v.ada
-ce2102w.ada
-ce2102x.ada
-ce2102y.ada
-ce2103a.tst
-ce2103b.tst
-ce2103c.ada
-ce2103d.ada
-ce2104a.ada
-ce2104b.ada
-ce2104c.ada
-ce2104d.ada
-ce2106a.ada
-ce2106b.ada
-ce2108e.ada
-ce2108f.ada
-ce2108g.ada
-ce2108h.ada
-ce2109a.ada
-ce2109b.ada
-ce2109c.ada
-ce2110a.ada
-ce2110c.ada
-ce2111a.ada
-ce2111b.ada
-ce2111c.ada
-ce2111e.ada
-ce2111f.ada
-ce2111g.ada
-ce2111i.ada
-ce2201a.ada
-ce2201b.ada
-ce2201c.ada
-ce2201d.dep
-ce2201e.dep
-ce2201f.ada
-ce2201g.ada
-ce2201h.ada
-ce2201i.ada
-ce2201j.ada
-ce2201k.ada
-ce2201l.ada
-ce2201m.ada
-ce2201n.ada
-ce2202a.ada
-ce2203a.tst
-ce2204a.ada
-ce2204b.ada
-ce2204c.ada
-ce2204d.ada
-ce2205a.ada
-ce2206a.ada
-ce2208b.ada
-ce2401a.ada
-ce2401b.ada
-ce2401c.ada
-ce2401e.ada
-ce2401f.ada
-ce2401h.ada
-ce2401i.ada
-ce2401j.ada
-ce2401k.ada
-ce2401l.ada
-ce2402a.ada
-ce2403a.tst
-ce2404a.ada
-ce2404b.ada
-ce2405b.ada
-ce2406a.ada
-ce2407a.ada
-ce2407b.ada
-ce2408a.ada
-ce2408b.ada
-ce2409a.ada
-ce2409b.ada
-ce2410a.ada
-ce2410b.ada
-ce2411a.ada
-ce3002b.tst
-ce3002c.tst
-ce3002d.ada
-ce3002f.ada
-ce3102a.ada
-ce3102b.tst
-ce3102d.ada
-ce3102e.ada
-ce3102f.ada
-ce3102g.ada
-ce3102h.ada
-ce3102i.ada
-ce3102j.ada
-ce3102k.ada
-ce3103a.ada
-ce3104a.ada
-ce3104b.ada
-ce3104c.ada
-ce3106a.ada
-ce3106b.ada
-ce3107a.tst
-ce3107b.ada
-ce3108a.ada
-ce3108b.ada
-ce3110a.ada
-ce3112c.ada
-ce3112d.ada
-ce3114a.ada
-ce3115a.ada
-ce3201a.ada
-ce3202a.ada
-ce3206a.ada
-ce3207a.ada
-ce3301a.ada
-ce3302a.ada
-ce3303a.ada
-ce3304a.tst
-ce3305a.ada
-ce3306a.ada
-ce3401a.ada
-ce3402a.ada
-ce3402c.ada
-ce3402d.ada
-ce3402e.ada
-ce3403a.ada
-ce3403b.ada
-ce3403c.ada
-ce3403d.ada
-ce3403e.ada
-ce3403f.ada
-ce3404a.ada
-ce3404b.ada
-ce3404c.ada
-ce3404d.ada
-ce3405a.ada
-ce3405c.ada
-ce3405d.ada
-ce3406a.ada
-ce3406b.ada
-ce3406c.ada
-ce3406d.ada
-ce3407a.ada
-ce3407b.ada
-ce3407c.ada
-ce3408a.ada
-ce3408b.ada
-ce3408c.ada
-ce3409a.ada
-ce3409b.ada
-ce3409c.ada
-ce3409d.ada
-ce3409e.ada
-ce3410a.ada
-ce3410b.ada
-ce3410c.ada
-ce3410d.ada
-ce3410e.ada
-ce3411a.ada
-ce3411c.ada
-ce3412a.ada
-ce3413a.ada
-ce3413b.ada
-ce3413c.ada
-ce3414a.ada
-ce3601a.ada
-ce3602a.ada
-ce3602b.ada
-ce3602c.ada
-ce3602d.ada
-ce3603a.ada
-ce3604a.ada
-ce3604b.ada
-ce3605a.ada
-ce3605b.ada
-ce3605c.ada
-ce3605d.ada
-ce3605e.ada
-ce3606a.ada
-ce3606b.ada
-ce3701a.ada
-ce3704a.ada
-ce3704b.ada
-ce3704c.ada
-ce3704d.ada
-ce3704e.ada
-ce3704f.ada
-ce3704m.ada
-ce3704n.ada
-ce3704o.ada
-ce3705a.ada
-ce3705b.ada
-ce3705c.ada
-ce3705d.ada
-ce3705e.ada
-ce3706c.ada
-ce3706d.ada
-ce3706f.ada
-ce3706g.ada
-ce3707a.ada
-ce3708a.ada
-ce3801a.ada
-ce3801b.ada
-ce3804a.ada
-ce3804b.ada
-ce3804c.ada
-ce3804d.ada
-ce3804e.ada
-ce3804f.ada
-ce3804g.ada
-ce3804h.ada
-ce3804i.ada
-ce3804j.ada
-ce3804m.ada
-ce3804o.ada
-ce3804p.ada
-ce3805a.ada
-ce3805b.ada
-ce3806a.ada
-ce3806b.ada
-ce3806c.ada
-ce3806d.ada
-ce3806e.ada
-ce3806f.ada
-ce3806g.ada
-ce3806h.ada
-ce3809a.ada
-ce3809b.ada
-ce3810a.ada
-ce3810b.ada
-ce3815a.ada
-ce3901a.ada
-ce3902b.ada
-ce3904a.ada
-ce3904b.ada
-ce3905a.ada
-ce3905b.ada
-ce3905c.ada
-ce3905l.ada
-ce3906a.ada
-ce3906b.ada
-ce3906c.ada
-ce3906d.ada
-ce3906e.ada
-ce3906f.ada
-ce3907a.ada
-ce3908a.ada
-checkfil.ada
-coverage.txt
-cxa3001.a
-cxa3002.a
-cxa3003.a
-cxa3004.a
-cxa4001.a
-cxa4002.a
-cxa4003.a
-cxa4004.a
-cxa4005.a
-cxa4006.a
-cxa4007.a
-cxa4008.a
-cxa4009.a
-cxa4010.a
-cxa4011.a
-cxa4012.a
-cxa4013.a
-cxa4014.a
-cxa4015.a
-cxa4016.a
-cxa4017.a
-cxa4018.a
-cxa4019.a
-cxa4020.a
-cxa4021.a
-cxa4022.a
-cxa4023.a
-cxa4024.a
-cxa4025.a
-cxa4026.a
-cxa4027.a
-cxa4028.a
-cxa4029.a
-cxa4030.a
-cxa4031.a
-cxa4032.a
-cxa4033.a
-cxa4034.a
-cxa5011.a
-cxa5012.a
-cxa5013.a
-cxa5015.a
-cxa5a01.a
-cxa5a02.a
-cxa5a03.a
-cxa5a04.a
-cxa5a05.a
-cxa5a06.a
-cxa5a07.a
-cxa5a08.a
-cxa5a09.a
-cxa5a10.a
-cxa8001.a
-cxa8002.a
-cxa8003.a
-cxa9001.a
-cxa9002.a
-cxaa001.a
-cxaa002.a
-cxaa003.a
-cxaa004.a
-cxaa005.a
-cxaa006.a
-cxaa007.a
-cxaa008.a
-cxaa009.a
-cxaa010.a
-cxaa011.a
-cxaa012.a
-cxaa013.a
-cxaa014.a
-cxaa015.a
-cxaa016.a
-cxaa017.a
-cxaa018.a
-cxaa019.a
-cxab001.a
-cxac001.a
-cxac002.a
-cxac003.a
-cxac004.a
-cxac005.a
-cxaca01.a
-cxaca02.a
-cxacb01.a
-cxacb02.a
-cxacc01.a
-cxaf001.a
-cxb2001.a
-cxb2002.a
-cxb2003.a
-cxb3001.a
-cxb3002.a
-cxb3003.a
-cxb30040.c
-cxb30041.am
-cxb3005.a
-cxb30060.c
-cxb30061.am
-cxb3007.a
-cxb3008.a
-cxb3009.a
-cxb3010.a
-cxb3011.a
-cxb3012.a
-cxb30130.c
-cxb30131.c
-cxb30132.am
-cxb3014.a
-cxb3015.a
-cxb3016.a
-cxb4001.a
-cxb4002.a
-cxb4003.a
-cxb4004.a
-cxb4005.a
-cxb4006.a
-cxb4007.a
-cxb4008.a
-cxb40090.cbl
-cxb40091.cbl
-cxb40092.cbl
-cxb40093.am
-cxb5001.a
-cxb5002.a
-cxb5003.a
-cxb50040.ftn
-cxb50041.ftn
-cxb50042.am
-cxb50050.ftn
-cxb50051.ftn
-cxb50052.am
-cxc3001.a
-cxc3002.a
-cxc3003.a
-cxc3004.a
-cxc3005.a
-cxc3006.a
-cxc3007.a
-cxc3008.a
-cxc3009.a
-cxc6001.a
-cxc6002.a
-cxc6003.a
-cxc7001.a
-cxc7002.a
-cxc7003.a
-cxc7004.a
-cxd1001.a
-cxd1002.a
-cxd1003.a
-cxd1004.a
-cxd1005.a
-cxd1006.a
-cxd1007.a
-cxd1008.a
-cxd2001.a
-cxd2002.a
-cxd2003.a
-cxd2004.a
-cxd2006.a
-cxd2007.a
-cxd2008.a
-cxd3001.a
-cxd3002.a
-cxd3003.a
-cxd4001.a
-cxd4002.a
-cxd4003.a
-cxd4004.a
-cxd4005.a
-cxd4006.a
-cxd4007.a
-cxd4008.a
-cxd4009.a
-cxd4010.a
-cxd5001.a
-cxd6001.a
-cxd6002.a
-cxd6003.a
-cxd8001.a
-cxd8002.a
-cxd8003.a
-cxd9001.a
-cxda001.a
-cxda002.a
-cxda003.a
-cxda004.a
-cxdb001.a
-cxdb002.a
-cxdb003.a
-cxdb004.a
-cxe1001.a
-cxe2001.a
-cxe2002.a
-cxe4001.a
-cxe4002.a
-cxe4003.a
-cxe4004.a
-cxe4005.a
-cxe4006.a
-cxe5001.a
-cxe5002.a
-cxe5003.a
-cxf1001.a
-cxf2001.a
-cxf2002.a
-cxf2003.a
-cxf2004.a
-cxf2005.a
-cxf2a01.a
-cxf2a02.a
-cxf3001.a
-cxf3002.a
-cxf3003.a
-cxf3004.a
-cxf3a01.a
-cxf3a02.a
-cxf3a03.a
-cxf3a04.a
-cxf3a05.a
-cxf3a06.a
-cxf3a07.a
-cxf3a08.a
-cxg1001.a
-cxg1002.a
-cxg1003.a
-cxg1004.a
-cxg1005.a
-cxg2001.a
-cxg2002.a
-cxg2003.a
-cxg2004.a
-cxg2005.a
-cxg2006.a
-cxg2007.a
-cxg2008.a
-cxg2009.a
-cxg2010.a
-cxg2011.a
-cxg2012.a
-cxg2013.a
-cxg2014.a
-cxg2015.a
-cxg2016.a
-cxg2017.a
-cxg2018.a
-cxg2019.a
-cxg2020.a
-cxg2021.a
-cxg2022.a
-cxg2023.a
-cxg2024.a
-cxh1001.a
-cxh3001.a
-cxh3002.a
-cxh30030.a
-cxh30031.am
-cz00004.a
-cz1101a.ada
-cz1102a.ada
-cz1103a.ada
-d4a002a.ada
-d4a002b.ada
-d4a004a.ada
-d4a004b.ada
-e28002b.ada
-e28005d.ada
-e52103y.ada
-eb4011a.ada
-eb4012a.ada
-eb4014a.ada
-ee3203a.ada
-ee3204a.ada
-ee3402b.ada
-ee3409f.ada
-ee3412c.ada
-enumchek.ada
-f340a000.a
-f340a001.a
-f341a00.a
-f390a00.a
-f392a00.a
-f392c00.a
-f392d00.a
-f393a00.a
-f393b00.a
-f3a2a00.a
-f460a00.a
-f730a000.a
-f730a001.a
-f731a00.a
-f940a00.a
-f954a00.a
-fa11a00.a
-fa11b00.a
-fa11c00.a
-fa11d00.a
-fa13a00.a
-fa13b00.a
-fa21a00.a
-fb20a00.a
-fb40a00.a
-fc50a00.a
-fc51a00.a
-fc51b00.a
-fc51c00.a
-fc51d00.a
-fc54a00.a
-fc70a00.a
-fc70b00.a
-fc70c00.a
-fcndecl.ada
-fd72a00.a
-fdb0a00.a
-fdd2a00.a
-fxa5a00.a
-fxaca00.a
-fxacb00.a
-fxacc00.a
-fxc6a00.a
-fxe2a00.a
-fxf2a00.a
-fxf3a00.a
-impdef.a
-impdefc.a
-impdefd.a
-impdefe.a
-impdefg.a
-impdefh.a
-la140010.a
-la140011.am
-la140012.a
-la140020.a
-la140021.am
-la140022.a
-la140030.a
-la140031.a
-la140032.am
-la140033.a
-la140040.a
-la140041.am
-la140042.a
-la140050.a
-la140051.a
-la140052.am
-la140053.a
-la140060.a
-la140061.a
-la140062.am
-la140063.a
-la140070.a
-la140071.a
-la140072.am
-la140073.a
-la140080.a
-la140081.a
-la140082.am
-la140083.a
-la140090.a
-la140091.a
-la140092.am
-la140093.a
-la140100.a
-la140101.a
-la140102.am
-la140103.a
-la140110.a
-la140111.a
-la140112.am
-la140113.a
-la140120.a
-la140121.a
-la140122.am
-la140123.a
-la140130.a
-la140131.a
-la140132.am
-la140133.a
-la140140.a
-la140141.a
-la140142.am
-la140143.a
-la140150.a
-la140151.a
-la140152.am
-la140153.a
-la140160.a
-la140161.a
-la140162.am
-la140163.a
-la140170.a
-la140171.a
-la140172.am
-la140173.a
-la140180.a
-la140181.a
-la140182.am
-la140183.a
-la140190.a
-la140191.a
-la140192.am
-la140193.a
-la140200.a
-la140201.a
-la140202.am
-la140203.a
-la140210.a
-la140211.am
-la140212.a
-la140220.a
-la140221.am
-la140222.a
-la140240.a
-la140241.a
-la140242.am
-la140243.a
-la140250.a
-la140251.am
-la140252.a
-la140260.a
-la140261.a
-la140262.am
-la140263.a
-la140270.a
-la140271.a
-la140272.am
-la140273.a
-la200010.a
-la200011.a
-la200012.am
-la5001a0.ada
-la5001a1.ada
-la5001a2.ada
-la5001a3.ada
-la5001a4.ada
-la5001a5.ada
-la5001a6.ada
-la5001a7.ada
-la5007a0.ada
-la5007a1.ada
-la5007b0.ada
-la5007b1.ada
-la5007c0.ada
-la5007c1.ada
-la5007d0.ada
-la5007d1.ada
-la5007e0.ada
-la5007e1.ada
-la5007f0.ada
-la5007f1.ada
-la5007g0.ada
-la5007g1.ada
-la5008a0.ada
-la5008a1.ada
-la5008b0.ada
-la5008b1.ada
-la5008c0.ada
-la5008c1.ada
-la5008d0.ada
-la5008d1.ada
-la5008e0.ada
-la5008e1.ada
-la5008f0.ada
-la5008f1.ada
-la5008g0.ada
-la5008g1.ada
-lc300010.a
-lc300011.a
-lc300012.am
-lc300020.a
-lc300021.a
-lc300022.am
-lc300030.a
-lc300031.a
-lc300032.am
-lencheck.ada
-lxd70010.a
-lxd70011.a
-lxd70012.am
-lxd70030.a
-lxd70031.a
-lxd70032.am
-lxd70040.a
-lxd70041.a
-lxd70042.am
-lxd70050.a
-lxd70051.a
-lxd70052.am
-lxd70060.a
-lxd70061.a
-lxd70062.am
-lxd70070.a
-lxd70071.a
-lxd70072.am
-lxd70080.a
-lxd70081.a
-lxd70082.am
-lxd70090.a
-lxd70091.a
-lxd70092.am
-lxe30010.am
-lxe30011.am
-lxe30020.am
-lxe30021.am
-lxh40010.a
-lxh40011.a
-lxh40012.am
-lxh40020.a
-lxh40021.a
-lxh40022.am
-lxh40030.a
-lxh40031.a
-lxh40032.a
-lxh40033.am
-lxh40040.a
-lxh40041.a
-lxh40042.a
-lxh40043.am
-lxh40050.a
-lxh40051.a
-lxh40052.a
-lxh40053.am
-lxh40060.a
-lxh40061.a
-lxh40062.a
-lxh40063.am
-lxh40070.a
-lxh40071.a
-lxh40072.a
-lxh40073.am
-lxh40080.a
-lxh40081.a
-lxh40082.a
-lxh40083.a
-lxh40084.am
-lxh40090.a
-lxh40091.a
-lxh40092.a
-lxh40093.am
-lxh40100.a
-lxh40101.a
-lxh40102.a
-lxh40103.am
-lxh40110.a
-lxh40111.a
-lxh40112.am
-lxh40120.a
-lxh40121.a
-lxh40122.a
-lxh40123.am
-lxh40130.a
-lxh40131.a
-lxh40132.a
-lxh40133.am
-lxh40140.a
-lxh40141.a
-lxh40142.am
-macro.dfs
-macrosub.ada
-repbody.ada
-repspec.ada
-spprt13s.tst
-tctouch.ada
-testobj.txt
-tsttests.dat
-ug-apxa.doc
-ug-apxa.pdf
-ug-apxa.txt
-ug-apxb.doc
-ug-apxb.pdf
-ug-apxb.txt
-ug-apxc.doc
-ug-apxc.pdf
-ug-apxc.txt
-ug-apxd.doc
-ug-apxd.pdf
-ug-apxd.txt
-ug-body.doc
-ug-body.pdf
-ug-body.txt
-widechr.a
diff --git a/gcc/testsuite/ada/acats/support/checkfil.ada b/gcc/testsuite/ada/acats/support/checkfil.ada
deleted file mode 100644
index cde0e5c..0000000
--- a/gcc/testsuite/ada/acats/support/checkfil.ada
+++ /dev/null
@@ -1,197 +0,0 @@
--- CHECK_FILE.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.
---*
---
--- THIS IS A PROCEDURE USED BY MANY OF THE CHAPTER 14 TESTS TO CHECK THE
--- CONTENTS OF A TEXT FILE.
-
--- THIS PROCEDURE ASSUMES THE FILE PARAMETER PASSED TO IT IS AN OPEN
--- TEXT FILE.
-
--- THE STRING PARAMETER CONTAINS THE CHARACTERS THAT ARE SUPPOSED TO BE
--- IN THE TEXT FILE. A '#' CHARACTER IS USED IN THE STRING TO DENOTE
--- THE END OF A LINE. A '@' CHARACTER IS USED TO DENOTE THE END OF A
--- PAGE. A '%' CHARACTER IS USED TO DENOTE THE END OF THE TEXT FILE.
--- THESE SYMBOLS SHOULD NOT BE USED AS TEXT OUTPUT.
-
--- SPS 11/30/82
--- JBG 2/3/83
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CHECK_FILE (FILE: IN OUT FILE_TYPE; CONTENTS : STRING) IS
-
- X : CHARACTER;
- COL_COUNT : POSITIVE_COUNT := 1;
- LINE_COUNT : POSITIVE_COUNT := 1;
- PAGE_COUNT : POSITIVE_COUNT := 1;
- TRAILING_BLANKS_MSG_WRITTEN : BOOLEAN := FALSE;
- STOP_PROCESSING : EXCEPTION;
-
- PROCEDURE CHECK_END_OF_LINE (EXPECT_END_OF_PAGE : BOOLEAN) IS
- BEGIN
-
--- SKIP OVER ANY TRAILING BLANKS. AN IMPLEMENTATION CAN LEGALLY
--- APPEND BLANKS TO THE END OF ANY LINE.
-
- WHILE NOT END_OF_LINE (FILE) LOOP
- GET (FILE, X);
- IF X /= ' ' THEN
- FAILED ("FROM CHECK_FILE: END OF LINE EXPECTED - " &
- X & " ENCOUNTERED");
- RAISE STOP_PROCESSING;
- ELSE
- IF NOT TRAILING_BLANKS_MSG_WRITTEN THEN
- COMMENT ("FROM CHECK_FILE: " &
- "THIS IMPLEMENTATION PADS " &
- "LINES WITH BLANKS");
- TRAILING_BLANKS_MSG_WRITTEN := TRUE;
- END IF;
- END IF;
- END LOOP;
-
- IF LINE_COUNT /= LINE (FILE) THEN
- FAILED ("FROM CHECK_FILE: " &
- "LINE COUNT INCORRECT - EXPECTED " &
- POSITIVE_COUNT'IMAGE(LINE_COUNT) &
- " GOT FROM FILE " &
- POSITIVE_COUNT'IMAGE(LINE(FILE)));
- END IF;
-
--- NOTE: DO NOT SKIP_LINE WHEN AT END OF PAGE BECAUSE SKIP_LINE WILL
--- ALSO SKIP THE PAGE TERMINATOR. SEE RM 14.3.5 PARAGRAPH 1.
-
- IF NOT EXPECT_END_OF_PAGE THEN
- IF END_OF_PAGE (FILE) THEN
- FAILED ("FROM CHECK_FILE: PREMATURE END OF PAGE");
- RAISE STOP_PROCESSING;
- ELSE
- SKIP_LINE (FILE);
- LINE_COUNT := LINE_COUNT + 1;
- END IF;
- END IF;
- COL_COUNT := 1;
- END CHECK_END_OF_LINE;
-
- PROCEDURE CHECK_END_OF_PAGE IS
- BEGIN
- IF NOT END_OF_PAGE (FILE) THEN
- FAILED ("FROM CHECK_FILE: " &
- "END_OF_PAGE NOT WHERE EXPECTED");
- RAISE STOP_PROCESSING;
- ELSE
- IF PAGE_COUNT /= PAGE (FILE) THEN
- FAILED ("FROM CHECK_FILE: " &
- "PAGE COUNT INCORRECT - EXPECTED " &
- POSITIVE_COUNT'IMAGE (PAGE_COUNT) &
- " GOT FROM FILE " &
- POSITIVE_COUNT'IMAGE (PAGE(FILE)));
- END IF;
-
- SKIP_PAGE (FILE);
- PAGE_COUNT := PAGE_COUNT + 1;
- LINE_COUNT := 1;
- END IF;
- END CHECK_END_OF_PAGE;
-
-BEGIN
-
- RESET (FILE, IN_FILE);
- SET_LINE_LENGTH (STANDARD_OUTPUT, 0);
- SET_PAGE_LENGTH (STANDARD_OUTPUT, 0);
-
- FOR I IN 1 .. CONTENTS'LENGTH LOOP
-
- BEGIN
- CASE CONTENTS (I) IS
- WHEN '#' =>
- CHECK_END_OF_LINE (CONTENTS (I + 1) = '@');
- WHEN '@' =>
- CHECK_END_OF_PAGE;
- WHEN '%' =>
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("FROM CHECK_FILE: " &
- "END_OF_FILE NOT WHERE EXPECTED");
- RAISE STOP_PROCESSING;
- END IF;
- WHEN OTHERS =>
- IF COL_COUNT /= COL(FILE) THEN
- FAILED ("FROM CHECK_FILE: " &
- "COL COUNT INCORRECT - " &
- "EXPECTED " & POSITIVE_COUNT'
- IMAGE(COL_COUNT) & " GOT FROM " &
- "FILE " & POSITIVE_COUNT'IMAGE
- (COL(FILE)));
- END IF;
- GET (FILE, X);
- COL_COUNT := COL_COUNT + 1;
- IF X /= CONTENTS (I) THEN
- FAILED("FROM CHECK_FILE: " &
- "FILE DOES NOT CONTAIN CORRECT " &
- "OUTPUT - EXPECTED " & CONTENTS(I)
- & " - GOT " & X);
- RAISE STOP_PROCESSING;
- END IF;
- END CASE;
- EXCEPTION
- WHEN STOP_PROCESSING =>
- COMMENT ("FROM CHECK_FILE: " &
- "LAST CHARACTER IN FOLLOWING STRING " &
- "REVEALED ERROR: " & CONTENTS (1 .. I));
- EXIT;
- END;
-
- END LOOP;
-
-EXCEPTION
- WHEN STATUS_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "STATUS_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN MODE_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "MODE_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN NAME_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "NAME_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN USE_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "USE_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN DEVICE_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "DEVICE_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN END_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "END_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN DATA_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "DATA_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN LAYOUT_ERROR =>
- FAILED ("FROM CHECK_FILE: " &
- "LAYOUT_ERROR RAISED - FILE CHECKING INCOMPLETE");
- WHEN OTHERS =>
- FAILED ("FROM CHECK_FILE: " &
- "SOME EXCEPTION RAISED - FILE CHECKING INCOMPLETE");
-
-END CHECK_FILE;
diff --git a/gcc/testsuite/ada/acats/support/enumchek.ada b/gcc/testsuite/ada/acats/support/enumchek.ada
deleted file mode 100644
index 044c1a8..0000000
--- a/gcc/testsuite/ada/acats/support/enumchek.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- THIS GENERIC PROCEDURE IS INTENDED FOR USE IN CONJUNCTION WITH THE ACVC
--- CHAPTER 13 C TESTS. IT IS INSTANTIATED WITH TWO TYPES. THE FIRST IS AN
--- ENUMERATION TYPE FOR WHICH AN ENUMERATION CLAUSE HAS BEEN GIVEN, AND THE
--- SECOND IS AN INTEGER TYPE WHOSE 'SIZE IS THE SAME AS THE 'SIZE OF THIS
--- ENUMERATION TYPE.
-
--- THE PROCEDURE ENUM_CHECK IS THEN CALLED WITH THREE ARGUMENTS. THE FIRST IS
--- AN ENUMERATION LITERAL FROM THE ENUMERATION TYPE, THE SECOND IS AN INTEGER
--- LITERAL WHICH IS THE VALUE OF THE EXPECTED REPRESENTATION (TAKEN FROM THE
--- ENUMERATION REPRESENTATION CLAUSE), AND THE THIRD IS A STRING DESCRIBING OR
--- NAMING THE TYPE (USED IN A CALL TO FAILED IF THE REPRESENTATION CHECK FAILS).
-
--- THE CHECK IS TO CONVERT THE ENUMERATION VALUE TO A BOOLEAN ARRAY WITH A
--- LENGTH CORRESONDING TO THE 'SIZE OF THE ENUMERATION TYPE. AN INTEGER TYPE
--- IS THEN CREATED WITH THIS SAME 'SIZE, AND THE REQUIRED REPRESENTATION VALUE
--- IS CONVERTED FROM THIS TYPE TO A BOOLEAN ARRAY WITH THE SAME LENGTH. THE
--- TWO BOOLEAN ARRAYS ARE THEN COMPARED AND SHOULD BE EQUAL. THE CONVERSIONS
--- ARE PERFORMED USING APPROPRIATE INSTANTIATIONS OF UNCHECKED_CONVERSION.
-
--- AUTHOR: ROBERT B. K. DEWAR, UNCOPYRIGHTED, PUBLIC DOMAIN USE AUTHORIZED
-
-GENERIC
-
- TYPE ENUM_TYPE IS PRIVATE;
- TYPE INT_TYPE IS RANGE <>;
-
-PROCEDURE ENUM_CHECK (TEST_VALUE : ENUM_TYPE;
- REP_VALUE : INT_TYPE;
- TYPE_ID : STRING);
-
-
-WITH UNCHECKED_CONVERSION;
-WITH REPORT; USE REPORT;
-
-PROCEDURE ENUM_CHECK (TEST_VALUE : ENUM_TYPE;
- REP_VALUE : INT_TYPE;
- TYPE_ID : STRING) IS
-
- TYPE BIT_ARRAY_TYPE IS ARRAY (1 .. ENUM_TYPE'SIZE) OF BOOLEAN;
- PRAGMA PACK (BIT_ARRAY_TYPE);
-
- FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (ENUM_TYPE, BIT_ARRAY_TYPE);
- FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (INT_TYPE, BIT_ARRAY_TYPE);
-
- BIT_ARRAY_1 : BIT_ARRAY_TYPE;
- BIT_ARRAY_2 : BIT_ARRAY_TYPE;
-
- INT_VALUE : INT_TYPE := INT_TYPE (REP_VALUE);
-
-BEGIN
-
- -- VERIFY CORRECT CALL (THIS IS A SANITY CHECK ON THE TEST ITSELF)
-
- IF ENUM_TYPE'SIZE /= INT_TYPE'SIZE THEN
- FAILED ("ERROR IN ENUM_CHECK CALL: SIZES DO NOT MATCH");
- END IF;
-
- BIT_ARRAY_1 := TO_BITS (TEST_VALUE);
- BIT_ARRAY_2 := TO_BITS (INT_VALUE);
-
- IF BIT_ARRAY_1 /= BIT_ARRAY_2 THEN
- FAILED ("CHECK ON REPRESENTATION OF TYPE " & TYPE_ID & " FAILED.");
- END IF;
-
-END ENUM_CHECK;
diff --git a/gcc/testsuite/ada/acats/support/f340a000.a b/gcc/testsuite/ada/acats/support/f340a000.a
deleted file mode 100644
index a3daf96..0000000
--- a/gcc/testsuite/ada/acats/support/f340a000.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- F340A000.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic linked list abstraction for use in tests
--- covering tagged types and type extensions.
---
--- TEST FILES:
--- This foundation consists of the following files:
---
--- => F340A000.A
--- F340A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma
--- Elaborate_Body.
---
---!
-
-generic -- Singly-linked list abstraction.
- type Parent_Type is tagged private; -- Actual is parent
-package F340A000 is -- tagged type.
-
- pragma Elaborate_Body;
-
-
- -- Declarations for visible linked list nodes:
-
- type Node_Type;
-
- type Node_Ptr is access Node_Type;
-
- type Node_Type is new Parent_Type with record -- Record extension
- Next : Node_Ptr := null; -- of parent type.
- end record;
-
-
- -- Inherits primitive operations of actual type corresponding
- -- to Parent_Type.
-
- -- Add node at head of list.
- procedure Add (Item : in Node_Ptr;
- Head : in out Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Node_Ptr;
- Item : out Node_Ptr);
-
-
-
- -- Declarations for private linked list nodes:
-
- type Priv_Node_Type is new Parent_Type with private; -- Private extension
- -- of parent type.
-
- -- Inherits primitive operations of actual parameter corresponding
- -- to Parent_Type.
-
-
- type Priv_Node_Ptr is access Priv_Node_Type;
-
-
- -- Add node at head of list.
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr);
-
-
-private
-
- type Priv_Node_Type is new Parent_Type with record
- Next : Priv_Node_Ptr := null;
- end record;
-
-end F340A000;
-
-
- --==================================================================--
-
-
-package body F340A000 is -- Singly-linked list abstraction.
-
- procedure Add (Item : in Node_Ptr;
- Head : in out Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Node_Ptr;
- Item : out Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
-end F340A000;
diff --git a/gcc/testsuite/ada/acats/support/f340a001.a b/gcc/testsuite/ada/acats/support/f340a001.a
deleted file mode 100644
index 3fe027e..0000000
--- a/gcc/testsuite/ada/acats/support/f340a001.a
+++ /dev/null
@@ -1,75 +0,0 @@
--- F340A001.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares a tagged type and primitive subprogram for use in
--- tests covering tagged types and type extensions.
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- F340A000.A
--- => F340A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F340A001 is -- Book definitions.
-
-
- type Text_Ptr is access String;
-
- type Book_Type is tagged record -- Root tagged type.
- Title : Text_Ptr;
- Author : Text_Ptr;
- end record;
-
-
- procedure Create_Book (Title : in Text_Ptr; -- Primitive operation
- Author : in Text_Ptr; -- of root tagged type.
- Book : out Book_Type);
-
-
-end F340A001;
-
-
- --==================================================================--
-
-
-package body F340A001 is -- Book definitions.
-
-
- procedure Create_Book (Title : in Text_Ptr;
- Author : in Text_Ptr;
- Book : out Book_Type) is
- begin
- Book.Title := Title;
- Book.Author := Author;
- end Create_Book;
-
-
-end F340A001;
diff --git a/gcc/testsuite/ada/acats/support/f341a00.a b/gcc/testsuite/ada/acats/support/f341a00.a
deleted file mode 100644
index b2e389f..0000000
--- a/gcc/testsuite/ada/acats/support/f341a00.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- F341A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a simple class hierarchy (a root type and two
--- levels of derivation from it) to use in testing the basic OO features
--- related to tagged types.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F341A00_0 is -- package Bank
-
- type Dollar_Amount is new Float;
-
- type Account is tagged
- record
- Current_Balance: Dollar_Amount;
- end record;
-
- -- Primitive operations.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount);
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount);
- function Balance (A : in Account) return Dollar_Amount;
- procedure Service_Charge (A : in out Account);
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end F341A00_0;
-
-
- --=================================================================--
-
-
-package body F341A00_0 is
-
- -- Primitive operations for type Account.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance + X;
- end Deposit;
-
- --
-
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance - X;
- end Withdrawal;
-
- --
-
- function Balance (A : in Account) return Dollar_Amount is
- begin
- return (A.Current_Balance);
- end Balance;
-
- --
-
- procedure Service_Charge (A : in out Account) is
- begin
- A.Current_Balance := A.Current_Balance - 5.00;
- end Service_Charge;
-
- --
-
- procedure Add_Interest (A : in out Account) is
- -- No interest accumulated on this type of account.
- Interest_On_Account : Dollar_Amount := 0.00;
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- --
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Dollar_Amount := 10.00;
- begin
- A.Current_Balance := Initial_Deposit;
- end Open;
-
-end F341A00_0;
-
-
- --=================================================================--
-
-
-with F341A00_0;
-
-package F341A00_1 is -- package Checking
-
- package Bank renames F341A00_0;
-
- type Account is new Bank.Account with
- record
- Overdraft_Fee : Bank.Dollar_Amount;
- end record;
-
-
- -- Inherited primitive operations.
- -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge(A : in out Account);
- -- procedure Add_Interest (A : in out Account);
-
- -- Overridden primitive operation.
- procedure Open (A : in out Account);
-
-end F341A00_1;
-
-
- --=================================================================--
-
-
-package body F341A00_1 is
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account) is
- Check_Guarantee : Bank.Dollar_Amount := 10.00;
- Initial_Deposit : Bank.Dollar_Amount := 100.00;
- begin
- A.Current_Balance := Initial_Deposit;
- A.Overdraft_Fee := Check_Guarantee;
- end Open;
-
-end F341A00_1;
-
-
- --=================================================================--
-
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-
-package F341A00_2 is -- package Interest_Checking
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
-
- subtype Interest_Rate is Bank.Dollar_Amount digits 4;
-
- Current_Rate : Interest_Rate := 0.030;
-
- type Account is new Checking.Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- "Twice" inherited primitive operations (Bank.Account, Checking.Account)
- -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge(A : in out Account);
-
- -- Overridden primitive operations.
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end F341A00_2;
-
-
- --=================================================================--
-
-
-package body F341A00_2 is
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account) is
- use type Bank.Dollar_Amount;
- Interest_On_Account : Bank.Dollar_Amount
- := Bank.Dollar_Amount(A.Current_Balance * A.Rate);
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Bank.Dollar_Amount := 1000.00;
- begin
- Checking.Open (Checking.Account (A));
- A.Current_Balance := Initial_Deposit;
- A.Rate := Current_Rate;
- end Open;
-
-end F341A00_2;
diff --git a/gcc/testsuite/ada/acats/support/f390a00.a b/gcc/testsuite/ada/acats/support/f390a00.a
deleted file mode 100644
index 0230812..0000000
--- a/gcc/testsuite/ada/acats/support/f390a00.a
+++ /dev/null
@@ -1,94 +0,0 @@
--- F390A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares the root type and primitive subprograms of an
--- alert system abstraction, to be used for tests covering tagged
--- types and type extensions.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Added pragma Elaborate for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package F390A00 is -- Alert system abstraction.
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-end F390A00;
-
-
- --==================================================================--
-
-
-package body F390A00 is -- Alert system abstraction.
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
-end F390A00;
diff --git a/gcc/testsuite/ada/acats/support/f392a00.a b/gcc/testsuite/ada/acats/support/f392a00.a
deleted file mode 100644
index 2d4f7a5..0000000
--- a/gcc/testsuite/ada/acats/support/f392a00.a
+++ /dev/null
@@ -1,200 +0,0 @@
--- F392A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for tests needing a hierarchy of
--- types to check object-oriented features.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F392A00 is -- package Accounts
-
- --
- -- Types and subtypes.
- --
-
- type Dollar_Amount is new Float;
- type Interest_Rate is delta 0.001 range 0.000 .. 1.000;
- type Account_Types is (Bank, Savings, Preferred, Total);
- type Account_Counter is array (Account_Types) of Integer;
- type Account_Rep is (President, Manager, New_Account_Manager, Teller);
-
- --
- -- Constants.
- --
-
- Opening_Balance : constant Dollar_Amount := 100.00;
- Current_Rate : constant Interest_Rate := 0.030;
- Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;
-
- --
- -- Global Variables
- --
-
- Bank_Reserve : Dollar_Amount := 0.00;
- Daily_Representative : Account_Rep := New_Account_Manager;
- Number_Of_Accounts : Account_Counter := (Bank => 0,
- Savings => 0,
- Preferred => 0,
- Total => 0);
- --
- -- Account types and their primitive operations.
- --
-
- -- Root type.
-
- type Bank_Account is tagged
- record
- Balance : Dollar_Amount;
- end record;
-
- -- Primitive operations of Bank_Account.
-
- procedure Increment_Bank_Reserve (Acct : in Bank_Account);
- procedure Assign_Representative (Acct : in Bank_Account);
- procedure Increment_Counters (Acct : in Bank_Account);
- procedure Open (Acct : in out Bank_Account);
-
- --
-
- type Savings_Account is new Bank_Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Procedure Increment_Bank_Reserve inherited from parent (Bank_Account).
-
- -- Primitive operations (Overridden).
- procedure Assign_Representative (Acct : in Savings_Account);
- procedure Increment_Counters (Acct : in Savings_Account);
- procedure Open (Acct : in out Savings_Account);
-
- --
-
- type Preferred_Account is new Savings_Account with
- record
- Minimum_Balance : Dollar_Amount;
- end record;
-
- -- Procedure Increment_Bank_Reserve inherited twice.
- -- Procedure Assign_Representative inherited from parent (Savings_Account).
-
- -- Primitive operations (Overridden).
- procedure Increment_Counters (Acct : in Preferred_Account);
- procedure Open (Acct : in out Preferred_Account);
-
- -- Function used to verify Open operation for Preferred_Account objects.
- function Verify_Open (Acct : in Preferred_Account) return Boolean;
-
-
-end F392A00;
-
-
- --=================================================================--
-
-
-package body F392A00 is
-
- --
- -- Primitive operations for Bank_Account.
- --
-
- procedure Increment_Bank_Reserve (Acct : in Bank_Account) is
- begin
- Bank_Reserve := Bank_Reserve + Acct.Balance;
- end Increment_Bank_Reserve;
-
- procedure Assign_Representative (Acct : in Bank_Account) is
- begin
- Daily_Representative := Teller;
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Bank_Account) is
- begin
- Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Bank_Account) is
- begin
- Acct.Balance := Opening_Balance;
- end Open;
-
-
- --
- -- Overridden operations for Savings_Account type.
- --
-
- procedure Assign_Representative (Acct : in Savings_Account) is
- begin
- Daily_Representative := Manager;
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Savings_Account) is
- begin
- Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Savings_Account) is
- begin
- Open (Bank_Account(Acct));
- Acct.Rate := Current_Rate;
- Acct.Balance := 2.0 * Opening_Balance;
- end Open;
-
-
- --
- -- Overridden operation for Preferred_Account type.
- --
-
- procedure Increment_Counters (Acct : in Preferred_Account) is
- begin
- Number_Of_Accounts (Preferred) := Number_Of_Accounts (Preferred) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Preferred_Account) is
- begin
- Open (Savings_Account(Acct));
- Acct.Minimum_Balance := Preferred_Minimum_Balance;
- Acct.Balance := Acct.Minimum_Balance;
- end Open;
-
- --
- -- Function used to verify Open operation for Preferred_Account objects.
- --
-
- function Verify_Open (Acct : in Preferred_Account) return Boolean is
- begin
- return (Acct.Balance = Preferred_Minimum_Balance and
- Acct.Rate = Current_Rate and
- Acct.Minimum_Balance = Preferred_Minimum_Balance);
- end Verify_Open;
-
-end F392A00;
diff --git a/gcc/testsuite/ada/acats/support/f392c00.a b/gcc/testsuite/ada/acats/support/f392c00.a
deleted file mode 100644
index 8a470e7..0000000
--- a/gcc/testsuite/ada/acats/support/f392c00.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- F392C00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for tagged type and dispatching
--- tests. Each test describes the utilizations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 OCT 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-package F392C00_1 is -- Switches
-
- type Toggle is tagged private; ---------------------------------- Toggle
-
- function Create return Toggle;
- procedure Flip ( It : in out Toggle );
- function On ( It : Toggle'Class ) return Boolean;
- function Off ( It : Toggle'Class ) return Boolean;
-
- type Dimmer is new Toggle with private; ------------------------- Dimmer
-
- type Luminance is range 0..100;
-
- function Create return Dimmer;
- procedure Flip ( It : in out Dimmer );
- procedure Brighten( It : in out Dimmer;
- By : in Luminance := 10 );
- procedure Dim ( It : in out Dimmer;
- By : in Luminance := 10 );
- function Intensity( It : Dimmer ) return Luminance;
-
- type Auto_Dimmer is new Dimmer with private; --------------- Auto_Dimmer
-
- function Create return Auto_Dimmer;
- procedure Flip ( It: in out Auto_Dimmer );
- procedure Set_Auto ( It: in out Auto_Dimmer );
- procedure Clear_Auto( It: in out Auto_Dimmer );
- -- procedure Set_Manual( It: in out Auto_Dimmer ) renames Clear_Auto;
- procedure Set_Cutin ( It: in out Auto_Dimmer; Lumens: in Luminance );
- procedure Set_Cutout( It: in out Auto_Dimmer; Lumens: in Luminance );
-
- function Auto ( It: Auto_Dimmer ) return Boolean;
- function Cutout_Threshold( It: Auto_Dimmer ) return Luminance;
- function Cutin_Threshold ( It: Auto_Dimmer ) return Luminance;
-
- function TC_CW_TI( Key : Character ) return Toggle'Class;
-
- function TC_Non_Disp( It: Toggle ) return Boolean;
- function TC_Non_Disp( It: Dimmer ) return Boolean;
- function TC_Non_Disp( It: Auto_Dimmer ) return Boolean;
-
-private
-
- type Toggle is tagged record
- On : Boolean := False;
- end record;
-
- type Dimmer is new Toggle with record
- Intensity : Luminance := 100;
- end record;
-
- type Auto_Dimmer is new Dimmer with record
- Cutout_Threshold : Luminance := 60;
- Cutin_Threshold : Luminance := 40;
- Auto_Engaged : Boolean := False;
- end record;
-
-end F392C00_1;
-
-with TCTouch;
-package body F392C00_1 is
-
- function Create return Toggle is
- begin
- TCTouch.Touch( '1' ); ------------------------------------------------ 1
- return Toggle'( On => True );
- end Create;
-
- function Create return Dimmer is
- begin
- TCTouch.Touch( '2' ); ------------------------------------------------ 2
- return Dimmer'( On => True, Intensity => 75 );
- end Create;
-
- function Create return Auto_Dimmer is
- begin
- TCTouch.Touch( '3' ); ------------------------------------------------ 3
- return Auto_Dimmer'( On => True, Intensity => 25,
- Cutout_Threshold | Cutin_Threshold => 50,
- Auto_Engaged => True );
- end Create;
-
- procedure Flip ( It : in out Toggle ) is
- begin
- TCTouch.Touch( 'A' ); ------------------------------------------------ A
- It.On := not It.On;
- end Flip;
-
- function On( It : Toggle'Class ) return Boolean is
- begin
- TCTouch.Touch( 'B' ); ------------------------------------------------ B
- return It.On;
- end On;
-
- function Off( It : Toggle'Class ) return Boolean is
- begin
- TCTouch.Touch( 'C' ); ------------------------------------------------ C
- return not It.On;
- end Off;
-
- procedure Brighten( It : in out Dimmer;
- By : in Luminance := 10 ) is
- begin
- TCTouch.Touch( 'D' ); ------------------------------------------------ D
- if (It.Intensity+By) <= Luminance'Last then
- It.Intensity := It.Intensity+By;
- else
- It.Intensity := Luminance'Last;
- end if;
- end Brighten;
-
- procedure Dim ( It : in out Dimmer;
- By : in Luminance := 10 ) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------------ E
- if (It.Intensity-By) >= Luminance'First then
- It.Intensity := It.Intensity-By;
- else
- It.Intensity := Luminance'First;
- end if;
- end Dim;
-
- function Intensity( It : Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'F' ); ------------------------------------------------ F
- if On(It) then
- return It.Intensity;
- else
- return Luminance'First;
- end if;
- end Intensity;
-
- procedure Flip ( It : in out Dimmer ) is
- begin
- TCTouch.Touch( 'G' ); ------------------------------------------------ G
- if On( It ) and (It.Intensity < 50) then
- It.Intensity := Luminance'Last - It.Intensity;
- else
- Flip( Toggle( It ) );
- end if;
- end Flip;
-
- procedure Set_Auto ( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'H' ); ------------------------------------------------ H
- It.Auto_Engaged := True;
- end Set_Auto;
-
- procedure Clear_Auto( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'I' ); ------------------------------------------------ I
- It.Auto_Engaged := False;
- end Clear_Auto;
-
- function Auto ( It: Auto_Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'J' ); ------------------------------------------------ J
- return It.Auto_Engaged;
- end Auto;
-
- procedure Flip ( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'K' ); ------------------------------------------------ K
- if It.Auto_Engaged then
- if Off(It) then
- Flip( Dimmer( It ) );
- else
- It.Auto_Engaged := False;
- end if;
- else
- Flip( Dimmer( It ) );
- end if;
- end Flip;
-
- procedure Set_Cutin ( It : in out Auto_Dimmer;
- Lumens : in Luminance) is
- begin
- TCTouch.Touch( 'L' ); ------------------------------------------------ L
- It.Cutin_Threshold := Lumens;
- end Set_Cutin;
-
- procedure Set_Cutout( It : in out Auto_Dimmer;
- Lumens : in Luminance) is
- begin
- TCTouch.Touch( 'M' ); ------------------------------------------------ M
- It.Cutout_Threshold := Lumens;
- end Set_Cutout;
-
- function Cutout_Threshold( It : Auto_Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'N' ); ------------------------------------------------ N
- return It.Cutout_Threshold;
- end Cutout_Threshold;
-
- function Cutin_Threshold ( It : Auto_Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'O' ); ------------------------------------------------ O
- return It.Cutin_Threshold;
- end Cutin_Threshold;
-
- function TC_CW_TI( Key : Character ) return Toggle'Class is
- begin
- TCTouch.Touch( 'W' ); ------------------------------------------------ W
- case Key is
- when 'T' | 't' => return Toggle'( On => True );
- when 'D' | 'd' => return Dimmer'( On => True, Intensity => 75 );
- when 'A' | 'a' => return Auto_Dimmer'( On => True, Intensity => 25,
- Cutout_Threshold | Cutin_Threshold => 50,
- Auto_Engaged => True );
- when others => null;
- end case;
- end TC_CW_TI;
-
- function TC_Non_Disp( It: Toggle ) return Boolean is
- begin
- TCTouch.Touch( 'X' ); ------------------------------------------------ X
- return It.On;
- end TC_Non_Disp;
-
- function TC_Non_Disp( It: Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'Y' ); ------------------------------------------------ Y
- return It.On;
- end TC_Non_Disp;
-
- function TC_Non_Disp( It: Auto_Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'Z' ); ------------------------------------------------ Z
- return It.On;
- end TC_Non_Disp;
-
-end F392C00_1;
diff --git a/gcc/testsuite/ada/acats/support/f392d00.a b/gcc/testsuite/ada/acats/support/f392d00.a
deleted file mode 100644
index 24f7427..0000000
--- a/gcc/testsuite/ada/acats/support/f392d00.a
+++ /dev/null
@@ -1,103 +0,0 @@
--- F392D00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent tagged types and subprograms for use
--- in tests covering dispatching operations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F392D00 is
-
- type Depth_Of_Field is range 5 .. 100;
- type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand);
-
- type Remote_Camera is tagged record
- DOF : Depth_Of_Field := 10;
- Shutter: Shutter_Speed := One;
- end record;
-
- -- ...Other declarations.
-
- procedure Focus (C : in out Remote_Camera;
- Depth : in Depth_Of_Field);
-
- procedure Self_Test (C: in out Remote_Camera'Class);
-
- -- ...Other operations.
-
-private
-
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed);
-
- -- For the basic remote camera, shutter speed might be set as a function of
- -- focus perhaps, thus it is declared as a private operation (usable
- -- only internally within the abstraction).
-
-
-end F392D00;
-
-
- --==================================================================--
-
-
-package body F392D00 is
-
- procedure Focus (C : in out Remote_Camera;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 46;
- end Focus;
-
- -----------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Thousand;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- procedure Self_Test (C: in out Remote_Camera'Class) is
- TC_Dummy_Depth : constant Depth_Of_Field := 23;
- TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred;
- begin
-
- -- Test focus at various depths:
- Focus(C, TC_Dummy_Depth);
- -- ...Additional calls to Focus.
-
- -- Test various shutter speeds:
- Set_Shutter_Speed(C, TC_Dummy_Speed);
- -- ...Additional calls to Set_Shutter_Speed.
-
- end Self_Test;
-
-end F392D00;
diff --git a/gcc/testsuite/ada/acats/support/f393a00.a b/gcc/testsuite/ada/acats/support/f393a00.a
deleted file mode 100644
index e85c3f4..0000000
--- a/gcc/testsuite/ada/acats/support/f393a00.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- F393A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a simple background for a class family
--- based on an abstract type. It is to be used to test the
--- dispatching of various forms of subprogram defined/inherited and
--- overridden with the abstract type.
---
--- type procedures functions
--- ---- ---------- ---------
--- Object Initialize, Swap(abstract) Create(abstract)
--- Object'Class Initialized
--- Windmill is new Object Swap, Stop, Add_Spin Create, Spin
--- Pump is new Windmill Set_Rate Create, Rate
--- Mill is new Windmill Swap, Stop Create
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F393A00_0 is
- procedure TC_Touch ( A_Tag : Character );
- procedure TC_Validate( Expected: String; Message: String );
-end F393A00_0;
-
-with Report;
-package body F393A00_0 is
- Expectation : String(1..20);
- Finger : Natural := 0;
-
- procedure TC_Touch ( A_Tag : Character ) is
- begin
- Finger := Finger+1;
- Expectation(Finger) := A_Tag;
- end TC_Touch;
-
- procedure TC_Validate( Expected: String; Message: String ) is
- begin
- if Expectation(1..Finger) /= Expected then
- Report.Failed( Message & " Expecting: " & Expected
- & " Got: " & Expectation(1..Finger) );
- end if;
- Finger := 0;
- end TC_Validate;
-end F393A00_0;
-
-----------------------------------------------------------------------
-
-package F393A00_1 is
- type Object is abstract tagged private;
- procedure Initialize( An_Object: in out Object );
- function Initialized( An_Object: Object'Class ) return Boolean;
- procedure Swap( A,B: in out Object ) is abstract;
- function Create return Object is abstract;
-private
- type Object is abstract tagged record
- Initialized : Boolean := False;
- end record;
-end F393A00_1;
-
-with F393A00_0;
-package body F393A00_1 is
- procedure Initialize( An_Object: in out Object ) is
- begin
- An_Object.Initialized := True;
- F393A00_0.TC_Touch('a');
- end Initialize;
-
- function Initialized( An_Object: Object'Class ) return Boolean is
- begin
- F393A00_0.TC_Touch('b');
- return An_Object.Initialized;
- end Initialized;
-end F393A00_1;
-
-----------------------------------------------------------------------
-
-with F393A00_1;
-package F393A00_2 is
-
- type Rotational_Measurement is range -1_000 .. 1_000;
- type Windmill is new F393A00_1.Object with private;
-
- procedure Swap( A,B: in out Windmill );
-
- function Create return Windmill;
-
- procedure Add_Spin( To_Mill : in out Windmill;
- RPMs : in Rotational_Measurement );
-
- procedure Stop( Mill : in out Windmill );
-
- function Spin( Mill : Windmill ) return Rotational_Measurement;
-
-private
- type Windmill is new F393A00_1.Object with
- record
- Spin : Rotational_Measurement := 0;
- end record;
-end F393A00_2;
-
-with F393A00_0;
-package body F393A00_2 is
-
- procedure Swap( A,B: in out Windmill ) is
- T : constant Windmill := B;
- begin
- F393A00_0.TC_Touch('c');
- B := A;
- A := T;
- end Swap;
-
- function Create return Windmill is
- A_Mill : Windmill;
- begin
- F393A00_0.TC_Touch('d');
- return A_Mill;
- end Create;
-
- procedure Add_Spin( To_Mill : in out Windmill;
- RPMs : in Rotational_Measurement ) is
- begin
- F393A00_0.TC_Touch('e');
- To_Mill.Spin := To_Mill.Spin + RPMs;
- end Add_Spin;
-
- procedure Stop( Mill : in out Windmill ) is
- begin
- F393A00_0.TC_Touch('f');
- Mill.Spin := 0;
- end Stop;
-
- function Spin( Mill : Windmill ) return Rotational_Measurement is
- begin
- F393A00_0.TC_Touch('g');
- return Mill.Spin;
- end Spin;
-
-end F393A00_2;
-
-----------------------------------------------------------------------
-
-with F393A00_2;
-package F393A00_3 is
- type Pump is new F393A00_2.Windmill with private;
- function Create return Pump;
-
- type Gallons_Per_Revolution is digits 3;
- procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution);
- function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution;
-private
- type Pump is new F393A00_2.Windmill with
- record
- GPRPM : Gallons_Per_Revolution := 0.0; -- Gallons/RPM
- end record;
-end F393A00_3;
-
-with F393A00_0;
-package body F393A00_3 is
- function Create return Pump is
- Sump : Pump;
- begin
- F393A00_0.TC_Touch('h');
- return Sump;
- end Create;
-
- procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution)
- is
- begin
- F393A00_0.TC_Touch('i');
- A_Pump.GPRPM := To_Rate;
- end Set_Rate;
-
- function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution is
- begin
- F393A00_0.TC_Touch('j');
- return Of_Pump.GPRPM;
- end Rate;
-end F393A00_3;
-
-----------------------------------------------------------------------
-
-with F393A00_2;
-with F393A00_3;
-package F393A00_4 is
- type Mill is new F393A00_2.Windmill with private;
-
- procedure Swap( A,B: in out Mill );
- function Create return Mill;
- procedure Stop( It: in out Mill );
- private
- type Mill is new F393A00_2.Windmill with
- record
- Pump: F393A00_3.Pump := F393A00_3.Create;
- end record;
-end F393A00_4;
-
-with F393A00_0;
-package body F393A00_4 is
- procedure Swap( A,B: in out Mill ) is
- T: constant Mill := A;
- begin
- F393A00_0.TC_Touch('k');
- A := B;
- B := T;
- end Swap;
-
- function Create return Mill is
- A_Mill : Mill;
- begin
- F393A00_0.TC_Touch('l');
- return A_Mill;
- end Create;
-
- procedure Stop( It: in out Mill ) is
- begin
- F393A00_0.TC_Touch('m');
- F393A00_3.Stop( It.Pump );
- F393A00_2.Stop( F393A00_2.Windmill( It ) );
- end Stop;
-end F393A00_4;
diff --git a/gcc/testsuite/ada/acats/support/f393b00.a b/gcc/testsuite/ada/acats/support/f393b00.a
deleted file mode 100644
index afabdd7..0000000
--- a/gcc/testsuite/ada/acats/support/f393b00.a
+++ /dev/null
@@ -1,101 +0,0 @@
--- F393B00.A
- -- Alert_Foundation
- --
--- 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.
---*
- --
- -- FOUNDATION DESCRIPTION:
- -- This package declares three abstract types for use in C660 series
- -- tests, Alert, Special_Alert, and Private_Alert.
- -- It models (in miniature) an application situation in which an
- -- abstraction is defined in terms of structure (record and operations
- -- on the record) but not in terms of content (record is null). It
- -- also models a situation in which an abstraction includes some
- -- specific, implementation dependent, information.
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- package F393B00 is
- type Alert is abstract tagged null record; -- abstract type
- -- see procedure Handle below
-
- procedure Handle (A : in out Alert) is abstract;
- -- abstract procedure,
- -- explicitly declared
-
-
- type Private_Alert is abstract tagged private;
-
- procedure Handle (PA : in out Private_Alert) is abstract;
- -- ensures that Private_Alert
- -- is visibly abstract
-
-
- type Status_Kind is (Practice, Real, Dont_Care);
- type Urgency_Kind is (Low, Medium, High);
-
- type Practice_Alert is new Alert with record
- Status : Status_Kind := Dont_Care;
- Urgency : Urgency_Kind := Low;
- end record;
-
- procedure Handle (PA : in out Practice_Alert);
- -- overrides inherited Handle
-
-
-
- type Device is (Teletype, Console, Big_Screen);
-
- type Special_Alert (Age : Integer) is
- abstract new Practice_Alert with record
- Display : Device;
- end record;
-
- procedure Handle (SA : in out Special_Alert) is abstract;
- -- overrides inherited Handle
-
- private
- subtype Implementation_Detail is Integer range 1..10;
-
- type Private_Alert is abstract tagged record
- Private_Field : Implementation_Detail := 1;
- end record;
-
-
- end F393B00;
-
- --=======================================================================--
-
- package body F393B00 is
-
- procedure Handle (PA : in out Practice_Alert) is
- begin
- PA.Status := Real;
- PA.Urgency := Medium;
- end Handle;
-
- end F393B00;
-
diff --git a/gcc/testsuite/ada/acats/support/f3a2a00.a b/gcc/testsuite/ada/acats/support/f3a2a00.a
deleted file mode 100644
index c839082..0000000
--- a/gcc/testsuite/ada/acats/support/f3a2a00.a
+++ /dev/null
@@ -1,81 +0,0 @@
--- F3A2A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares support types and subprograms for testing
--- run-time accessibility checks.
---
--- CHANGE HISTORY:
--- 01 May 95 SAIC Initial prerelease version.
---
---!
-
-package F3A2A00 is
-
- type Tagged_Type is tagged record
- C: Integer := 0;
- end record;
-
- type Array_Type is array (1 .. 10) of Tagged_Type;
-
- type AccTag_L0 is access all Tagged_Type;
- type AccTagClass_L0 is access all Tagged_Type'Class;
-
- type AccArr_L0 is access all Array_Type;
-
- X_L0 : Tagged_Type;
-
-
- type TC_Result_Kind is (OK, P_E, O_E);
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-end F3A2A00;
-
-
- --==================================================================--
-
-
-with Report;
-package body F3A2A00 is
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK =>
- Report.Failed ("No exception raised: " & Message);
- when P_E =>
- Report.Failed ("Program_Error raised: " & Message);
- when O_E =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Display_Results;
-
-end F3A2A00;
diff --git a/gcc/testsuite/ada/acats/support/f460a00.a b/gcc/testsuite/ada/acats/support/f460a00.a
deleted file mode 100644
index 382f5c5..0000000
--- a/gcc/testsuite/ada/acats/support/f460a00.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- F460A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares support types and subprograms for testing
--- run-time accessibility checks.
---
--- CHANGE HISTORY:
--- 11 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Modified Array_Type.
---
---!
-
-package F460A00 is
-
- type Tagged_Type is tagged record
- C : Integer := 0;
- end record;
-
- type Derived_Tagged_Type is new Tagged_Type with record
- D : String (1 .. 4) := "void";
- end record;
-
- type Composite_Type (D: access Tagged_Type) is limited record
- C : Boolean;
- end record;
-
- type Array_Type is array (1 .. 10) of Tagged_Type;
-
- type AccTag_L0 is access constant Tagged_Type;
- type AccTagClass_L0 is access all Tagged_Type'Class;
-
- type AccArr_L0 is access all Array_Type;
-
- X_DerivedTag : aliased Derived_Tagged_Type;
- PTagClass_L0 : AccTagClass_L0 := X_DerivedTag'Access;
-
- type TC_Result_Kind is (OK, UN_Init, PE_Exception, Others_Exception);
-
- procedure TC_Check_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-end F460A00;
-
-
- --==================================================================--
-
-
-with Report;
-package body F460A00 is
-
- procedure TC_Check_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK | UN_Init =>
- Report.Failed ("No exception raised: " & Message);
- when PE_Exception =>
- Report.Failed ("Program_Error raised: " & Message);
- when Others_Exception =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Check_Results;
-
-end F460A00;
diff --git a/gcc/testsuite/ada/acats/support/f730a000.a b/gcc/testsuite/ada/acats/support/f730a000.a
deleted file mode 100644
index 137f333..0000000
--- a/gcc/testsuite/ada/acats/support/f730a000.a
+++ /dev/null
@@ -1,107 +0,0 @@
--- F730A000.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic linked list abstraction for use in tests
--- covering tagged types and type extensions.
---
--- TEST FILES:
--- This foundation consists of the following files:
---
--- => F730A000.A
--- F730A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Aug 96 SAIC ACVC 2.1: Modified prologue. Added pragma
--- Elaborate_Body. Removed extraneous record
--- extension.
---
---!
-
-generic -- Singly-linked list abstraction.
- type Parent_Type is tagged private; -- Actual is parent
-package F730A000 is -- tagged type.
-
- pragma Elaborate_Body;
-
-
- -- Declarations for private linked list nodes:
-
- type Priv_Node_Type is new Parent_Type with private; -- Private extension
- -- of parent type.
-
- -- Inherits primitive operations of actual parameter corresponding
- -- to Parent_Type.
-
-
- type Priv_Node_Ptr is access Priv_Node_Type;
-
-
- -- Add node at head of list.
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr);
-
-
-private
-
- type Priv_Node_Type is new Parent_Type with record
- Next : Priv_Node_Ptr := null;
- end record;
-
-end F730A000;
-
-
- --==================================================================--
-
-
-package body F730A000 is -- Singly-linked list abstraction.
-
-
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
-end F730A000;
diff --git a/gcc/testsuite/ada/acats/support/f730a001.a b/gcc/testsuite/ada/acats/support/f730a001.a
deleted file mode 100644
index 18153b7..0000000
--- a/gcc/testsuite/ada/acats/support/f730a001.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- F730A001.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares a tagged type and primitive subprogram for use in
--- tests covering tagged types and type extensions.
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- F730A000.A
--- => F730A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package F730A001 is -- Book definitions.
-
-
- type Text_Ptr is access String;
-
- type Book_Type is tagged record -- Root tagged type.
- Title : Text_Ptr;
- Author : Text_Ptr;
- end record;
-
-
- procedure Create_Book (Title : in Text_Ptr; -- Primitive operation
- Author : in Text_Ptr; -- of root tagged type.
- Book : out Book_Type);
-
-
-end F730A001;
-
-
- --==================================================================--
-
-
-package body F730A001 is -- Book definitions.
-
-
- procedure Create_Book (Title : in Text_Ptr;
- Author : in Text_Ptr;
- Book : out Book_Type) is
- begin
- Book.Title := Title;
- Book.Author := Author;
- end Create_Book;
-
-
-end F730A001;
diff --git a/gcc/testsuite/ada/acats/support/f731a00.a b/gcc/testsuite/ada/acats/support/f731a00.a
deleted file mode 100644
index 5e29fbd..0000000
--- a/gcc/testsuite/ada/acats/support/f731a00.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- F731A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent tagged types and subprograms for use
--- in tests covering operations of private types and private extensions.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F731A00 is
-
- type Parent is tagged private;
-
- function Vis_Op (P: Parent) return Boolean;
-
-private
-
- type Parent is tagged record
- Component : Integer := 1;
- end record;
-
- function Pri_Op (P: Parent) return Boolean;
-
-end F731A00;
-
-
- --==================================================================--
-
-
-package body F731A00 is
- function Vis_Op (P: Parent) return Boolean is
- begin
- return True;
- end Vis_Op;
-
- function Pri_Op (P: Parent) return Boolean is
- begin
- return False;
- end Pri_Op;
-
-end F731A00;
diff --git a/gcc/testsuite/ada/acats/support/f940a00.a b/gcc/testsuite/ada/acats/support/f940a00.a
deleted file mode 100644
index ddc614f..0000000
--- a/gcc/testsuite/ada/acats/support/f940a00.a
+++ /dev/null
@@ -1,97 +0,0 @@
--- F940A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation contains test control code for tests covering
--- the protected record.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F940A00 is
- -- Interlock_Foundation
-
- protected type Interlock_Type is
- entry Post;
- entry Consume;
- private
- Int_Count : Integer := 0;
- end Interlock_Type;
-
- protected Counter is -- used to count the number of
- procedure Increment; -- resources that have been granted
- procedure Decrement; -- to tasks
- function Number return integer;
- private
- Count : Integer := 0;
- end Counter;
-
-end F940A00;
- -- Interlock_Foundation
-
---===================================--
-
-package body F940A00 is
- -- Interlock_Foundation
-
- protected body Interlock_Type is
-
- entry Post when true is
- begin
- Int_Count := Int_Count + 1;
- end Post;
-
- entry Consume when Int_Count > 0 is
- begin
- Int_Count := Int_Count - 1;
- end Consume;
-
- end Interlock_Type;
-
-
- 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;
-
-end F940A00;
- -- Interlock_Foundation
diff --git a/gcc/testsuite/ada/acats/support/f954a00.a b/gcc/testsuite/ada/acats/support/f954a00.a
deleted file mode 100644
index 615aa98..0000000
--- a/gcc/testsuite/ada/acats/support/f954a00.a
+++ /dev/null
@@ -1,134 +0,0 @@
--- F954A00.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:
--- This file contains foundation code for tests covering the requeue
--- statement.
---
--- TEST DESCRIPTION:
--- See prologues of specific tests.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F954A00 is -- Printer device abstraction.
-
-
- -- Model a printer device driver as a protected type. A printer remains
- -- unavailable while data is printing. The printer generates an interrupt
- -- when printing is complete, after which the printer is again made
- -- available.
-
-
- type Printers_Info is tagged record
- Some_Info : Integer;
- end record;
-
- --==============================================--
-
- protected type Printers is -- Device driver for printer.
-
- procedure Start_Printing (File_Name : String); -- Begin printing on
- -- printer.
-
- procedure Handle_Interrupt; -- Handle interrupt from
- -- printer.
-
- entry Done_Printing; -- Wait until printer is
- -- done.
-
- function Available return Boolean; -- Return value of Ready.
- function Is_Done return Boolean; -- Return value of Done.
-
- private
-
- Ready : Boolean := True; -- Entry barrier.
- Done : Boolean := True; -- Testing flag.
-
- end Printers;
-
- --==============================================--
-
- Number_Of_Printers : constant := 2;
-
- type Printer_ID is range 1 .. Number_Of_Printers;
-
- type Printer_Array is array (Printer_ID) of Printers;
- type Info_Array is array (Printer_ID) of Printers_Info;
-
- Printer : Printer_Array;
- Printer_Info : constant Info_Array := ( (Some_Info => 1),
- (Some_Info => 2) );
-
-end F954A00;
-
-
- --==================================================================--
-
-
-package body F954A00 is -- Printer server abstraction.
-
-
- protected body Printers is
-
- procedure Start_Printing (File_Name : String) is
- begin
- Ready := False; -- Block other requests
- Done := False; -- for this printer
- -- Send data to the printer... -- and begin printing.
- end Start_Printing;
-
-
- -- Set the "not ready" one-shot
- entry Done_Printing when Ready is -- Callers wait here
- begin -- until printing is
- Done := True; -- done (signaled by a
- end Done_Printing; -- printer interrupt).
-
-
- procedure Handle_Interrupt is -- Called when the
- begin -- printer interrupts,
- Ready := True; -- indicating that
- end Handle_Interrupt; -- printing is done.
-
-
- function Available return Boolean is -- Artifice for test
- begin -- purposes: checks
- return (Ready); -- whether printer is
- end Available; -- still printing.
-
-
- function Is_Done return Boolean is -- Artifice for test
- begin -- purposes: checks
- return (Done); -- whether Done_Printing
- end Is_Done; -- entry was executed.
-
- end Printers;
-
-
-end F954A00;
diff --git a/gcc/testsuite/ada/acats/support/fa11a00.a b/gcc/testsuite/ada/acats/support/fa11a00.a
deleted file mode 100644
index b57a6b7..0000000
--- a/gcc/testsuite/ada/acats/support/fa11a00.a
+++ /dev/null
@@ -1,73 +0,0 @@
--- FA11A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a tagged type and primitive subprograms in
--- a parent package.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11A00 is -- Widget_Pkg
--- This package represents processing of widgets in a window system. It
--- contains a tagged type that can be extended by its children.
-
- type Widget_Length is range 1 .. 100;
-
- type Widget is tagged -- Parent tagged type
- record
- Width, Height : Widget_Length;
- -- More components to be added by extension
- end record;
-
- -- To be inherited by its children derivatives.
- procedure Set_Width (The_Widget : in out Widget;
- W : in Widget_Length);
-
- -- To be inherited by its children derivatives.
- procedure Set_Height (The_Widget : in out Widget;
- H : in Widget_Length);
-
-end FA11A00; -- Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00 is -- Widget_Pkg
-
- procedure Set_Width (The_Widget : in out Widget;
- W : in Widget_Length) is
- begin
- The_Widget.Width := W;
- end Set_Width;
- -------------------------------------------------------
- procedure Set_Height (The_Widget : in out Widget;
- H : in Widget_Length) is
- begin
- The_Widget.Height := H;
- end Set_Height;
-
-end FA11A00; -- Widget_Pkg
diff --git a/gcc/testsuite/ada/acats/support/fa11b00.a b/gcc/testsuite/ada/acats/support/fa11b00.a
deleted file mode 100644
index 161be8e..0000000
--- a/gcc/testsuite/ada/acats/support/fa11b00.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- FA11B00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11B00 is -- Application_One_Widget
--- This foundation simulates code that might be obtained as an already
--- implemented set of objects and services, perhaps from a source code
--- vendor. It represents processing of widgets in a window system.
--- These widgets all have the same characteristics, but they are application
--- specific, so we do not allow assignment of an App_1_Widget to App_2_Widget.
-
--- The dimension measurement is in pixels (dots on the screen).
- type Pixels is range 0 .. 10_000;
- type Widget_Id is new Integer;
- type Widget_Color_Enum is (Amber, Green, White, None);
- subtype Widget_Label_Str is string (1 .. 15);
-
- type Widget_Location is
- record
- X_Location, Y_Location : Pixels;
- end record;
-
- type Widget_Size is
- record
- X_Length, Y_Length : Pixels;
- end record;
-
- -- NOTE : not a tagged record.
- type App1_Widget (Maximum_Size : Pixels := Pixels'Last)
- is record -- Parent type
- Size : Widget_Size := (Maximum_Size, Maximum_Size);
- ID : Widget_Id := 1;
- Location : Widget_Location := (0,0);
- Color : Widget_Color_Enum := None;
- Label : Widget_Label_Str := " ";
- end record;
-
- -- Primitive operation of type Widget.
- -- To be inherited by its children derivatives.
- procedure App1_Widget_Specific_Oper (The_Widget : in out App1_Widget;
- I : in Widget_Id;
- C : in Widget_Color_Enum;
- L : in Widget_Label_Str);
-
-end FA11B00; -- Application_One_Widget
-
---=======================================================================--
-
-package body FA11B00 is -- Application_One_Widget
-
- procedure Set_Color (The_Widget : in out App1_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
- -------------------------------------------------------------
- procedure Set_Label (The_Widget : in out App1_Widget;
- L : in Widget_Label_Str) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- -------------------------------------------------------------
- procedure Set_Id (The_Widget : in out App1_Widget;
- I : in Widget_Id) is
- begin
- The_Widget.Id := I;
- end Set_Id;
- -------------------------------------------------------------
- procedure App1_Widget_Specific_Oper
- (The_Widget : in out App1_Widget;
- I : in Widget_Id;
- C : in Widget_Color_Enum;
- L : in Widget_Label_Str) is
- begin
- Set_Color (The_Widget, C);
- Set_Label (The_Widget, L);
- Set_Id (The_Widget, I);
- end App1_Widget_Specific_Oper;
-
-end FA11B00; -- Application_One_Widget
diff --git a/gcc/testsuite/ada/acats/support/fa11c00.a b/gcc/testsuite/ada/acats/support/fa11c00.a
deleted file mode 100644
index 4b153b2..0000000
--- a/gcc/testsuite/ada/acats/support/fa11c00.a
+++ /dev/null
@@ -1,112 +0,0 @@
--- FA11C00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11C00_0 is -- Package Animal
-
- type Kilogram_Weight_Type is new Natural;
- subtype Species_Name_Type is String (1 .. 20);
-
- type Animal is tagged
- record
- Common_Name : Species_Name_Type;
- Weight : Kilogram_Weight_Type;
- end record;
-
- function Image (A : Animal) return String;
-
-end FA11C00_0; -- Package Animal
-
- --=================================================================--
-
-package body FA11C00_0 is -- Package body Animal
-
- function Image (A : Animal) return String is
- begin
- return ("Animal Species: " & A.Common_Name);
- end Image;
-
-end FA11C00_0; -- Package body Animal
-
- --=================================================================--
-
-package FA11C00_0.FA11C00_1 is -- Package Animal.Mammal
-
- type Hair_Color_Type is (Black, Brown, Blonde, Grey, White, Red);
-
- type Mammal is new Animal with
- record
- Hair_Color : Hair_Color_Type;
- end record;
-
- function Image (M : Mammal) return String;
-
-end FA11C00_0.FA11C00_1; -- Package Animal.Mammal
-
- --=================================================================--
-
-package body FA11C00_0.FA11C00_1 is -- Package body Animal.Mammal
-
- function Image (M : Mammal) return String is
- begin
- return ("Mammal Species: " & M.Common_Name);
- end Image;
-
-end FA11C00_0.FA11C00_1; -- Package body Animal.Mammal
-
- --=================================================================--
-
-package FA11C00_0.FA11C00_1.FA11C00_2 is -- Package Animal.Mammal.Primate
-
- type Habitat_Type is (Arboreal, Terrestrial);
-
- type Primate is new Mammal with
- record
- Habitat : Habitat_Type;
- end record;
-
- function Image (P : Primate) return String;
-
-end FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-
- --=================================================================--
-
- -- Package body Animal.Mammal.Primate
-package body FA11C00_0.FA11C00_1.FA11C00_2 is
-
- function Image (P : Primate) return String is
- begin
- return ("Primate Species: " & P.Common_Name);
- end Image;
-
-end FA11C00_0.FA11C00_1.FA11C00_2; -- Package body Animal.Mammal.Primate
diff --git a/gcc/testsuite/ada/acats/support/fa11d00.a b/gcc/testsuite/ada/acats/support/fa11d00.a
deleted file mode 100644
index 9efe33b..0000000
--- a/gcc/testsuite/ada/acats/support/fa11d00.a
+++ /dev/null
@@ -1,78 +0,0 @@
--- FA11D00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified type Int_Type
---
---!
-
-package FA11D00 is -- Complex_Definition_Pkg
-
- -- Simulate a complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Int_Type is range -200 .. 100;
-
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
- One : constant Complex_Type := (Real => 1, Imag => 0);
- Check_Value : constant Complex_Type := (Real => 17, Imag => 23);
-
- Add_Error : exception;
- Subtract_Error : exception;
- Divide_Error : exception;
- Multiply_Error : exception;
-
- TC_Handled_In_Caller,
- TC_Handled_In_Child_Pkg_Proc,
- TC_Handled_In_Child_Pkg_Func,
- TC_Handled_In_Grandchild_Pkg_Proc,
- TC_Handled_In_Grandchild_Pkg_Func,
- TC_Handled_In_Child_Sub,
- TC_Propagated_To_Caller : boolean := False;
-
- function Complex (Real, Imag : Int_Type)
- return Complex_Type;
-
-end FA11D00; -- Complex_Definition_Pkg
-
---=======================================================================--
-
-package body FA11D00 is -- Complex_Definition_Pkg
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
-
-end FA11D00; -- Complex_Definition_Pkg
diff --git a/gcc/testsuite/ada/acats/support/fa13a00.a b/gcc/testsuite/ada/acats/support/fa13a00.a
deleted file mode 100644
index be6ecde..0000000
--- a/gcc/testsuite/ada/acats/support/fa13a00.a
+++ /dev/null
@@ -1,171 +0,0 @@
--- FA13A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation code is used to check visibility of separate
--- subunit of child packages.
--- Declares a package containing type definitions; package will be
--- with'ed by the root of the elevator abstraction.
---
--- Declare an elevator abstraction in a parent root package which manages
--- basic operations. This package has a private part. Declare a
--- private child package which calculates the floors for going up or
--- down. Declare a public child package which provides the actual
--- operations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates a fragment of an elevator operation application.
-
-package FA13A00_0 is -- Building Manager
-
- type Electrical_Power is (Off, V120, V240);
- Power : Electrical_Power := V120;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_0;
-
--- No bodies provided for FA13A00_0.
-
- --==================================================================--
-
-package FA13A00_1 is -- Basic Elevator Operations
-
- type Call_Waiting_Type is private;
- type Floor is (Basement, Floor1, Floor2, Floor3, Penthouse);
- type Floor_No is range Floor'Pos(Floor'First) .. Floor'Pos(Floor'Last);
- Current_Floor : Floor := Floor1;
-
- TC_Operation : boolean := true;
-
- procedure Call (F : in Floor; C : in out Call_Waiting_Type);
- procedure Clear_Calls (C : in out Call_Waiting_Type);
-
-private
- type Call_Waiting_Type is array (Floor) of boolean;
- Call_Waiting : Call_Waiting_Type := (others => false);
-
-end FA13A00_1;
-
-
- --==================================================================--
-
-package body FA13A00_1 is
-
- -- Call the elevator.
-
- procedure Call (F : in Floor; C : in out Call_Waiting_Type) is
- begin
- C (F) := true;
- end Call;
-
- --------------------------------------------
-
- -- Clear all calls of the elevator.
-
- procedure Clear_Calls (C : in out Call_Waiting_Type) is
- begin
- C := (others => false);
- end Clear_Calls;
-
-end FA13A00_1;
-
- --==================================================================--
-
--- Private child package of an elevator application. This package calculates
--- how many floors to go up or down.
-
-private package FA13A00_1.FA13A00_2 is -- Floor Calculation
-
- -- Other type definitions in real application.
-
- procedure Up (HowMany : in Floor_No);
-
- procedure Down (HowMany : in Floor_No);
-
-end FA13A00_1.FA13A00_2;
-
- --==================================================================--
-
-package body FA13A00_1.FA13A00_2 is
-
- -- Go up from the current floor.
-
- procedure Up (HowMany : in Floor_No) is
- begin
- Current_Floor := Floor'val (Floor'pos (Current_Floor) + HowMany);
- end Up;
-
- --------------------------------------------
-
- -- Go down from the current floor.
-
- procedure Down (HowMany : in Floor_No) is
- begin
- Current_Floor := Floor'val (Floor'pos (Current_Floor) - HowMany);
- end Down;
-
-end FA13A00_1.FA13A00_2;
-
- --==================================================================--
-
--- Public child package of an elevator application. This package provides
--- the actual operation of the elevator.
-
-package FA13A00_1.FA13A00_3 is -- Move Elevator
-
- -- Other type definitions in real application.
-
- procedure Move_Elevator (F : in Floor;
- C : in out Call_Waiting_Type);
-
-end FA13A00_1.FA13A00_3;
-
- --==================================================================--
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation
-
-package body FA13A00_1.FA13A00_3 is
-
- -- Going up or down depends on the current floor.
-
- procedure Move_Elevator (F : in Floor;
- C : in out Call_Waiting_Type) is
- begin
- if F > Current_Floor then
- FA13A00_1.FA13A00_2.Up (Floor'Pos (F) - Floor'Pos (Current_Floor));
- FA13A00_1.Call (F, C);
- elsif F < Current_Floor then
- FA13A00_1.FA13A00_2.Down (Floor'Pos (Current_Floor) - Floor'Pos (F));
- FA13A00_1.Call (F, C);
- end if;
-
- end Move_Elevator;
-
-end FA13A00_1.FA13A00_3;
diff --git a/gcc/testsuite/ada/acats/support/fa13b00.a b/gcc/testsuite/ada/acats/support/fa13b00.a
deleted file mode 100644
index da55554..0000000
--- a/gcc/testsuite/ada/acats/support/fa13b00.a
+++ /dev/null
@@ -1,106 +0,0 @@
--- FA13B00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation code is used to check visibility of separate
--- subunit of child packages.
--- Declares a package containing type definitions and a private
--- part; package will be with'ed by the parent's body of the subunits.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA13B00_0 is
-
- -- Type definitions.
-
- type Visible_Integer is range 1 .. 10;
-
- type Private_Record is private;
-
- type Visible_Tagged is tagged
- record
- PR : Private_Record;
- end record;
-
- type Private_Tagged is tagged private;
-
- Visible_Num : Visible_Integer := 7;
-
- -- Subprogram definitions.
-
- function Assign_Visible_Tagged (I : Visible_Integer)
- return Visible_Tagged;
-
- function Assign_Private_Tagged (I : Visible_Integer)
- return Private_Tagged;
-
-private
-
- -- Type definitions.
-
- type Private_Integer is range 11 .. 20;
-
- type Private_Record is
- record
- VI : Visible_Integer;
- end record;
-
- type Private_Tagged is tagged
- record
- VI : Visible_Integer;
- end record;
-
- -- Object definitions.
-
- Private_Num : Visible_Integer := 6;
-
-end FA13B00_0;
-
- --==================================================================--
-
-package body FA13B00_0 is
-
- function Assign_Visible_Tagged(I : Visible_Integer)
- return Visible_Tagged is
- VT : Visible_Tagged := (PR => (VI => I));
- begin
- return VT;
- end Assign_Visible_Tagged;
-
- -------------------------------------------------------
-
- function Assign_Private_Tagged (I : Visible_Integer)
- return Private_Tagged is
- PT : Private_Tagged := (VI => I);
- begin
- return PT;
- end Assign_Private_Tagged;
-
- -------------------------------------------------------
-
-end FA13B00_0;
diff --git a/gcc/testsuite/ada/acats/support/fa21a00.a b/gcc/testsuite/ada/acats/support/fa21a00.a
deleted file mode 100644
index 7af0da1..0000000
--- a/gcc/testsuite/ada/acats/support/fa21a00.a
+++ /dev/null
@@ -1,127 +0,0 @@
--- FA21A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various supporting types, objects, and
--- subprograms for use in tests checking preelaborability.
---
--- CHANGE HISTORY:
--- 20 Mar 95 SAIC Initial prerelease version.
---
---!
-
-with Ada.Finalization; -- Preelaborated library unit.
-package FA21A00 is
-
- pragma Preelaborate (FA21A00);
-
-
- type My_Int is new Integer range 0 .. 100;
- function Func return My_Int; -- Non-static function.
-
- subtype Idx is Natural range 1 .. 5;
-
- Three : constant My_Int := 3;
- Ten : My_Int := 10; -- Non-static.
-
- type RecWithDisc (D: My_Int) is record
- Twice: My_Int := D*2;
- end record;
-
- type RecCallDefault is record
- C : My_Int := Func;
- D : My_Int := 0;
- end record;
-
- type RecPrimDefault is record
- C : My_Int := Ten;
- end record;
-
- type Tag is tagged record
- C : My_Int;
- end record;
-
- type AccTag is access all Tag;
-
- Tag1: aliased Tag; -- OK.
-
- type My_Controlled is new Ada.Finalization.Controlled with record
- C : My_Int;
- end record;
-
- type ContComp is tagged record
- C: My_Controlled;
- end record;
-
- task type Tsk (D: My_Int);
-
- protected type Prot is
- entry E;
- end Prot;
-
- type Priv is tagged private;
-
- type PrivComp is array (1 .. 5) of Priv;
-
- type Pri_Ext is new Tag with private;
-
- type PriExtComp is array (1 .. 5) of Pri_Ext;
-
-private
-
- type Priv is tagged record
- B: Boolean;
- end record;
-
- type Pri_Ext is new Tag with record
- N: String (1 .. 5);
- end record;
-
-end FA21A00;
-
-
- --===================================================================--
-
-
-package body FA21A00 is
-
- task body Tsk is
- begin
- null;
- end Tsk;
-
- protected body Prot is
- entry E when False is
- begin
- null;
- end E;
- end Prot;
-
- function Func return My_Int is
- begin
- return 0;
- end Func;
-
-end FA21A00;
diff --git a/gcc/testsuite/ada/acats/support/fb20a00.a b/gcc/testsuite/ada/acats/support/fb20a00.a
deleted file mode 100644
index 46184c9..0000000
--- a/gcc/testsuite/ada/acats/support/fb20a00.a
+++ /dev/null
@@ -1,101 +0,0 @@
--- FB20A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This test performs a search for the first instance of a specified
--- substring within a specified string, returning boolean result.
--- (Case insensitive analysis) Both the string and the substring are
--- made upper case. Successive slices are taken from the input string
--- and compared with the substring. If a match is found, the search is
--- terminated immediately. The search continues until the last index
--- position from which a substring-length slice can be constructed is
--- passed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FB20A00 is
-
- function Find ( Str : in String ;
- Sub : in String ) return Boolean;
-
-end FB20A00;
-
- --=================================================================--
-
-package body FB20A00 is
-
- function Find ( Str : in String ;
- Sub : in String ) return Boolean is
-
- New_Str : String (Str'First .. Str'Last);
- New_Sub : String (Sub'First .. Sub'Last);
-
- Pos : Integer := Str'First ; -- Character index.
-
-
- function Upper_Case (Str : in String) return String is
- subtype Upper is Character range 'A' .. 'Z' ;
- subtype Lower is Character range 'a' .. 'z' ;
- Ret : String (Str'First .. Str'Last) ;
- Pos : Integer;
- begin
- for I in Str'Range loop
- if ( Str (I) in Lower ) then
- Pos := Upper'Pos (Upper'First) +
- ( Lower'Pos (Str(I)) - Lower'Pos(Lower'First) ) ;
- Ret (I) := Upper'Val (Pos) ;
- else
- Ret (I) := Str (I);
- end if ;
- end loop ;
- return (Ret) ;
- end Upper_Case;
-
- begin
-
-
- New_Str := Upper_Case (Str); -- Convert Str and Sub to upper
- New_Sub := Upper_Case (Sub); -- case for comparison.
-
- while ( Pos <= New_Str'Last-New_Sub'Length+1 ) -- Search until no more
- and then -- sub-string-length
- ( New_Str ( Pos .. Pos+New_Sub'Length-1 ) /= New_Sub ) -- slices
- -- remain.
- loop
- Pos := Pos + 1 ;
- end loop ;
-
- if ( Pos > New_Str'Last-New_Sub'Length+1 ) then -- Substring not found.
- return (False);
- else
- return (True);
- end if ;
-
- end Find;
-
-end FB20A00;
diff --git a/gcc/testsuite/ada/acats/support/fb40a00.a b/gcc/testsuite/ada/acats/support/fb40a00.a
deleted file mode 100644
index adffc69..0000000
--- a/gcc/testsuite/ada/acats/support/fb40a00.a
+++ /dev/null
@@ -1,81 +0,0 @@
--- FB40A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation package contains global variables, types, a user
--- defined exception, and two subprograms used to increment the
--- global variables.
--- See prologues of specific tests for specific information.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package FB40A00 is -- package Text_Parser
-
- -- Global Variables
-
- AlphaNumeric_Count,
- Non_AlphaNumeric_Count : Natural := 0;
-
-
- -- Types
-
- type String_Pointer_Type is access String;
-
-
- -- Exceptions
-
- Completed_Text_Processing : exception;
-
- -- Subprograms
-
- procedure Increment_AlphaNumeric_Count;
- procedure Increment_Non_AlphaNumeric_Count;
-
-end FB40A00;
-
-
- --=================================================================--
-
-
-package body FB40A00 is
-
-
- procedure Increment_AlphaNumeric_Count is
- begin
- AlphaNumeric_Count := AlphaNumeric_Count + 1;
- end Increment_AlphaNumeric_Count;
-
-
- procedure Increment_Non_AlphaNumeric_Count is
- begin
- Non_AlphaNumeric_Count := Non_AlphaNumeric_Count + 1;
- end Increment_Non_AlphaNumeric_Count;
-
-
-end FB40A00;
diff --git a/gcc/testsuite/ada/acats/support/fc50a00.a b/gcc/testsuite/ada/acats/support/fc50a00.a
deleted file mode 100644
index 4c37328..0000000
--- a/gcc/testsuite/ada/acats/support/fc50a00.a
+++ /dev/null
@@ -1,92 +0,0 @@
--- FC50A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various tagged types which will be passed as
--- actuals to generic formal tagged private types. It also declares
--- various objects of these types, which will be used for testing.
--- The types defined are both discriminated and nondiscriminated.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC50A00 is
-
---
--- Nonlimited tagged types:
---
-
- type Count_Type is tagged record -- Nondiscriminated
- Count : Integer := 0; -- type.
- end record;
-
-
- subtype Str_Len is Natural range 0 .. 100;
- subtype Stu_ID is String (1 .. 5);
- subtype Dept_ID is String (1 .. 4);
- subtype Emp_ID is String (1 .. 9);
- type Status is (Student, Faculty, Staff);
- subtype Reserved is Positive range 1 .. 50;
-
-
- type Person_Type (Stat : Status; -- Discriminated
- NameLen, AddrLen : Str_Len) is -- type.
- tagged record
- Name : String (1 .. NameLen);
- Address : String (1 .. AddrLen);
- case Stat is
- when Student =>
- Student_ID : Stu_ID;
- when Faculty =>
- Department : Dept_ID;
- when Staff =>
- Employee_ID : Emp_ID;
- end case;
- end record;
-
-
- type VIPerson_Type is new Person_Type with record -- Extension of
- Parking_Space : Reserved; -- discriminated type.
- end record;
-
-
- -- Testing entities: ------------------------------------------------
-
- TC_Count_Item : constant Count_Type := (Count => 111);
- TC_Default_Count : constant Count_Type := (Count => 0);
-
- TC_Person_Item : constant Person_Type :=
- (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
- TC_Default_Person : constant Person_Type :=
- (Student, 0, 0, "", "", "00000");
-
- TC_VIPerson_Item : constant VIPerson_Type := (TC_Person_Item with 1);
-
- ---------------------------------------------------------------------
-
-
-end FC50A00;
diff --git a/gcc/testsuite/ada/acats/support/fc51a00.a b/gcc/testsuite/ada/acats/support/fc51a00.a
deleted file mode 100644
index 9b584d7..0000000
--- a/gcc/testsuite/ada/acats/support/fc51a00.a
+++ /dev/null
@@ -1,99 +0,0 @@
--- FC51A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a fraction type abstraction. Fractions are
--- implemented as records with two scalar components: a numerator
--- of type integer and a denominator of type positive. Fractions are
--- created via an overloaded "/" operator.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC51A00 is -- Fraction type abstraction.
-
- type Fraction_Type is private;
-
- -- Create a fraction object by integer division.
- function "/" (Left, Right : Integer) return Fraction_Type;
-
- -- Change the sign of a fraction.
- function "-" (Frac : Fraction_Type) return Fraction_Type;
-
- -- Return value of numerator as integer.
- function Numerator (Frac : Fraction_Type) return Integer;
-
- -- Return value of denominator as integer.
- function Denominator (Frac : Fraction_Type) return Integer;
-
- -- ... Other operations on fraction types.
-
-private
-
- type Fraction_Type is record
- Numerator : Integer;
- Denominator : Positive;
- end record;
-
-end FC51A00;
-
-
- --==================================================================--
-
-
-package body FC51A00 is
-
- function "/" (Left, Right : Integer) return Fraction_Type is
- Result : Fraction_Type;
- begin
- Result.Numerator := Left;
- Result.Denominator := Right;
- return Result;
- end "/";
-
-
- function "-" (Frac : Fraction_Type) return Fraction_Type is
- Result : Fraction_Type := Frac;
- begin
- Result.Numerator := -(Result.Numerator);
- return Result;
- end "-";
-
-
- function Numerator (Frac : Fraction_Type) return Integer is
- begin
- return (Frac.Numerator);
- end Numerator;
-
-
- function Denominator (Frac : Fraction_Type) return Integer is
- begin
- return (Frac.Denominator);
- end Denominator;
-
-
-end FC51A00;
diff --git a/gcc/testsuite/ada/acats/support/fc51b00.a b/gcc/testsuite/ada/acats/support/fc51b00.a
deleted file mode 100644
index 1d2b57e..0000000
--- a/gcc/testsuite/ada/acats/support/fc51b00.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- FC51B00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a set of tagged and untagged indefinite
--- subtypes.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC51B00 is -- Type definitions.
-
- subtype Size is Natural range 1 .. 4;
-
- type Matrix is array -- Unconstrained array
- (Size range <>, Size range <>) of Integer; -- type.
-
- type Square (Side : Size) is record -- Unconstrained record
- Mat : Matrix (1 .. Side, 1 .. Side); -- with undefaulted
- end record; -- discriminants.
-
- type Square_Pair (Dimension : Size) is tagged record -- Unconstrained tagged
- Left : Square (Dimension); -- type.
- Right : Square (Dimension);
- end record;
-
- type Vector is tagged record -- Constrained tagged
- Mat : Matrix (1 .. 3, 1 .. 1); -- type (used to get
- end record; -- class-wide type).
-
- generic -- Template for a generic formal package.
- type Vectors (<>) is new Vector with private; -- Type with unknown
- package Signature is end; -- discriminants.
-
-end FC51B00;
-
-
--- No body for FC51B00;
diff --git a/gcc/testsuite/ada/acats/support/fc51c00.a b/gcc/testsuite/ada/acats/support/fc51c00.a
deleted file mode 100644
index 33364c9..0000000
--- a/gcc/testsuite/ada/acats/support/fc51c00.a
+++ /dev/null
@@ -1,112 +0,0 @@
--- FC51C00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a hierarchy of tagged types, which includes
--- both abstract and non-abstract types, and which have both abstract
--- and non-abstract primitive subprograms.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Nov 95 SAIC ACVC 2.0.1 fixes: Deleted primitive operation Proc
--- of Concrete_Root.
--- 11 Aug 96 SAIC ACVC 2.1: Changed procedure bodies to update
--- actual parameters.
---
---!
-
-package FC51C00 is
-
---
--- Non-abstract ultimate ancestor type:
---
-
- type Concrete_Root is tagged null record;
-
- function Func (P: Concrete_Root) return Concrete_Root; -- Abstract when
- -- inherited.
-
-
---
--- Abstract descendant of non-abstract ultimate ancestor:
---
-
- type Abstract_Child is abstract new Concrete_Root with null record;
-
- -- Inherits:
- -- function Func (P: Abstract_Child) return Abstract_Child is abstract;
-
- procedure Proc (P: in out Abstract_Child) is abstract; -- Abstract.
- procedure New_Proc (P : out Abstract_Child) is abstract; -- Abstract.
-
-
-
---
--- Non-abstract descendant of abstract descendant:
---
-
- type Concrete_GrandChild is new Abstract_Child with null record;
-
- function Func (P: Concrete_GrandChild) return Concrete_GrandChild;
-
- procedure Proc (P: in out Concrete_GrandChild);
- procedure New_Proc (P : out Concrete_GrandChild);
-
-
-end FC51C00;
-
-
- --===================================================================--
-
-
-package body FC51C00 is
-
- Value : Concrete_GrandChild;
-
-
- function Func (P: Concrete_Root) return Concrete_Root is
- begin
- return P;
- end Func;
-
-
- function Func (P: Concrete_GrandChild) return Concrete_GrandChild is
- begin
- return P;
- end Func;
-
-
- procedure Proc (P: in out Concrete_GrandChild) is
- begin
- P := Value;
- end Proc;
-
-
- procedure New_Proc (P : out Concrete_GrandChild) is
- begin
- P := Value;
- end New_Proc;
-
-end FC51C00;
diff --git a/gcc/testsuite/ada/acats/support/fc51d00.a b/gcc/testsuite/ada/acats/support/fc51d00.a
deleted file mode 100644
index 4d31bb1..0000000
--- a/gcc/testsuite/ada/acats/support/fc51d00.a
+++ /dev/null
@@ -1,82 +0,0 @@
--- FC51D00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction. List elements can
--- be of any (nonlimited) type. Lists are implemented as arrays of
--- pointers and are only two elements in length.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type (<>) is private;
-package FC51D00 is -- This package simulates a generic list abstraction.
-
- -- The definition of List_Type below is purely artificial; its validity
- -- in the context of the abstraction is irrelevant to the feature being
- -- tested.
-
- type Element_Ptr is access Element_Type;
-
- subtype List_Size is Natural range 1 .. 2;
- type List_Type is array (List_Size) of Element_Ptr;
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type;
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type);
-
- -- ... Other list operations for Element_Type.
-
-end FC51D00;
-
-
- --==================================================================--
-
-
-package body FC51D00 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type is
- begin
- return L(I).all;
- end View_Element;
-
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type) is
- begin
- L(I) := new Element_Type'(E);
- end Write_Element;
-
-end FC51D00;
diff --git a/gcc/testsuite/ada/acats/support/fc54a00.a b/gcc/testsuite/ada/acats/support/fc54a00.a
deleted file mode 100644
index 16bf742..0000000
--- a/gcc/testsuite/ada/acats/support/fc54a00.a
+++ /dev/null
@@ -1,132 +0,0 @@
--- FC54A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various types which will serve as designated
--- types for tests involving generic formal access types (including
--- access-to-subprogram types).
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC54A00 is
-
-
- -- Discrete (integer) types:
-
- Bits : constant := 8; -- Named number.
-
- type Numerals is range -256 .. 255;
- type New_Numerals is new Numerals range -128 .. 127;
- subtype Positives is Numerals range 0 .. 255;
- subtype Same_Numerals is Numerals;
- subtype Numerals_Static is Numerals range -2**Bits .. 2**Bits - 1;
-
- Min : Numerals := Numerals'First; -- Variable.
- Max : Integer := 255; -- Variable.
-
- subtype Numerals_Nonstatic is Numerals range Min .. 255;
- subtype Positive_Nonstatic is Positives range 0 .. Positives(Max);
- subtype Pos_Dupl_Nonstatic is Positives range 0 .. Positives(Max);
- subtype Pos_Attr_Nonstatic is Positives range Positive_Nonstatic'Range;
-
-
-
- -- Floating point types:
-
- type Float_Type is digits 3;
- type New_Float is new Float_Type;
- subtype Float_100 is Float_Type range 0.0 .. 100.0;
- subtype Same_Float is Float_Type;
-
- Hundred : constant := 100.0; -- Named number.
-
- type Float_With_Range is digits 3 range 0.0 .. 100.0;
- subtype Float_Same_Range is Float_With_Range range 0.0 .. Hundred;
-
-
-
- -- Tagged record types:
-
- subtype Lengths is Natural range 0 .. 50;
-
- type Parent is abstract tagged null record;
-
- type Tag (Len: Lengths) is new Parent with record
- Msg : String (1 .. Len);
- end record;
-
- type New_Tag is new Tag with record
- Sent : Boolean;
- end record;
-
- subtype Same_Tag is Tag;
-
- Twenty : constant := 20; -- Named number.
-
- subtype Tag20 is Tag (Len => 20);
- subtype Tag25 is Tag (25);
- subtype Tag_Twenty is Tag (Twenty);
-
- My_Len : Lengths := Twenty; -- Variable.
- subtype Sub_Length is Lengths range 1 .. My_Len;
-
- subtype Tag20_Nonstatic is Tag (Len => Sub_Length'Last);
- subtype Tag20_Dupl_Nonstatic is Tag (Sub_Length'Last);
- subtype Tag20_Same_Nonstatic is Tag20_Nonstatic;
- subtype Tag20_Var_Nonstatic is Tag (Len => My_Len);
-
-
-
- -- Access types (designated type is tagged):
-
- type Tagged_Ptr is access Tag;
- type Tag_Class_Ptr is access Tag'Class;
-
- subtype Msg_Ptr_Static is Tagged_Ptr(Twenty);
-
-
-
- -- Array types:
-
- type New_String is new String;
- subtype Same_String is String;
-
- Ten : constant := 10; -- Named number.
-
- subtype Msg_Static is String(1 .. Ten);
- type Msg10 is new String(1 .. 10);
- subtype Msg20 is String(1 .. 20);
-
- Size : Positive := 10;
-
- subtype Msg_Nonstatic is String(1 .. Size);
- subtype Msg_Dupl_Nonstatic is String(1 .. Size);
- subtype Msg_Same_Nonstatic is Msg_Nonstatic;
-
-
-end FC54A00;
diff --git a/gcc/testsuite/ada/acats/support/fc70a00.a b/gcc/testsuite/ada/acats/support/fc70a00.a
deleted file mode 100644
index e903a13..0000000
--- a/gcc/testsuite/ada/acats/support/fc70a00.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- FC70A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic complex integer support package, to be
--- used for tests covering generic formal packages.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Complex integer abstraction.
- type Int_Type is range <>;
-package FC70A00 is
-
- -- Simulate a generic complex integer support package. Complex integers
- -- are treated as coordinates in the Cartesian plane.
-
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- (0,0).
- One : constant Complex_Type; -- (1,0).
-
-
- function "-" (Right : Complex_Type) -- Invert a complex
- return Complex_Type; -- integer.
-
- function "+" (Left, Right : Complex_Type) -- Add two complex
- return Complex_Type; -- integers.
-
- function "*" (Left, Right : Complex_Type) -- Multiply two complex
- return Complex_Type; -- integers.
-
- function Reciprocal (Right : Complex_Type) -- Return the reciprocal
- return Complex_Type; -- of a complex integer.
-
- function Complex (Real, Imag : Int_Type) -- Create a complex
- return Complex_Type; -- integer.
-
-private
-
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
- One : constant Complex_Type := (Real => 1, Imag => 0);
-
-end FC70A00;
-
-
- --==================================================================--
-
-
-package body FC70A00 is -- Complex integer abstraction.
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return ( (Real, Imag) );
- end Complex;
-
- --==============================================--
-
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return ( (-Right.Real, -Right.Imag) );
- end "-";
-
- --==============================================--
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
- --==============================================--
-
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Real => (Left.Real * Right.Real) - (Left.Imag * Right.Imag),
- Imag => (Left.Imag * Right.Real) + (Left.Real * Right.Imag)) );
- end "*";
-
- --==============================================--
-
- function Reciprocal (Right : Complex_Type) return Complex_Type is
- Denominator : Int_Type := Right.Real**2 + Right.Imag**2;
- begin -- NOTE: Results are truncated.
- return ( (Right.Real/Denominator, -Right.Imag/Denominator) );
- end Reciprocal;
-
-end FC70A00;
diff --git a/gcc/testsuite/ada/acats/support/fc70b00.a b/gcc/testsuite/ada/acats/support/fc70b00.a
deleted file mode 100644
index 46b106e..0000000
--- a/gcc/testsuite/ada/acats/support/fc70b00.a
+++ /dev/null
@@ -1,133 +0,0 @@
--- FC70B00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction. List elements can
--- be of any (nonlimited) type. Lists are implemented as singly linked
--- lists. Access to list elements is sequential. For each list, pointers
--- are maintained to the first and last elements in the list, as well as
--- the next element to be accessed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- List abstraction.
- type Element_Type is private; -- List elems can be of any nonlimited type.
-package FC70B00 is
-
- type List_Type is limited private;
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return Boolean;
-
- -- Read current element value; do NOT advance "current" pointer.
- procedure View_Element (L : in List_Type; E : out Element_Type);
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Type; E : out Element_Type);
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Type; E : in Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Type; E : in Element_Type);
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-private
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end FC70B00;
-
-
- --==================================================================--
-
-
-package body FC70B00 is
-
- function End_Of_List (L : List_Type) return Boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure View_Element (L : in List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- end View_Element;
-
-
- procedure Read_Element (L : in out List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
-
-
- procedure Write_Element (L : in out List_Type; E : in Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
-
-
- procedure Add_Element (L : in out List_Type; E : in Element_Type) is
- New_Node : Node_Pointer := new Node_Type'(E, null);
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-
-end FC70B00;
diff --git a/gcc/testsuite/ada/acats/support/fc70c00.a b/gcc/testsuite/ada/acats/support/fc70c00.a
deleted file mode 100644
index 140b240..0000000
--- a/gcc/testsuite/ada/acats/support/fc70c00.a
+++ /dev/null
@@ -1,100 +0,0 @@
--- FC70C00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction in two packages.
--- The first package declares the types, the second declares the
--- operations. List elements can be of any (nonlimited) type. Lists are
--- implemented as singly linked lists. Access to list elements is
--- sequential. For each list, pointers are maintained to the first and
--- last elements in the list, as well as the next element to be accessed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type is private; -- List elems may be of any nonlimited type.
-package FC70C00_0 is -- List abstraction.
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end FC70C00_0;
-
-
- --==================================================================--
-
-
--- No body for FC70C00_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- List abstraction.
-generic
- with package List_Mgr is new FC70C00_0 (<>);
-package FC70C00_1 is -- Basic list operations.
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Mgr.List_Type) return Boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Mgr.List_Type);
-
-end FC70C00_1;
-
-
- --==================================================================--
-
-
-package body FC70C00_1 is
-
- function End_Of_List (L : List_Mgr.List_Type) return Boolean is
- use List_Mgr; -- Renders "=" directly visible.
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure Reset (L : in out List_Mgr.List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end FC70C00_1;
diff --git a/gcc/testsuite/ada/acats/support/fcndecl.ada b/gcc/testsuite/ada/acats/support/fcndecl.ada
deleted file mode 100644
index eddc137..0000000
--- a/gcc/testsuite/ada/acats/support/fcndecl.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- FCNDECL.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.
---*
---
--- PACKAGE THAT MAY BE MODIFIED TO DECLARE FUNCTIONS THAT RETURN
--- VALUES USABLE FOR INITIALIZATION OF CONSTANTS IN PACKAGE SPPRT13.
-
-WITH SYSTEM;
-PACKAGE FCNDECL IS
--- INSERT FUNCTION DECLARATIONS AS NEEDED.
-
- type Mem is array (1 .. 100) of Long_Long_Integer;
- Var0: Mem;
- Var1: Mem;
- Var2: Mem;
-
- Var_Addr : constant System.Address := Var0'address;
- Var_Addr1: constant System.Address := Var1'address;
- Var_Addr2: constant System.Address := Var2'address;
-
- Ent0: Mem;
- Ent1: Mem;
- Ent2: Mem;
-
- Entry_Addr : constant System.Address := Ent0'address;
- Entry_Addr1: constant System.Address := Ent0'address;
- Entry_Addr2: constant System.Address := Ent0'address;
-
-END FCNDECL;
diff --git a/gcc/testsuite/ada/acats/support/fd72a00.a b/gcc/testsuite/ada/acats/support/fd72a00.a
deleted file mode 100644
index fe662ca..0000000
--- a/gcc/testsuite/ada/acats/support/fd72a00.a
+++ /dev/null
@@ -1,84 +0,0 @@
--- FD72A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for testing package
--- System.Address_To_Access_Conversions
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- FD72A00.A
---
--- CHANGE HISTORY:
--- 08 FEB 96 SAIC Initial version
---
---!
-
-with Impdef;
-with System.Storage_Elements;
-package FD72A00 is
- use System;
-
- subtype Number is System.Storage_Elements.Integer_Address;
-
- package Num_IO renames Impdef.Address_Value_IO;
-
- -- the following conversions To/From Hex are to prevent optimizers from
- -- optimizing out the otherwise senseless identity conversions, and
- -- given the unknown nature of the type Number, the Identity operations
- -- provided in Report will not suffice to this cause.
-
- function Address_To_Hex( Adder: System.Address ) return String;
-
- function Hex_To_Address( Hex: access String ) return System.Address;
-
-end FD72A00;
-
-package body FD72A00 is
-
- function Address_To_Hex( Adder: System.Address ) return String is
- S : String(1..64)
- := "uninitializedDEFuninitializedDEFuninitializedDEFuninitializedDEF";
- DeBlank : Positive := S'First;
- begin
- Num_IO.Put( S, Number( System.Storage_Elements.To_Integer( Adder ) ),
- Base => 16 );
- while S(DeBlank) = ' ' loop
- DeBlank := DeBlank +1;
- end loop;
- return S(DeBlank..S'Last);
- end Address_To_Hex;
-
- function Hex_To_Address( Hex: access String ) return System.Address is
- The_Number : Number;
- Tail : Natural;
- begin
- Num_IO.Get( Hex.all, The_Number, Tail );
- return System.Storage_Elements.To_Address(
- System.Storage_Elements.Integer_Address( The_Number ) );
- end Hex_To_Address;
-
-end FD72A00;
diff --git a/gcc/testsuite/ada/acats/support/fdb0a00.a b/gcc/testsuite/ada/acats/support/fdb0a00.a
deleted file mode 100644
index 4888c24..0000000
--- a/gcc/testsuite/ada/acats/support/fdb0a00.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- FDB0A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides the basis for testing package
--- System.Storage_Pools. It provides simple implementations of
--- Allocate and Deallocate that have the side effect of calling
--- TCTouch.Touch when they are called.
---
--- CHANGE HISTORY:
--- 02 JUN 95 SAIC Initial version
--- 05 APR 96 SAIC Fixed header for 2.1
--- 02 JUL 98 EDS Swapped Pool.Avail change with overflow check
---!
-
----------------------------------------------------------------- FDB0A00
-
-with Report;
-with System.Storage_Pools;
-with System.Storage_Elements;
-package FDB0A00 is
-
- type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
- is new System.Storage_Pools.Root_Storage_Pool with private;
-
- procedure Allocate(
- Pool : in out Stack_Heap;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count);
-
- procedure Deallocate(
- Pool : in out Stack_Heap;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count);
-
- function Storage_Size( Pool: in Stack_Heap )
- return System.Storage_Elements.Storage_Count;
-
- function TC_Largest_Request return System.Storage_Elements.Storage_Count;
-
- Pool_Overflow : exception;
-
-private
-
- type Data_Array is array(System.Storage_Elements.Storage_Count range <>)
- of System.Storage_Elements.Storage_Element;
-
- type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
- is new System.Storage_Pools.Root_Storage_Pool with record
- Data : Data_Array(1..Water_Line);
- Avail : System.Storage_Elements.Storage_Count := 1;
- end record;
-
-end FDB0A00;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body FDB0A00 is
-
- Largest_Request_On_Record : System.Storage_Elements.Storage_Count := 0;
-
- procedure Allocate(
- Pool : in out Stack_Heap;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count) is
- use type System.Storage_Elements.Storage_Offset;
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
-
- -- set the pointer to the next correctly aligned available address
- Pool.Avail := Pool.Avail
- + (Alignment - (Pool.Data(Pool.Avail)'Address mod Alignment));
-
- -- check for overflow
- if Pool.Avail + Size_In_Storage_Elements > Pool.Water_Line then
- raise Pool_Overflow;
- end if;
-
- -- set the resulting address to that address
- Storage_Address := Pool.Data(Pool.Avail)'Address;
-
- -- update the housekeeping
- Pool.Avail := Pool.Avail + Size_In_Storage_Elements;
- Largest_Request_On_Record
- := System.Storage_Elements.Storage_Count'Max(Largest_Request_On_Record,
- Size_In_Storage_Elements);
- exception
- when Constraint_Error => raise Pool_Overflow; -- in case I missed an edge
- end Allocate;
-
- procedure Deallocate(
- Pool : in out Stack_Heap;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count) is
- begin
- TCTouch.Touch('D'); --------------------------------------------------- D
-
- -- for the purposes of validation, the simplest possible implementation
- -- of Deallocate is shown below:
-
- null;
-
- end Deallocate;
-
- function Storage_Size( Pool: in Stack_Heap )
- return System.Storage_Elements.Storage_Count is
- begin
- TCTouch.Touch('S'); --------------------------------------------------- S
- return Pool.Water_Line;
- end Storage_Size;
-
- function TC_Largest_Request return System.Storage_Elements.Storage_Count is
- begin
- return Largest_Request_On_Record;
- end TC_Largest_Request;
-
-end FDB0A00;
diff --git a/gcc/testsuite/ada/acats/support/fdd2a00.a b/gcc/testsuite/ada/acats/support/fdd2a00.a
deleted file mode 100644
index 43a1110..0000000
--- a/gcc/testsuite/ada/acats/support/fdd2a00.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- FDD2A00.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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.
---
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides the basis for testing user-defined stream
--- attributes. It provides operations which count calls to stream
--- attributes.
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
-
-with Ada.Streams;
-use Ada.Streams;
-package FDD2A00 is
-
- type Kinds is (Read, Write, Input, Output);
- type Counts is array (Kinds) of Natural;
-
-
- type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
- record
- First : Stream_Element_Offset := 1;
- Last : Stream_Element_Offset := 0;
- Contents : Stream_Element_Array (1 .. Size);
- end record;
-
- procedure Clear (Stream : in out My_Stream);
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
-
- procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
-
-
- generic
- type T (<>) is limited private;
- with procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : T);
- with function Actual_Input
- (Stream : access Root_Stream_Type'Class) return T;
- with procedure Actual_Read (Stream : access Root_Stream_Type'Class;
- Item : out T);
- with procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : T);
- package Counting_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Counting_Stream_Ops;
-
-end FDD2A00;
-package body FDD2A00 is
-
- procedure Clear (Stream : in out My_Stream) is
- begin
- Stream.First := 1;
- Stream.Last := 0;
- end Clear;
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- if Item'Length >= Stream.Last - Stream.First + 1 then
- Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
- Stream.Contents (Stream.First .. Stream.Last);
- Last := Item'First + Stream.Last - Stream.First;
- Stream.First := Stream.Last + 1;
- else
- Item := Stream.Contents (Stream.First ..
- Stream.First + Item'Length - 1);
- Last := Item'Last;
- Stream.First := Stream.First + Item'Length;
- end if;
- end Read;
-
- procedure Write (Stream : in out My_Stream;
- Item : in Stream_Element_Array) is
- begin
- Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
- Stream.Last := Stream.Last + Item'Length;
- end Write;
-
-
- package body Counting_Stream_Ops is
- Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Write) := Cnts (Write) + 1;
- Actual_Write (Stream, Item);
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return Actual_Input (Stream);
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- Actual_Read (Stream, Item);
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Output) := Cnts (Output) + 1;
- Actual_Output (Stream, Item);
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Counting_Stream_Ops;
-
-end FDD2A00;
diff --git a/gcc/testsuite/ada/acats/support/fxa5a00.a b/gcc/testsuite/ada/acats/support/fxa5a00.a
deleted file mode 100644
index 6b2fcef..0000000
--- a/gcc/testsuite/ada/acats/support/fxa5a00.a
+++ /dev/null
@@ -1,121 +0,0 @@
--- FXA5A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation package contains constants and a function used in
--- the evaluation of the Generic Elementary Functions.
---
--- CHANGE HISTORY:
--- 06 Mar 95 SAIC Initial prerelease version.
--- 03 Apr 95 SAIC Corrected error in context clause.
--- 12 Jun 95 SAIC Added procedure Dont_Optimize. Added New_Float
--- type, and overload of function
--- Result_Within_Range.
---
---!
-
-with Ada.Numerics;
-with Report;
-
-package FXA5A00 is
-
- -- Constants.
-
- Epsilon : constant Float := Float'Model_Epsilon;
- Small : constant Float := Float'Model_Small;
- Large : constant Float := Float'Safe_Last;
- Minus_Large : constant Float := Float'Safe_First;
-
- Half_Pi : constant Float := Ada.Numerics.Pi / 2.0;
- Two_Pi : constant Float := Ada.Numerics.Pi * 2.0;
-
- Floating_Delta : constant Float := 0.05;
- One_Plus_Delta : constant Float := 1.0 + Floating_Delta;
- One_Minus_Delta : constant Float := 1.0 - Floating_Delta;
- Minus_One_Plus_Delta : constant Float := -1.0 + Floating_Delta;
- Minus_One_Minus_Delta : constant Float := -1.0 - Floating_Delta;
-
-
- type New_Float is new Float digits 6;
-
- function Result_Within_Range (Result : Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean;
-
- function Result_Within_Range (Result : New_Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean;
-
- -- This procedure is designed to defeat optimization attempts by an
- -- implementation in cases where an exception is specifically raised
- -- in a test to test a prescribed exception result condition.
- -- The parameter Num is a unique identifier for location purposes within
- -- the test.
-
- generic
- type Eval_Type is digits <>;
- procedure Dont_Optimize (Check_Result : Eval_Type;
- Num : Integer);
-
-end FXA5A00;
-
----
-
-package body FXA5A00 is
-
-
- function Result_Within_Range (Result : Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean is
- begin
- return (Result <= Expected_Result + Relative_Error) and
- (Result >= Expected_Result - Relative_Error);
- end Result_Within_Range;
-
-
- function Result_Within_Range (Result : New_Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean is
- begin
- return (Float(Result) <= Expected_Result + Relative_Error) and
- (Float(Result) >= Expected_Result - Relative_Error);
- end Result_Within_Range;
-
-
- procedure Dont_Optimize (Check_Result : Eval_Type;
- Num : Integer) is
- begin
- -- Note that the use of Minus_Large here is simply as a "dummy" value,
- -- designed to indicate use of the Check_Result parameter, and has no
- -- pass/fail significance to any test using this procedure.
- --
- if Float(Check_Result) = Minus_Large then
- Report.Comment("Attempted Defeat of Optimization ONLY -- Not " &
- "a cause for test failure! " &
- "Result = Minus_Large, Case:" & Integer'Image(Num));
- end if;
- end Dont_Optimize;
-
-end FXA5A00;
diff --git a/gcc/testsuite/ada/acats/support/fxaca00.a b/gcc/testsuite/ada/acats/support/fxaca00.a
deleted file mode 100644
index d8aa5e5..0000000
--- a/gcc/testsuite/ada/acats/support/fxaca00.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- FXACA00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of type definitions and object declarations
--- used by tests of Stream_IO functionality.
--- Objects of both record types specified below (discriminated records
--- with defaults, and discriminated records w/o defaults that have the
--- discriminant included in a representation clause for the type) should
--- have their discriminants included in the stream when using 'Write
--- Likewise, discriminants should be extracted from the stream when
--- using 'Read.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with ImpDef;
-
-package FXACA00 is
-
- type Origin_Type is (Foreign, Domestic);
-
- for Origin_Type'Size use 1; -- Forces objects of the type to be
- -- representable in 1 bit, used in rep clause
- -- below for Sales_Record_Type.
-
- type Product_Type (Manufacture : Origin_Type := Domestic) is
- record
- Item : String (1..8);
- ID : Natural range 1..100;
- case Manufacture is
- when Foreign =>
- Importer : String (1..10);
- when Domestic =>
- Distributor : String (1..10);
- end case;
- end record;
-
-
- type Sales_Record_Type (Buyer : Origin_Type) is -- No default provided
- record -- for the discriminant.
- Name : String (1..6);
- Sale_Item : Boolean := False;
- case Buyer is
- when Foreign =>
- Quantity_Discount : Boolean;
- when Domestic =>
- Cash_Discount : Boolean;
- end case;
- end record;
-
-
- String_Bits : constant := ImpDef.Char_Bits * 6 - 1;
-
- -- This discriminated record type has a representation clause that
- -- includes the discriminant of the object of this type.
-
- for Sales_Record_Type use
- record
- Name at 0 range 0..String_Bits;
- Sale_Item at ImpDef.Next_Storage_Slot range 0..0;
- Buyer at ImpDef.Next_Storage_Slot range 1..1;
- Quantity_Discount at ImpDef.Next_Storage_Slot range 2..2;
- Cash_Discount at ImpDef.Next_Storage_Slot range 3..3;
- end record;
-
-
- type Timespan_Type is (Week, Month, Year);
-
- type Sales_Statistics_Type is
- array (Timespan_Type) of natural range 0 .. 500;
-
-
- -- Object Declarations
-
-
- Product_01 : Product_Type := (Domestic, "Product1", 1, "Distrib 01");
- Product_02 : Product_Type (Manufacture => Foreign) := (Foreign,
- "Product2",
- 2,
- "Importer02");
- Product_03 : Product_Type (Foreign) := (Manufacture => Foreign,
- Item => "Product3",
- ID => 3,
- Importer => "Importer03");
- --
-
- Sale_Count_01 : Integer := 2;
- Sale_Count_02 : Integer := 0;
- Sale_Count_03 : Integer := 3;
-
- --
-
- Sale_Rec_01 : Sales_Record_Type (Domestic) :=
- (Domestic, "Buyer1", False, True);
- Sale_Rec_02 : Sales_Record_Type (Domestic) :=
- (Domestic, "Buyer2", True, False);
-
- Sale_Rec_03 : Sales_Record_Type (Buyer => Foreign) :=
- (Buyer => Foreign, Name => "Buyer3", Sale_Item => True,
- Quantity_Discount => True);
-
- Sale_Rec_04 : Sales_Record_Type (Foreign) :=
- (Foreign, "Buyer4", True, False);
- Sale_Rec_05 : Sales_Record_Type (Buyer => Foreign) := (Foreign,
- "Buyer5",
- False,
- False);
- --
-
-
- Product_01_Stats : Sales_Statistics_Type := (2,4,8);
- Product_02_Stats : Sales_Statistics_Type := (Week => 0,
- Month => 5,
- Year => 10);
- Product_03_Stats : Sales_Statistics_Type := (3, 6, others => 12);
-
-
-end FXACA00;
diff --git a/gcc/testsuite/ada/acats/support/fxacb00.a b/gcc/testsuite/ada/acats/support/fxacb00.a
deleted file mode 100644
index 22b50ef..0000000
--- a/gcc/testsuite/ada/acats/support/fxacb00.a
+++ /dev/null
@@ -1,107 +0,0 @@
--- FXACB00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of type definitions and object declarations
--- used by tests of Stream_IO functionality.
--- These types include an unconstrained array type, and a discriminated
--- record without a default discriminant, specifically chosen for use in
--- demonstrating the capabilities of 'Output and 'Input.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FXACB00 is
-
- type Customer_Type is (Residence, Apartment, Commercial);
- type Electric_Usage_Type is range 0..100000;
- type Months_In_Service_Type is range 1..12;
- type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter);
- subtype Month_In_Quarter_Type is Positive range 1..3;
- type Service_History_Type is
- array (Quarterly_Period_Type range <>, Month_In_Quarter_Type range <>)
- of Electric_Usage_Type;
-
-
- type Service_Type (Customer : Customer_Type) is
- record
- Name : String (1..21);
- Account_ID : Natural range 0..100;
- case Customer is
- when Residence | Apartment =>
- Low_Income_Credit : Boolean := False;
- when Commercial =>
- Baseline_Allowance : Natural range 0..1000;
- Quantity_Discount : Boolean := False;
- end case;
- end record;
-
-
- -- Object Declarations
-
-
- Customer1 : Service_Type (Residence) :=
- (Residence, "1221 Morningstar Lane", 44, False);
- Customer2 : Service_Type (Apartment) := (Customer => Apartment,
- Account_ID => 67,
- Name => "15 South Front St. #8",
- Low_Income_Credit => True);
- Customer3 : Service_Type (Commercial) := (Commercial,
- "12442 Central Avenue ",
- 100,
- Baseline_Allowance => 938,
- Quantity_Discount => True);
-
- --
-
- C1_Months : Months_In_Service_Type := 10;
- C2_Months : Months_In_Service_Type := 2;
- C3_Months : Months_In_Service_Type := 12;
-
- --
-
- C1_Service_History :
- Service_History_Type (Quarterly_Period_Type, Month_In_Quarter_Type) :=
- (Spring => (1 => 35, 2 => 39, 3 => 32),
- Summer => (1 => 34, 2 => 33, 3 => 39),
- Autumn => (1 => 45, 2 => 40, 3 => 38),
- Winter => (1 => 53, 2 => 0, 3 => 0));
-
- C2_Service_History :
- Service_History_Type (Quarterly_Period_Type range Spring..Summer,
- Month_In_Quarter_Type) :=
- (Spring => (23, 22, 0), Summer => (0, 0, 0));
-
- C3_Service_History :
- Service_History_Type (Quarterly_Period_Type, Month_In_Quarter_Type) :=
- (others => (others => 200));
-
- --
-
- Total_Customers_In_Service : constant Natural := 3;
-
-end FXACB00;
diff --git a/gcc/testsuite/ada/acats/support/fxacc00.a b/gcc/testsuite/ada/acats/support/fxacc00.a
deleted file mode 100644
index 64d63be..0000000
--- a/gcc/testsuite/ada/acats/support/fxacc00.a
+++ /dev/null
@@ -1,115 +0,0 @@
--- FXACC00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of a tagged type definition and several
--- record extensions. Objects of each type have also been declared
--- and given initial values.
---
--- Visual Description of Type Extensions:
---
--- type Ticket_Request
--- |
--- _______________|_________________
--- | |
--- | |
--- type Subscriber_Request type VIP_Request
--- |
--- |
--- type Last_Minute_Request
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Calendar;
-
-package FXACC00 is
-
- type Location_Type is (Backstage, Orchestra, Center, Back, Balcony);
- type Quantity_Type is range 1 .. 100;
- subtype Season_Ticket_Type is Positive range 1 .. 1750;
- type VIP_Status_Type is (Mayor, City_Council, Visitor);
- type Donation_Type is (To_Charity, To_Theatre, Personal);
-
- Show_Of_Appreciation : constant Boolean := True;
-
- type Ticket_Request is tagged
- record
- Location : Location_Type;
- Number_Of_Tickets : Quantity_Type;
- end record;
-
-
- type Subscriber_Request is new Ticket_Request with
- record
- Subscription_Number : Season_Ticket_Type;
- end record;
-
-
- type VIP_Request is new Ticket_Request with
- record
- Rank : VIP_Status_Type;
- end record;
-
-
- type Last_Minute_Request (Special_Consideration : Boolean)
- is new VIP_Request with
- record
- Time_of_Request : Ada.Calendar.Time;
- case Special_Consideration is
- when True => Donation : Donation_Type;
- when False => null;
- end case;
- end record;
-
-
- -- Object Declarations.
-
-
- Box_Office_Request : Ticket_Request :=
- (Location => Back,
- Number_Of_Tickets => 2);
-
- Summer_Subscription : Subscriber_Request :=
- (Ticket_Request'(Box_Office_Request)
- with Subscription_Number => 567);
-
- Mayoral_Ticket_Request : VIP_Request :=
- (Location => Backstage,
- Number_Of_Tickets => 6,
- Rank => Mayor);
-
- Late_Request : Last_Minute_Request (Show_Of_Appreciation) :=
- (Special_Consideration => Show_Of_Appreciation,
- Location => Orchestra,
- Number_Of_Tickets => 2,
- Rank => City_Council,
- Time_Of_Request => Ada.Calendar.Clock,
- Donation => To_Charity);
-
-
-end FXACC00;
diff --git a/gcc/testsuite/ada/acats/support/fxc6a00.a b/gcc/testsuite/ada/acats/support/fxc6a00.a
deleted file mode 100644
index 1e51d2a..0000000
--- a/gcc/testsuite/ada/acats/support/fxc6a00.a
+++ /dev/null
@@ -1,162 +0,0 @@
--- FXC6A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various volatile and non-volatile types. Some
--- are by-reference types, and some allow pass-by-copy.
---
--- CHANGE HISTORY:
--- 23 Jan 96 SAIC Initial version for ACVC 2.1.
--- 02 DEC 97 EDS Removed Pragma Volatile applied to composite types.
--- 27 AUG 99 RLB Repaired so Nonvolatile_Tagged really is
--- Nonvolatile.
---!
-
-package FXC6A00 is
-
- type Roman is ('I', 'V', 'X', 'L', 'C', 'D', 'M'); -- By-copy type.
-
- type Acc_Roman is access all Roman;
-
-
- type Tagged_Type is tagged record -- By-reference type.
- C: Natural;
- end record;
-
-
- type Volatile_Tagged is new Tagged_Type with record -- Volatile by-reference
- R1: Roman; -- type.
- end record;
- pragma Volatile (Volatile_Tagged);
-
- type Acc_Volatile_Tagged is access all Volatile_Tagged;
-
- -- By-reference type.
- type NonVolatile_Tagged is new Tagged_Type with record
- R2: aliased Roman;
- end record;
-
-
- task type Task_Type is -- By-reference type.
- entry Calculate (C: in out Natural);
- end Task_Type;
-
- type Acc_Task_Type is access all Task_Type;
-
-
- protected type Protected_Type is -- By-reference type.
- procedure Op;
- private
- Count : Natural := 0;
- end Protected_Type;
-
-
- protected type Volatile_Protected is -- Volatile by-reference
- procedure Handler; -- type.
- pragma Interrupt_Handler (Handler);
-
- function Handled return Boolean;
- private
- Was_Handled : Boolean := False;
- end Volatile_Protected;
- pragma Volatile (Volatile_Protected);
-
- type Acc_Vol_Protected is access all Volatile_Protected;
-
-
- type Record_Type is record -- Allows pass-by-copy.
- C: String(1 .. 2);
- end record;
-
-
- type Volatile_Record is limited record -- Volatile by-reference
- C: String(1 .. 2); -- type.
- end record;
- pragma Volatile (Volatile_Record);
-
-
- type Composite_Type is record -- By-reference type.
- C: Tagged_Type;
- D: aliased Volatile_Tagged; -- Volatile component.
- end record;
-
-
- type Private_Type is private; -- By-reference type.
-
-
- type Array_Type is array (1..3) of Tagged_Type; -- By-reference type.
- pragma Volatile_Components (Array_Type);
-
- type Acc_Array_Type is access all Array_Type;
-
-
- type Lim_Private_Type is limited private; -- By-copy type.
-
-private
-
- type Private_Type is new Tagged_Type with record
- D: Character;
- end record;
-
-
- type Lim_Private_Type is new Integer;
-
-end FXC6A00;
-
-
- --==================================================================--
-
-
-package body FXC6A00 is
-
- task body Task_Type is
- begin
- accept Calculate (C: in out Natural) do
- C := C * 10;
- end Calculate;
- end Task_Type;
-
-
- protected body Protected_Type is
- procedure Op is
- begin
- Count := Count + 1;
- end Op;
- end Protected_Type;
-
-
- protected body Volatile_Protected is
- procedure Handler is
- begin
- Was_Handled := True;
- end Handler;
-
- function Handled return Boolean is
- begin
- return Was_Handled;
- end Handled;
- end Volatile_Protected;
-
-end FXC6A00;
diff --git a/gcc/testsuite/ada/acats/support/fxe2a00.a b/gcc/testsuite/ada/acats/support/fxe2a00.a
deleted file mode 100644
index ed94315..0000000
--- a/gcc/testsuite/ada/acats/support/fxe2a00.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- FXE2A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a Declared Pure package, a Shared Passive
--- package, a Remote Types package and a normal, unrestricted package.
---
--- It is used by tests checking the interrelationship between the
--- categorized packages
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
---====================================================================
-
--- This is a DECLARED PURE package
---
-package FXE2A00_0 is
-
- pragma pure (FXE2A00_0);
-
- type Type_From_0 is (Red, Orange, Yellow);
-
-
-end FXE2A00_0;
-
-
---====================================================================
-
--- This is a SHARED_PASSIVE package
---
-package FXE2A00_1 is
-
-
- pragma shared_passive (FXE2A00_1);
-
- type Type_From_1 is (Blue, Indigo, Violet);
-
-end FXE2A00_1;
-
-
---====================================================================
-
--- This is a REMOTE TYPES package
---
-package FXE2A00_2 is
-
- pragma Remote_Types (FXE2A00_2);
-
- type Type_From_2 is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
-
-end FXE2A00_2;
-
-
---====================================================================
-
--- This is a NORMAL unrestricted package which has no categorization
---
-package FXE2A00_4 is
-
- type Type_From_4 is (Black, White);
-
-end FXE2A00_4;
-
---====================================================================
diff --git a/gcc/testsuite/ada/acats/support/fxf2a00.a b/gcc/testsuite/ada/acats/support/fxf2a00.a
deleted file mode 100644
index 2471f5c..0000000
--- a/gcc/testsuite/ada/acats/support/fxf2a00.a
+++ /dev/null
@@ -1,96 +0,0 @@
--- FXF2A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares supporting objects, types and a generic
--- function for testing decimal fixed point operations.
---
--- The generic function contains a loop which steps through two arrays:
--- one of binary operations and one of operands. For each iteration, the
--- current operation is performed on the current operand and a variable
--- "Result" e.g.:
---
--- Result := Operation(2)(Operand(3), Result);
---
--- The result of each operation is cumulated in Result and returned to
--- the caller when the loop completes.
---
--- CHANGE HISTORY:
--- 12 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-package FXF2A00 is
-
- Loop_Count : constant := 30000; -- # test iterations.
- Optr_Count : constant := 6; -- # operations in op sequence.
- Opnd_Count : constant := 5; -- # different operands.
-
- type Loop_Range is range 1 .. Loop_Count; -- range 1 .. 30000.
- type Optr_Range is mod Optr_Count; -- range 0 .. 5.
- type Opnd_Range is mod Opnd_Count; -- range 0 .. 4.
-
-
- generic
-
- type Decimal_Fixed is delta <> digits <>;
-
- type Operator_Ptr is access
- function (L, R : Decimal_Fixed) return Decimal_Fixed;
-
- type Operator_Table is array (Optr_Range) of Operator_Ptr;
- type Operand_Table is array (Opnd_Range) of Decimal_Fixed;
-
- function Operations_Loop (Initial : Decimal_Fixed;
- Operator: Operator_Table;
- Operand : Operand_Table) return Decimal_Fixed;
-
-end FXF2A00;
-
-
- --==================================================================--
-
-
-package body FXF2A00 is
-
- function Operations_Loop (Initial : Decimal_Fixed;
- Operator: Operator_Table;
- Operand : Operand_Table) return Decimal_Fixed is
-
- Result : Decimal_Fixed := Initial; -- Cumulator.
- Optr_Index : Optr_Range := 0; -- Index into operations table.
- Opnd_Index : Opnd_Range := 0; -- Index into operand table.
-
- begin
- for Count in Loop_Range loop
- Result := Operator(Optr_Index) (Result, Operand(Opnd_Index));
- Optr_Index := Optr_Index + 1; -- Modular addition.
- Opnd_Index := Opnd_Index + 1; -- Modular addition.
- end loop;
-
- return Result;
- end Operations_Loop;
-
-end FXF2A00;
diff --git a/gcc/testsuite/ada/acats/support/fxf3a00.a b/gcc/testsuite/ada/acats/support/fxf3a00.a
deleted file mode 100644
index 645010e..0000000
--- a/gcc/testsuite/ada/acats/support/fxf3a00.a
+++ /dev/null
@@ -1,330 +0,0 @@
--- FXF3A00.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation contains decimal data values, valid and invalid
--- Picture strings, and Edited Output result strings that will be used
--- in tests of Appendix F.3.
--- Note: In this foundation package, the effect of "Table Driven Data"
--- is achieved using a series of arrays to hold the various data items.
--- Since the data items (Picture strings, Edited Output) are often of
--- different lengths, the arrays are defined to contain pointers to
--- string values, thereby allowing the "tables" to hold string data of
--- different sizes.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Feb 95 SAIC Picture string, decimal data, and edited_output
--- modifications.
--- 23 Feb 95 SAIC Picture string modification.
--- 10 Mar 95 SAIC Added explanatory comments.
--- 15 Nov 95 SAIC Corrected picture string for ACVC 2.0.1.
--- 06 Oct 96 SAIC Corrected invalid picture strings.
--- 13 Feb 97 PWB.CTA Deleted invalid picture string.
--- 17 Feb 97 PWB.CTA Added leading blank to two picture strings
---!
-
-with Ada.Text_IO.Editing;
-
-package FXF3A00 is
-
- Number_Of_NDP_Items : constant := 12; -- No Decimal Places.
- Number_Of_2DP_Items : constant := 20; -- Two Decimal Places.
- Number_Of_Valid_Strings : constant := 40;
- Number_Of_FF_Strings : constant := 4; -- French Francs
- Number_Of_DM_Strings : constant := 5; -- Deutchemarks
- Number_Of_CHF_Strings : constant := 1; -- Swiss Francs
- Number_Of_Foreign_Strings : constant := Number_Of_FF_Strings +
- Number_Of_DM_Strings +
- Number_Of_CHF_Strings;
- Number_Of_Invalid_Strings : constant := 25;
- Number_Of_Erroneous_Conditions : constant := 3;
- Number_Of_Edited_Output_Strings : constant := 32;
-
- -- The following string is to be used as a picture string with length
- -- beyond the maximum (Max_Picture_Length) that is supported by the
- -- implementation.
-
- A_Picture_String_Too_Long : constant
- String (1..Ada.Text_IO.Editing.Max_Picture_Length + 1) := (others => '9');
-
-
- type Str_Ptr is access String;
-
- type Decimal_Type_NDP is delta 1.0 digits 16; -- no decimal places
- type Decimal_Type_2DP is delta 0.01 digits 16; -- two decimal places
-
- type Data_Array_Type_1 is array (Integer range <>) of Decimal_Type_NDP;
- type Data_Array_Type_2 is array (Integer range <>) of Decimal_Type_2DP;
-
-
- type Picture_String_Array_Type is
- array (Integer range <>) of Str_Ptr;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of Str_Ptr;
-
-
-
- Data_With_NDP : Data_Array_Type_1 (1..Number_Of_NDP_Items) :=
- ( 1 => 1234.0,
- 2 => 51234.0,
- 3 => -1234.0,
- 4 => 1234.0,
- 5 => 1.0,
- 6 => 0.0,
- 7 => -10.0,
- 8 => -1.0,
- 9 => 1234.0,
- 10 => 1.0,
- 11 => 36.0,
- 12 => 0.0
- );
-
-
- Data_With_2DP : Data_Array_Type_2 (1..Number_Of_2DP_Items) :=
- ( 1 => 123456.78,
- 2 => 123456.78,
- 3 => 0.0,
- 4 => 0.20,
- 5 => 123456.00,
- 6 => -123456.78,
- 7 => 123456.78,
- 8 => -12.34,
- 9 => 1.23,
- 10 => 12.34,
-
- -- Items 11-20 are used with picture strings in evaluating use of
- -- foreign currency symbols.
-
- 11 => 123456.78,
- 12 => 123456.78,
- 13 => 32.10,
- 14 => -5432.10,
- 15 => -1234.57,
- 16 => 123456.78,
- 17 => 12.34,
- 18 => 12.34,
- 19 => 1.23,
- 20 => 12345.67
- );
-
-
-
- Valid_Strings : Picture_String_Array_Type
- (1..Number_Of_Valid_Strings) :=
-
- -- Items 1-10 are used in conjunction with Data_With_2DP values
- -- to produce edited output strings, as well as in tests of
- -- function Valid.
-
- ( 1 => new String'("-###**_***_**9.99"),
- 2 => new String'("-$**_***_**9.99"),
- 3 => new String'("-$$$$$$.$$"),
- 4 => new String'("-$$$$$$.$$"),
- 5 => new String'("+BBBZZ_ZZZ_ZZZ.ZZ"),
- 6 => new String'("--_---_---_--9"),
- 7 => new String'("-$_$$$_$$$_$$9.99"),
- 8 => new String'("<$$_$$$9.99>"),
- 9 => new String'("$_$$9.99"),
- 10 => new String'("$$9.99"),
-
- -- Items 11-22 are used in conjunction with Data_With_NDP values
- -- to produce edited output strings.
-
- 11 => new String'("ZZZZ9"),
- 12 => new String'("ZZZZ9"),
- 13 => new String'("<#Z_ZZ9>"),
- 14 => new String'("<#Z_ZZ9>"),
- 15 => new String'("ZZZ.ZZ"),
- 16 => new String'("ZZZ.ZZ"),
- 17 => new String'("<###99>"),
- 18 => new String'("ZZZZZ-"),
- 19 => new String'("$$$$9"),
- 20 => new String'("$$$$$"),
- 21 => new String'("<###99>"),
- 22 => new String'("$$$$9"),
-
- -- Items 23-40 are used in validation of the Valid, To_Picture, and
- -- Pic_String subprograms of package Text_IO.Editing, and are not
- -- used to generate edited output.
-
- 23 => new String'("zZzZzZzZzZzZzZzZzZ"),
- 24 => new String'("999999999999999999"),
- 25 => new String'("******************"),
- 26 => new String'("$$$$$$$$$$$$$$$$$$"),
- 27 => new String'("9999/9999B9999_999909999"),
- 28 => new String'("+999999999999999999"),
- 29 => new String'("-999999999999999999"),
- 30 => new String'("999999999999999999+"),
- 31 => new String'("999999999999999999-"),
- 32 => new String'("<<<_<<<_<<<_<<<_<<<_<<9>"),
- 33 => new String'("++++++++++++++++++++"),
- 34 => new String'("--------------------"),
- 35 => new String'("zZzZzZzZzZzZzZzZzZ.zZ"),
- 36 => new String'("******************.99"),
- 37 => new String'("$$$$$$$$$$$$$$$$$$.99"),
-
- -- The following string has length 30, which is the minimum value
- -- that must be supported for Max_Picture_Length.
-
- 38 => new String'("9_999_999_999_999_999_999BB.99"),
- 39 => new String'("<<<_<<<_<<<_<<<.99>"),
- 40 => new String'("ZZZZZZZZZZZZZZZZZ+")
- );
-
-
-
- Foreign_Strings : Picture_String_Array_Type
- (1..Number_Of_Foreign_Strings) :=
-
- -- These strings are going to be used in conjunction with non-default
- -- values for Currency string, Radix mark, and Separator in calls to
- -- Image and Put, as well as in tests of function Valid.
-
- ( 1 => new String'("-###**_***_**9.99"), -- FF
- 2 => new String'("-$**_***_**9.99"), -- FF
- 3 => new String'("<###z_ZZ9.99>"), -- FF
- 4 => new String'("<###Z_ZZ9.99>"), -- FF
- 5 => new String'("<<<<_<<<.<<###>"), -- DM
- 6 => new String'("-$_$$$_$$$_$$9.99"), -- DM
- 7 => new String'("$z99.99"), -- DM
- 8 => new String'("$$$9.99"), -- DM
- 9 => new String'("$_$$9.99"), -- DM
- 10 => new String'("###_###_##9.99") -- CHF
- );
-
-
-
- Invalid_Strings : Picture_String_Array_Type
- (1..Number_Of_Invalid_Strings) :=
- --
- -- The RM references to the right of these invalid picture strings
- -- indicates which of the composition constraints of picture strings
- -- is violated by the particular string (and all following strings
- -- until another reference is presented). However, certain strings
- -- violate multiple of the constraints.
- --
- ( 1 => new String'("<<<"),
- 2 => new String'("<<>>"),
- 3 => new String'("<<<9_B0/$DB"),
- 4 => new String'("+BB"),
- 5 => new String'("<-"),
- 6 => new String'("<CR"),
- 7 => new String'("<db"),
- 8 => new String'("<<BBBcr"),
- 9 => new String'("<<__DB"),
- 10 => new String'("<<<++++_++-"),
- 11 => new String'("-999.99>"),
- 12 => new String'("+++9.99+"),
- 13 => new String'("++++>>"),
- 14 => new String'("->"),
- 15 => new String'("++9-"),
- 16 => new String'("---999999->"),
- 17 => new String'("+++-"),
- 18 => new String'("+++_+++_+.--"),
- 19 => new String'("--B.BB+>"),
- 20 => new String'("$$#$"),
- 21 => new String'("#B$$$$"),
- 22 => new String'("**Z"),
- 23 => new String'("ZZZzzz*"),
- 24 => new String'("9.99DB(2)"),
- 25 => new String'(A_Picture_String_Too_Long)
- );
-
-
- Edited_Output : Edited_Output_Results_Array_Type
- (1..Number_Of_Edited_Output_Strings) :=
-
- -- The following 10 edited output strings result from the first 10
- -- valid strings when used with the first 10 Data_With_2DP numeric
- -- values.
- ( 1 => new String'(" $***123,456.78"),
- 2 => new String'(" $***123,456.78"),
- 3 => new String'(" "),
- 4 => new String'(" $.20"),
- 5 => new String'("+ 123,456.00"),
- 6 => new String'(" -123,457"),
- 7 => new String'(" $123,456.78"),
- 8 => new String'("( $12.34)"),
- 9 => new String'(" $1.23"),
- 10 => new String'("$12.34"),
-
- -- The following 10 edited output strings correspond to the 10 foreign
- -- currency picture strings (the currency string is supplied at the
- -- time of the call to Editing.Image or Editing.Put), when used in
- -- conjunction with Data_With_2DP items 11-20
-
- 11 => new String'(" FF***123.456,78"),
- 12 => new String'(" FF***123.456,78"),
- 13 => new String'(" FF 32,10 "),
- 14 => new String'("( FF5.432,10)"),
- 15 => new String'(" (1,234.57DM )"),
- 16 => new String'(" DM123,456.78"),
- 17 => new String'("DM 12.34"),
- 18 => new String'(" DM12.34"),
- 19 => new String'(" DM1.23"),
- 20 => new String'(" CHF12,345.67"),
-
- -- The following 12 edited output strings correspond to the 12
- -- Data_With_NDP items formatted using Valid_String items 11-22.
- -- This combination shows decimal data with no decimal places
- -- formatted using picture strings.
-
- 21 => new String'(" 1234"),
- 22 => new String'("51234"),
- 23 => new String'("($1,234)"),
- 24 => new String'(" $1,234 "),
- 25 => new String'(" 1.00"),
- 26 => new String'(" "),
- 27 => new String'("( $10)"),
- 28 => new String'(" 1-"),
- 29 => new String'("$1234"),
- 30 => new String'(" $1"),
- 31 => new String'(" $36 "),
- 32 => new String'(" $0")
- );
-
-
-
- -- The following data is used to create exception situations in tests of
- -- the Edited Output capabilities of package Ada.Text_IO.Editing. The data
- -- are not themselves erroneous, but will produce exceptions based on the
- -- data/picture string combination used.
-
- Erroneous_Data : Data_Array_Type_2 (1..Number_Of_Erroneous_Conditions) :=
- ( 1 => 12.34,
- 2 => -12.34,
- 3 => 51234.0
- );
-
- Erroneous_Strings : Picture_String_Array_Type
- (1..Number_Of_Erroneous_Conditions) :=
- ( 1 => new String'("9.99"),
- 2 => new String'("99.99"),
- 3 => new String'("$$$$9")
- );
-
-end FXF3A00;
diff --git a/gcc/testsuite/ada/acats/support/impbit.adb b/gcc/testsuite/ada/acats/support/impbit.adb
deleted file mode 100644
index 5e189b0..0000000
--- a/gcc/testsuite/ada/acats/support/impbit.adb
+++ /dev/null
@@ -1,6 +0,0 @@
-with System;
-with Ada.Text_IO;
-procedure Impbit is
-begin
- Ada.Text_IO.Put_Line (System.Address'Size'Img);
-end Impbit;
diff --git a/gcc/testsuite/ada/acats/support/impdef.a b/gcc/testsuite/ada/acats/support/impdef.a
deleted file mode 100644
index ca02a7a..0000000
--- a/gcc/testsuite/ada/acats/support/impdef.a
+++ /dev/null
@@ -1,385 +0,0 @@
--- IMPDEF.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.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used in at least
--- one core test. Entities which are used exclusively in tests for
--- annexes C-H are located in annex-specific child units of this package.
---
--- CHANGE HISTORY:
--- 12 DEC 93 SAIC Initial PreRelease version
--- 02 DEC 94 SAIC Second PreRelease version
--- 16 May 95 SAIC Added constants specific to tests of the random
--- number generator.
--- 16 May 95 SAIC Added Max_RPC_Call_Time constant.
--- 17 Jul 95 SAIC Added Non_State_String constant.
--- 21 Aug 95 SAIC Created from existing IMPSPEC.ADA and IMPBODY.ADA
--- files.
--- 30 Oct 95 SAIC Added external name string constants.
--- 24 Jan 96 SAIC Added alignment constants.
--- 29 Jan 96 SAIC Moved entities not used in core tests into annex-
--- specific child packages. Adjusted commentary.
--- Renamed Validating_System_Programming_Annex to
--- Validating_Annex_C. Added similar Validating_Annex_?
--- constants for the other non-core annexes (D-H).
--- 01 Mar 96 SAIC Added external name string constants.
--- 21 Mar 96 SAIC Added external name string constants.
--- 02 May 96 SAIC Removed constants for draft test CXA5014, which was
--- removed from the tentative ACVC 2.1 suite.
--- Added constants for use with FXACA00.
--- 06 Jun 96 SAIC Added constants for wide character test files.
--- 11 Dec 96 SAIC Updated constants for wide character test files.
--- 13 Dec 96 SAIC Added Address_Value_IO
--- 13 Sep 99 RLB Added more external name string constants.
--- 16 Sep 99 RLB Corrected definition of Non_State_String constant.
---
---!
-
-with Report;
-with Ada.Text_IO;
-with System.Storage_Elements;
-
-package ImpDef is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following boolean constants indicate whether this validation will
- -- include any of annexes C-H. The values of these booleans affect the
- -- behavior of the test result reporting software.
- --
- -- True means the associated annex IS included in the validation.
- -- False means the associated annex is NOT included.
-
- Validating_Annex_C : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_D : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_E : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_F : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_G : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_H : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the minimum time required to allow another task to get
- -- control. It is expected that the task is on the Ready queue.
- -- A duration of 0.0 would normally be sufficient but some number
- -- greater than that is expected.
-
- Minimum_Task_Switch : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
- -- The above constant has been chosen for use with delay statements in the
- -- GCC testsuite so that they do not take too long, but may be too small.
-
- Long_Minimum_Task_Switch : constant Duration := 0.1;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the time required to activate another task and allow it
- -- to run to its first accept statement. We are considering a simple task
- -- with very few Ada statements before the accept. An implementation is
- -- free to specify a delay of several seconds, or even minutes if need be.
- -- The main effect of specifying a longer delay than necessary will be an
- -- extension of the time needed to run the associated tests.
-
- Switch_To_New_Task : constant Duration := 0.001;
- -- ^^^ -- MODIFY HERE AS NEEDED
-
- -- The above constant has been chosen for use with delay statements in the
- -- GCC testsuite so that they do not take too long, but may be too small.
-
- Long_Switch_To_New_Task : constant Duration := 0.1;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the time which will clear the queues of other tasks
- -- waiting to run. It is expected that this will be about five
- -- times greater than Switch_To_New_Task.
-
- Clear_Ready_Queue : constant Duration := 0.1;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Some implementations will boot with the time set to 1901/1/1/0.0
- -- When a delay of Delay_For_Time_Past is given, the implementation
- -- guarantees that a subsequent call to Ada.Calendar.Time_Of(1901,1,1)
- -- will yield a time that has already passed (for example, when used in
- -- a delay_until statement).
-
- Delay_For_Time_Past : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Minimum time interval between calls to the time dependent Reset
- -- procedures in Float_Random and Discrete_Random packages that is
- -- guaranteed to initiate different sequences. See RM A.5.2(45).
-
- Time_Dependent_Reset : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Test CXA5013 will loop, trying to generate the required sequence
- -- of random numbers. If the RNG is faulty, the required sequence
- -- will never be generated. Delay_Per_Random_Test is a time-out value
- -- which allows the test to run for a period of time after which the
- -- test is failed if the required sequence has not been produced.
- -- This value should be the time allowed for the test to run before it
- -- times out. It should be long enough to allow multiple (independent)
- -- runs of the testing code, each generating up to 1000 random
- -- numbers.
-
- Delay_Per_Random_Test : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The time required to execute this procedure must be greater than the
- -- time slice unit on implementations which use time slicing. For
- -- implementations which do not use time slicing the body can be null.
-
- procedure Exceed_Time_Slice;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This constant must not depict a random number generator state value.
- -- Using this string in a call to function Value from either the
- -- Discrete_Random or Float_Random packages will result in
- -- Constraint_Error or Program_Error (expected result in test CXA5012).
- -- If there is no such string, set it to "**NONE**".
-
- Non_State_String : constant String := "By No Means A State";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This string constant must be a legal external tag value as used by
- -- CD10001 for the type Some_Tagged_Type in the representation
- -- specification for the value of 'External_Tag.
-
- External_Tag_Value : constant String := "implementation_defined";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following address constant must be a valid address to locate
- -- the C program CD30005_1. It is shown here as a named number;
- -- the implementation may choose to type the constant as appropriate.
-
- function Cd30005_Proc (X : Integer) return Integer;
- pragma Import (C, Cd30005_Proc, "_cd30005_1");
-
- pragma Linker_Options ("ACATS4GNATDIR/support/cd300051.o");
-
- CD30005_1_Foreign_Address : constant System.Address:= Cd30005_Proc'Address;
-
- -- CD30005_1_Foreign_Address : constant System.Address:=
- -- System.Storage_Elements.To_Address ( 16#0000_0000# )
- -- MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constant must be the external name resulting
- -- from the C compilation of CD30005_1. The string will be used as an
- -- argument to pragma Import.
-
- CD30005_1_External_Name : constant String := "_cd30005_1";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following constants should represent the largest default alignment
- -- value and the largest alignment value supported by the linker.
- -- See RM 13.3(35).
-
- Max_Default_Alignment : constant := Standard'Maximum_Alignment;
- -- ^ --- MODIFY HERE AS NEEDED
-
- Max_Linker_Alignment : constant := Standard'Maximum_Alignment;
- -- ^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the C compilation of CXB30040.C, CXB30060.C, CXB30130.C, and
- -- CXB30131.C. The strings will be used as arguments to pragma Import.
-
- CXB30040_External_Name : constant String := "CXB30040";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30060_External_Name : constant String := "CXB30060";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30130_External_Name : constant String := "CXB30130";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30131_External_Name : constant String := "CXB30131";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the COBOL compilation of CXB40090.CBL, CXB40091.CBL, and
- -- CXB40092.CBL. The strings will be used as arguments to pragma Import.
-
- CXB40090_External_Name : constant String := "CXB40090";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB40091_External_Name : constant String := "CXB40091";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB40092_External_Name : constant String := "CXB40092";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the Fortran compilation of CXB50040.FTN, CXB50041.FTN,
- -- CXB50050.FTN, and CXB50051.FTN.
- --
- -- The strings will be used as arguments to pragma Import.
- --
- -- Note that the use of these four string constants will be split between
- -- two tests, CXB5004 and CXB5005.
-
- CXB50040_External_Name : constant String := "CXB50040";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50041_External_Name : constant String := "CXB50041";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50050_External_Name : constant String := "CXB50050";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50051_External_Name : constant String := "CXB50051";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following constants have been defined for use with the
- -- representation clause in FXACA00 of type Sales_Record_Type.
- --
- -- Char_Bits should be an integer at least as large as the number
- -- of bits needed to hold a character in an array.
- -- A value of 6 * Char_Bits will be used in a representation clause
- -- to reserve space for a six character string.
- --
- -- Next_Storage_Slot should indicate the next storage unit in the record
- -- representation clause that does not overlap the storage designated for
- -- the six character string.
-
- Char_Bits : constant := 8;
- -- MODIFY HERE AS NEEDED ---^
-
- Next_Storage_Slot : constant := 6;
- -- MODIFY HERE AS NEEDED ---^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constant must be the path name for the .AW
- -- files that will be processed by the Wide Character processor to
- -- create the C250001 and C250002 tests. The Wide Character processor
- -- will expect to find the files to process at this location.
-
- Test_Path_Root : constant String :=
- "ACATS4GNATDIR/tests/c2/";
- -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
- -- The following two strings must not be modified unless the .AW file
- -- names have been changed. The Wide Character processor will use
- -- these strings to find the .AW files used in creating the C250001
- -- and C250002 tests.
-
- Wide_Character_Test : constant String := Test_Path_Root & "c250001";
- Upper_Latin_Test : constant String := Test_Path_Root & "c250002";
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following instance of Integer_IO or Modular_IO must be supplied
- -- in order for test CD72A02 to compile correctly.
- -- Depending on the choice of base type used for the type
- -- System.Storage_Elements.Integer_Address; one of the two instances will
- -- be correct. Comment out the incorrect instance.
-
- -- package Address_Value_IO is
- -- new Ada.Text_IO.Integer_IO(System.Storage_Elements.Integer_Address);
-
- package Address_Value_IO is
- new Ada.Text_IO.Modular_IO(System.Storage_Elements.Integer_Address);
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following constants have been defined for use with various delay
- -- statements in the GCC testsuite so that they do not take too long.
-
- One_Second : constant Duration := 0.001;
- One_Long_Second : constant Duration := 0.1;
-
-end ImpDef;
-
-
- --==================================================================--
-
-
-package body ImpDef is
-
- -- NOTE: These are example bodies. It is expected that implementors
- -- will write their own versions of these routines.
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The time required to execute this procedure must be greater than the
- -- time slice unit on implementations which use time slicing. For
- -- implementations which do not use time slicing the body can be null.
-
- Procedure Exceed_Time_Slice is
- T : Integer := 0;
- Loop_Max : constant Integer := 4_000;
- begin
- for I in 1..Loop_Max loop
- T := Report.Ident_Int (1) * Report.Ident_Int (2);
- end loop;
- end Exceed_Time_Slice;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef;
diff --git a/gcc/testsuite/ada/acats/support/impdefd.a b/gcc/testsuite/ada/acats/support/impdefd.a
deleted file mode 100644
index 85f6b79..0000000
--- a/gcc/testsuite/ada/acats/support/impdefd.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- IMPDEFD.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.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex D (Real-Time Systems).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Real-Time Systems Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
--- 27 Aug 98 EDS Removed Processor_Type value Time_Slice
---!
-
-package ImpDef.Annex_D is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This constant is the maximum storage size that can be specified
- -- for a task. A single task that has this size must be able to
- -- run. Ideally, this value is large enough that two tasks of this
- -- size cannot run at the same time. If the value is too small then
- -- test CXDC001 may take longer to run. See the test for further
- -- information.
-
- Maximum_Task_Storage_Size : constant := 16_000_000;
- -- ^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Indicates the type of processor on which the tests are running.
-
- type Processor_Type is (Uni_Processor, Multi_Processor);
-
- Processor : constant Processor_Type := Uni_Processor;
- -- ^^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_D;
diff --git a/gcc/testsuite/ada/acats/support/impdefe.a b/gcc/testsuite/ada/acats/support/impdefe.a
deleted file mode 100644
index ae9f651..0000000
--- a/gcc/testsuite/ada/acats/support/impdefe.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- IMPDEFE.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.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex E (Distributed Systems).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Distributed Systems Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package ImpDef.Annex_E is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The Max_RPC_Call_Time value is the longest time a test needs to wait for
- -- an RPC to complete. Included in this time is the time for the called
- -- procedure to make a task entry call where the task is ready to accept
- -- the call.
-
- Max_RPC_Call_Time : constant Duration := 2.0;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_E;
diff --git a/gcc/testsuite/ada/acats/support/impdefg.a b/gcc/testsuite/ada/acats/support/impdefg.a
deleted file mode 100644
index 6afc7cd..0000000
--- a/gcc/testsuite/ada/acats/support/impdefg.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- IMPDEFG.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.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex G (Numerics).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Numerics Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package ImpDef.Annex_G is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This function must return a "negative zero" value for implementations
- -- for which Float'Signed_Zeros is True.
-
- function Negative_Zero return Float;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_G;
-
-
- --==================================================================--
-
-
-package body ImpDef.Annex_G is
-
- -- NOTE: These are example bodies. It is expected that implementors
- -- will write their own versions of these routines.
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This function must return a negative zero value for implementations
- -- for which Float'Signed_Zeros is True.
- --
- -- The default body simply returns a negated literal 0.0. If the
- -- default body does not return the value corresponding to a negatively
- -- signed zero for the implementation under test, it must be replaced
- -- by one which does. See RM A.5.3(13).
-
- function Negative_Zero return Float is
- begin
- return -0.0; -- Note: If this value is not negative zero for the
- -- implementation, use of this "default" value
- -- could result in false failures in
- -- implementations where Float'Signed_Zeros
- -- is True.
-
- -- ^^^^^^^^^^^^^^^^^^^^ MODIFY THIS BODY AS NEEDED ^^^^^^^^^^^^^^^^^^^^
-
- end Negative_Zero;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_G;
diff --git a/gcc/testsuite/ada/acats/support/impdefh.a b/gcc/testsuite/ada/acats/support/impdefh.a
deleted file mode 100644
index e6cfda7..0000000
--- a/gcc/testsuite/ada/acats/support/impdefh.a
+++ /dev/null
@@ -1,102 +0,0 @@
--- IMPDEFH.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.
---*
---
--- DESCRIPTION:
--- This package is used to define those values that are implementation
--- defined for use with validating the Safety and Security special needs
--- annex, Annex-H.
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Safety and Security Annex.
---
--- CHANGE HISTORY:
--- 13 FEB 96 SAIC Initial version
--- 25 NOV 96 SAIC Revised for release 2.1
---
---!
-
-package Impdef.Annex_H is
-
- type Scalar_To_Normalize is
- ( Id0, Id1, Id2, Id3, Id4, Id5, Id6, Id7, Id8, Id9,
- Id10, Id11, Id12, Id13, Id14, Id15, Id16, Id17, Id18, Id19,
- Id20, Id21, Id22, Id23, Id24, Id25, Id26, Id27, Id28, Id29,
- Id30, Id31, Id32, Id33, Id34, Id35, Id36, Id37, Id38, Id39,
- Id40, Id41, Id42, Id43, Id44, Id45, Id46, Id47, Id48, Id49,
- Id50, Id51, Id52, Id53, Id54, Id55, Id56, Id57, Id58, Id59,
- Id60, Id61, Id62, Id63, Id64, Id65, Id66, Id67, Id68, Id69,
- Id70, Id71, Id72, Id73, Id74, Id75, Id76, Id77, Id78, Id79,
- Id80, Id81, Id82, Id83, Id84, Id85, Id86, Id87, Id88, Id89,
- Id90, Id91, Id92, Id93, Id94, Id95, Id96, Id97, Id98, Id99,
- IdA0, IdA1, IdA2, IdA3, IdA4, IdA5, IdA6, IdA7, IdA8, IdA9,
- IdB0, IdB1, IdB2, IdB3, IdB4, IdB5, IdB6 );
-
- -- NO MODIFICATION NEEDED TO TYPE SCALAR_TO_NORMALIZE. DO NOT MODIFY.
-
- type Small_Number is range 1..100;
-
- -- NO MODIFICATION NEEDED TO TYPE SMALL_NUMBER. DO NOT MODIFY.
-
---=====================================================================
- -- When the value documented in H.1(5) as the predictable initial value
- -- for an uninitialized object of the type Scalar_To_Normalize
- -- (an enumeration type containing 127 identifiers) is to be in the range
- -- Id0..IdB6, set the following constant to True; otherwise leave it set
- -- to False.
-
- Default_For_Scalar_To_Normalize_Is_In_Range : constant Boolean := False;
- -- MODIFY HERE AS NEEDED --- ^^^^^
-
---=====================================================================
- -- If the above constant Default_For_Scalar_To_Normalize_Is_In_Range is
- -- set True, the following constant must be set to the value documented
- -- in H.1(5) as the predictable initial value for the type
- -- Scalar_To_Normalize.
-
- Default_For_Scalar_To_Normalize : constant Scalar_To_Normalize := Id0;
- -- MODIFY HERE AS NEEDED --- ^^^
-
---=====================================================================
- -- When the value documented in H.1(5) as the predictable initial value
- -- for an uninitialized object of the type Small_Number
- -- (an integer type containing 100 values) is to be in the range
- -- 1..100, set the following constant to True; otherwise leave it set
- -- to False.
-
- Default_For_Small_Number_Is_In_Range : constant Boolean := False;
- -- MODIFY HERE AS NEEDED --- ^^^^^
-
---=====================================================================
- -- If the above constant Default_For_Small_Number_Is_In_Range is
- -- set True, the following constant must be set to the value documented
- -- in H.1(5) as the predictable initial value for the type Small_Number.
-
- Default_For_Small_Number : constant Small_Number := 100;
- -- MODIFY HERE AS NEEDED --- ^^^
-
---=====================================================================
-
-end Impdef.Annex_H;
diff --git a/gcc/testsuite/ada/acats/support/lencheck.ada b/gcc/testsuite/ada/acats/support/lencheck.ada
deleted file mode 100644
index f8ed138..0000000
--- a/gcc/testsuite/ada/acats/support/lencheck.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- THIS GENERIC PROCEDURE IS INTENDED FOR USE IN CONJUNCTION WITH THE
--- ACVC CHAPTER 13 C TESTS. IT IS INSTANTIATED FOR A TYPE WHOSE
--- REPRESENTATION IS TO BE CHECKED, AND THEN THE PROCEDURE REP_CHECK
--- IS CALLED WITH TWO ARGUMENTS, THE FIRST IS A VALUE OF THE TYPE TO
--- BE CHECKED, AND THE SECOND IS A STRING DESCRIBING OR NAMING THE
--- TYPE (FOR USE IN A CALL TO FAILED IF THE REPRESENTATION CHECK FAILS)
-
--- THE CHECK IS TO CONVERT THE VALUE TO A PACKED BOOLEAN ARRAY WITH A
--- LENGTH CORRESPONDING TO THE 'SIZE OF THE TYPE, AND THEN CONVERT IT
--- BACK AGAIN AND CHECK THAT THE SAME VALUE IS OBTAINED. THE
--- CONVERSIONS ARE PERFORMED USING APPROPRIATE INSTANTIATIONS OF
--- UNCHECKED_CONVERSION.
-
--- AUTHOR: ROBERT B. K. DEWAR, UNCOPYRIGHTED, PUBLIC DOMAIN USE
--- AUTHORIZED
--- DHH 03/27/89 CHANGED REP_CHECK TO LENGTH_CHECK BY ADDING A THIRD
--- PARAMETER TO GIVE LENGTH EXPECTED AND BY DOING A BIT TO
--- BIT COPY OF THE UNCHECKED CONVERSION BOOLEAN ARRAY SO
--- A STRAIGHT COMPARE OF THE TWO VALUES CAN BE DONE.
-
-GENERIC
-
- TYPE TEST_TYPE IS PRIVATE;
-
-PROCEDURE LENGTH_CHECK (TEST_VALUE : TEST_TYPE;
- EXPECTED_LENGTH : INTEGER;
- TYPE_ID : STRING);
-
-WITH UNCHECKED_CONVERSION;
-WITH REPORT; USE REPORT;
-
-PROCEDURE LENGTH_CHECK (TEST_VALUE : TEST_TYPE;
- EXPECTED_LENGTH : INTEGER;
- TYPE_ID : STRING) IS
- LEN : CONSTANT INTEGER := EXPECTED_LENGTH;
- TYPE BIT_ARRAY_TYPE IS ARRAY (1 .. LEN) OF BOOLEAN;
- PRAGMA PACK (BIT_ARRAY_TYPE);
- TYPE NEW_BIT_ARRAY_TYPE IS ARRAY (1 .. 3) OF BIT_ARRAY_TYPE;
-
- FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (TEST_TYPE,
- BIT_ARRAY_TYPE);
- FUNCTION FROM_BITS IS NEW UNCHECKED_CONVERSION (BIT_ARRAY_TYPE,
- TEST_TYPE);
-
- BIT_ARRAY : BIT_ARRAY_TYPE := (OTHERS => FALSE);
-
- BIT_ARRAY_NEW : NEW_BIT_ARRAY_TYPE := (OTHERS => (OTHERS => FALSE));
-BEGIN
-
- BIT_ARRAY := TO_BITS (TEST_VALUE);
-
- FOR I IN 1 .. LEN LOOP
- BIT_ARRAY_NEW(IDENT_INT(1)) (IDENT_INT(I)) := BIT_ARRAY(I);
- END LOOP;
-
- IF TEST_VALUE /= FROM_BITS (BIT_ARRAY_NEW(1)) THEN
- FAILED ("CHECK ON REPRESENTATION FOR " & TYPE_ID & " FAILED.");
- END IF;
-
-END LENGTH_CHECK;
diff --git a/gcc/testsuite/ada/acats/support/macro.dfs b/gcc/testsuite/ada/acats/support/macro.dfs
deleted file mode 100644
index c0acaf1..0000000
--- a/gcc/testsuite/ada/acats/support/macro.dfs
+++ /dev/null
@@ -1,300 +0,0 @@
--- MACRO.DFS
--- THIS FILE CONTAINS THE MACRO DEFINITIONS USED IN THE ACVC TESTS.
--- THESE DEFINITIONS ARE USED BY THE ACVC TEST PRE-PROCESSOR,
--- MACROSUB. MACROSUB WILL CALCULATE VALUES FOR THOSE MACRO SYMBOLS
--- WHOSE DEFINITIONS DEPEND ON THE VALUE OF MAX_IN_LEN (NAMELY, THE
--- VALUES OF THE MACRO SYMBOLS BIG_ID1, BIG_ID2, BIG_ID3, BIG_ID4,
--- BIG_STRING1, BIG_STRING2, MAX_STRING_LITERAL, BIG_INT_LIT, BIG_REAL_LIT,
--- AND BLANKS). THEREFORE, ANY VALUES GIVEN IN THIS FILE FOR THOSE
--- MACRO SYMBOLS WILL BE IGNORED BY MACROSUB.
-
--- NOTE: AS REQUIRED BY THE MACROSUB PROGRAM, THE FIRST MACRO DEFINED
--- IN THIS FILE IS $MAX_IN_LEN. THE NEXT 5 MACRO DEFINITIONS
--- ARE FOR THOSE MACRO SYMBOLS THAT DEPEND ON THE VALUE OF
--- MAX_IN_LEN. THESE ARE IN ALPHABETIC ORDER. FOLLOWING THESE
--- ARE 36 MORE DEFINITIONS, ALSO IN ALPHABETIC ORDER.
-
--- EACH DEFINITION IS ACCORDING TO THE FOLLOWING FORMAT:
-
--- A. A NUMBER OF LINES PRECEDED BY THE ADA COMMENT DELIMITER, --.
--- THE FIRST OF THESE LINES CONTAINS THE MACRO SYMBOL AS IT APPEARS
--- IN THE TEST FILES (WITH THE DOLLAR SIGN). THE NEXT FEW "COMMENT"
--- LINES CONTAIN A DESCRIPTION OF THE VALUE TO BE SUBSTITUTED.
--- THE REMAINING "COMMENT" LINES, THE FIRST OF WHICH BEGINS WITH THE
--- WORDS "USED IN: " (NO QUOTES), CONTAIN A LIST OF THE TEST FILES
--- (WITHOUT THE .TST EXTENSION) IN WHICH THE MACRO SYMBOL APPEARS.
--- EACH TEST FILE NAME IS PRECEDED BY ONE OR MORE BLANKS.
--- B. A LINE, WITHOUT THE COMMENT DELIMITER, CONSISTING OF THE
--- IDENTIFIER (WITHOUT THE DOLLAR SIGN) OF THE MACRO SYMBOL,
--- FOLLOWED BY A SPACE OR TAB, FOLLOWED BY THE VALUE TO BE
--- SUBSTITUTED. IN THE DISTRIBUTION FILE, A SAMPLE VALUE IS
--- PROVIDED; THIS VALUE MUST BE REPLACED BY A VALUE APPROPRIATE TO
--- THE IMPLEMENTATION.
-
--- DEFINITIONS ARE SEPARATED BY ONE OR MORE EMPTY LINES.
--- THE LIST OF DEFINITIONS BEGINS AFTER THE FOLLOWING EMPTY LINE.
-
--- $MAX_IN_LEN
--- AN INTEGER LITERAL GIVING THE MAXIMUM LENGTH PERMITTED BY THE
--- COMPILER FOR A LINE OF ADA SOURCE CODE (NOT INCLUDING AN END-OF-LINE
--- CHARACTER).
--- USED IN: A26007A
-MAX_IN_LEN 200
-
--- $MAX_STRING_LITERAL
--- A STRING LITERAL CONSISTING OF $MAX_IN_LEN CHARACTERS (INCLUDING THE
--- QUOTE CHARACTERS).
--- USED IN: A26007A
-MAX_STRING_LITERAL "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
-
--- $BIG_ID1
--- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN.
--- THE MACROSUB PROGRAM WILL SUPPLY AN IDENTIFIER IN WHICH THE
--- LAST CHARACTER IS '1' AND ALL OTHERS ARE 'A'.
--- USED IN: C23003A C23003B C23003G C23003I
--- C35502D C35502F
-BIG_ID1 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA1
-
--- $BIG_ID2
--- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN,
--- DIFFERING FROM $BIG_ID1 ONLY IN THE LAST CHARACTER. THE MACROSUB
--- PROGRAM WILL USE '2' AS THE LAST CHARACTER.
--- USED IN: C23003A C23003B B23003F C23003G C23003I
-BIG_ID2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2
-
--- $BIG_ID3
--- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN.
--- MACROSUB WILL USE '3' AS THE "MIDDLE" CHARACTER; ALL OTHERS ARE 'A'.
--- USED IN: C23003A C23003B C23003G C23003I
-BIG_ID3 AAAAAAAAAAAAAAAAAAAAAAAAAAAAA3AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-
--- $BIG_ID4
--- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN,
--- DIFFERING FROM $BIG_ID3 ONLY IN THE MIDDLE CHARACTER. MACROSUB
--- WILL USE '4' AS THE MIDDLE CHARACTER.
--- USED IN: C23003A C23003B C23003G C23003I
-BIG_ID4 AAAAAAAAAAAAAAAAAAAAAAAAAAAAA4AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
-
--- $BIG_STRING1
--- A STRING LITERAL (WITH QUOTES) WHOSE CATENATION WITH $BIG_STRING2
--- ($BIG_STRING1 & $BIG_STRING2) PRODUCES THE IMAGE OF $BIG_ID1.
--- USED IN: C35502D C35502F
-BIG_STRING1 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
-
--- $BIG_STRING2
--- A STRING LITERAL (WITH QUOTES) WHOSE CATENATION WITH $BIG_STRING1
--- ($BIG_STRING1 & $BIG_STRING2) PRODUCES THE IMAGE OF $BIG_ID1.
--- USED IN: C35502D C35502F
-BIG_STRING2 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAA1"
-
--- $BLANKS
--- A SEQUENCE OF ($MAX_IN_LEN - 20) BLANKS.
--- USED IN: B22001A B22001B B22001C B22001D B22001E B22001F
--- B22001G B22001I B22001J B22001K B22001L B22001M
--- B22001N
--- < LIMITS OF SAMPLE SHOWN BY ANGLE BRACKETS >
-BLANKS
-
--- $ACC_SIZE
--- AN INTEGER LITERAL WHOSE VALUE IS THE MINIMUM NUMBER OF BITS
--- SUFFICIENT TO HOLD ANY VALUE OF AN ACCESS TYPE.
--- USED IN: CD2A83C BD2A02A
-ACC_SIZE ACATS4GNATBIT
-
--- $ALIGNMENT
--- A VALUE THAT IS LEGITIMATE FOR USE IN A RECORD ALIGNMENT CLAUSE.
--- USED IN: CD4041A BD4006A
-ALIGNMENT 4
-
--- $COUNT_LAST
--- AN INTEGER LITERAL WHOSE VALUE IS TEXT_IO.COUNT'LAST.
--- USED IN: CE3002B
-COUNT_LAST 2147483647
-
--- $ENTRY_ADDRESS
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY
--- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION.
--- USED IN: SPPRT13SP
-ENTRY_ADDRESS ENTRY_ADDR
-
--- $ENTRY_ADDRESS1
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY
--- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION. THE ADDRESS
--- MUST BE DISTINCT FROM THAT USED IN $ENTRY_ADDRESS.
--- USED IN: SPPRT13SP
-ENTRY_ADDRESS1 ENTRY_ADDR1
-
--- $ENTRY_ADDRESS2
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY
--- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION. THE ADDRESS
--- MUST BE DISTINCT FROM THOSE USED IN $ENTRY_ADDRESS
--- AND $ENTRY_ADDRESS1.
--- USED IN: SPPRT13SP
-ENTRY_ADDRESS2 ENTRY_ADDR2
-
--- $FIELD_LAST
--- AN INTEGER LITERAL WHOSE VALUE IS TEXT_IO.FIELD'LAST.
--- USED IN: CE3002C
-FIELD_LAST 255
-
--- $FORM_STRING
--- A STRING LITERAL SPECIFYING THAT THE EXTERNAL FILE MEETS BOTH
--- CONDITIONS: (1) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT
--- AN APPROPRIATE LINE-LENGTH FOR THE FILE, (2) THERE IS A VALUE
--- OF TYPE TEXT_IO.COUNT THAT IS NOT AN APPROPRIATE PAGE-LENGTH
--- FOR THE FILE.
--- IF IT IS NOT POSSIBLE TO SATISFY BOTH CONDITIONS, THEN SUBSTITUTE
--- A STRING LITERAL SPECIFYING THAT THE EXTERNAL FILE SATISFIES ONE
--- OF THE CONDITIONS. IF IT IS NOT POSSIBLE TO SATISFY EITHER CONDITION,
--- THEN SUBSTITUTE THE NULL STRING ("").
--- USED IN: CE3304A
-FORM_STRING ""
-
--- $FORM_STRING2
--- A STRING LITERAL SPECIFYING THAT THE CAPACITY OF THE FILE IS
--- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION
--- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL
--- "CANNOT_RESTRICT_FILE_CAPACITY".
--- USED IN: CE2203A CE2403A
-FORM_STRING2 "CANNOT_RESTRICT_FILE_CAPACITY"
-
--- $GREATER_THAN_DURATION
--- A REAL LITERAL WHOSE VALUE (NOT SUBJECT TO ROUND-OFF ERROR
--- IF POSSIBLE) LIES BETWEEN DURATION'BASE'LAST AND DURATION'LAST. IF
--- NO SUCH VALUES EXIST, USE A VALUE IN DURATION'RANGE.
--- USED IN: C96005B
-GREATER_THAN_DURATION 86_000.0
-
-
-
-
--- $ILLEGAL_EXTERNAL_FILE_NAME1
--- AN ILLEGAL EXTERNAL FILE NAME (E.G., TOO LONG, CONTAINING INVALID
--- CHARACTERS, CONTAINING WILD-CARD CHARACTERS, OR SPECIFYING A
--- NONEXISTENT DIRECTORY).
--- USED IN: CE2102C CE2102H CE2103A CE2103B CE3102B CE3107A
-ILLEGAL_EXTERNAL_FILE_NAME1 /NODIRECTORY/FILENAME
-
--- $ILLEGAL_EXTERNAL_FILE_NAME2
--- AN ILLEGAL EXTERNAL FILE NAME, DIFFERENT FROM $ILLEGAL_EXTERNAL_FILE_NAME1.
--- USED IN: CE2102C CE2102H CE2103A CE2103B CE3102B
-ILLEGAL_EXTERNAL_FILE_NAME2 /@@/@@/@@\@@\@@\@@
-
--- $INAPPROPRIATE_LINE_LENGTH
--- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE LINE-LENGTH
--- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1.
--- USED IN: CE3304A
-INAPPROPRIATE_LINE_LENGTH -1
-
--- $INAPPROPRIATE_PAGE_LENGTH
--- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE PAGE-LENGTH
--- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1.
--- USED IN: CE3304A
-INAPPROPRIATE_PAGE_LENGTH -1
-
--- $INTEGER_FIRST
--- AN INTEGER LITERAL, WITH SIGN, WHOSE VALUE IS INTEGER'FIRST.
--- THE LITERAL MUST NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING
--- BLANKS.
--- USED IN: C35503F B54B01B
-INTEGER_FIRST -2147483648
-
--- $INTEGER_LAST
--- AN INTEGER LITERAL WHOSE VALUE IS INTEGER'LAST. THE LITERAL MUST
--- NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING BLANKS.
--- USED IN: C35503F B54B01B
-INTEGER_LAST 2147483647
-
-
--- $LESS_THAN_DURATION
--- A REAL LITERAL (WITH SIGN) WHOSE VALUE (NOT SUBJECT TO
--- ROUND-OFF ERROR IF POSSIBLE) LIES BETWEEN DURATION'BASE'FIRST AND
--- DURATION'FIRST. IF NO SUCH VALUES EXIST, USE A VALUE IN
--- DURATION'RANGE.
--- USED IN: C96005B
-LESS_THAN_DURATION -86_400.0
-
-
--- $MACHINE_CODE_STATEMENT
--- A VALID MACHINE CODE STATEMENT AS SPECIFIED IN THE PACKAGE
--- MACHINE_CODE. IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE
--- CODE THEN USE THE ADA NULL STATEMENT (I.E. NULL; ).
--- USED IN: AD8011A BD8001A BD8002A BD8004A BD8004B
-MACHINE_CODE_STATEMENT Asm_Insn'(Asm ("ACATS4GNATINSN"));
-
--- $MAX_INT
--- AN INTEGER LITERAL WHOSE VALUE IS SYSTEM.MAX_INT.
--- THE LITERAL MUST NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING
--- BLANKS.
--- USED IN: C35503D C35503F C4A007A
-MAX_INT ACATS4GNATMAXINT
-
-
--- $MIN_INT
--- AN INTEGER LITERAL, WITH SIGN, WHOSE VALUE IS SYSTEM.MIN_INT.
--- THE LITERAL MUST NOT CONTAIN UNDERSCORES OR LEADING OR TRAILING
--- BLANKS.
--- USED IN: C35503D C35503F
-MIN_INT ACATS4GNATMININT
-
--- $NAME
--- THE NAME OF A PREDEFINED INTEGER TYPE OTHER THAN INTEGER,
--- SHORT_INTEGER, OR LONG_INTEGER.
--- (IMPLEMENTATIONS WHICH HAVE NO SUCH TYPES SHOULD USE AN UNDEFINED
--- IDENTIFIER SUCH AS NO_SUCH_TYPE_AVAILABLE.)
--- USED IN: C45231D CD7101G
-NAME LONG_LONG_INTEGER
-
--- $OPTIONAL_DISC
--- A DISCRIMINANT USED AS THE DISCRIMINANT PART OF $RECORD_NAME.
--- IF MACHINE CODE INSERTIONS ARE NOT SUPPORTED THEN SUBSTITUTE
--- NO_SUCH_MACHINE_CODE_DISC.
--- USED IN: BD8002A
-OPTIONAL_DISC
-
--- $RECORD_DEFINITION
--- THE RECORD TYPE DEFINITION (WITH FINAL SEMICOLON) FOR THE TYPE THAT
--- WAS USED IN THE MACRO $RECORD_NAME, AS DECLARED IN PACKAGE
--- MACHINE_CODE. IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE CODE,
--- THEN USE A NULL RECORD DEFINITION
--- USED IN: BD8002A
-RECORD_DEFINITION RECORD ASM : STRING (1..4); END RECORD;
-
--- $RECORD_NAME
--- A VALID RECORD TYPE NAME THAT IS DEFINED IN PACKAGE MACHINE_CODE.
--- IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE CODE THEN
--- USE THE NAME "NO_SUCH_MACHINE_CODE_TYPE"
--- USED IN: BD8002A
-RECORD_NAME Asm_Insn
-
--- $TASK_SIZE
--- AN INTEGER LITERAL WHOSE VALUE IS THE NUMBER OF BITS REQUIRED TO
--- HOLD A TASK OBJECT.
--- USED IN: CD2A91C
-TASK_SIZE ACATS4GNATBIT
-
--- $TASK_STORAGE_SIZE
--- THE NUMBER OF STORAGE UNITS REQUIRED FOR A TASK ACTIVATION.
--- USED IN: BD2C01D BD2C02A BD2C03A C87B62D CD1009K CD1009T
--- CD1009U CD1C03E CD1C06A CD2C11A CC1225A CD2C11D
-TASK_STORAGE_SIZE 32768
-
--- $VARIABLE_ADDRESS
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS
--- IMPLEMENTATION.
--- USED IN: SPPRT13SP
-VARIABLE_ADDRESS VAR_ADDR
-
--- $VARIABLE_ADDRESS1
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS
--- IMPLEMENTATION. THE ADDRESS MUST BE DISTINCT FROM THAT USED IN
--- THE MACRO $VARIABLE_ADDRESS.
--- USED IN: SPPRT13SP
-VARIABLE_ADDRESS1 VAR_ADDR1
-
--- $VARIABLE_ADDRESS2
--- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS
--- IMPLEMENTATION. THE ADDRESS MUST BE DISTINCT FROM THOSE USED IN
--- THE MACROS $VARIABLE_ADDRESS AND $VARIABLE_ADDRESS1.
--- USED IN: SPPRT13SP
-VARIABLE_ADDRESS2 VAR_ADDR2
diff --git a/gcc/testsuite/ada/acats/support/macrodef.adb b/gcc/testsuite/ada/acats/support/macrodef.adb
deleted file mode 100644
index 8a9087d..0000000
--- a/gcc/testsuite/ada/acats/support/macrodef.adb
+++ /dev/null
@@ -1,11 +0,0 @@
-with Ada.Text_IO;
-with System;
-procedure Macrodef is
-begin
- Ada.Text_IO.Put_Line ("Integer'First = " & Integer'Image (Integer'First));
- Ada.Text_IO.Put_Line ("Integer'Last = " & Integer'Image (Integer'Last));
- Ada.Text_IO.Put_Line ("System.Min_Int = " & Long_Long_Integer'Image (System.Min_Int));
- Ada.Text_IO.Put_Line ("System.Max_Int = " & Long_Long_Integer'Image (System.Max_Int));
- Ada.Text_IO.Put_Line ("Ada.Text_IO.Count'Last = " & Ada.Text_IO.Count'Image (Ada.Text_IO.Count'Last));
- Ada.Text_IO.Put_Line ("Ada.Text_IO.Field'Last = " & Ada.Text_IO.Field'Image (Ada.Text_IO.Field'Last));
-end Macrodef;
diff --git a/gcc/testsuite/ada/acats/support/macrosub.ada b/gcc/testsuite/ada/acats/support/macrosub.ada
deleted file mode 100644
index 81204fb..0000000
--- a/gcc/testsuite/ada/acats/support/macrosub.ada
+++ /dev/null
@@ -1,548 +0,0 @@
--- MACROSUB.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.
---*
---
------------------------------------------------------------------------
--- --
--- THIS PROGRAM IS CALLED MACROSUB. IT IS USED TO REPLACE THE --
--- MACROS IN THE ACVC TEST SUITE WITH THEIR PROPER VALUES. THE --
--- STEPS LISTED BELOW SHOULD BE FOLLOWED TO ENSURE PROPER RUNNING --
--- OF THE MACROSUB PROGRAM: --
--- --
--- 1) Edit the file MACRO.DFS (included with the testtape) --
--- and insert your macro values. The macros which use --
--- the value of MAX_IN_LEN are calculated automatically --
--- and do not need to be entered. --
--- --
--- 2) Create a file called TSTTESTS.DAT which includes all --
--- of the .TST test file names and their directory --
--- specifications, if necessary. If a different name --
--- other than TSTTESTS.DAT is used, this name must be --
--- substituted in the MACROSUB.ADA file. --
--- --
--- 3) Compile and link MACROSUB. --
--- --
--- 4) Run the MACROSUB program. --
--- --
--- WHEN THE PROGRAM FINISHES RUNNING, THE MACROS WILL HAVE BEEN --
--- REPLACED WITH THE APPROPRIATE VALUES FROM MACRO.DFS. --
--- --
--- --
--- --
--- HISTORY: --
--- BCB 04/17/90 CHANGED MODE OF CALC_MAX_VALS TO OUT. CHANGED --
--- VALUE OF MAX_VAL_LENGTH FROM 512 TO 400. ADDED --
--- EXCEPTION HANDLER SO PROGRAM DOES NOT CRASH IF --
--- AN EXCEPTION IS RAISED. ADDED MESSAGES TO --
--- REPORT PROGRESS OF PROGRAM. CHANGED PROGRAM SO --
--- IT DOES NOT ABORT IF A FILE CANNOT BE FOUND. --
--- MODIFIED PROGRAM SO IT ACCEPTS FILENAMES WITH --
--- VERSION NUMBERS. --
------------------------------------------------------------------------
-
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PACKAGE DEFS IS
-
------------------------------------------------------------------------
--- --
--- THIS PACKAGE IS USED BY MACROSUB.ADA, PARSEMAC.ADA, AND BY --
--- GETSUBS.ADA. THE PACKAGE CONTAINS VARIABLE DECLARATIONS WHICH --
--- NEED TO BE KNOWN BY ALL OF THE PROCEDURES AND PACKAGES WHICH --
--- MAKE UP THE PROGRAM. --
--- --
------------------------------------------------------------------------
-
- MAX_VAL_LENGTH : CONSTANT INTEGER := 400;
-
- SUBTYPE VAL_STRING IS STRING (1..MAX_VAL_LENGTH);
-
- TYPE REC_TYPE IS RECORD
- MACRO_NAME : STRING (1..80);
- NAME_LENGTH, VALUE_LENGTH : INTEGER;
- MACRO_VALUE : VAL_STRING;
- END RECORD;
-
- TYPE TABLE_TYPE IS ARRAY (1..100) OF REC_TYPE;
-
- SYMBOL_TABLE : TABLE_TYPE;
-
- NUM_MACROS : INTEGER;
-
-END DEFS;
-
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH DEFS;
-USE DEFS;
-
-PACKAGE GETSUBS IS
-
-------------------------------------------------------------------------
--- --
--- THIS PACKAGE IS USED BY MACROSUB.ADA FOR READING FROM MACRO.DFS --
--- THE VALUES FOR THE MACRO SUBSTITUTIONS FOR A TEST TAPE. --
--- --
-------------------------------------------------------------------------
-
- MAC_FILE, LINE_LEN : EXCEPTION;
-
- PROCEDURE CALC_MAX_VALS(INDEX, LENGTH, MAX_IN_LEN : IN INTEGER;
- CALCULATED : OUT BOOLEAN);
-
- PROCEDURE FILL_TABLE;
-
-END GETSUBS;
-
-PACKAGE BODY GETSUBS IS
-
------------------------------------------------------------------------
--- --
--- PROCEDURE CALC_MAX_VALS CALCULATES THE VALUE FOR THE MACRO --
--- READ FROM MACRO.DFS IF ITS LENGTH IS EQUAL OR NEARLY EQUAL TO --
--- MAX_IN_LEN. IT THEN RETURNS A FLAG SET TO TRUE IF A VALUE WAS --
--- CALCULATED, FALSE IF ONE WAS NOT. --
--- --
------------------------------------------------------------------------
-
- PROCEDURE CALC_MAX_VALS(INDEX, LENGTH, MAX_IN_LEN : IN INTEGER;
- CALCULATED : OUT BOOLEAN) IS
-
- BEGIN
-
- IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = "BIG_ID1"
- THEN SYMBOL_TABLE (INDEX).MACRO_VALUE (1..MAX_IN_LEN) :=
- (1..(MAX_IN_LEN-1) => 'A') & "1";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_ID2" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN) := (1..(MAX_IN_LEN-1) => 'A') & "2";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_ID3" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN) := (1..(MAX_IN_LEN + 1)/2 => 'A') & "3" &
- ((MAX_IN_LEN + 1)/2 + 2..MAX_IN_LEN => 'A');
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_ID4" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN) := (1..(MAX_IN_LEN + 1)/2 => 'A') & "4" &
- ((MAX_IN_LEN + 1)/2 + 2..MAX_IN_LEN => 'A');
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_STRING1" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..(MAX_IN_LEN + 1)/2 + 2) :=
- '"' & (1..(MAX_IN_LEN + 1)/2 => 'A') & '"';
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_STRING2" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN - (MAX_IN_LEN + 1)/2 + 2) :=
- '"' & (2..MAX_IN_LEN - (MAX_IN_LEN + 1)/2 => 'A') &
- '1' & '"';
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "MAX_STRING_LITERAL" THEN SYMBOL_TABLE (INDEX).
- MACRO_VALUE (1..MAX_IN_LEN) := '"' &
- (1..MAX_IN_LEN-2 => 'A') & '"';
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_INT_LIT" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN) := (1..MAX_IN_LEN-3 => '0') & "298";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_REAL_LIT" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN) := (1..MAX_IN_LEN-5 => '0') & "690.0";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "MAX_LEN_INT_BASED_LITERAL" THEN
- SYMBOL_TABLE (INDEX).
- MACRO_VALUE (1..MAX_IN_LEN) := "2:" &
- (1..MAX_IN_LEN - 5 => '0') & "11:";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "MAX_LEN_REAL_BASED_LITERAL" THEN SYMBOL_TABLE (INDEX).
- MACRO_VALUE (1..MAX_IN_LEN) := "16:" &
- (1..MAX_IN_LEN - 7 => '0') & "F.E:";
- CALCULATED := TRUE;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BLANKS" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..MAX_IN_LEN-20) := (1..MAX_IN_LEN-20 => ' ');
- CALCULATED := TRUE;
- ELSE
- CALCULATED := FALSE;
- END IF;
- IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BLANKS" THEN SYMBOL_TABLE (INDEX).VALUE_LENGTH :=
- MAX_IN_LEN - 20;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_STRING1" THEN
- SYMBOL_TABLE (INDEX).VALUE_LENGTH :=
- (MAX_IN_LEN + 1)/2 + 2;
- ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) =
- "BIG_STRING2" THEN
- SYMBOL_TABLE (INDEX).VALUE_LENGTH :=
- MAX_IN_LEN - (MAX_IN_LEN + 1)/2 + 2;
- ELSE SYMBOL_TABLE (INDEX).VALUE_LENGTH := MAX_IN_LEN;
- END IF;
- END CALC_MAX_VALS;
-
------------------------------------------------------------------------
--- --
--- PROCEDURE FILL_TABLE READS THE MACRO NAMES AND MACRO VALUES IN --
--- FROM MACRO.DFS AND STORES THEM IN THE SYMBOL TABLE. PROCEDURE --
--- CALC_MAX_VALS IS CALLED TO DETERMINE IF THE MACRO VALUE SHOULD --
--- BE CALCULATED OR READ FROM MACRO.DFS. --
--- --
------------------------------------------------------------------------
-
- PROCEDURE FILL_TABLE IS
-
- INFILE1 : FILE_TYPE;
- MACRO_FILE : CONSTANT STRING := "MACRO.DFS";
- A_LINE : VAL_STRING;
- I, INDEX, LENGTH, HOLD, A_LENGTH, NAME : INTEGER;
- MAX_IN_LEN : INTEGER := 1;
- CALCULATED : BOOLEAN;
-
- BEGIN
- INDEX := 1;
- BEGIN
- OPEN (INFILE1, IN_FILE, MACRO_FILE);
- EXCEPTION
- WHEN NAME_ERROR =>
- PUT_LINE ("** ERROR: MACRO FILE " & MACRO_FILE &
- " NOT FOUND.");
- RAISE MAC_FILE;
- END;
- WHILE NOT END_OF_FILE (INFILE1) LOOP
- GET_LINE (INFILE1, A_LINE, A_LENGTH);
- IF A_LENGTH > 0 AND A_LINE (1..2) /= "--" AND
- A_LINE (1) /= ' ' AND A_LINE (1) /= ASCII.HT THEN
- I := 1;
- WHILE I <= A_LENGTH AND THEN
- ((A_LINE (I) IN 'A'..'Z') OR
- (A_LINE (I) IN '0'..'9') OR
- A_LINE (I) = '_') LOOP
- I := I + 1;
- END LOOP;
- I := I - 1;
- LENGTH := I;
- BEGIN
- SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) :=
- A_LINE (1..I);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- PUT_LINE ("** ERROR: LINE LENGTH IS " &
- "GREATER THAN MAX_VAL_LENGTH.");
- RAISE LINE_LEN;
- END;
- SYMBOL_TABLE (INDEX).NAME_LENGTH := I;
- CALC_MAX_VALS (INDEX, LENGTH, MAX_IN_LEN,
- CALCULATED);
- IF NOT CALCULATED THEN
- I := I + 1;
- WHILE A_LINE (I) = ' ' OR A_LINE (I) =
- ASCII.HT LOOP
- I := I + 1;
- IF SYMBOL_TABLE (INDEX).MACRO_NAME
- (1..LENGTH) = "BLANKS" THEN
- EXIT;
- END IF;
- END LOOP;
- HOLD := I;
-
--- MACRO VALUE BEGINS AT POSITION HOLD.
--- NOW FIND WHERE IT ENDS BY STARTING AT THE END OF THE INPUT
--- LINE AND SEARCHING BACKWARD FOR A NON-BLANK.
-
- I := A_LENGTH;
- WHILE I > HOLD AND THEN (A_LINE (I) = ' '
- OR A_LINE(I) = ASCII.HT) LOOP
- I := I - 1;
- END LOOP;
- LENGTH := I - HOLD + 1;
- SYMBOL_TABLE (INDEX).MACRO_VALUE (1..LENGTH)
- := A_LINE (HOLD..I);
- SYMBOL_TABLE (INDEX).VALUE_LENGTH := LENGTH;
- NAME := SYMBOL_TABLE (INDEX).NAME_LENGTH;
- IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..NAME) =
- "MAX_IN_LEN" THEN MAX_IN_LEN :=
- INTEGER'VALUE (SYMBOL_TABLE (INDEX).
- MACRO_VALUE (1..LENGTH));
- END IF;
- END IF;
- INDEX := INDEX + 1;
- END IF;
- END LOOP;
- NUM_MACROS := INDEX - 1;
- CLOSE (INFILE1);
- END FILL_TABLE;
-
-BEGIN
- NULL;
-END GETSUBS;
-
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH DEFS;
-USE DEFS;
-
-PACKAGE PARSEMAC IS
-
-------------------------------------------------------------------------
--- --
--- THIS PACKAGE IS USED BY MACROSUB.ADA FOR FINDING A MACRO TO --
--- SUBSTITUTE. MACRO SUBSTITUTIONS ARE MADE IN *.TST TESTS IN THE --
--- ACVC TEST SUITE. THIS PROCEDURE IS CURRENTLY SET UP FOR ACVC --
--- VERSION 1.10. --
--- --
-------------------------------------------------------------------------
-
- PROCEDURE LOOK_FOR_MACRO (A_LINE : IN STRING;
- A_LENGTH : IN INTEGER;
- PTR : IN OUT INTEGER;
- MACRO : OUT STRING;
- MACRO_LEN : IN OUT INTEGER);
-
-
- PROCEDURE WHICH_MACRO (MACRO : IN STRING;
- MACRO_LEN : IN INTEGER;
- TEMP_MACRO : OUT STRING;
- TEMP_MACRO_LEN : IN OUT INTEGER);
-
-END PARSEMAC;
-
-PACKAGE BODY PARSEMAC IS
-
------------------------------------------------------------------------
--- PROCEDURE LOOK_FOR_MACRO LOOKS FOR A DOLLAR SIGN WHICH SIGNALS --
--- THE START OF A MACRO IN THE *.TST FILES. IT THEN COUNTS --
--- CHARACTERS UNTIL A <LETTER>, <NUMBER>, OR <_> IS NOT FOUND. --
--- RETURN PARAMETERS SEND THE BEGINNING POINTER AND LENGTH OF THE --
--- MACRO BACK TO THE MAIN PROGRAM. ALSO RETURNED IS THE MACRO --
--- STRING. --
------------------------------------------------------------------------
-
- PROCEDURE LOOK_FOR_MACRO (A_LINE : IN STRING;
- A_LENGTH : IN INTEGER;
- PTR : IN OUT INTEGER;
- MACRO : OUT STRING;
- MACRO_LEN : IN OUT INTEGER) IS
-
- II, J : INTEGER := INTEGER'LAST;
-
- BEGIN
- FOR I IN PTR..A_LENGTH LOOP
- IF A_LINE (I) = '$' THEN
- II := I+1;
- EXIT;
- END IF;
- II := I;
- END LOOP;
- IF II < A_LENGTH THEN -- DOLLAR SIGN IS FOUND.
- J := II;
- WHILE J <= A_LENGTH AND THEN ((A_LINE(J) IN 'A'..'Z') OR
- (A_LINE(J) IN '0'..'9') OR
- A_LINE(J) = '_') LOOP
- J := J+1;
- END LOOP;
- J := J-1;
- MACRO_LEN := (J-II+1);
- MACRO (1..MACRO_LEN) := A_LINE (II .. J);
- -- DON'T INCLUDE THE DOLLAR SIGN
- PTR := J+1;
- ELSE
- MACRO_LEN := 0;
- END IF;
- RETURN;
- END LOOK_FOR_MACRO;
-
-------------------------------------------------------------------------
--- PROCEDURE WHICH_MACRO COMPARES THE INPUT MACRO STRING TO A --
--- VALUE READ FROM MACRO.DFS AND STORED IN THE SYMBOL TABLE AND --
--- RETURNS THE MACRO SUBSTITUTION STRING BACK TO THE MAIN PROGRAM. --
-------------------------------------------------------------------------
-
- PROCEDURE WHICH_MACRO (MACRO : IN STRING;
- MACRO_LEN : IN INTEGER;
- TEMP_MACRO : OUT STRING;
- TEMP_MACRO_LEN : IN OUT INTEGER) IS
-
- BEGIN
- FOR INDEX IN 1 .. NUM_MACROS LOOP
- IF MACRO (1..MACRO_LEN) =
- SYMBOL_TABLE (INDEX).MACRO_NAME
- (1..SYMBOL_TABLE (INDEX).NAME_LENGTH) THEN
- TEMP_MACRO_LEN :=
- SYMBOL_TABLE (INDEX).VALUE_LENGTH;
- TEMP_MACRO (1..TEMP_MACRO_LEN) :=
- SYMBOL_TABLE (INDEX).MACRO_VALUE
- (1..TEMP_MACRO_LEN);
- EXIT;
- END IF;
- IF INDEX = NUM_MACROS THEN
- PUT_LINE ("** ERROR: MACRO " & MACRO (1..MACRO_LEN)
- & " NOT FOUND. UPDATE PROGRAM.");
- TEMP_MACRO_LEN := MACRO_LEN;
- TEMP_MACRO (1..TEMP_MACRO_LEN) :=
- MACRO (1..MACRO_LEN);
- END IF;
- END LOOP;
-
- END WHICH_MACRO;
-
-BEGIN
- NULL;
-END PARSEMAC;
-
-WITH TEXT_IO, GETSUBS, PARSEMAC, DEFS;
-USE TEXT_IO, GETSUBS, PARSEMAC, DEFS;
-
-PROCEDURE MACROSUB IS
-
-------------------------------------------------------------------------
--- --
--- MACROSUB IS THE MAIN PROGRAM THAT CALLS PROCEDURES IN TWO --
--- PACKAGES, GETSUBS AND PARSEMAC. THIS PROGRAM IS USED TO MAKE --
--- THE MACRO SUBSTITUTIONS FOR TST TESTS IN THE ACVC TEST SUITE. --
--- --
-------------------------------------------------------------------------
-
- INFILE1, INFILE2, OUTFILE1 : FILE_TYPE;
- FNAME, MACRO : VAL_STRING;
- LENGTH, A_LENGTH, PTR,
- TEMP_MACRO_LENGTH, MACRO_LEN, FILE_COUNT : INTEGER := 0;
- A_LINE, TEMP_MACRO, TEMP_LINE, NEW_LINE : VAL_STRING;
- END_OF_LINE_SEARCH, FLAG : BOOLEAN := FALSE;
- TESTS_FILE : CONSTANT STRING := "TSTTESTS.DAT";
- TSTTESTS,FILE_CRE : EXCEPTION;
-
-BEGIN
- PUT_LINE ("BEGINNING MACRO SUBSTITUTIONS.");
- FILL_TABLE;
- BEGIN
- OPEN (INFILE2, IN_FILE, TESTS_FILE);
- EXCEPTION
- WHEN NAME_ERROR =>
- PUT_LINE ("** ERROR: ERROR DURING OPENING OF " &
- "TSTTESTS.DAT");
- RAISE TSTTESTS;
- END;
- WHILE NOT END_OF_FILE (INFILE2) LOOP
- GET_LINE (INFILE2, FNAME, LENGTH);
- FILE_COUNT := FILE_COUNT + 1;
- BEGIN
- OPEN (INFILE1, IN_FILE, FNAME(1..LENGTH));
- EXCEPTION
- WHEN NAME_ERROR =>
- PUT_LINE ("** ERROR: ERROR DURING OPENING OF " &
- FNAME(1..LENGTH) & ".");
- FLAG := TRUE;
- END;
- IF NOT FLAG THEN
- PUT_LINE ("WORKING ON " & FNAME(1..LENGTH));
- IF FILE_COUNT = 70 THEN
- PUT_LINE ("MACRO SUBSTITUTIONS HALF COMPLETED.");
- END IF;
- FOR I IN REVERSE 1 .. LENGTH LOOP
- IF FNAME(I) = ';' THEN
- LENGTH := I - 1;
- EXIT;
- END IF;
- END LOOP;
- IF FNAME (LENGTH-2..LENGTH) = "TST" THEN
- FNAME (LENGTH-2..LENGTH) := "ADT";
- ELSIF FNAME (LENGTH-2..LENGTH) = "tst" THEN
- FNAME (LENGTH-2..LENGTH) := "adt";
- END IF;
- BEGIN
- CREATE (OUTFILE1, OUT_FILE, FNAME (1..LENGTH));
- EXCEPTION
- WHEN OTHERS =>
- PUT_LINE ("** ERROR: EXCEPTION RAISED DURING" &
- " ATTEMPTED CREATION OF " &
- FNAME(1..LENGTH) & ".");
- RAISE FILE_CRE;
- END;
- WHILE NOT END_OF_FILE (INFILE1) LOOP
- GET_LINE (INFILE1, A_LINE, A_LENGTH);
- IF A_LENGTH > 0 AND A_LINE(1..2) /= "--" THEN
- END_OF_LINE_SEARCH := FALSE;
- PTR := 1;
- WHILE NOT END_OF_LINE_SEARCH LOOP
- LOOK_FOR_MACRO (A_LINE, A_LENGTH, PTR,
- MACRO, MACRO_LEN);
- IF MACRO_LEN = 0 THEN
- END_OF_LINE_SEARCH := TRUE;
- ELSE -- SEE WHICH MACRO IT IS
- WHICH_MACRO (MACRO, MACRO_LEN,
- TEMP_MACRO, TEMP_MACRO_LENGTH);
- END IF;
- IF NOT END_OF_LINE_SEARCH THEN
- IF PTR-MACRO_LEN-2 > 0 THEN
- -- IF MACRO IS NOT FIRST ON THE LINE
- NEW_LINE (1..PTR-MACRO_LEN-2)
- := A_LINE(1..PTR-MACRO_LEN -2);
- -- THE OLD LINE UNTIL THE DOLLAR SIGN
- END IF;
- NEW_LINE(PTR-MACRO_LEN-1 ..
- TEMP_MACRO_LENGTH +
- (PTR-MACRO_LEN) - 2) :=
- TEMP_MACRO(1..TEMP_MACRO_LENGTH);
- IF PTR <= A_LENGTH THEN
- -- IF MACRO IS NOT LAST ON THE LINE
- NEW_LINE (TEMP_MACRO_LENGTH +
- PTR-MACRO_LEN - 1 ..
- TEMP_MACRO_LENGTH - 1 +
- A_LENGTH - MACRO_LEN) :=
- A_LINE (PTR..A_LENGTH);
- ELSE
- END_OF_LINE_SEARCH := TRUE;
- END IF;
- A_LENGTH := A_LENGTH +
- TEMP_MACRO_LENGTH -
- MACRO_LEN - 1;
- A_LINE (1..A_LENGTH) :=
- NEW_LINE (1..A_LENGTH);
- PTR := PTR - MACRO_LEN +
- TEMP_MACRO_LENGTH - 1;
- END IF;
- END LOOP;
- END IF;
- PUT_LINE (OUTFILE1, A_LINE (1..A_LENGTH));
- END LOOP;
- CLOSE (OUTFILE1);
- CLOSE (INFILE1);
- ELSE
- FLAG := FALSE;
- END IF;
- END LOOP;
- CLOSE (INFILE2);
- PUT_LINE ("MACRO SUBSTITUTIONS COMPLETED.");
-EXCEPTION
- WHEN MAC_FILE | LINE_LEN | TSTTESTS | FILE_CRE =>
- NULL;
- WHEN OTHERS =>
- PUT_LINE ("UNEXPECTED EXCEPTION RAISED");
-END MACROSUB;
diff --git a/gcc/testsuite/ada/acats/support/repbody.ada b/gcc/testsuite/ada/acats/support/repbody.ada
deleted file mode 100644
index d7b9fe0..0000000
--- a/gcc/testsuite/ada/acats/support/repbody.ada
+++ /dev/null
@@ -1,330 +0,0 @@
--- REPBODY.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.
---*
---
--- HISTORY:
--- DCB 04/27/80
--- JRK 6/10/80
--- JRK 11/12/80
--- JRK 8/6/81
--- JRK 10/27/82
--- JRK 6/1/84
--- JRK 11/18/85 ADDED PRAGMA ELABORATE.
--- PWB 07/29/87 ADDED STATUS ACTION_REQUIRED AND
--- PROCEDURE SPECIAL_ACTION.
--- TBN 08/20/87 ADDED FUNCTION LEGAL_FILE_NAME.
--- BCB 05/17/90 MODIFIED TO ALLOW OUTPUT TO DIRECT_IO FILE.
--- ADDED TIME-STAMP.
--- LDC 05/17/90 REMOVED OUTPUT TO DIRECT_IO FILE.
--- WMC 08/11/92 UPDATED ACVC VERSION STRING TO "9X BASIC".
--- DTN 07/05/92 UPDATED ACVC VERSION STRING TO
--- "ACVC 2.0 JULY 6 1993 DRAFT".
--- WMC 01/24/94 MODIFIED LEGAL_FILE_NAME TO ALLOW FIVE POSSIBLE
--- FILE NAMES (INCREASED RANGE OF TYPE FILE_NUM TO 1..5).
--- WMC 11/06/94 UPDATED ACVC VERSION STRING TO
--- "ACVC 2.0 NOVEMBER 6 1994 DRAFT".
--- DTN 12/04/94 UPDATED ACVC VERSION STRING TO
--- "ACVC 2.0".
--- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_CHAR.
--- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_STR.
--- DTN 11/21/95 UPDATED ACVC VERSION STRING TO
--- "ACVC 2.0.1".
--- DTN 12/14/95 UPDATED ACVC VERSION STRING TO
--- "ACVC 2.1".
--- EDS 12/17/97 UPDATED ACVC VERSION STRING TO
--- "2.2".
--- RLB 3/16/00 UPDATED ACATS VERSION STRING TO "2.3".
--- CHANGED VARIOUS STRINGS TO READ "ACATS".
--- RLB 3/22/01 UPDATED ACATS VERSION STRING TO "2.4".
--- RLB 3/29/02 UPDATED ACATS VERSION STRING TO "2.5".
--- RLB 3/06/07 UPDATED ACATS VERSION STRING TO "2.6".
-
-WITH TEXT_IO, CALENDAR;
-USE TEXT_IO, CALENDAR;
-PRAGMA ELABORATE (TEXT_IO, CALENDAR);
-
-PACKAGE BODY REPORT IS
-
- TYPE STATUS IS (PASS, FAIL, DOES_NOT_APPLY, ACTION_REQUIRED,
- UNKNOWN);
-
- TYPE TIME_INTEGER IS RANGE 0 .. 86_400;
-
- TEST_STATUS : STATUS := FAIL;
-
- MAX_NAME_LEN : CONSTANT := 15; -- MAXIMUM TEST NAME LENGTH.
- TEST_NAME : STRING (1..MAX_NAME_LEN);
-
- NO_NAME : CONSTANT STRING (1..7) := "NO_NAME";
- TEST_NAME_LEN : INTEGER RANGE 0..MAX_NAME_LEN := 0;
-
-
-
- ACATS_VERSION : CONSTANT STRING := "2.6";
- -- VERSION OF ACATS BEING RUN (X.XX).
-
- PROCEDURE PUT_MSG (MSG : STRING) IS
- -- WRITE MESSAGE. LONG MESSAGES ARE FOLDED (AND INDENTED).
- MAX_LEN : CONSTANT INTEGER RANGE 50..150 := 72; -- MAXIMUM
- -- OUTPUT LINE LENGTH.
- INDENT : CONSTANT INTEGER := TEST_NAME_LEN + 9; -- AMOUNT TO
- -- INDENT CONTINUATION LINES.
- I : INTEGER := 0; -- CURRENT INDENTATION.
- M : INTEGER := MSG'FIRST; -- START OF MESSAGE SLICE.
- N : INTEGER; -- END OF MESSAGE SLICE.
- BEGIN
- LOOP
- IF I + (MSG'LAST-M+1) > MAX_LEN THEN
- N := M + (MAX_LEN-I) - 1;
- IF MSG (N) /= ' ' THEN
- WHILE N >= M AND THEN MSG (N+1) /= ' ' LOOP
- N := N - 1;
- END LOOP;
- IF N < M THEN
- N := M + (MAX_LEN-I) - 1;
- END IF;
- END IF;
- ELSE N := MSG'LAST;
- END IF;
- SET_COL (STANDARD_OUTPUT, TEXT_IO.COUNT (I+1));
- PUT_LINE (STANDARD_OUTPUT, MSG (M..N));
- I := INDENT;
- M := N + 1;
- WHILE M <= MSG'LAST AND THEN MSG (M) = ' ' LOOP
- M := M + 1;
- END LOOP;
- EXIT WHEN M > MSG'LAST;
- END LOOP;
- END PUT_MSG;
-
- FUNCTION TIME_STAMP RETURN STRING IS
- TIME_NOW : CALENDAR.TIME;
- YEAR,
- MONTH,
- DAY,
- HOUR,
- MINUTE,
- SECOND : TIME_INTEGER := 1;
-
- FUNCTION CONVERT (NUMBER : TIME_INTEGER) RETURN STRING IS
- STR : STRING (1..2) := (OTHERS => '0');
- DEC_DIGIT : CONSTANT STRING := "0123456789";
- NUM : TIME_INTEGER := NUMBER;
- BEGIN
- IF NUM = 0 THEN
- RETURN STR;
- ELSE
- NUM := NUM MOD 100;
- STR (2) := DEC_DIGIT (INTEGER (NUM MOD 10 + 1));
- NUM := NUM / 10;
- STR (1) := DEC_DIGIT (INTEGER (NUM + 1));
- RETURN STR;
- END IF;
- END CONVERT;
- BEGIN
- TIME_NOW := CALENDAR.CLOCK;
- SPLIT (TIME_NOW, YEAR_NUMBER (YEAR), MONTH_NUMBER (MONTH),
- DAY_NUMBER (DAY), DAY_DURATION (SECOND));
- HOUR := SECOND / 3600;
- SECOND := SECOND MOD 3600;
- MINUTE := SECOND / 60;
- SECOND := SECOND MOD 60;
- RETURN (CONVERT (TIME_INTEGER (YEAR)) & "-" &
- CONVERT (TIME_INTEGER (MONTH)) & "-" &
- CONVERT (TIME_INTEGER (DAY)) & " " &
- CONVERT (TIME_INTEGER (HOUR)) & ":" &
- CONVERT (TIME_INTEGER (MINUTE)) & ":" &
- CONVERT (TIME_INTEGER (SECOND)));
- END TIME_STAMP;
-
- PROCEDURE TEST (NAME : STRING; DESCR : STRING) IS
- BEGIN
- TEST_STATUS := PASS;
- IF NAME'LENGTH <= MAX_NAME_LEN THEN
- TEST_NAME_LEN := NAME'LENGTH;
- ELSE TEST_NAME_LEN := MAX_NAME_LEN;
- END IF;
- TEST_NAME (1..TEST_NAME_LEN) :=
- NAME (NAME'FIRST .. NAME'FIRST+TEST_NAME_LEN-1);
-
- PUT_MSG ("");
- PUT_MSG (",.,. " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- "ACATS " & ACATS_VERSION & " " & TIME_STAMP);
- PUT_MSG ("---- " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- DESCR & ".");
- END TEST;
-
- PROCEDURE COMMENT (DESCR : STRING) IS
- BEGIN
- PUT_MSG (" - " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- DESCR & ".");
- END COMMENT;
-
- PROCEDURE FAILED (DESCR : STRING) IS
- BEGIN
- TEST_STATUS := FAIL;
- PUT_MSG (" * " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- DESCR & ".");
- END FAILED;
-
- PROCEDURE NOT_APPLICABLE (DESCR : STRING) IS
- BEGIN
- IF TEST_STATUS = PASS OR TEST_STATUS = ACTION_REQUIRED THEN
- TEST_STATUS := DOES_NOT_APPLY;
- END IF;
- PUT_MSG (" + " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- DESCR & ".");
- END NOT_APPLICABLE;
-
- PROCEDURE SPECIAL_ACTION (DESCR : STRING) IS
- BEGIN
- IF TEST_STATUS = PASS THEN
- TEST_STATUS := ACTION_REQUIRED;
- END IF;
- PUT_MSG (" ! " & TEST_NAME (1..TEST_NAME_LEN) & " " &
- DESCR & ".");
- END SPECIAL_ACTION;
-
- PROCEDURE RESULT IS
- BEGIN
- CASE TEST_STATUS IS
- WHEN PASS =>
- PUT_MSG ("==== " & TEST_NAME (1..TEST_NAME_LEN) &
- " PASSED ============================.");
- WHEN DOES_NOT_APPLY =>
- PUT_MSG ("++++ " & TEST_NAME (1..TEST_NAME_LEN) &
- " NOT-APPLICABLE ++++++++++++++++++++.");
- WHEN ACTION_REQUIRED =>
- PUT_MSG ("!!!! " & TEST_NAME (1..TEST_NAME_LEN) &
- " TENTATIVELY PASSED !!!!!!!!!!!!!!!!.");
- PUT_MSG ("!!!! " & (1..TEST_NAME_LEN => ' ') &
- " SEE '!' COMMENTS FOR SPECIAL NOTES!!");
- WHEN OTHERS =>
- PUT_MSG ("**** " & TEST_NAME (1..TEST_NAME_LEN) &
- " FAILED ****************************.");
- END CASE;
- TEST_STATUS := FAIL;
- TEST_NAME_LEN := NO_NAME'LENGTH;
- TEST_NAME (1..TEST_NAME_LEN) := NO_NAME;
- END RESULT;
-
- FUNCTION IDENT_INT (X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF EQUAL (X, X) THEN -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN 0; -- NEVER EXECUTED.
- END IDENT_INT;
-
- FUNCTION IDENT_CHAR (X : CHARACTER) RETURN CHARACTER IS
- BEGIN
- IF EQUAL (CHARACTER'POS(X), CHARACTER'POS(X)) THEN -- ALWAYS
- -- EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN '0'; -- NEVER EXECUTED.
- END IDENT_CHAR;
-
- FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER IS
- BEGIN
- IF EQUAL (WIDE_CHARACTER'POS(X), WIDE_CHARACTER'POS(X)) THEN
- -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN '0'; -- NEVER EXECUTED.
- END IDENT_WIDE_CHAR;
-
- FUNCTION IDENT_BOOL (X : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- IF EQUAL (BOOLEAN'POS(X), BOOLEAN'POS(X)) THEN -- ALWAYS
- -- EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN FALSE; -- NEVER EXECUTED.
- END IDENT_BOOL;
-
- FUNCTION IDENT_STR (X : STRING) RETURN STRING IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN ""; -- NEVER EXECUTED.
- END IDENT_STR;
-
- FUNCTION IDENT_WIDE_STR (X : WIDE_STRING) RETURN WIDE_STRING IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN ""; -- NEVER EXECUTED.
- END IDENT_WIDE_STR;
-
- FUNCTION EQUAL (X, Y : INTEGER) RETURN BOOLEAN IS
- REC_LIMIT : CONSTANT INTEGER RANGE 1..100 := 3; -- RECURSION
- -- LIMIT.
- Z : BOOLEAN; -- RESULT.
- BEGIN
- IF X < 0 THEN
- IF Y < 0 THEN
- Z := EQUAL (-X, -Y);
- ELSE Z := FALSE;
- END IF;
- ELSIF X > REC_LIMIT THEN
- Z := EQUAL (REC_LIMIT, Y-X+REC_LIMIT);
- ELSIF X > 0 THEN
- Z := EQUAL (X-1, Y-1);
- ELSE Z := Y = 0;
- END IF;
- RETURN Z;
- EXCEPTION
- WHEN OTHERS =>
- RETURN X = Y;
- END EQUAL;
-
- FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1;
- NAM : STRING := "")
- RETURN STRING IS
- SUFFIX : STRING (2..6);
- BEGIN
- IF NAM = "" THEN
- SUFFIX := TEST_NAME(3..7);
- ELSE
- SUFFIX := NAM(3..7);
- END IF;
-
- CASE X IS
- WHEN 1 => RETURN ('X' & SUFFIX);
- WHEN 2 => RETURN ('Y' & SUFFIX);
- WHEN 3 => RETURN ('Z' & SUFFIX);
- WHEN 4 => RETURN ('V' & SUFFIX);
- WHEN 5 => RETURN ('W' & SUFFIX);
- END CASE;
- END LEGAL_FILE_NAME;
-
-BEGIN
-
- TEST_NAME_LEN := NO_NAME'LENGTH;
- TEST_NAME (1..TEST_NAME_LEN) := NO_NAME;
-
-END REPORT;
diff --git a/gcc/testsuite/ada/acats/support/repspec.ada b/gcc/testsuite/ada/acats/support/repspec.ada
deleted file mode 100644
index 19c371f..0000000
--- a/gcc/testsuite/ada/acats/support/repspec.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- REPSPEC.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.
---*
---
--- PURPOSE:
--- THIS REPORT PACKAGE PROVIDES THE MECHANISM FOR REPORTING THE
--- PASS/FAIL/NOT-APPLICABLE RESULTS OF EXECUTABLE (CLASSES A, C,
--- D, E, AND L) TESTS.
-
--- IT ALSO PROVIDES THE MECHANISM FOR GUARANTEEING THAT CERTAIN
--- VALUES BECOME DYNAMIC (NOT KNOWN AT COMPILE-TIME).
-
--- HISTORY:
--- JRK 12/13/79
--- JRK 06/10/80
--- JRK 08/06/81
--- JRK 10/27/82
--- JRK 06/01/84
--- PWB 07/30/87 ADDED PROCEDURE SPECIAL_ACTION.
--- TBN 08/20/87 ADDED FUNCTION LEGAL_FILE_NAME.
--- BCB 05/17/90 ADDED FUNCTION TIME_STAMP.
--- WMC 01/24/94 INCREASED RANGE OF TYPE FILE_NUM FROM 1..3 TO 1..5.
--- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_CHAR.
--- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_STR.
-
-PACKAGE REPORT IS
-
- SUBTYPE FILE_NUM IS INTEGER RANGE 1..5;
-
- -- THE REPORT ROUTINES.
-
- PROCEDURE TEST -- THIS ROUTINE MUST BE INVOKED AT THE
- -- START OF A TEST, BEFORE ANY OF THE
- -- OTHER REPORT ROUTINES ARE INVOKED.
- -- IT SAVES THE TEST NAME AND OUTPUTS THE
- -- NAME AND DESCRIPTION.
- ( NAME : STRING; -- TEST NAME, E.G., "C23001A-AB".
- DESCR : STRING -- BRIEF DESCRIPTION OF TEST, E.G.,
- -- "UPPER/LOWER CASE EQUIVALENCE IN " &
- -- "IDENTIFIERS".
- );
-
- PROCEDURE FAILED -- OUTPUT A FAILURE MESSAGE. SHOULD BE
- -- INVOKED SEPARATELY TO REPORT THE
- -- FAILURE OF EACH SUBTEST WITHIN A TEST.
- ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT FAILED.
- -- SHOULD BE PHRASED AS:
- -- "(FAILED BECAUSE) ...REASON...".
- );
-
- PROCEDURE NOT_APPLICABLE -- OUTPUT A NOT-APPLICABLE MESSAGE.
- -- SHOULD BE INVOKED SEPARATELY TO REPORT
- -- THE NON-APPLICABILITY OF EACH SUBTEST
- -- WITHIN A TEST.
- ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT IS
- -- NOT-APPLICABLE. SHOULD BE PHRASED AS:
- -- "(NOT-APPLICABLE BECAUSE)...REASON...".
- );
-
- PROCEDURE SPECIAL_ACTION -- OUTPUT A MESSAGE DESCRIBING SPECIAL
- -- ACTIONS TO BE TAKEN.
- -- SHOULD BE INVOKED SEPARATELY TO GIVE
- -- EACH SPECIAL ACTION.
- ( DESCR : STRING -- BRIEF DESCRIPTION OF ACTION TO BE
- -- TAKEN.
- );
-
- PROCEDURE COMMENT -- OUTPUT A COMMENT MESSAGE.
- ( DESCR : STRING -- THE MESSAGE.
- );
-
- PROCEDURE RESULT; -- THIS ROUTINE MUST BE INVOKED AT THE
- -- END OF A TEST. IT OUTPUTS A MESSAGE
- -- INDICATING WHETHER THE TEST AS A
- -- WHOLE HAS PASSED, FAILED, IS
- -- NOT-APPLICABLE, OR HAS TENTATIVELY
- -- PASSED PENDING SPECIAL ACTIONS.
-
- -- THE DYNAMIC VALUE ROUTINES.
-
- -- EVEN WITH STATIC ARGUMENTS, THESE FUNCTIONS WILL HAVE DYNAMIC
- -- RESULTS.
-
- FUNCTION IDENT_INT -- AN IDENTITY FUNCTION FOR TYPE INTEGER.
- ( X : INTEGER -- THE ARGUMENT.
- ) RETURN INTEGER; -- X.
-
- FUNCTION IDENT_CHAR -- AN IDENTITY FUNCTION FOR TYPE
- -- CHARACTER.
- ( X : CHARACTER -- THE ARGUMENT.
- ) RETURN CHARACTER; -- X.
-
- FUNCTION IDENT_WIDE_CHAR -- AN IDENTITY FUNCTION FOR TYPE
- -- WIDE_CHARACTER.
- ( X : WIDE_CHARACTER -- THE ARGUMENT.
- ) RETURN WIDE_CHARACTER; -- X.
-
- FUNCTION IDENT_BOOL -- AN IDENTITY FUNCTION FOR TYPE BOOLEAN.
- ( X : BOOLEAN -- THE ARGUMENT.
- ) RETURN BOOLEAN; -- X.
-
- FUNCTION IDENT_STR -- AN IDENTITY FUNCTION FOR TYPE STRING.
- ( X : STRING -- THE ARGUMENT.
- ) RETURN STRING; -- X.
-
- FUNCTION IDENT_WIDE_STR -- AN IDENTITY FUNCTION FOR TYPE WIDE_STRING.
- ( X : WIDE_STRING -- THE ARGUMENT.
- ) RETURN WIDE_STRING; -- X.
-
- FUNCTION EQUAL -- A RECURSIVE EQUALITY FUNCTION FOR TYPE
- -- INTEGER.
- ( X, Y : INTEGER -- THE ARGUMENTS.
- ) RETURN BOOLEAN; -- X = Y.
-
--- OTHER UTILITY ROUTINES.
-
- FUNCTION LEGAL_FILE_NAME -- A FUNCTION TO GENERATE LEGAL EXTERNAL
- -- FILE NAMES.
- ( X : FILE_NUM := 1; -- DETERMINES FIRST CHARACTER OF NAME.
- NAM : STRING := "" -- DETERMINES REST OF NAME.
- ) RETURN STRING; -- THE GENERATED NAME.
-
- FUNCTION TIME_STAMP -- A FUNCTION TO GENERATE THE TIME AND
- -- DATE TO PLACE IN THE OUTPUT OF AN ACVC
- -- TEST.
- RETURN STRING; -- THE TIME AND DATE.
-
-END REPORT;
diff --git a/gcc/testsuite/ada/acats/support/spprt13s.tst b/gcc/testsuite/ada/acats/support/spprt13s.tst
deleted file mode 100644
index 64b4731..0000000
--- a/gcc/testsuite/ada/acats/support/spprt13s.tst
+++ /dev/null
@@ -1,67 +0,0 @@
--- SPPRT13SP.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.
---*
---
--- SPECIFICATION FOR PACKAGE SPPRT13
-
--- PURPOSE:
--- THIS PACKAGE CONTAINS CONSTANTS OF TYPE SYSTEM.ADDRESS.
--- THESE CONSTANTS ARE USED BY SELECTED CHAPTER 13 TESTS,
--- BY PARTS OF THE AVAT SYSTEM, AND BY ISOLATED TESTS FOR
--- OTHER CHAPTERS.
-
--- MACRO SUBSTITUTIONS:
--- $VARIABLE_ADDRESS, $VARIABLE_ADDRESS1, AND $VARIABLE_ADDRESS2 ARE
--- EXPRESSIONS YIELDING LEGAL ADDRESSES FOR VARIABLES FOR THIS
--- IMPLEMENTATION.
-
--- $ENTRY_ADDRESS, $ENTRY_ADDRESS1, AND $ENTRY_ADDRESS2 ARE
--- EXPRESSIONS YIELDING LEGAL ADDRESSES FOR TASK ENTRIES
--- (I.E., FOR INTERRUPTS) FOR THIS IMPLEMENTATION.
-
--- IF NO EXPRESSIONS CAN BE GIVEN THAT ARE SATISFACTORY FOR THE
--- VALUES OF THESE CONSTANTS, THEN DECLARE SUITABLE FUNCTIONS
--- IN THE SPECIFICATION OF PACKAGE FCNDECL, CREATE A PACKAGE BODY
--- CONTAINING BODIES FOR THE FUNCTIONS, AND REPLACE THE MACROS WITH
--- APPROPRIATE FUNCTION CALLS.
-
-WITH FCNDECL; USE FCNDECL;
-WITH SYSTEM;
-PACKAGE SPPRT13 IS
-
- VARIABLE_ADDRESS : CONSTANT SYSTEM.ADDRESS :=
- $VARIABLE_ADDRESS;
- VARIABLE_ADDRESS1 : CONSTANT SYSTEM.ADDRESS :=
- $VARIABLE_ADDRESS1;
- VARIABLE_ADDRESS2 : CONSTANT SYSTEM.ADDRESS :=
- $VARIABLE_ADDRESS2;
-
- ENTRY_ADDRESS : CONSTANT SYSTEM.ADDRESS :=
- $ENTRY_ADDRESS;
- ENTRY_ADDRESS1 : CONSTANT SYSTEM.ADDRESS :=
- $ENTRY_ADDRESS1;
- ENTRY_ADDRESS2 : CONSTANT SYSTEM.ADDRESS :=
- $ENTRY_ADDRESS2;
-
-END SPPRT13;
diff --git a/gcc/testsuite/ada/acats/support/tctouch.ada b/gcc/testsuite/ada/acats/support/tctouch.ada
deleted file mode 100644
index 83f1254..0000000
--- a/gcc/testsuite/ada/acats/support/tctouch.ada
+++ /dev/null
@@ -1,265 +0,0 @@
--- TCTouch.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.
---*
---
--- FOUNDATION DESCRIPTION:
--- The tools in this foundation are not peculiar to any particular
--- aspect of the language, but simplify the test writing and reading
--- process. Assert and Assert_Not are used to reduce the textual
--- overhead of the test-that-this-condition-is-(not)-true paradigm.
--- Touch and Validate are used to simplify tracing an expected path
--- of execution.
--- A tag comment of the form:
---
--- TCTouch.Touch( 'A' ); ----------------------------------------- A
---
--- is recommended to improve readability of this feature.
---
--- Report.Test must be called before any of the procedures in this
--- package with the exception of Touch.
--- The usage paradigm is to call Touch in locations in the test where you
--- want a trace of execution. Each call to Touch should have a unique
--- character associated with it. At each place where a check can
--- reasonably be performed to determine correct execution of a
--- sub-test, a call to Validate should be made. The first parameter
--- passed to Validate is the expected string of characters produced by
--- call(s) to Touch in the subtest just executed. The second parameter
--- is the message to pass to Report.Failed if the expected sequence was
--- not executed.
---
--- Validate should always be called after calls to Touch before a test
--- completes.
---
--- In the event that calls may have been made to Touch that are not
--- intended to be recorded, or, the failure of a previous subtest may
--- leave Touch calls "Unvalidated", the procedure Flush will reset the
--- tracker to the "empty" state. Flush does not make any calls to
--- Report.
---
--- Calls to Assert and Assert_Not are to replace the idiom:
---
--- if BadCondition then -- or if not PositiveTest then
--- Report.Failed(Message);
--- end if;
---
--- with:
---
--- Assert_Not( BadCondition, Message ); -- or
--- Assert( PositiveTest, Message );
---
--- Implementation_Check is for use with tests that cross the boundary
--- between the core and the Special Needs Annexes. There are several
--- instances where language in the core becomes enforceable only when
--- a Special Needs Annex is supported. Implementation_Check should be
--- called in place of Report.Failed in these cases; it examines the
--- constants in Impdef that indicate if the particular Special Needs
--- Annex is being validated with this validation; and acts accordingly.
---
--- The constant Foundation_ID contains the internal change version
--- for this software.
---
--- ERROR CONDITIONS:
---
--- It is an error to perform more than Max_Touch_Count (80) calls to
--- Touch without a subsequent call to Validate. To do so will cause
--- a false test failure.
---
--- CHANGE HISTORY:
--- 02 JUN 94 SAIC Initial version
--- 27 OCT 94 SAIC Revised version
--- 07 AUG 95 SAIC Added Implementation_Check
--- 07 FEB 96 SAIC Changed to match new Impdef for 2.1
--- 16 MAR 00 RLB Changed foundation id to reflect test suite version.
--- 22 MAR 01 RLB Changed foundation id to reflect test suite version.
--- 29 MAR 02 RLB Changed foundation id to reflect test suite version.
--- 06 MAR 07 RLB Changed foundation id to reflect test suite version.
---
---!
-
-package TCTouch is
- Foundation_ID : constant String := "TCTouch ACATS 2.6";
- Max_Touch_Count : constant := 80;
-
- procedure Assert ( SB_True : Boolean; Message : String );
- procedure Assert_Not( SB_False : Boolean; Message : String );
-
- procedure Touch ( A_Tag : Character );
- procedure Validate( Expected: String;
- Message : String;
- Order_Meaningful : Boolean := True );
-
- procedure Flush;
-
- type Special_Needs_Annexes is ( Annex_C, Annex_D, Annex_E,
- Annex_F, Annex_G, Annex_H );
-
- procedure Implementation_Check( Message : in String;
- Annex : in Special_Needs_Annexes
- := Annex_C );
- -- If Impdef.Validating_Annex_<Annex> is true, will call Report.Failed
- -- otherwise will call Report.Not_Applicable. This is to allow tests
- -- which are driven by wording in the core of the language, yet have
- -- their functionality dictated by the Special Needs Annexes to perform
- -- dual purpose.
- -- The default of Annex_C for the Annex parameter is to support early
- -- tests written with the assumption that Implementation_Check was
- -- expressly for use with the Systems Programming Annex.
-
-end TCTouch;
-
-with Report;
-with Impdef;
-package body TCTouch is
-
- procedure Assert( SB_True : Boolean; Message : String ) is
- begin
- if not SB_True then
- Report.Failed( "Assertion failed: " & Message );
- end if;
- end Assert;
-
- procedure Assert_Not( SB_False : Boolean; Message : String ) is
- begin
- if SB_False then
- Report.Failed( "Assertion failed: " & Message );
- end if;
- end Assert_Not;
-
- Collection : String(1..Max_Touch_Count);
- Finger : Natural := 0;
-
- procedure Touch ( A_Tag : Character ) is
- begin
- Finger := Finger+1;
- Collection(Finger) := A_Tag;
- exception
- when Constraint_Error =>
- Report.Failed("Trace Overflow: " & Collection);
- Finger := 0;
- end Touch;
-
- procedure Sort_String( S: in out String ) is
- -- algorithm from Booch Components Page 472
- No_Swaps : Boolean;
- procedure Swap(C1, C2: in out Character) is
- T: Character := C1;
- begin C1 := C2; C2 := T; end Swap;
- begin
- for OI in S'First+1..S'Last loop
- No_Swaps := True;
- for II in reverse OI..S'Last loop
- if S(II) < S(II-1) then
- Swap(S(II),S(II-1));
- No_Swaps := False;
- end if;
- end loop;
- exit when No_Swaps;
- end loop;
- end Sort_String;
-
- procedure Validate( Expected: String;
- Message : String;
- Order_Meaningful : Boolean := True) is
- Want : String(1..Expected'Length) := Expected;
- begin
- if not Order_Meaningful then
- Sort_String( Want );
- Sort_String( Collection(1..Finger) );
- end if;
- if Collection(1..Finger) /= Want then
- Report.Failed( Message & " Expecting: " & Want
- & " Got: " & Collection(1..Finger) );
- end if;
- Finger := 0;
- end Validate;
-
- procedure Flush is
- begin
- Finger := 0;
- end Flush;
-
- procedure Implementation_Check( Message : in String;
- Annex : in Special_Needs_Annexes
- := Annex_C ) is
- -- default to cover some legacy
- -- USAGE DISCIPLINE:
- -- Implementation_Check is designed to be used in tests that have
- -- interdependency on one of the Special Needs Annexes, yet are _really_
- -- tests based in the core language. There will be instances where the
- -- execution of a test would be failing in the light of the requirements
- -- of the annex, yet from the point of view of the core language without
- -- the additional requirements of the annex, the test does not apply.
- -- In these cases, rather than issuing a call to Report.Failed, calling
- -- TCTouch.Implementation_Check will check that sensitivity, and if
- -- the implementation is attempting to validate against the specific
- -- annex, Report.Failed will be called, otherwise, Report.Not_Applicable
- -- will be called.
- begin
-
- case Annex is
- when Annex_C =>
- if ImpDef.Validating_Annex_C then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex C not supported" );
- end if;
-
- when Annex_D =>
- if ImpDef.Validating_Annex_D then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex D not supported" );
- end if;
-
- when Annex_E =>
- if ImpDef.Validating_Annex_E then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex E not supported" );
- end if;
-
- when Annex_F =>
- if ImpDef.Validating_Annex_F then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex F not supported" );
- end if;
-
- when Annex_G =>
- if ImpDef.Validating_Annex_G then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex G not supported" );
- end if;
-
- when Annex_H =>
- if ImpDef.Validating_Annex_H then
- Report.Failed( Message );
- else
- Report.Not_Applicable( Message & " Annex H not supported" );
- end if;
- end case;
- end Implementation_Check;
-
-end TCTouch;
diff --git a/gcc/testsuite/ada/acats/support/tsttests.dat b/gcc/testsuite/ada/acats/support/tsttests.dat
deleted file mode 100644
index 60a8bf8..0000000
--- a/gcc/testsuite/ada/acats/support/tsttests.dat
+++ /dev/null
@@ -1,38 +0,0 @@
-ACATS4GNATDIR/tests/a/a26007a.tst
-ACATS4GNATDIR/tests/a/ad8011a.tst
-ACATS4GNATDIR/tests/c2/c23003a.tst
-ACATS4GNATDIR/tests/c2/c23003b.tst
-ACATS4GNATDIR/tests/c2/c23003g.tst
-ACATS4GNATDIR/tests/c2/c23003i.tst
-ACATS4GNATDIR/tests/c3/c35502d.tst
-ACATS4GNATDIR/tests/c3/c35502f.tst
-ACATS4GNATDIR/tests/c3/c35503d.tst
-ACATS4GNATDIR/tests/c3/c35503f.tst
-ACATS4GNATDIR/tests/c4/c45231d.tst
-ACATS4GNATDIR/tests/c4/c4a007a.tst
-ACATS4GNATDIR/tests/c8/c87b62d.tst
-ACATS4GNATDIR/tests/c9/c96005b.tst
-ACATS4GNATDIR/tests/cc/cc1225a.tst
-ACATS4GNATDIR/tests/cd/cd1009k.tst
-ACATS4GNATDIR/tests/cd/cd1009t.tst
-ACATS4GNATDIR/tests/cd/cd1009u.tst
-ACATS4GNATDIR/tests/cd/cd1c03e.tst
-ACATS4GNATDIR/tests/cd/cd1c06a.tst
-ACATS4GNATDIR/tests/cd/cd2a83c.tst
-ACATS4GNATDIR/tests/cd/cd2a91c.tst
-ACATS4GNATDIR/tests/cd/cd2c11a.tst
-ACATS4GNATDIR/tests/cd/cd2c11d.tst
-ACATS4GNATDIR/tests/cd/cd4041a.tst
-ACATS4GNATDIR/tests/cd/cd7101g.tst
-ACATS4GNATDIR/tests/ce/ce2102c.tst
-ACATS4GNATDIR/tests/ce/ce2102h.tst
-ACATS4GNATDIR/tests/ce/ce2103a.tst
-ACATS4GNATDIR/tests/ce/ce2103b.tst
-ACATS4GNATDIR/tests/ce/ce2203a.tst
-ACATS4GNATDIR/tests/ce/ce2403a.tst
-ACATS4GNATDIR/tests/ce/ce3002b.tst
-ACATS4GNATDIR/tests/ce/ce3002c.tst
-ACATS4GNATDIR/tests/ce/ce3102b.tst
-ACATS4GNATDIR/tests/ce/ce3107a.tst
-ACATS4GNATDIR/tests/ce/ce3304a.tst
-ACATS4GNATDIR/support/spprt13s.tst
diff --git a/gcc/testsuite/ada/acats/support/widechr.a b/gcc/testsuite/ada/acats/support/widechr.a
deleted file mode 100644
index 2eac588..0000000
--- a/gcc/testsuite/ada/acats/support/widechr.a
+++ /dev/null
@@ -1,294 +0,0 @@
--- WIDECHR.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.
---*
---
--- DESCRIPTION:
---
--- This program reads C250001.AW and C250002.AW; translates a special
--- character sequence into characters and wide characters with positions
--- above ASCII.DEL. The resulting tests are written as C250001.A and
--- C250002.A respectively. This program may need to
--- be modified if the Wide_Character representation recognized by
--- your compiler differs from the Wide_Character
--- representation generated by the package Ada.Wide_Text_IO.
--- Modify this program as needed to translate that file.
---
--- A wide character is represented by an 8 character sequence:
---
--- ["abcd"]
---
--- where the character code represented is specified by four hexadecimal
--- digits, abcd, with letters in upper case. For example the wide
--- character with the code 16#AB13# is represented by the eight
--- character sequence:
---
--- ["AB13"]
---
--- ASSUMPTIONS:
---
--- The path for these files is specified in ImpDef.
---
--- SPECIAL REQUIREMENTS:
---
--- Compile, bind and execute this program. It will process the ".AW"
--- tests, "translating" them to ".A" tests.
---
--- CHANGE HISTORY:
--- 11 DEC 96 SAIC ACVC 2.1 Release
---
--- 11 DEC 96 Keith Constructed initial release version
---!
-
-with Ada.Text_IO;
-with Ada.Wide_Text_IO;
-with Ada.Strings.Fixed;
-with Impdef;
-
-procedure WideChr is
-
- -- Debug
- --
- -- To have the program generate trace/debugging information, de-comment
- -- the call to Put_Line
-
- procedure Debug( S: String ) is
- begin
- null; -- Ada.Text_IO.Put_Line(S);
- end Debug;
-
- package TIO renames Ada.Text_IO;
- package WIO renames Ada.Wide_Text_IO;
- package SF renames Ada.Strings.Fixed;
-
- In_File : TIO.File_Type;
-
- -- This program is actually dual-purpose. It translates the ["xxxx"]
- -- notation to Wide_Character, as well as a similar notation ["xx"] into
- -- Character. The intent of the latter being the ability to represent
- -- literals in the Latin-1 character set that have position numbers
- -- greater than ASCII.DEL. The variable Output_Mode drives the algorithms
- -- to generate Wide_Character output (Wide) or Character output (Narrow).
-
- type Output_Modes is ( Wide, Narrow );
- Output_Mode : Output_Modes := Wide;
-
- Wide_Out : WIO.File_Type;
- Narrow_Out : TIO.File_Type;
-
- In_Line : String(1..132); -- SB: $MAX_LINE_LENGTH
-
- -- Index variables
- --
- -- the following index variables: In_Length, Front, Open_Bracket and
- -- Close_Bracket are used by the scanning software to keep track of
- -- what's where.
- --
- -- In_Length stores the value returned by Ada.Text_IO.Get_Line indicating
- -- the position of the last "useful" character in the string In_Line.
- --
- -- Front retains the index of the first non-translating character in
- -- In_Line, it is used to indicate the starting index of the portion of
- -- the string to save without special interpretation. In the example
- -- below, where there are two consecutive characters to translate, we see
- -- that Front will assume three different values processing the string,
- -- these are indicated by the digits '1', '2' & '3' in the comment
- -- attached to the declaration. The processing software will dump
- -- In_Line(Front..Open_Bracket-1) to the output stream. Note that in
- -- the second case, this results in a null string, and in the third case,
- -- where Open_Bracket does not obtain a third value, the slice
- -- In_Line(Front..In_Length) is used instead.
- --
- -- Open_Bracket and Close_Bracket are used to retain the starting index
- -- of the character pairs [" and "] respectively. For the purposes of
- -- this software the character pairs are what are considered to be the
- -- "brackets" enclosing the hexadecimal values to be translated.
- -- Looking at the example below you will see where these index variables
- -- will "point" in the first and second case.
-
- In_Length : Natural := 0; ---> Some_["0A12"]["0B13"]_Thing
- Front : Natural := 0; -- 1 2 3
- Open_Bracket : Natural := 0; -- 1 2
- Close_Bracket : Natural := 0; -- 1 2
-
- -- Xlation
- --
- -- This translation table gives an easy way to translate the "decimal"
- -- value of a hex digit (as represented by a Latin-1 character)
-
- type Xlate is array(Character range '0'..'F') of Natural;
- Xlation : constant Xlate :=
- ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4,
- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9,
- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14,
- 'F' => 15,
- others => 0);
-
- -- To_Ch
- --
- -- This function takes a string which is assumed to be trimmed to just a
- -- hexadecimal representation of a Latin-1 character. The result of the
- -- function is the Latin-1 character at the position designated by the
- -- incoming hexadecimal value. (hexadecimal in human readable form)
-
- function To_Ch( S:String ) return Character is
- Numerical : Natural := 0;
- begin
- Debug("To Wide: " & S);
- for I in S'Range loop
- Numerical := Numerical * 16 + Xlation(S(I));
- end loop;
- return Character'Val(Numerical);
- exception
- when Constraint_Error => return '_';
- end To_Ch;
-
- -- To_Wide
- --
- -- This function takes a string which is assumed to be trimmed to just a
- -- hexadecimal representation of a Wide_character. The result of the
- -- function is the Wide_character at the position designated by the
- -- incoming hexadecimal value. (hexadecimal in human readable form)
-
- function To_Wide( S:String ) return Wide_character is
- Numerical : Natural := 0;
- begin
- Debug("To Wide: " & S);
- for I in S'Range loop
- Numerical := Numerical * 16 + Xlation(S(I));
- end loop;
- return Wide_Character'Val(Numerical);
- exception
- when Constraint_Error => return '_';
- end To_Wide;
-
- -- Make_Wide
- --
- -- this function converts a String to a Wide_String
-
- function Make_Wide( S: String ) return Wide_String is
- W: Wide_String(S'Range);
- begin
- for I in S'Range loop
- W(I) := Wide_Character'Val( Character'Pos(S(I)) );
- end loop;
- return W;
- end Make_Wide;
-
- -- Close_Files
- --
- -- Depending on which input we've processed, close the output file
-
- procedure Close_Files is
- begin
- TIO.Close(In_File);
- if Output_Mode = Wide then
- WIO.Close(Wide_Out);
- else
- TIO.Close(Narrow_Out);
- end if;
- end Close_Files;
-
- -- Process
- --
- -- for all lines in the input file
- -- scan the file for occurrences of [" and "]
- -- for found occurrence, attempt translation of the characters found
- -- between the brackets. As a safeguard, unrecognizable character
- -- sequences will be replaced with the underscore character. This
- -- handles the cases in the tests where the test documentation includes
- -- examples that are non-conformant: i.e. ["abcd"] or ["XXXX"]
-
- procedure Process( Input_File_Name: String ) is
- begin
- TIO.Open(In_File,TIO.In_File,Input_File_Name & ".aw" );
-
- if Output_Mode = Wide then
- WIO.Create(Wide_Out,WIO.Out_File, Input_File_Name & ".a" );
- else
- TIO.Create(Narrow_Out,TIO.Out_File, Input_File_Name & ".a" );
- end if;
-
- File: while not TIO.End_Of_File( In_File ) loop
- In_Line := (others => ' ');
- TIO.Get_Line(In_File,In_Line,In_Length);
- Debug(In_Line(1..In_Length));
-
- Front := 1;
-
- Line: loop
- -- scan for next occurrence of ["abcd"]
- Open_Bracket := SF.Index( In_Line(Front..In_Length), "[""" );
- Close_Bracket := SF.Index( In_Line(Front..In_Length), """]" );
- Debug( "[=" & Natural'Image(Open_Bracket) );
- Debug( "]=" & Natural'Image(Close_Bracket) );
-
- if Open_Bracket = 0 or Close_Bracket = 0 then
- -- done with the line, output remaining characters and exit
- Debug("Done with line");
- if Output_Mode = Wide then
- WIO.Put_Line(Wide_Out, Make_Wide(In_Line(Front..In_Length)) );
- else
- TIO.Put_Line(Narrow_Out, In_Line(Front..In_Length) );
- end if;
- exit Line;
- else
- -- output the "normal" stuff up to the bracket
- if Output_Mode = Wide then
- WIO.Put(Wide_Out, Make_Wide(In_Line(Front..Open_Bracket-1)) );
- else
- TIO.Put(Narrow_Out, In_Line(Front..Open_Bracket-1) );
- end if;
-
- -- point beyond the closing bracket
- Front := Close_Bracket +2;
-
- -- output the translated hexadecimal character
- if Output_Mode = Wide then
- WIO.Put(Wide_Out,
- To_Wide( In_Line(Open_Bracket+2..Close_Bracket-1) ));
- else
- TIO.Put(Narrow_Out,
- To_Ch( In_Line(Open_Bracket+2..Close_Bracket-1)) );
- end if;
- end if;
- end loop Line;
-
- end loop File;
-
- Close_Files;
- exception
- when others =>
- Ada.Text_IO.Put_Line("Error in processing " & Input_File_Name);
- raise;
- end Process;
-
-begin
-
- Output_Mode := Wide;
- Process( Impdef.Wide_Character_Test );
-
- Output_Mode := Narrow;
- Process( Impdef.Upper_Latin_Test );
-
-end WideChr;
diff --git a/gcc/testsuite/ada/acats/tests/a/a22006b.ada b/gcc/testsuite/ada/acats/tests/a/a22006b.ada
deleted file mode 100644
index 250caf2..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a22006b.ada
+++ /dev/null
@@ -1,38 +0,0 @@
--- A22006B.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 HORIZONTAL TABULATION CAN BE USED WITHIN AND OUTSIDE OF
--- COMMENTS.
-
--- JBG 5/26/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE A22006B IS
-BEGIN
- TEST ("A22006B", "CHECK USE OF HT IN AND OUT OF COMMENTS");
- -- PRECEDING LINE CONTAINED A LEADING HT
- -- NEXT LINE CONTAINS A TAB INSIDE A COMMENT
- -- HERE IS HT => <= CHARACTER IN A COMMENT
- RESULT; -- TAB PRECEDES THIS COMMENT
-END A22006B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a22006c.ada b/gcc/testsuite/ada/acats/tests/a/a22006c.ada
deleted file mode 100644
index e04eb12..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a22006c.ada
+++ /dev/null
@@ -1,51 +0,0 @@
-
-
-
--- A22006C.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 COMPILATION MAY BE PRECEDED BY EXTRA LINES
--- (INCLUDING LINES TERMINATED BY FORMAT EFFECTORS OTHER
--- THAN HORIZONTAL TABULATION).
-
--- NOTE: THIS FILE BEGINS WITH:
--- 1) AN EMPTY LINE
--- 2) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX)
--- 3) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX)
--- 4) A VERTICAL TABULATION CHARACTER (ASCII 11. = 0B HEX)
--- 5) A LINE FEED CHARACTER (ASCII 10. = 0A HEX)
--- 6) A LINE FEED CHARACTER (ASCII 10. = 0A HEX)
--- 7) A FORM FEED CHARACTER (ASCII 12. = 0C HEX)
-
--- PWB 2/13/86
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE A22006C IS
-BEGIN
- TEST ("A22006C", "CHECK THAT A COMPILATION CAN BE PRECEDED " &
- "BY EXTRA LINES");
- RESULT;
-END A22006C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a22006d.ada b/gcc/testsuite/ada/acats/tests/a/a22006d.ada
deleted file mode 100644
index d19362c..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a22006d.ada
+++ /dev/null
@@ -1,41 +0,0 @@
- -- A22006D.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 COMPILATION CAN BE PRECEDED BY SPACES AND
--- HORIZONTAL TABULATION CHARACTERS.
-
--- NOTE: THE FIRST LINE OF THIS FILE BEGINS WITH FOUR SPACE
--- CHARACTERS AND A HORIZONTAL TABULATION CHARACTER
-
--- PWB 2/13/86
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE A22006D IS
-BEGIN
- TEST ("A22006D", "CHECK THAT A COMPILATION CAN BE PRECEDED " &
- "BY SPACE AND HORIZONTAL TABULATION CHARACTERS");
- RESULT;
-END A22006D;
diff --git a/gcc/testsuite/ada/acats/tests/a/a26007a.tst b/gcc/testsuite/ada/acats/tests/a/a26007a.tst
deleted file mode 100644
index d40aa3d..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a26007a.tst
+++ /dev/null
@@ -1,48 +0,0 @@
--- A26007A.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 THAT A STRING LITERAL HAVING THE MAXIMUM PERMITTED LINE LENGTH
--- CAN BE GENERATED.
-
--- TBN 3/5/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE A26007A IS
-
- MAX_LEN_STRING_LIT : STRING (1 .. $MAX_IN_LEN - 2);
-
- -- MAX_IN_LEN IS THE MAXIMUM LINE LENGTH PERMITTED.
-
-BEGIN
- TEST ("A26007A", "CHECK THAT A STRING LITERAL HAVING THE " &
- "MAXIMUM PERMITTED LINE LENGTH CAN BE GENERATED");
-
- MAX_LEN_STRING_LIT :=
-$MAX_STRING_LITERAL
-;
- -- MAX_STRING_LITERAL IS A STRING LITERAL THAT IS MAXIMUM LENGTH.
- -- QUOTES ARE COUNTED AS PART OF THE STRING LITERAL.
-
- RESULT;
-END A26007A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a27003a.ada b/gcc/testsuite/ada/acats/tests/a/a27003a.ada
deleted file mode 100644
index 77234e5..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a27003a.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- A27003A.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 STRING LITERAL, CONSECUTIVE HYPHENS
--- ARE PERMITTED WITHOUT INDICATING A COMMENT,
--- AND THAT IN A COMMENT, A SINGLE DOUBLE-QUOTE IS
--- PERMITTED WITHOUT INDICATING A STRING LITERAL.
-
--- PWB 03/04/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE A27003A IS
-
- -- COMMENT : " IS PERMITTED HERE.
-
- STR1 : CONSTANT STRING := "AB--C";
- STR2 : STRING (1..10);
-
-BEGIN
-
- TEST ("A27003A", "CONSECUTIVE HYPHENS PERMITTED IN " &
- "STRING LITERAL, AND QUOTE PERMITTED " &
- "IN COMMENT");
-
- STR2 := STR1 & "--ABC";
- -- COMMENT : " IS PERMITTED HERE.
-
- RESULT;
-
-END A27003A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a29003a.ada b/gcc/testsuite/ada/acats/tests/a/a29003a.ada
deleted file mode 100644
index e72de79..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a29003a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- A29003A.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 PREDEFINED ATTRIBUTES EXCEPT DIGITS, DELTA, AND RANGE,
--- AND ALL PREDEFINED TYPE AND PACKAGE NAMES ARE NOT RESERVED WORDS.
-
--- AH 8/11/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE A29003A IS
- SUBTYPE INT IS INTEGER;
-
--- PREDEFINED ATTRIBUTES
-
- ADDRESS : INT := IDENT_INT(0); -- ATTRIBUTE
- AFT : INT := IDENT_INT(0); -- ATTRIBUTE
- BASE : INT := IDENT_INT(0); -- ATTRIBUTE
- CALLABLE : INT := IDENT_INT(0); -- ATTRIBUTE
- CONSTRAINED : INT := IDENT_INT(0); -- ATTRIBUTE
- COUNT : INT := IDENT_INT(0); -- ATTRIBUTE
- EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
- EPSILON : INT := IDENT_INT(0); -- ATTRIBUTE
- FIRST : INT := IDENT_INT(0); -- ATTRIBUTE
- FIRST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE
- FORE : INT := IDENT_INT(0); -- ATTRIBUTE
- IMAGE : INT := IDENT_INT(0); -- ATTRIBUTE
- LARGE : INT := IDENT_INT(0); -- ATTRIBUTE
- LAST : INT := IDENT_INT(0); -- ATTRIBUTE
- LAST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE
- LENGTH : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_EMIN : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_OVERFLOWS : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_RADIX : INT := IDENT_INT(0); -- ATTRIBUTE
- MACHINE_ROUNDS : INT := IDENT_INT(0); -- ATTRIBUTE
- MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE
- POS : INT := IDENT_INT(0); -- ATTRIBUTE
- POSITION : INT := IDENT_INT(0); -- ATTRIBUTE
- PRED : INT := IDENT_INT(0); -- ATTRIBUTE
- SAFE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE
- SAFE_LARGE : INT := IDENT_INT(0); -- ATTRIBUTE
- SAFE_SMALL : INT := IDENT_INT(0); -- ATTRIBUTE
- SIZE : INT := IDENT_INT(0); -- ATTRIBUTE
- SMALL : INT := IDENT_INT(0); -- ATTRIBUTE
- STORAGE_SIZE : INT := IDENT_INT(0); -- ATTRIBUTE
- SUCC : INT := IDENT_INT(0); -- ATTRIBUTE
- TERMINATED : INT := IDENT_INT(0); -- ATTRIBUTE
- VAL : INT := IDENT_INT(0); -- ATTRIBUTE
- VALUE : INT := IDENT_INT(0); -- ATTRIBUTE
- WIDTH : INT := IDENT_INT(0); -- ATTRIBUTE
-
--- PREDEFINED TYPES
-
- BOOLEAN : INT := IDENT_INT(0); -- TYPE
- CHARACTER : INT := IDENT_INT(0); -- TYPE
- DURATION : INT := IDENT_INT(0); -- TYPE
- FLOAT : INT := IDENT_INT(0); -- TYPE
- INTEGER : INT := IDENT_INT(0); -- TYPE
- NATURAL : INT := IDENT_INT(0); -- TYPE
- POSITIVE : INT := IDENT_INT(0); -- TYPE
- STRING : INT := IDENT_INT(0); -- TYPE
-
--- PREDEFINED PACKAGE NAMES
-
- ASCII : INT := IDENT_INT(0); -- PACKAGE
- CALENDAR : INT := IDENT_INT(0); -- PACKAGE
- DIRECT_IO : INT := IDENT_INT(0); -- PACKAGE
- IO_EXCEPTIONS : INT := IDENT_INT(0); -- PACKAGE
- LOW_LEVEL_IO : INT := IDENT_INT(0); -- PACKAGE
- MACHINE_CODE : INT := IDENT_INT(0); -- PACKAGE
- SEQUENTIAL_IO : INT := IDENT_INT(0); -- PACKAGE
- SYSTEM : INT := IDENT_INT(0); -- PACKAGE
- TEXT_IO : INT := IDENT_INT(0); -- PACKAGE
- UNCHECKED_CONVERSION : INT := IDENT_INT(0); -- PACKAGE
- UNCHECKED_DEALLOCATION : INT := IDENT_INT(0); -- PACKAGE
-
-BEGIN
- TEST("A29003A", "NO ADDITIONAL RESERVED WORDS");
- RESULT;
-END A29003A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a2a031a.ada b/gcc/testsuite/ada/acats/tests/a/a2a031a.ada
deleted file mode 100644
index f89f904..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a2a031a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- A2A031A.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 EXCLAMATION MARK CAN REPLACE A VERTICAL BAR WHEN THE
--- VERTICAL BAR IS USED AS A SEPARATOR.
-
--- CONTEXTS ARE:
--- AS A CHOICE IN A VARIANT PART
--- IN A DISCRIMINANT CONSTRAINT
--- IN A CASE STATEMENT CHOICE
--- IN AN AGGREGATE
--- IN AN EXCEPTION HANDLER.
-
--- JBG 5/25/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE A2A031A IS
-
- TYPE ENUM IS (E1, E2, E3);
- TYPE REC (A, B : ENUM) IS
- RECORD
- C : INTEGER;
- CASE A IS
- WHEN E1 ! E2 => -- CHOICE OF VARIANT.
- D : INTEGER;
- WHEN E3 =>
- E : FLOAT;
- END CASE;
- END RECORD;
-
- EX1, EX2, EX3 : EXCEPTION;
-
- VAR : REC (A!B => E2); -- DISCRIMINANT CONSTRAINT.
-
- EVAR : ENUM := E2;
-
-BEGIN
-
- TEST ("A2A031A", "CHECK USE OF ! AS SEPARATOR IN PLACE OF |");
-
- CASE EVAR IS
- WHEN E3 => NULL;
- WHEN E2!E1 => NULL; -- CASE STATEMENT CHOICE.
- END CASE;
-
- VAR := (A!B => E2, C ! D => 0); -- AGGREGATE.
-
- RESULT;
-EXCEPTION
- WHEN EX1!EX2 ! EX3 => NULL; -- EXCEPTION HANDLER.
-END A2A031A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a33003a.ada b/gcc/testsuite/ada/acats/tests/a/a33003a.ada
deleted file mode 100644
index 8fe513f..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a33003a.ada
+++ /dev/null
@@ -1,49 +0,0 @@
--- A33003A.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 FOLLOWING FORMS OF ALMOST RECURSIVE TYPES CAN BE
--- DECLARED:
--- A) A RECORD HAVING A COMPONENT OF AN ACCESS TYPE WHOSE DESIGNATED
--- TYPE IS THE RECORD TYPE;
-
--- TBN 10/6/86
--- DTN 11/12/91 DELETED SUBPARTS (B and C).
-
-WITH REPORT; USE REPORT;
-PROCEDURE A33003A IS
-
- TYPE REC;
- TYPE ACC_REC IS ACCESS REC;
- TYPE REC IS
- RECORD
- A : INTEGER;
- B : ACC_REC;
- END RECORD;
-
-BEGIN
- TEST ("A33003A", "CHECK THAT ALMOST RECURSIVE TYPES CAN BE " &
- "DECLARED");
-
- RESULT;
-END A33003A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a34017c.ada b/gcc/testsuite/ada/acats/tests/a/a34017c.ada
deleted file mode 100644
index 8884f46..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a34017c.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- A34017C.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 DERIVED TYPE DEFINITION IS GIVEN IN THE VISIBLE PART
--- OF A PACKAGE, THE TYPE MAY BE USED AS THE PARENT TYPE IN A DERIVED
--- TYPE DEFINITION IN THE PRIVATE PART OF THE PACKAGE AND IN THE BODY.
-
--- CHECK THAT IF A TYPE IS DECLARED IN THE VISIBLE PART OF A PACKAGE,
--- AND IS NOT A DERIVED TYPE OR A PRIVATE TYPE, IT MAY BE USED AS THE
--- PARENT TYPE IN A DERIVED TYPE DEFINITION IN THE VISIBLE PART, PRIVATE
--- PART, AND BODY.
-
-
--- DSJ 4/27/83
-
-
-WITH REPORT;
-PROCEDURE A34017C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A34017C", "CHECK THAT A DERIVED TYPE MAY BE USED AS A " &
- "PARENT TYPE IN THE PRIVATE PART AND BODY. " &
- "CHECK THAT OTHER TYPES MAY BE USED AS PARENT " &
- "TYPES IN VISIBLE PART ALSO");
-
- DECLARE
-
- TYPE REC IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PACKAGE PACK1 IS
-
- TYPE T1 IS RANGE 1 .. 10;
- TYPE T2 IS NEW REC;
-
- TYPE T3 IS (A,B,C);
- TYPE T4 IS ARRAY ( 1 .. 2 ) OF INTEGER;
- TYPE T5 IS
- RECORD
- X : CHARACTER;
- END RECORD;
- TYPE T6 IS ACCESS INTEGER;
-
- TYPE N1 IS NEW T3;
- TYPE N2 IS NEW T4;
- TYPE N3 IS NEW T5;
- TYPE N4 IS NEW T6;
-
- PRIVATE
-
- TYPE P1 IS NEW T1;
- TYPE P2 IS NEW T2;
- TYPE P3 IS NEW T3;
- TYPE P4 IS NEW T4;
- TYPE P5 IS NEW T5;
- TYPE P6 IS NEW T6;
-
- END PACK1;
-
- PACKAGE BODY PACK1 IS
-
- TYPE Q1 IS NEW T1;
- TYPE Q2 IS NEW T2;
- TYPE Q3 IS NEW T3;
- TYPE Q4 IS NEW T4;
- TYPE Q5 IS NEW T5;
- TYPE Q6 IS NEW T6;
-
- END PACK1;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END A34017C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a35101b.ada b/gcc/testsuite/ada/acats/tests/a/a35101b.ada
deleted file mode 100644
index a8e5d12..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a35101b.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- A35101B.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 ONE ENUMERATION LITERAL IS PERMITTED IN AN ENUMERATION
--- TYPE DEFINITION.
-
--- RJW 2/14/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE A35101B IS
-
-BEGIN
-
- TEST ("A35101B", "CHECK THAT ONE ENUMERATION LITERAL IS " &
- "PERMITTED IN AN ENUMERATION TYPE " &
- "DEFINITION" );
- DECLARE
-
- TYPE E1 IS (A); -- OK.
- TYPE E2 IS ('1'); -- OK.
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A35101B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a35402a.ada b/gcc/testsuite/ada/acats/tests/a/a35402a.ada
deleted file mode 100644
index 03df442..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a35402a.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- A35402A.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 BOUNDS OF AN INTEGER TYPE DEFINITION NEED NOT
--- HAVE THE SAME INTEGER TYPE.
-
--- RJW 2/20/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE A35402A IS
-
-BEGIN
-
- TEST ( "A35402A", "CHECK THAT THE BOUNDS OF AN INTEGER " &
- "TYPE DEFINITION NEED NOT HAVE THE SAME " &
- "INTEGER TYPE" );
-
- DECLARE
- TYPE INT1 IS RANGE 1 .. 10;
- TYPE INT2 IS RANGE 2 .. 8;
- TYPE INT3 IS NEW INTEGER;
-
- I : CONSTANT INTEGER := 5;
- I1 : CONSTANT INT1 := 5;
- I2 : CONSTANT INT2 := 5;
- I3 : CONSTANT INT3 := 5;
-
- TYPE INTRANGE1 IS RANGE I .. I1; -- OK.
-
- TYPE INTRANGE2 IS RANGE I1 .. I2; -- OK.
-
- TYPE INTRANGE3 IS RANGE I2 .. I3; -- OK.
-
- TYPE INTRANGE4 IS RANGE I3 .. I; -- OK.
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A35402A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a35801f.ada b/gcc/testsuite/ada/acats/tests/a/a35801f.ada
deleted file mode 100644
index bc50d2c..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a35801f.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- A35801F.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 ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE
--- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A FLOATING POINT
--- TYPE.
-
--- THIS CHECK IS PROVIDED THROUGH THE USE OF THIS TEST IN CONJUNCTION
--- WITH TEST B35801C.
-
--- R.WILLIAMS 8/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE A35801F IS
-
- TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0;
- SUBTYPE SURREAL IS REAL RANGE -50.0 .. 50.0;
-
- TYPE NFLT IS NEW FLOAT;
- SUBTYPE UNIT IS NFLT RANGE -1.0 .. 1.0;
-
- SUBTYPE EMPTY IS FLOAT RANGE 1.0 .. -1.0;
-
- R1 : REAL := SURREAL'FIRST; -- OK.
- R2 : REAL := SURREAL'LAST; -- OK.
-
- N1 : NFLT := UNIT'FIRST; -- OK.
- N2 : NFLT := UNIT'LAST; -- OK.
-
- F1 : FLOAT := FLOAT'FIRST; -- OK.
- F2 : FLOAT := FLOAT'LAST; -- OK.
-
- E1 : FLOAT := EMPTY'FIRST; -- OK.
- E2 : FLOAT := EMPTY'LAST; -- OK.
-
-BEGIN
- TEST ( "A35801F", "CHECK THAT THE ATTRIBUTES FIRST AND LAST " &
- "RETURN VALUES HAVING THE SAME BASE TYPE AS " &
- "THE PREFIX WHEN THE PREFIX IS A FLOATING " &
- "POINT TYPE" );
-
- RESULT;
-END A35801F;
diff --git a/gcc/testsuite/ada/acats/tests/a/a35902c.ada b/gcc/testsuite/ada/acats/tests/a/a35902c.ada
deleted file mode 100644
index 2dd0c9b..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a35902c.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- A35902C.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 FIXED POINT TYPE WITH ONLY ONE MODEL NUMBER IS
--- ALLOWED.
-
--- HISTORY:
--- RJW 02/26/86 CREATED ORIGINAL TEST.
--- DHH 10/15/87 CORRECTED RANGE ERRORS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE A35902C IS
-
-BEGIN
-
- TEST ("A35902C", "CHECK THAT A FIXED POINT TYPE WITH ONLY ONE " &
- "MODEL NUMBER IS ALLOWED" );
- DECLARE
- TYPE F IS DELTA 1.0 RANGE -0.5 .. 0.5; -- OK.
- F1 : F := 0.0;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A35902C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a38106d.ada b/gcc/testsuite/ada/acats/tests/a/a38106d.ada
deleted file mode 100644
index 7db6aa6..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a38106d.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- A38106D.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 AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE
--- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON
--- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE
--- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
--- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE
--- INCOMPLETE TYPE.
-
--- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES
--- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES
--- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY
--- TYPES
-
--- PART 1: FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE SPECIFICATION.
-
--- DSJ 5/05/83
--- SPS 10/18/83
--- EG 12/19/83
-
-WITH REPORT ;
-PROCEDURE A38106D IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A38106D", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " &
- "TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " &
- "EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " &
- "ACCESS TYPE AND AFTER THE FULL DECLARATION " &
- "(WHICH IS IN THE PACKAGE SPECIFICATION)") ;
-
- DECLARE
-
- PACKAGE PACK1 IS
- TYPE T1 ;
- TYPE T2 ;
-
- PACKAGE PACK2 IS
- TYPE ACC1 IS ACCESS T1 ;
- TYPE ACC2 IS ACCESS T2 ;
- END PACK2 ;
-
- TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
- TYPE T2 IS
- RECORD
- C1, C2 : INTEGER ;
- END RECORD ;
- END PACK1 ;
-
- PACKAGE BODY PACK1 IS
- A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL
- A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL
- R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL
- R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL
-
- PACKAGE BODY PACK2 IS
- X1 : INTEGER := A1(1) ; -- LEGAL
- X2 : INTEGER := A1'FIRST ; -- LEGAL
- X3 : INTEGER := A1'LAST ; -- LEGAL
- X4 : INTEGER := A1'LENGTH ; -- LEGAL
- B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL
- X5 : INTEGER := R1.C1 ; -- LEGAL
- END PACK2 ;
-
- END PACK1 ;
-
- BEGIN
-
- NULL ;
-
- END ;
-
- RESULT ;
-
-END A38106D ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a38106e.ada b/gcc/testsuite/ada/acats/tests/a/a38106e.ada
deleted file mode 100644
index a0778ac..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a38106e.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- A38106E.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 AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE
--- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON
--- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE
--- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
--- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE
--- INCOMPLETE TYPE.
-
--- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES
--- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES
--- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY
--- TYPES
-
--- PART 2 : FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE BODY
-
--- DSJ 5/05/83
--- SPS 10/18/83
--- EG 12/19/83
-
-WITH REPORT ;
-PROCEDURE A38106E IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A38106E", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " &
- "TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " &
- "EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " &
- "ACCESS TYPE AND AFTER THE FULL DECLARATION " &
- "(WHICH IS IN THE PACKAGE BODY)");
-
- DECLARE
-
- PACKAGE PACK1 IS
- PRIVATE
- TYPE T1 ;
- TYPE T2 ;
- PACKAGE PACK2 IS
- TYPE ACC1 IS ACCESS T1 ;
- TYPE ACC2 IS ACCESS T2 ;
- END PACK2 ;
- END PACK1 ;
-
- PACKAGE BODY PACK1 IS
- TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
- TYPE T2 IS
- RECORD
- C1, C2 : INTEGER ;
- END RECORD ;
-
- A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL
- A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL
- R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL
- R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL
-
- PACKAGE BODY PACK2 IS
- X1 : INTEGER := A1(1) ; -- LEGAL
- X2 : INTEGER := A1'FIRST ; -- LEGAL
- X3 : INTEGER := A1'LAST ; -- LEGAL
- X4 : INTEGER := A1'LENGTH ; -- LEGAL
- B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL
- X5 : INTEGER := R1.C1 ; -- LEGAL
- END PACK2 ;
-
- END PACK1 ;
-
- BEGIN
-
- NULL ;
-
- END ;
-
- RESULT ;
-
-END A38106E ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a49027a.ada b/gcc/testsuite/ada/acats/tests/a/a49027a.ada
deleted file mode 100644
index 83e531b..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a49027a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- A49027A.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 SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE AND
--- STATIC IN THE CORRESPONDING INSTANCE.
--- CHECK THAT FOR A GENERIC INSTANTIATION, IF THE ACTUAL PARAMETER
--- IS A STATIC SUBTYPE, THEN EVERY USE OF THE CORRESPONDING FORMAL
--- PARAMETER WITHIN THE INSTANCE IS CONSIDERED TO DENOTE A STATIC
--- SUBTYPE
---
--- THIS IS A TEST BASED ON AI-00409/05-BI-WJ.
-
--- HISTORY:
--- EDWARD V. BERARD, 27 AUGUST 1990
--- CJJ 10 OCT 1990 TEST OBJECTIVE CHANGED TO REFLECT AIG
--- OBJECTIVE.
-
-WITH REPORT ;
-
-PROCEDURE A49027A IS
-
-BEGIN -- A49027A
-
- REPORT.TEST ("A49027A", "CHECK THAT A SUBTYPE CAN BE NONSTATIC " &
- "IN A GENERIC TEMPLATE AND STATIC IN THE " &
- "CORRESPONDING INSTANCE.") ;
-
- LOCAL_BLOCK:
-
- DECLARE
-
- TYPE NUMBER IS RANGE 1 .. 10 ;
-
- GENERIC
-
- TYPE NUMBER_TYPE IS RANGE <> ;
-
- PACKAGE STATIC_TEST IS
-
- TYPE NEW_NUMBER_TYPE IS NEW NUMBER_TYPE ;
- SUBTYPE SUB_NUMBER_TYPE IS NUMBER_TYPE ;
-
- END STATIC_TEST ;
-
- PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST
- (NUMBER_TYPE => NUMBER) ;
-
- TYPE ANOTHER_NUMBER IS RANGE
- NEW_STATIC_TEST.NEW_NUMBER_TYPE'FIRST ..
- NEW_STATIC_TEST.NEW_NUMBER_TYPE'LAST ;
-
- TYPE YET_ANOTHER_NUMBER IS RANGE
- NEW_STATIC_TEST.SUB_NUMBER_TYPE'FIRST ..
- NEW_STATIC_TEST.SUB_NUMBER_TYPE'LAST ;
-
- BEGIN -- LOCAL_BLOCK
-
- NULL ;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT ;
-
-END A49027A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a49027b.ada b/gcc/testsuite/ada/acats/tests/a/a49027b.ada
deleted file mode 100644
index a27956d..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a49027b.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- A49027B.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 SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE
--- AND STATIC IN THE CORRESPONDING INSTANCE.
-
--- CHECK THAT IF A GENERIC PARAMETER IS A STATIC EXPRESSION AND THE
--- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE,
--- THEN EACH USE OF THE FORMAL PARAMETERS IN THE INSTANCE IS SAID TO
--- BE STATIC.
---
--- A NAME DENOTING A CONSTANT DECLARED IN A GENERIC INSTANCE IS
--- ALLOWED AS A PRIMARY IN A STATIC EXPRESSION IF THE CONSTANT
--- IS DECLARED BY A CONSTANT DECLARATION WITH A STATIC SUBTYPE
--- AND INITIALIZED WITH A STATIC EXPRESSION.
---
--- THIS IS A TEST BASED ON AI-00505/03-BI-WA.
-
--- HISTORY:
--- EDWARD V. BERARD, 27 AUGUST 1990
--- DAS 8 OCT 90 ADDED CODE TO MATCH EXAMPLE 1 IN
--- AI-00505.
--- JRL 05/29/92 CORRECTED MINOR PROBLEM IN REPORT.TEST STRING.
--- JRL 02/18/93 EXPANDED TEXT OF REPORT.TEST STRING.
--- PWN 04/14/95 CORRECTED MINOR COPYRIGHT COMMENT PROBLEM.
-
-
-WITH REPORT ;
-
-PROCEDURE A49027B IS
-
-BEGIN -- A49027B
-
- REPORT.TEST ("A49027B", "CHECK THAT IF A GENERIC ACTUAL " &
- "PARAMETER IS A STATIC EXPRESSION AND THE " &
- "CORRESPONDING FORMAL PARAMETER HAS A STATIC " &
- "SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " &
- "FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE " &
- "STATIC. CHECK THAT A NAME DENOTING A CONSTANT " &
- "DECLARED IN A GENERIC INSTANCE IS ALLOWED AS " &
- "A PRIMARY IN A STATIC EXPRESSION IF THE " &
- "CONSTANT IS DECLARED BY A CONSTANT DECLARATION " &
- "WITH A STATIC SUBTYPE AND INITIALIZED WITH A " &
- "STATIC EXPRESSION. (AI-00505)");
-
- LOCAL_BLOCK:
-
- DECLARE
-
- TYPE NUMBER IS RANGE 1 .. 10 ;
- TYPE COLOR IS (RED, ORANGE, YELLOW, GREEN, BLUE) ;
- MIDDLE_COLOR : CONSTANT COLOR := GREEN ;
-
- ENUMERATED_VALUE : COLOR := COLOR'LAST ;
-
- GENERIC
-
- TYPE NUMBER_TYPE IS RANGE <> ;
- X : INTEGER ;
- TYPE ENUMERATED IS (<>) ;
-
- FIRST_NUMBER : IN NUMBER_TYPE ;
- SECOND_NUMBER : IN NUMBER_TYPE ;
- THIRD_NUMBER : IN NUMBER_TYPE ;
- FIRST_ENUMERATED : IN ENUMERATED ;
- SECOND_ENUMERATED : IN ENUMERATED ;
- THIRD_ENUMERATED : IN ENUMERATED ;
-
- FIRST_INTEGER_VALUE : IN INTEGER ;
- SECOND_INTEGER_VALUE : IN INTEGER ;
-
- PACKAGE STATIC_TEST IS
-
- Y : CONSTANT INTEGER := X;
- Z : CONSTANT NUMBER_TYPE := 5;
-
- SUBTYPE FIRST_NUMBER_SUBTYPE IS NUMBER_TYPE
- RANGE FIRST_NUMBER .. SECOND_NUMBER ;
- SUBTYPE SECOND_NUMBER_SUBTYPE IS NUMBER_TYPE
- RANGE FIRST_NUMBER .. THIRD_NUMBER ;
-
- SUBTYPE FIRST_ENUMERATED_SUBTYPE IS ENUMERATED
- RANGE FIRST_ENUMERATED .. SECOND_ENUMERATED ;
- SUBTYPE SECOND_ENUMERATED_SUBTYPE IS ENUMERATED
- RANGE FIRST_ENUMERATED .. THIRD_ENUMERATED ;
-
- SUBTYPE THIRD_NUMBER_TYPE IS INTEGER
- RANGE FIRST_INTEGER_VALUE .. SECOND_INTEGER_VALUE ;
-
- END STATIC_TEST ;
-
- PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST
- (NUMBER_TYPE => NUMBER,
- X => 3,
- ENUMERATED => COLOR,
- FIRST_NUMBER => NUMBER'FIRST,
- SECOND_NUMBER => NUMBER'LAST,
- THIRD_NUMBER => NUMBER'SUCC(NUMBER'FIRST),
- FIRST_ENUMERATED => RED,
- SECOND_ENUMERATED => MIDDLE_COLOR,
- THIRD_ENUMERATED => COLOR'VAL (1),
- FIRST_INTEGER_VALUE => COLOR'POS (YELLOW),
- SECOND_INTEGER_VALUE => NUMBER'POS (5)) ;
-
- TYPE T1 IS RANGE 1 .. NEW_STATIC_TEST.Y;
- TYPE T2 IS RANGE 1 .. NEW_STATIC_TEST.Z;
-
- TYPE ANOTHER_NUMBER IS RANGE
- NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'FIRST ..
- NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'LAST ;
-
- TYPE YET_ANOTHER_NUMBER IS RANGE
- NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'FIRST ..
- NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'LAST ;
-
- TYPE STILL_ANOTHER_NUMBER IS RANGE
- NEW_STATIC_TEST.THIRD_NUMBER_TYPE'FIRST ..
- NEW_STATIC_TEST.THIRD_NUMBER_TYPE'LAST ;
-
- BEGIN -- LOCAL_BLOCK
-
- CASE ENUMERATED_VALUE IS
- WHEN YELLOW => NULL ;
- WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'FIRST
- => NULL ;
- WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'LAST
- => NULL ;
- WHEN NEW_STATIC_TEST.SECOND_ENUMERATED_SUBTYPE'LAST
- => NULL ;
- WHEN COLOR'LAST => NULL ;
- END CASE ;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT ;
-
-END A49027B ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a49027c.ada b/gcc/testsuite/ada/acats/tests/a/a49027c.ada
deleted file mode 100644
index a10449e..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a49027c.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- A49027C.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 GENERIC PARAMETER IS A STATIC EXPRESSION AND THE
--- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE,
--- THEN EACH USE OF THE FORMAL PARAMETER IN THE INSTANCE IS SAID TO
--- BE STATIC.
---
--- SEE AI-00505. THIS TEST IS TAKEN FROM THE SECOND EXAMPLE.
---
--- HISTORY:
--- DAS 8 OCT 90 INITIAL VERSION.
--- PWN 12/01/95 CORRECTED FORMAT OF CALL TO REPORT.TEST
--- KAS 25NOV96 CHANGED LITERAL 7 TO (IMPDEF.CHAR_BITS-1)
---!
-
-WITH REPORT; USE REPORT;
-WITH IMPDEF;
-
-PROCEDURE A49027C IS
-
- GENERIC
- X : INTEGER;
- PACKAGE GP IS
- TYPE REC IS
- RECORD
- C : STRING (1..X);
- END RECORD;
- END GP;
-
- PACKAGE NP IS NEW GP (1);
-
- TYPE NR IS NEW NP.REC;
- FOR NR USE
- RECORD
- C AT 0 RANGE 0..IMPDEF.CHAR_BITS-1; -- SUBTYPE INDICATION
- END RECORD; -- FOR C IN NP IS CONSIDERED STATIC.
-
-BEGIN
- TEST("A49027C", "CHECK THAT IF A GENERIC PARAMETER IS A STATIC " &
- "EXPRESSION AND THE CORRESPONDING (IN) PARAMETER HAS A " &
- "STATIC SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " &
- "FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE STATIC.");
-
- RESULT;
-
-END A49027C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a54b01a.ada b/gcc/testsuite/ada/acats/tests/a/a54b01a.ada
deleted file mode 100644
index 6a7b1ac..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a54b01a.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- A54B01A.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 CASE EXPRESSION IS A CONSTANT, VARIABLE,
--- TYPE CONVERSION, OR QUALIFIED EXPRESSION,
--- AND THE SUBTYPE OF THE
--- EXPRESSION IS STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL
--- VALUES IN THE SUBTYPE'S RANGE ARE COVERED.
-
-
--- RM 01/23/80
--- SPS 10/26/82
--- SPS 2/1/83
-
-WITH REPORT ;
-PROCEDURE A54B01A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A54B01A" , "CHECK THAT IF" &
- " THE SUBTYPE OF A CASE EXPRESSION IS STATIC," &
- " AN 'OTHERS' CAN BE OMITTED IF ALL" &
- " VALUES IN THE SUBTYPE'S RANGE ARE COVERED" );
-
- -- THE TEST CASES APPEAR IN THE FOLLOWING ORDER:
- --
- -- I. CONSTANTS
- --
- -- II. STATIC SUBRANGES
- --
- -- (A) VARIABLES (INTEGER , BOOLEAN)
- -- (B) QUALIFIED EXPRESSIONS
- -- (C) TYPE CONVERSIONS
-
- DECLARE -- CONSTANTS
- T : CONSTANT BOOLEAN := TRUE;
- FIVE : CONSTANT INTEGER := IDENT_INT(5);
- BEGIN
-
- CASE FIVE IS
- WHEN INTEGER'FIRST..4 => NULL ;
- WHEN 5 => NULL ;
- WHEN 6 .. INTEGER'LAST => NULL ;
- END CASE;
-
- CASE T IS
- WHEN TRUE => NULL ;
- WHEN FALSE => NULL ;
- END CASE;
-
- END ;
-
-
- DECLARE -- STATIC SUBRANGES
-
- SUBTYPE STAT IS INTEGER RANGE 1..5 ;
- I : INTEGER RANGE 1..5 ;
- J : STAT ;
- BOOL: BOOLEAN := FALSE ;
- CHAR: CHARACTER := 'U' ;
- TYPE ENUMERATION IS ( FIRST,SECOND,THIRD,FOURTH,FIFTH );
- ENUM: ENUMERATION := THIRD ;
-
-
- BEGIN
-
- I := IDENT_INT( 2 );
- J := IDENT_INT( 2 );
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- CASE BOOL IS
- WHEN TRUE => NULL ;
- WHEN FALSE => NULL ;
- END CASE;
-
- CASE STAT'( 2 ) IS
- WHEN 5 | 2..4 => NULL ;
- WHEN 1 => NULL ;
- END CASE;
-
- CASE STAT( J ) IS
- WHEN 5 | 2..4 => NULL ;
- WHEN 1 => NULL ;
- END CASE;
-
-
- END ; -- STATIC SUBRANGES
-
- RESULT ;
-
-
-END A54B01A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a54b02a.ada b/gcc/testsuite/ada/acats/tests/a/a54b02a.ada
deleted file mode 100644
index 08d908e..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a54b02a.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- A54B02A.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 CASE EXPRESSION IS A VARIABLE, CONSTANT, TYPE
--- CONVERSION, ATTRIBUTE (IN PARTICULAR 'FIRST AND 'LAST),
--- FUNCTION INVOCATION, QUALIFIED EXPRESSION, OR A PARENTHESIZED
--- EXPRESSION HAVING ONE OF THESE FORMS, AND THE SUBTYPE OF THE
--- EXPRESSION IS NON-STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL
--- VALUES IN THE BASE TYPE'S RANGE ARE COVERED.
-
--- RM 01/27/80
--- SPS 10/26/82
--- SPS 2/2/83
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT ;
-PROCEDURE A54B02A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A54B02A" , "CHECK THAT IF THE" &
- " SUBTYPE OF A CASE EXPRESSION IS NON-STATIC," &
- " AN 'OTHERS' CAN BE OMITTED IF ALL" &
- " VALUES IN THE BASE TYPE'S RANGE ARE COVERED" );
-
- -- THE TEST CASES APPEAR IN THE FOLLOWING ORDER:
- --
- -- (A) VARIABLES (INTEGER , BOOLEAN)
- -- (B) CONSTANTS (INTEGER, BOOLEAN)
- -- (C) ATTRIBUTES ('FIRST, 'LAST)
- -- (D) FUNCTION CALLS
- -- (E) QUALIFIED EXPRESSIONS
- -- (F) TYPE CONVERSIONS
- -- (G) PARENTHESIZED EXPRESSIONS OF THE ABOVE KINDS
-
-
- DECLARE -- NON-STATIC RANGES
-
- SUBTYPE STAT IS INTEGER RANGE 1..50 ;
- SUBTYPE DYN IS STAT RANGE 1..IDENT_INT( 5 ) ;
- I : STAT RANGE 1..IDENT_INT( 5 );
- J : DYN ;
- SUBTYPE DYNCHAR IS
- CHARACTER RANGE ASCII.NUL .. IDENT_CHAR('Q');
- SUBTYPE STATCHAR IS
- DYNCHAR RANGE 'A' .. 'C' ;
- CHAR: DYNCHAR := 'F' ;
- TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N );
- SUBTYPE STATENUM IS
- ENUMERATION RANGE A .. L ;
- SUBTYPE DYNENUM IS
- STATENUM RANGE A .. ENUMERATION'VAL(IDENT_INT(5));
- ENUM: DYNENUM := B ;
- CONS : CONSTANT DYN := 3;
-
- FUNCTION FF RETURN DYN IS
- BEGIN
- RETURN 2 ;
- END FF ;
-
- BEGIN
-
- I := IDENT_INT( 2 );
- J := IDENT_INT( 2 );
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
- CASE J IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
- CASE CONS IS
- WHEN INTEGER'FIRST..INTEGER'LAST => NULL;
- END CASE;
-
- CASE DYN'FIRST IS
- WHEN INTEGER'FIRST..0 => NULL;
- WHEN 1..INTEGER'LAST => NULL;
- END CASE;
-
- CASE STATCHAR'LAST IS
- WHEN CHARACTER'FIRST..'A' => NULL;
- WHEN 'B'..CHARACTER'LAST => NULL;
- END CASE;
-
- CASE FF IS
- WHEN 4..5 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- WHEN 1..3 => NULL ;
- END CASE;
-
- CASE DYN'( 2 ) IS
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- WHEN 5 | 2..4 => NULL ;
- WHEN 1 => NULL ;
- END CASE;
-
- CASE DYN( J ) IS
- WHEN 5 | 2..4 => NULL ;
- WHEN 1 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
-
- CASE ( CHAR ) IS
- WHEN ASCII.NUL .. 'P' => NULL ;
- WHEN 'Q' => NULL ;
- WHEN 'R' .. 'Y' => NULL ;
- WHEN 'Z' .. CHARACTER'LAST => NULL ;
- END CASE;
-
- CASE ( ENUM ) IS
- WHEN A | C | E => NULL ;
- WHEN B | D => NULL ;
- WHEN F .. L => NULL ;
- WHEN M .. N => NULL ;
- END CASE;
-
- CASE ( FF ) IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
- CASE ( DYN'( I ) ) IS
- WHEN 4..5 => NULL ;
- WHEN 1..3 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
- CASE ( DYN( 2 ) ) IS
- WHEN 5 | 2..4 => NULL ;
- WHEN 1 => NULL ;
- WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ;
- END CASE;
-
- CASE (CONS) IS
- WHEN 1..100 => NULL;
- WHEN INTEGER'FIRST..0 => NULL;
- WHEN 101..INTEGER'LAST => NULL;
- END CASE;
-
- CASE (DYNCHAR'LAST) IS
- WHEN 'B'..'Y' => NULL;
- WHEN CHARACTER'FIRST..'A' => NULL;
- WHEN 'Z'..CHARACTER'LAST => NULL;
- END CASE;
-
- END;
-
-
- RESULT ;
-
-
-END A54B02A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a55b12a.ada b/gcc/testsuite/ada/acats/tests/a/a55b12a.ada
deleted file mode 100644
index 7545807..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a55b12a.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- A55B12A.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 SUBTYPE OF A LOOP PARAMETER IN A LOOP OF THE FORM
---
--- FOR I IN ST RANGE L..R LOOP
---
--- IS CORRECTLY DETERMINED SO THAT WHEN THE LOOP PARAMETER IS USED
--- IN A CASE STATEMENT AN 'OTHERS' ALTERNATIVE IS NOT REQUIRED IF
--- THE CHOICES COVER THE APPROPRIATE RANGE OF SUBTYPE VALUES.
-
--- CASE A :
--- L AND R ARE BOTH STATIC EXPRESSIONS, AND ST IS A STATIC
--- SUBTYPE COVERING A RANGE GREATER THAN L..R .
-
-
--- RM 02/02/80
--- JRK 03/02/83
-
-WITH REPORT ;
-PROCEDURE A55B12A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A55B12A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
- " IN A LOOP OF THE FORM 'FOR I IN ST RANGE" &
- " L..R LOOP' IS CORRECTLY DETERMINED (A)" );
-
- DECLARE
-
- SUBTYPE STAT IS INTEGER RANGE 1..10 ;
- TYPE NEW_STAT IS NEW INTEGER RANGE 1..10 ;
-
- TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N );
- SUBTYPE STAT_E IS ENUMERATION RANGE A..L ;
- SUBTYPE STAT_B IS BOOLEAN RANGE FALSE..TRUE ;
- SUBTYPE STAT_C IS CHARACTER RANGE 'A'..'L' ;
-
- BEGIN
-
- FOR I IN STAT RANGE 1..5 LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
- FOR I IN NEW_STAT RANGE 1..5 LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
- FOR I IN INTEGER RANGE 1..5 LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN REVERSE STAT RANGE 1..5 LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN STAT_E RANGE A..E LOOP
-
- CASE I IS
- WHEN C..E => NULL ;
- WHEN A..B => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN STAT_B RANGE TRUE..TRUE LOOP
-
- CASE I IS
- WHEN TRUE => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN STAT_C RANGE 'A'..'E' LOOP
-
- CASE I IS
- WHEN 'A'..'C' => NULL ;
- WHEN 'D'..'E' => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN STAT_C RANGE 'E'..'B' LOOP
-
- CASE I IS
- WHEN 'D'..'C' => NULL ;
- WHEN 'E'..'B' => NULL ;
- WHEN 'F'..'A' => NULL ;
- WHEN 'M'..'A' => NULL ;
- END CASE;
-
- END LOOP;
-
-
- END ;
-
- RESULT ;
-
-END A55B12A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a55b13a.ada b/gcc/testsuite/ada/acats/tests/a/a55b13a.ada
deleted file mode 100644
index c2cc5ac..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a55b13a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- A55B13A.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.
---*
--- USING A CASE_STATEMENT , CHECK THAT IF L , R ARE LITERALS
--- OF TYPE T (INTEGER, BOOLEAN, CHARACTER, USER-DEFINED
--- ENUMERATION TYPE) THE SUBTYPE BOUNDS ASSOCIATED WITH A
--- LOOP OF THE FORM
--- FOR I IN L..R LOOP
--- ARE THE SAME AS THOSE FOR THE CORRESPONDING LOOP OF THE FORM
--- FOR I IN T RANGE L..R LOOP .
-
-
--- RM 04/07/81
--- SPS 3/2/83
--- JBG 8/21/83
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT ;
-PROCEDURE A55B13A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A55B13A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
- " IN A LOOP OF THE FORM 'FOR I IN " &
- " LITERAL_L .. LITERAL_R LOOP' IS CORRECTLY" &
- " DETERMINED" );
-
- DECLARE
-
- TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H );
- ONE : CONSTANT := 1 ;
- FIVE : CONSTANT := 5 ;
-
-
- BEGIN
-
-
- FOR I IN 1..5 LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN REVERSE ONE .. FIVE LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL ;
- WHEN 2 | 4 => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN REVERSE FALSE..TRUE LOOP
-
- CASE I IS
- WHEN FALSE => NULL ;
- WHEN TRUE => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN CHARACTER'('A') .. ASCII.DEL LOOP
-
- CASE I IS
- WHEN CHARACTER'('A')..CHARACTER'('U') => NULL ;
- WHEN CHARACTER'('V')..ASCII.DEL => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN CHARACTER'('A')..CHARACTER'('H') LOOP
-
- CASE I IS
- WHEN CHARACTER'('A')..CHARACTER'('D') => NULL ;
- WHEN CHARACTER'('E')..CHARACTER'('H') => NULL ;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN REVERSE B..H LOOP
-
- CASE I IS
- WHEN B..D => NULL ;
- WHEN E..H => NULL ;
- WHEN MIDPOINT => NULL ;
- END CASE;
-
- END LOOP;
-
-
- END ;
-
-
- RESULT ;
-
-
-END A55B13A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a55b14a.ada b/gcc/testsuite/ada/acats/tests/a/a55b14a.ada
deleted file mode 100644
index 617d95b..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a55b14a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- A55B14A.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.
---*
--- USING A CASE_STATEMENT , CHECK THAT THE SUBTYPE BOUNDS ASSOCIATED
--- WITH A LOOP OF THE FORM
--- FOR I IN ST LOOP
--- ARE, RESPECTIVELY, ST'FIRST..ST'LAST WHEN ST IS STATIC.
-
--- RM 04/07/81
--- SPS 3/2/83
--- JBG 3/14/83
-
-WITH REPORT;
-PROCEDURE A55B14A IS
-
- USE REPORT;
- USE ASCII ;
-
- TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H );
- SUBTYPE ST_I IS INTEGER RANGE 1..5 ;
- TYPE NEW_ST_I IS NEW INTEGER RANGE 1..5 ;
- SUBTYPE ST_E IS ENUMERATION RANGE B..G ;
- SUBTYPE ST_B IS BOOLEAN RANGE FALSE..FALSE;
- SUBTYPE ST_C IS CHARACTER RANGE 'A'..DEL ;
-
-BEGIN
-
- TEST("A55B14A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" &
- " IN A LOOP OF THE FORM 'FOR I IN ST LOOP'" &
- " ARE CORRECTLY DETERMINED WHEN ST IS STATIC" );
-
- BEGIN
-
-
- FOR I IN ST_I LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL;
- WHEN 2 | 4 => NULL;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN NEW_ST_I LOOP
-
- CASE I IS
- WHEN 1 | 3 | 5 => NULL;
- WHEN 2 | 4 => NULL;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN ST_B LOOP
-
- CASE I IS
- WHEN FALSE => NULL;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN ST_C LOOP
-
- CASE I IS
- WHEN 'A'..'U' => NULL;
- WHEN 'V'..DEL => NULL;
- END CASE;
-
- END LOOP;
-
-
- FOR I IN ST_E LOOP
-
- CASE I IS
- WHEN B..D => NULL;
- WHEN E..G => NULL;
- WHEN MIDPOINT => NULL;
- END CASE;
-
- END LOOP;
-
-
- END;
-
-
- RESULT;
-
-
-END A55B14A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a71004a.ada b/gcc/testsuite/ada/acats/tests/a/a71004a.ada
deleted file mode 100644
index da793a8..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a71004a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- A71004A.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 FORMS OF DECLARATION PERMITTED IN THE PRIVATE PART OF
--- A PACKAGE ARE INDEED ACCEPTED BY THE COMPILER.
--- TASKS, GENERICS, FIXED AND FLOAT DECLARATIONS ARE NOT TESTED.
-
--- DAT 5/6/81
--- VKG 2/16/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE A71004A IS
-BEGIN
-
- TEST ("A71004A", "ALL FORMS OF DECLARATIONS IN PRIVATE PART");
-
- DD:
- DECLARE
-
- PACKAGE P1 IS
-
- TYPE P IS PRIVATE;
- TYPE L IS LIMITED PRIVATE;
- CP : CONSTANT P;
- CL : CONSTANT L;
-
- PRIVATE
-
- ONE : CONSTANT := 1;
- TWO : CONSTANT := ONE * 1.0 + 1.0;
- N1, N2, N3 : CONSTANT := TWO;
- TYPE I IS RANGE -10 .. 10;
- X4, X5 : CONSTANT I := I(IDENT_INT(3));
- X6, X7 : I := X4 + X5;
- TYPE AR IS ARRAY (I) OF L;
-
- X10 : ARRAY (IDENT_INT(1) .. IDENT_INT (10)) OF I;
- X11 : CONSTANT ARRAY (1..10) OF I := (1..10=>3);
- TYPE T3 IS (E12);
- TYPE T4 IS NEW T3;
-
- TYPE REC1 (D:BOOLEAN:=TRUE) IS RECORD NULL; END RECORD;
- SUBTYPE REC1TRUE IS REC1( D => TRUE ) ;
- TYPE L IS NEW REC1TRUE ;
- X8 , X9 : AR;
- TYPE A6 IS ACCESS REC1 ;
- SUBTYPE L1 IS L ;
- SUBTYPE A7 IS A6(D=>TRUE);
- SUBTYPE I14 IS I RANGE 1 .. 1;
- TYPE UA1 IS ARRAY (I14 RANGE <> ) OF I14;
- TYPE UA2 IS NEW UA1;
- USE STANDARD.ASCII;
-
- PROCEDURE P1 ;
-
- FUNCTION F1 (X : UA1) RETURN UA1;
-
- FUNCTION "+" (X : UA1) RETURN UA1;
-
- PACKAGE PK IS
- PRIVATE
- END;
-
- PACKAGE PK1 IS
- PACKAGE PK2 IS END;
- PRIVATE
- PACKAGE PK3 IS PRIVATE END;
- END PK1;
-
- EX : EXCEPTION;
- EX1, EX2 : EXCEPTION;
- X99 : I RENAMES X7;
- EX3 : EXCEPTION RENAMES EX1;
- PACKAGE PQ1 RENAMES DD.P1;
- PACKAGE PQ2 RENAMES PK1;
- PACKAGE PQ3 RENAMES PQ2 . PK2;
- FUNCTION "-" (X : UA1) RETURN UA1 RENAMES "+";
- PROCEDURE P98 RENAMES P1;
- TYPE P IS NEW L;
- CP : CONSTANT P := (D=> TRUE);
- CL : CONSTANT L := L(CP);
-
- END P1;
-
- PACKAGE BODY P1 IS
-
- PROCEDURE P1 IS BEGIN NULL; END P1;
-
- FUNCTION F1 (X : UA1) RETURN UA1 IS
- BEGIN RETURN X; END F1;
-
- FUNCTION "+" (X : UA1) RETURN UA1 IS
- BEGIN RETURN F1(X); END "+";
-
- PACKAGE BODY PK1 IS
- PACKAGE BODY PK3 IS END;
- END PK1;
-
- BEGIN
- NULL ;
- END P1;
-
- BEGIN
- NULL;
- END DD;
- RESULT;
-
-END A71004A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a73001i.ada b/gcc/testsuite/ada/acats/tests/a/a73001i.ada
deleted file mode 100644
index 9595d00..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a73001i.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- A73001I.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 SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR
--- GENERIC INSTANTIATION IN A PACKAGE SPECIFICATION NO PACKAGE BODY IS
--- REQUIRED.
-
--- BHS 6/26/84
-
-WITH REPORT;
-PROCEDURE A73001I IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("A73001I", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " &
- "SUBPROGRAM DECLARED BY RENAMING DECLARATION " &
- "OR GENERIC INSTANTIATION IN A PACKAGE " &
- "SPECIFICATION");
-
- DECLARE
- PACKAGE PACK1 IS
- FUNCTION ADDI (X,Y : INTEGER) RETURN INTEGER RENAMES "+";
- END PACK1;
-
- BEGIN
- NULL;
- END;
-
-
- DECLARE
- GENERIC
- TYPE ITEM IS RANGE <>;
- PROCEDURE P (X : IN OUT ITEM);
-
- PROCEDURE P (X : IN OUT ITEM) IS
- BEGIN
- NULL;
- END P;
-
- PACKAGE PACK2 IS
- PROCEDURE NADA IS NEW P (INTEGER);
- END PACK2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A73001I;
diff --git a/gcc/testsuite/ada/acats/tests/a/a73001j.ada b/gcc/testsuite/ada/acats/tests/a/a73001j.ada
deleted file mode 100644
index 025e6db..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a73001j.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- A73001J.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 SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR
--- GENERIC INSTANTIATION IN A GENERIC PACKAGE SPECIFICATION, NO PACKAGE
--- BODY IS REQUIRED.
-
-
--- BHS 6/27/84
-
-WITH REPORT;
-PROCEDURE A73001J IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("A73001J", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " &
- "SUBPROGRAM DECLARED BY RENAMING DECLARATION " &
- "OR GENERIC INSTANTIATION IN A GENERIC " &
- "PACKAGE SPECIFICATION");
-
- DECLARE
- GENERIC
- TYPE ITEM IS RANGE <>;
- PACKAGE PACK1 IS
- FUNCTION ADDI (X,Y : ITEM) RETURN ITEM RENAMES "+";
- END PACK1;
-
- BEGIN
- NULL;
- END;
-
-
- DECLARE
- GENERIC
- TYPE ITEM IS RANGE <>;
- PROCEDURE P (X : IN OUT ITEM);
-
- PROCEDURE P (X : IN OUT ITEM) IS
- BEGIN
- NULL;
- END P;
-
- GENERIC
- TYPE OBJ IS RANGE <>;
- PACKAGE PACK2 IS
- PROCEDURE NADA IS NEW P (OBJ);
- END PACK2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A73001J;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74105b.ada b/gcc/testsuite/ada/acats/tests/a/a74105b.ada
deleted file mode 100644
index 2bd4e09..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74105b.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- A74105B.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 FULL TYPE DECLARATION OF A PRIVATE TYPE WITHOUT
--- DISCRIMINANTS MAY BE A CONSTRAINED TYPE WITH DISCRIMINANTS.
-
--- DSJ 4/29/83
--- SPS 10/22/83
-
-WITH REPORT;
-PROCEDURE A74105B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("A74105B", "CHECK THAT THE FULL TYPE DECLARATION OF A " &
- "PRIVATE TYPE WITHOUT DISCRIMINANTS MAY BE " &
- "A CONSTRAINED TYPE WITH DISCRIMINANTS");
-
- DECLARE
-
- TYPE REC1 (D : INTEGER) IS
- RECORD
- C1, C2 : INTEGER;
- END RECORD;
-
- TYPE REC2 (F : INTEGER := 0) IS
- RECORD
- E1, E2 : INTEGER;
- END RECORD;
-
- TYPE REC3 IS NEW REC1 (D => 1);
-
- TYPE REC4 IS NEW REC2 (F => 2);
-
- PACKAGE PACK1 IS
- TYPE P1 IS PRIVATE;
- TYPE P2 IS PRIVATE;
- TYPE P3 IS PRIVATE;
- TYPE P4 IS PRIVATE;
- PRIVATE
- TYPE P1 IS ACCESS REC1;
- TYPE P2 IS NEW REC4;
- TYPE P3 IS NEW REC1 (D => 5);
- TYPE P4 IS NEW REC2 (F => 7);
- END PACK1;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END A74105B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74106a.ada b/gcc/testsuite/ada/acats/tests/a/a74106a.ada
deleted file mode 100644
index 43afe59..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74106a.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- A74106A.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 FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
--- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE,
--- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH
--- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE
--- ABOVE.
-
--- PART A: TYPES NOT INVOLVING FLOATING-POINT DATA OR FIXED-POINT DATA.
-
-
--- RM 05/13/81
-
-
-WITH REPORT;
-PROCEDURE A74106A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A74106A" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " &
- "TYPES CAN BE DEFINED IN TERMS OF " &
- "VARIOUS OTHER TYPES" );
-
- DECLARE
-
- TYPE ENUM IS ( A , B , C , D );
-
- PACKAGE P0 IS
- TYPE T0 IS PRIVATE;
- PRIVATE
- TYPE T0 IS NEW INTEGER;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE T1 IS PRIVATE;
- TYPE T2 IS PRIVATE;
- TYPE T3 IS PRIVATE;
- TYPE T4 IS PRIVATE;
- TYPE T5 IS PRIVATE;
- TYPE T6 IS PRIVATE;
- TYPE T7 IS PRIVATE;
- TYPE T8 IS PRIVATE;
- TYPE T9 IS PRIVATE;
- TYPE TA IS PRIVATE;
- TYPE TB IS PRIVATE;
- TYPE TC IS PRIVATE;
- TYPE TD(I : INTEGER) IS PRIVATE;
- TYPE NT IS NEW ENUM;
- TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN;
- TYPE ACC_T IS ACCESS CHARACTER;
- TYPE REC_T IS RECORD T : BOOLEAN; END RECORD;
- TYPE D_REC_T(I : INTEGER := 1) IS
- RECORD T : ENUM; END RECORD;
- PRIVATE
- TYPE TY(B : BOOLEAN) IS
- RECORD G : BOOLEAN; END RECORD;
- TYPE TC IS NEW T0;
- TYPE T1 IS RANGE 1..100;
- TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z';
- TYPE T3 IS NEW NT;
- TYPE T4 IS ARRAY(1..2) OF INTEGER;
- TYPE T5 IS NEW ARR_T;
- TYPE T6 IS ACCESS ENUM;
- TYPE T7 IS NEW ACC_T;
- TYPE T8 IS
- RECORD T : CHARACTER; END RECORD;
- TYPE T9 IS NEW REC_T;
- TYPE TA IS ACCESS TD;
- TYPE TB IS ACCESS D_REC_T;
- TYPE TD(I : INTEGER) IS
- RECORD G : BOOLEAN; END RECORD;
-
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- DECLARE
-
- TYPE ENUM IS ( A , B , C , D );
-
- PACKAGE P0 IS
- TYPE T0 IS LIMITED PRIVATE;
- PRIVATE
- TYPE T0 IS NEW ENUM;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE T1 IS LIMITED PRIVATE;
- TYPE T2 IS LIMITED PRIVATE;
- TYPE T3 IS LIMITED PRIVATE;
- TYPE T4 IS LIMITED PRIVATE;
- TYPE T5 IS LIMITED PRIVATE;
- TYPE T6 IS LIMITED PRIVATE;
- TYPE T7 IS LIMITED PRIVATE;
- TYPE T8 IS LIMITED PRIVATE;
- TYPE T9 IS LIMITED PRIVATE;
- TYPE TA IS LIMITED PRIVATE;
- TYPE TB IS LIMITED PRIVATE;
- TYPE TC IS LIMITED PRIVATE;
- TYPE TD(I : INTEGER) IS LIMITED PRIVATE;
- TYPE NT IS NEW ENUM;
- TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN;
- TYPE ACC_T IS ACCESS CHARACTER;
- TYPE REC_T IS RECORD T : BOOLEAN; END RECORD;
- TYPE D_REC_T(I : INTEGER := 1) IS
- RECORD T : ENUM; END RECORD;
- PRIVATE
- TYPE TY(B : BOOLEAN) IS
- RECORD G : BOOLEAN; END RECORD;
- TYPE TC IS NEW T0;
- TYPE T1 IS RANGE 1..100;
- TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z';
- TYPE T3 IS NEW NT;
- TYPE T4 IS ARRAY(1..2) OF INTEGER;
- TYPE T5 IS NEW ARR_T;
- TYPE T6 IS ACCESS ENUM;
- TYPE T7 IS NEW ACC_T;
- TYPE T8 IS RECORD T : CHARACTER; END RECORD;
- TYPE T9 IS NEW REC_T;
- TYPE TA IS ACCESS TD;
- TYPE TB IS ACCESS D_REC_T;
- TYPE TD(I : INTEGER) IS
- RECORD G : BOOLEAN; END RECORD;
-
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- RESULT;
-
-
-END A74106A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74106b.ada b/gcc/testsuite/ada/acats/tests/a/a74106b.ada
deleted file mode 100644
index 6f8963b..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74106b.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- A74106B.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 FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
--- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE,
--- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH
--- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE
--- ABOVE.
-
--- PART B: TYPES INVOLVING FLOATING-POINT DATA.
-
-
--- RM 05/08/81
-
-
-WITH REPORT;
-PROCEDURE A74106B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A74106B" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " &
- "TYPES CAN BE DEFINED IN TERMS OF " &
- "FLOATING-POINT TYPES" );
-
- DECLARE
-
- PACKAGE P0 IS
- TYPE F0 IS PRIVATE;
- PRIVATE
- TYPE F0 IS NEW FLOAT;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE F1 IS PRIVATE;
- TYPE F2 IS PRIVATE;
- TYPE F3 IS PRIVATE;
- TYPE F4 IS PRIVATE;
- TYPE F5 IS PRIVATE;
- TYPE F6 IS PRIVATE;
- TYPE F7 IS PRIVATE;
- TYPE F8 IS PRIVATE;
- TYPE F9 IS PRIVATE;
- TYPE FA IS PRIVATE;
- TYPE FB IS PRIVATE;
- TYPE FC IS PRIVATE;
- TYPE FD(I : INTEGER) IS PRIVATE;
- TYPE NF IS NEW FLOAT;
- TYPE ARR_F IS ARRAY(1..2) OF FLOAT;
- TYPE ACC_F IS ACCESS FLOAT;
- TYPE REC_F IS RECORD F : FLOAT; END RECORD;
- TYPE D_REC_F(I : INTEGER := 1) IS
- RECORD F : FLOAT; END RECORD;
- PRIVATE
- TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD;
- TYPE FC IS NEW F0;
- TYPE F1 IS DIGITS 3;
- TYPE F2 IS NEW FLOAT DIGITS 4;
- TYPE F3 IS NEW NF;
- TYPE F4 IS ARRAY(1..2) OF FLOAT;
- TYPE F5 IS NEW ARR_F;
- TYPE F6 IS ACCESS FLOAT;
- TYPE F7 IS NEW ACC_F;
- TYPE F8 IS RECORD F : FLOAT; END RECORD;
- TYPE F9 IS NEW REC_F;
- TYPE FA IS ACCESS FD;
- TYPE FB IS ACCESS D_REC_F;
- TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD;
-
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- DECLARE
-
- PACKAGE P0 IS
- TYPE F0 IS LIMITED PRIVATE;
- PRIVATE
- TYPE F0 IS NEW FLOAT;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE F1 IS LIMITED PRIVATE;
- TYPE F2 IS LIMITED PRIVATE;
- TYPE F3 IS LIMITED PRIVATE;
- TYPE F4 IS LIMITED PRIVATE;
- TYPE F5 IS LIMITED PRIVATE;
- TYPE F6 IS LIMITED PRIVATE;
- TYPE F7 IS LIMITED PRIVATE;
- TYPE F8 IS LIMITED PRIVATE;
- TYPE F9 IS LIMITED PRIVATE;
- TYPE FA IS LIMITED PRIVATE;
- TYPE FB IS LIMITED PRIVATE;
- TYPE FC IS LIMITED PRIVATE;
- TYPE FD(I : INTEGER) IS LIMITED PRIVATE;
- TYPE NF IS NEW FLOAT;
- TYPE ARR_F IS ARRAY(1..2) OF FLOAT;
- TYPE ACC_F IS ACCESS FLOAT;
- TYPE REC_F IS RECORD F : FLOAT; END RECORD;
- TYPE D_REC_F(I : INTEGER := 1) IS
- RECORD F : FLOAT; END RECORD;
- PRIVATE
- TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD;
- TYPE FC IS NEW F0;
- TYPE F1 IS DIGITS 3;
- TYPE F2 IS NEW FLOAT DIGITS 4;
- TYPE F3 IS NEW NF;
- TYPE F4 IS ARRAY(1..2) OF FLOAT;
- TYPE F5 IS NEW ARR_F;
- TYPE F6 IS ACCESS FLOAT;
- TYPE F7 IS NEW ACC_F;
- TYPE F8 IS RECORD F : FLOAT; END RECORD;
- TYPE F9 IS NEW REC_F;
- TYPE FA IS ACCESS FD;
- TYPE FB IS ACCESS D_REC_F;
- TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD;
-
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- RESULT;
-
-
-END A74106B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74106c.ada b/gcc/testsuite/ada/acats/tests/a/a74106c.ada
deleted file mode 100644
index fef0203..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74106c.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- A74106C.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 FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED
--- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY
--- TYPE, RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE
--- (WITH OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY
--- OF THE ABOVE.
-
--- PART C: TYPES INVOLVING FIXED-POINT DATA.
-
--- HISTORY:
--- RM 05/11/81 CREATED ORIGINAL TEST.
--- DHH 10/15/87 CORRECTED RANGE ERRORS.
-
-
-WITH REPORT;
-PROCEDURE A74106C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A74106C" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE" &
- " TYPES CAN BE DEFINED IN TERMS OF" &
- " FIXED-POINT TYPES" );
-
- DECLARE
-
- PACKAGE P0 IS
- TYPE F0 IS PRIVATE;
- PRIVATE
- TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0;
- TYPE F1 IS PRIVATE;
- TYPE F2 IS PRIVATE;
- TYPE F3 IS PRIVATE;
- TYPE F4 IS PRIVATE;
- TYPE F5 IS PRIVATE;
- TYPE F6 IS PRIVATE;
- TYPE F7 IS PRIVATE;
- TYPE F8 IS PRIVATE;
- TYPE F9 IS PRIVATE;
- TYPE FA IS PRIVATE;
- TYPE FB IS PRIVATE;
- TYPE FC IS PRIVATE;
- TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0;
- TYPE ARR_F IS ARRAY(1..2) OF FX;
- TYPE ACC_F IS ACCESS FX;
- TYPE REC_F IS RECORD F : FX; END RECORD;
- TYPE D_REC_F(I : INTEGER := 1) IS
- RECORD F : FX; END RECORD;
- PRIVATE
- TYPE FC IS NEW F0;
- TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0;
- TYPE F2 IS NEW FX RANGE 0.0 .. 0.5;
- TYPE F3 IS NEW NF;
- TYPE F4 IS ARRAY(1..2) OF FX;
- TYPE F5 IS NEW ARR_F;
- TYPE F6 IS ACCESS FX;
- TYPE F7 IS NEW ACC_F;
- TYPE F8 IS RECORD F : FX; END RECORD;
- TYPE F9 IS NEW REC_F;
- TYPE FA IS ACCESS D_REC_F;
- TYPE FB IS ACCESS D_REC_F;
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- DECLARE
-
- PACKAGE P0 IS
- TYPE F0 IS LIMITED PRIVATE;
- PRIVATE
- TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0;
- END P0;
-
- PACKAGE P1 IS
- USE P0;
- TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0;
- TYPE F1 IS LIMITED PRIVATE;
- TYPE F2 IS LIMITED PRIVATE;
- TYPE F3 IS LIMITED PRIVATE;
- TYPE F4 IS LIMITED PRIVATE;
- TYPE F5 IS LIMITED PRIVATE;
- TYPE F6 IS LIMITED PRIVATE;
- TYPE F7 IS LIMITED PRIVATE;
- TYPE F8 IS LIMITED PRIVATE;
- TYPE F9 IS LIMITED PRIVATE;
- TYPE FA IS LIMITED PRIVATE;
- TYPE FB IS LIMITED PRIVATE;
- TYPE FC IS LIMITED PRIVATE;
- TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0;
- TYPE ARR_F IS ARRAY(1..2) OF FX;
- TYPE ACC_F IS ACCESS FX;
- TYPE REC_F IS RECORD F : FX; END RECORD;
- TYPE D_REC_F(I : INTEGER := 1) IS
- RECORD F : FX; END RECORD;
- PRIVATE
- TYPE FC IS NEW F0;
- TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0;
- TYPE F2 IS NEW FX RANGE 0.0 .. 0.5;
- TYPE F3 IS NEW NF;
- TYPE F4 IS ARRAY(1..2) OF FX;
- TYPE F5 IS NEW ARR_F;
- TYPE F6 IS ACCESS FX;
- TYPE F7 IS NEW ACC_F;
- TYPE F8 IS RECORD F : FX; END RECORD;
- TYPE F9 IS NEW REC_F;
- TYPE FA IS ACCESS D_REC_F;
- TYPE FB IS ACCESS D_REC_F;
- END P1;
-
- BEGIN
-
- NULL;
-
- END;
-
-
- RESULT;
-
-
-END A74106C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74205e.ada b/gcc/testsuite/ada/acats/tests/a/a74205e.ada
deleted file mode 100644
index 769e2e7..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74205e.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- A74205E.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 ADDITIONAL OPERATIONS FOR A COMPOSITE TYPE WITH A
--- COMPONENT OF A PRIVATE TYPE ARE AVAILABLE AT THE EARLIEST
--- PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION OF THE COMPOSITE
--- TYPE AND AFTER THE FULL DECLARATION OF THE PRIVATE TYPE.
-
--- IN PARTICULAR, CHECH FOR THE FOLLOWING :
-
--- (1) RELATIONAL OPERATORS WITH ARRAYS OF SCALAR TYPES
--- (2) EQUALITY WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES
--- (3) LOGICAL OPERATORS WITH ARRAYS OF BOOLEAN TYPES
--- (4) CATENATION WITH ARRAYS OF LIMITED PRIVATE TYPES
--- (5) INITIALIZATION WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES
--- (6) ASSIGNMENT WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES
--- (7) SELECTED COMPONENTS WITH COMPOSITES OF PRIVATE RECORD TYPES
--- (8) INDEXED COMPONENTS WITH COMPOSITES OF PRIVATE ARRAY TYPES
--- (9) SLICES WITH COMPOSITES OF PRIVATE ARRAY TYPES
--- (10) QUALIFICATION FOR COMPOSITES OF PRIVATE TYPES
--- (11) AGGREGATES FOR ARRAYS AND RECORDS OF PRIVATES TYPES
--- (12) USE OF 'SIZE FOR ARRAYS AND RECORDS OF PRIVATE TYPES
-
--- DSJ 5/2/83
-
-WITH REPORT ;
-PROCEDURE A74205E IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A74205E", "CHECK THAT ADDITIONAL OPERATIONS FOR "
- & "COMPOSITE TYPES OF PRIVATE TYPES ARE "
- & "AVAILABLE AT THE EARLIEST PLACE AFTER THE "
- & "FULL DECLARATION AND IN THE IMMEDIATE "
- & "SCOPE OF THE COMPOSITE TYPE") ;
-
- DECLARE
-
- PACKAGE PACK1 IS
- TYPE LP1 IS LIMITED PRIVATE ;
- PACKAGE PACK_LP IS
- TYPE LP_ARR IS ARRAY (INTEGER RANGE <>) OF LP1 ;
- SUBTYPE LP_ARR2 IS LP_ARR ( 1 .. 2 ) ;
- SUBTYPE LP_ARR4 IS LP_ARR ( 1 .. 4 ) ;
- END PACK_LP ;
-
- TYPE T1 IS PRIVATE ;
- PACKAGE PACK2 IS
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF T1 ;
- SUBTYPE ARR2 IS ARR ( 1 .. 2 ) ;
- SUBTYPE ARR4 IS ARR ( 1 .. 4 ) ;
- END PACK2 ;
-
- TYPE T2 IS PRIVATE ;
- TYPE T3 IS PRIVATE ;
- PACKAGE PACK3 IS
- TYPE ARR_T2 IS ARRAY ( 1 .. 2 ) OF T2 ;
- TYPE ARR_T3 IS ARRAY ( 1 .. 2 ) OF T3 ;
- END PACK3 ;
- PRIVATE
- TYPE LP1 IS NEW BOOLEAN ;
- TYPE T1 IS NEW BOOLEAN ;
- TYPE T2 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
- TYPE T3 IS
- RECORD
- C1 : INTEGER ;
- END RECORD ;
- END PACK1 ;
-
- PACKAGE BODY PACK1 IS
-
- PACKAGE BODY PACK_LP IS
- L1, L2 : LP_ARR2 := (TRUE,FALSE) ; -- LEGAL
- A3 : LP_ARR2 := L1 ; -- LEGAL
- B3 : BOOLEAN := L1 = L2 ; -- LEGAL
- B4 : BOOLEAN := L1 /= L2 ; -- LEGAL
- END PACK_LP ;
-
- PACKAGE BODY PACK2 IS
- A1, A2 : ARR2 := (FALSE,TRUE) ; -- LEGAL
- A4 : ARR2 := ARR2'(A1) ; -- LEGAL
- B1 : BOOLEAN := A1 < A2 ; -- LEGAL
- B2 : BOOLEAN := A1 >= A2 ; -- LEGAL
- N3 : INTEGER := A1'SIZE ; -- LEGAL
- PROCEDURE G1 (X : ARR2 := NOT A1) IS -- LEGAL
- BEGIN
- NULL ;
- END G1 ;
-
- PROCEDURE G2 (X : ARR2 := A1 AND A2) IS -- LEGAL
- BEGIN
- NULL ;
- END G2 ;
-
- PROCEDURE G3 (X : ARR4 := A1 & A2) IS -- LEGAL
- BEGIN
- NULL ;
- END G3 ;
-
- PROCEDURE G4 (X : ARR2 := (FALSE,TRUE) ) IS -- LEGAL
- BEGIN
- NULL ;
- END G4 ;
- END PACK2 ;
-
- PACKAGE BODY PACK3 IS
- X2 : ARR_T2 :=
- (1=>(1,2), 2=>(3,4)) ; -- LEGAL
- X3 : ARR_T3 :=
- (1=>(C1=>5), 2=>(C1=>6)) ; -- LEGAL
- N1 : INTEGER := X3(1).C1 ; -- LEGAL
- N2 : INTEGER := X2(1)(2) ; -- LEGAL
- N4 : T2 := X2(1)(1..2) ; -- LEGAL
- END PACK3 ;
-
- END PACK1 ;
-
- BEGIN
-
- NULL ;
-
- END ;
-
- RESULT ;
-
-END A74205E ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a74205f.ada b/gcc/testsuite/ada/acats/tests/a/a74205f.ada
deleted file mode 100644
index 23eb301..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a74205f.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- A74205F.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 AN ACCESS TYPE WHOSE DESIGNATED TYPE IS A PRIVATE TYPE
--- ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON
--- CHARACTERISTICS OF THE FULL DECLARATION OF THE PRIVATE TYPE ARE MADE
--- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
--- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE PRIVATE
--- TYPE.
-
--- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES
--- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES
--- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY
--- TYPES
-
--- DSJ 5/5/83
-
-WITH REPORT ;
-PROCEDURE A74205F IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("A74205F", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS TYPES "
- & "OF PRIVATE TYPES ARE AVAILABLE AT THE EARLIEST "
- & "PLACE IN THE IMMEDIATE SCOPE OF THE ACCESS TYPE "
- & "AND AFTER THE FULL DECLARATION") ;
-
- DECLARE
-
- PACKAGE PACK1 IS
- TYPE T1 IS PRIVATE ;
- TYPE T2 IS PRIVATE ;
- PACKAGE PACK2 IS
- TYPE ACC1 IS ACCESS T1 ;
- TYPE ACC2 IS ACCESS T2 ;
- END PACK2 ;
- PRIVATE
- TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ;
- TYPE T2 IS
- RECORD
- C1, C2 : INTEGER ;
- END RECORD ;
- END PACK1 ;
-
- PACKAGE BODY PACK1 IS
- A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL
- A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL
- R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL
- R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL
-
- PACKAGE BODY PACK2 IS
- X1 : INTEGER := A1(1) ; -- LEGAL
- X2 : INTEGER := A1'FIRST ; -- LEGAL
- X3 : INTEGER := A1'LAST ; -- LEGAL
- X4 : INTEGER := A1'LENGTH ; -- LEGAL
- B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL
- X5 : INTEGER := R1.C1 ; -- LEGAL
- END PACK2 ;
-
- END PACK1 ;
-
- BEGIN
-
- NULL ;
-
- END ;
-
- RESULT ;
-
-END A74205F ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83009a.ada b/gcc/testsuite/ada/acats/tests/a/a83009a.ada
deleted file mode 100644
index da64073..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83009a.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- A83009A.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 DERIVED TYPE DECLARATION AND A GENERIC
--- INSTANTIATION MAY DERIVE TWO OR MORE SUBPROGRAM HOMOGRAPHS.
--- CHECK THE CASES WHERE:
--- 1) THE DERIVED SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF THE
--- SUBSTITUTION OF THE DERIVED TYPE FOR THE PARENT TYPE IN
--- THE IMPLICIT SUBPROGRAM SPECIFICATIONS.
--- 2) THE PARENT TYPE IS DECLARED IN A GENERIC INSTANCE AND
--- THE INSTANCE INCLUDES TWO OR MORE DERIVABLE SUBPROGRAMS
--- THAT ARE HOMOGRAPHS AS A RESULT OF THE ARGUMENTS GIVEN
--- FOR THE GENERIC FORMAL-TYPE PARAMETERS.
--- TEST CASES WHERE THE DERIVED TYPE DECLARATIONS AND GENERIC
--- INSTANTIATIONS ARE GIVEN IN:
--- . THE VISIBLE PART OF A PACKAGE SPECIFICATION,
--- . THE PRIVATE PART OF A PACKAGE SPECIFICATION,
--- . A PACKAGE BODY,
--- . A SUBPROGRAM BODY,
--- . A BLOCK STATEMENT.
---
--- HISTORY:
--- VCL 03-08-88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE A83009A IS
- TYPE ENUM IS (E1, E2, E3);
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- PACKAGE G_PACK IS
- TYPE PARENT IS (E1, E2, E3);
-
- PROCEDURE HP (P1 : PARENT; P2 : T1);
- PROCEDURE HP (P3 : PARENT; P4 : T2);
-
- FUNCTION HF (P1 : T1) RETURN PARENT;
- FUNCTION HF (P2 : T2) RETURN PARENT;
- END G_PACK;
-
- PACKAGE BODY G_PACK IS
- PROCEDURE HP (P1 : PARENT; P2 : T1) IS
- BEGIN
- NULL;
- END HP;
-
- PROCEDURE HP (P3 : PARENT; P4 : T2) IS
- BEGIN
- NULL;
- END HP;
-
- FUNCTION HF (P1 : T1) RETURN PARENT IS
- BEGIN
- RETURN E1;
- END HF;
-
- FUNCTION HF (P2 : T2) RETURN PARENT IS
- BEGIN
- RETURN E2;
- END HF;
- END G_PACK;
-BEGIN
- TEST ("A83009A", "A DERIVED TYPE DECLARATION AND A GENERIC " &
- "INSTANTIATION MAY DERIVE TWO OR " &
- "MORE SUBPROGRAM HOMOGRAPHS");
-
- DECLARE
- -- SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF SUBSTITUTION.
-
- PACKAGE PACK2 IS
- TYPE CHILD1 IS PRIVATE;
-
- PACKAGE IN_PACK2 IS
- TYPE PARENT IS (E1, E2, E3);
- PROCEDURE HP (P1 : PARENT; P2 : CHILD1);
- PROCEDURE HP (P3 : CHILD1; P4 : PARENT);
-
- FUNCTION HF (P1 : CHILD1; P2 : PARENT)
- RETURN PARENT;
- FUNCTION HF (P3 : PARENT; P4 : CHILD1)
- RETURN PARENT;
- END IN_PACK2;
- PRIVATE
- TYPE CHILD1 IS NEW IN_PACK2.PARENT;
- END PACK2;
-
- PACKAGE BODY PACK2 IS
- TYPE CHILD2 IS NEW CHILD1;
-
- PACKAGE IN_BODY IS
- TYPE CHILD3 IS NEW CHILD1;
- END IN_BODY;
-
- PROCEDURE P IS
- TYPE CHILD4 IS NEW CHILD1;
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY IN_PACK2 IS
- PROCEDURE HP (P1 : PARENT; P2 : CHILD1) IS
- BEGIN
- NULL;
- END HP;
-
- PROCEDURE HP (P3 : CHILD1; P4 : PARENT) IS
- BEGIN
- NULL;
- END HP;
-
- FUNCTION HF (P1 : CHILD1; P2 : PARENT)
- RETURN PARENT IS
- BEGIN
- RETURN E1;
- END HF;
-
- FUNCTION HF (P3 : PARENT; P4 : CHILD1)
- RETURN PARENT IS
- BEGIN
- RETURN E2;
- END HF;
- END IN_PACK2;
- BEGIN
- DECLARE
- TYPE CHILD5 IS NEW CHILD1;
- BEGIN
- NULL;
- END;
- END PACK2;
- BEGIN
- NULL;
- END;
-
- DECLARE
- -- PARENT TYPE IN GENERIC INSTANCE HAS DERIVABLE HOMOGRAPHS.
-
- PACKAGE INSTANCE1 IS
- NEW G_PACK (BOOLEAN, BOOLEAN);
-
- TYPE CHILD1 IS NEW INSTANCE1.PARENT;
-
- PACKAGE PACK1 IS
- PACKAGE INSTANCE2 IS
- NEW G_PACK (CHARACTER, CHARACTER);
-
- TYPE CHILD2 IS NEW INSTANCE2.PARENT;
- TYPE CHILD3 IS PRIVATE;
- PRIVATE
- PACKAGE INSTANCE3 IS
- NEW G_PACK (ENUM, ENUM);
-
- TYPE CHILD3 IS NEW INSTANCE3.PARENT;
- END PACK1;
-
- PROCEDURE P1 IS
- PACKAGE INSTANCE4 IS
- NEW G_PACK (BOOLEAN, BOOLEAN);
-
- TYPE CHILD4 IS NEW INSTANCE4.PARENT;
- BEGIN
- NULL;
- END P1;
-
- PACKAGE BODY PACK1 IS
- PACKAGE INSTANCE5 IS
- NEW G_PACK (ENUM, ENUM);
-
- TYPE CHILD5 IS NEW INSTANCE5.PARENT;
- END PACK1;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END A83009A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83009b.ada b/gcc/testsuite/ada/acats/tests/a/a83009b.ada
deleted file mode 100644
index ebd9412..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83009b.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- A83009B.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 DERIVED TYPE DECLARATION IN A GENERIC
--- UNIT MAY DERIVE TWO OR MORE SUBPROGRAM HOMOGRAPHS.
--- CHECK THE CASES WHERE:
--- 1) THE DERIVED SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF THE
--- SUBSTITUTION OF THE DERIVED TYPE FOR THE PARENT TYPE IN
--- THE IMPLICIT SUBPROGRAM SPECIFICATIONS.
--- 2) THE PARENT TYPE IS DECLARED IN A GENERIC INSTANCE AND
--- THE INSTANCE INCLUDES TWO OR MORE DERIVABLE SUBPROGRAMS
--- THAT ARE HOMOGRAPHS AS A RESULT OF THE ARGUMENTS GIVEN
--- FOR THE GENERIC FORMAL-TYPE PARAMETERS.
--- TEST CASES WHERE THE DERIVED TYPE DECLARATIONS ARE GIVEN IN:
--- . THE VISIBLE PART OF A GENERIC PACKAGE SPECIFICATION,
--- . THE PRIVATE PART OF A GENERIC PACKAGE SPECIFICATION,
--- . A GENERIC PACKAGE BODY,
--- . A GENERIC SUBPROGRAM BODY.
---
--- HISTORY:
--- DHH 09/20/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE A83009B IS
- TYPE ENUM IS (E1, E2, E3);
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- PACKAGE G_PACK IS
- TYPE PARENT IS (E1, E2, E3);
-
- PROCEDURE HP (P1 : PARENT; P2 : T1);
- PROCEDURE HP (P3 : PARENT; P4 : T2);
-
- FUNCTION HF (P1 : T1) RETURN PARENT;
- FUNCTION HF (P2 : T2) RETURN PARENT;
- END G_PACK;
-
- PACKAGE BODY G_PACK IS
- PROCEDURE HP (P1 : PARENT; P2 : T1) IS
- BEGIN
- NULL;
- END HP;
-
- PROCEDURE HP (P3 : PARENT; P4 : T2) IS
- BEGIN
- NULL;
- END HP;
-
- FUNCTION HF (P1 : T1) RETURN PARENT IS
- BEGIN
- RETURN E1;
- END HF;
-
- FUNCTION HF (P2 : T2) RETURN PARENT IS
- BEGIN
- RETURN E2;
- END HF;
- END G_PACK;
-BEGIN
- TEST ("A83009B", "A DERIVED TYPE DECLARATION IN A GENERIC " &
- "UNIT MAY DERIVE TWO OR MORE SUBPROGRAM " &
- "HOMOGRAPHS");
-
- DECLARE
- -- SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF SUBSTITUTION.
-
- GENERIC
- PACKAGE PACK2 IS
- TYPE CHILD1 IS PRIVATE;
-
- PACKAGE IN_PACK2 IS
- TYPE PARENT IS (E1, E2, E3);
- PROCEDURE HP (P1 : PARENT; P2 : CHILD1);
- PROCEDURE HP (P3 : CHILD1; P4 : PARENT);
-
- FUNCTION HF (P1 : CHILD1; P2 : PARENT)
- RETURN PARENT;
- FUNCTION HF (P3 : PARENT; P4 : CHILD1)
- RETURN PARENT;
- END IN_PACK2;
-
- USE IN_PACK2;
- PRIVATE
- TYPE CHILD1 IS NEW IN_PACK2.PARENT; -- PRIVATE PART
- END PACK2; -- OF SPEC.
-
- PACKAGE BODY PACK2 IS
- TYPE CHILD2 IS NEW CHILD1; -- VISIBLE PART OF BODY.
-
- GENERIC
- PACKAGE IN_BODY IS
- TYPE CHILD3 IS NEW CHILD1; -- VISIBLE PART OF SPEC.
- END IN_BODY;
-
- GENERIC
- PROCEDURE P;
- PROCEDURE P IS
- TYPE CHILD4 IS NEW CHILD1; -- SUBPROGRAM BODY.
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY IN_PACK2 IS
- PROCEDURE HP (P1 : PARENT; P2 : CHILD1) IS
- BEGIN
- NULL;
- END HP;
-
- PROCEDURE HP (P3 : CHILD1; P4 : PARENT) IS
- BEGIN
- NULL;
- END HP;
-
- FUNCTION HF (P1 : CHILD1; P2 : PARENT)
- RETURN PARENT IS
- BEGIN
- RETURN E1;
- END HF;
-
- FUNCTION HF (P3 : PARENT; P4 : CHILD1)
- RETURN PARENT IS
- BEGIN
- RETURN E2;
- END HF;
- END IN_PACK2;
- BEGIN
- NULL;
- END PACK2;
- BEGIN
- NULL;
- END;
-
- DECLARE
- -- PARENT TYPE IN GENERIC INSTANCE HAS DERIVABLE HOMOGRAPHS.
-
- GENERIC
- PACKAGE PACK1 IS
- PACKAGE INSTANCE2 IS
- NEW G_PACK (CHARACTER, CHARACTER);
-
- TYPE CHILD2 IS NEW INSTANCE2.PARENT;
- TYPE CHILD3 IS PRIVATE;
- PRIVATE
- PACKAGE INSTANCE3 IS
- NEW G_PACK (ENUM, ENUM);
-
- TYPE CHILD3 IS NEW INSTANCE3.PARENT;
- END PACK1;
-
- GENERIC
- PROCEDURE P1;
- PROCEDURE P1 IS
- PACKAGE INSTANCE4 IS
- NEW G_PACK (BOOLEAN, BOOLEAN);
-
- TYPE CHILD4 IS NEW INSTANCE4.PARENT;
- BEGIN
- NULL;
- END P1;
-
- PACKAGE BODY PACK1 IS
- PACKAGE INSTANCE5 IS
- NEW G_PACK (ENUM, ENUM);
-
- TYPE CHILD5 IS NEW INSTANCE5.PARENT;
- END PACK1;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END A83009B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83a02a.ada b/gcc/testsuite/ada/acats/tests/a/a83a02a.ada
deleted file mode 100644
index 45bdfad..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83a02a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- A83A02A.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 LABEL IN A NESTED SUBPROGRAM OR PACKAGE CAN BE IDENTICAL
--- TO A LABEL OUTSIDE SUCH CONSTRUCT.
-
-
--- "INSIDE LABEL": INSIDE * PACKAGE _PACK A
--- * FUNCTION INSIDE PACKAGE _PACKFUN B
--- * PROCEDURE _PROC C
--- * PROCEDURE INSIDE BLOCK _BLOCKPROC D
-
--- "OUTSIDE LABEL": INSIDE * MAIN _MAIN 1
--- * BLOCK IN MAIN _BLOCK 2
--- * LOOP IN BLOCK IN MAIN _BLOCKLOOP 3
--- * LOOP IN MAIN _LOOP 4
-
--- CASES TESTED: A1 B2 A3 B4 1 2 3 4
--- D1 C2 C3 D4
--- D2 AB A X . X .
--- B . X . X
--- C . X X .
--- D X . . X
-
-
--- RM 02/09/80
-
-
-WITH REPORT ;
-PROCEDURE A83A02A IS
-
- USE REPORT ;
-
- PROCEDURE PROC1 IS
- BEGIN
- << LAB_PROC_BLOCK >> NULL ; -- C2 C
- << LAB_PROC_BLOCKLOOP >> NULL ; -- C3
- END PROC1 ;
-
- PACKAGE PACK1 IS
- FUNCTION F RETURN INTEGER ;
- END PACK1 ;
-
- PACKAGE BODY PACK1 IS
- FUNCTION F RETURN INTEGER IS
- BEGIN
- << LAB_PACKFUN_BLOCK >> NULL ; -- B2 B
- << LAB_PACKFUN_LOOP >> NULL ; -- B4
- << LAB_PACKFUN_PACK >> NULL ; -- BA (AB)
- RETURN 7 ;
- END F ;
- BEGIN
- << LAB_PACK_MAIN >> NULL ; -- A1 A
- << LAB_PACK_BLOCKLOOP >> NULL ; -- A3
- << LAB_PACKFUN_PACK >> NULL ; -- BA (AB)
- END PACK1 ;
-
-BEGIN
-
- TEST( "A83A02A" , "CHECK THAT A LABEL IN A NESTED SUBPROGRAM" &
- " OR PACKAGE CAN BE IDENTICAL TO A LABEL" &
- " OUTSIDE SUCH CONSTRUCT" );
-
- << LAB_PACK_MAIN >> NULL ; -- A1 1
- << LAB_BLOCKPROC_MAIN >> NULL ; -- D1
-
-
- DECLARE --
-
- PROCEDURE PROC2 IS
- BEGIN
- << LAB_BLOCKPROC_MAIN >> NULL ; -- D1 D
- << LAB_BLOCKPROC_LOOP >> NULL ; -- D4
- << LAB_BLOCKPROC_BLOCK >> NULL ; -- D2
- END PROC2 ;
-
- BEGIN
-
- << LAB_PACKFUN_BLOCK >> NULL ; -- B2 2
- << LAB_PROC_BLOCK >> NULL ; -- C2
- << LAB_BLOCKPROC_BLOCK >> NULL ; -- D2
-
- FOR I IN 1..2 LOOP
- << LAB_PACK_BLOCKLOOP >> NULL ; -- A3 3
- << LAB_PROC_BLOCKLOOP >> NULL ; -- C3
- END LOOP;
-
- END ;
-
- FOR I IN 1..2 LOOP
- << LAB_PACKFUN_LOOP >> NULL ; -- B4 4
- << LAB_BLOCKPROC_LOOP >> NULL ; -- D4
- END LOOP;
-
-
- RESULT ;
-
-
-END A83A02A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83a02b.ada b/gcc/testsuite/ada/acats/tests/a/a83a02b.ada
deleted file mode 100644
index 7613f09..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83a02b.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- A83A02B.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 LABEL IN A NESTED TASK CAN BE IDENTICAL TO A LABEL
--- OUTSIDE THE TASK.
-
-
--- "INSIDE LABEL": INSIDE * TASK BODY _TASK A
--- * BLOCK IN TASK BODY _TASKBLOCK B
--- * LOOP IN BLOCK IN TASK BODY _TASKBLOCKLOOP
--- * ACCEPT ST. WITHIN TASK BDY _TASKACCEPT D
-
--- "OUTSIDE LABEL": INSIDE * MAIN _MAIN 1
--- * BLOCK IN MAIN _BLOCK 2
--- * LOOP IN BLOCK IN MAIN _BLOCKLOOP 3
--- * LOOP IN MAIN _LOOP 4
-
--- CASES TESTED: A1 B2 A3 B4 | 1 2 3 4
--- D1 C2 C3 D4 ---+----------
--- A | X . X .
--- B | . X . X
--- C | . X X .
--- D | X . . X
-
-
--- RM 02/10/80
-
-
-WITH REPORT ;
-PROCEDURE A83A02B IS
-
- USE REPORT ;
-
- TASK TYPE TASK1 IS
- ENTRY E1 ;
- END TASK1 ;
-
- TASK BODY TASK1 IS
- BEGIN
-
- << LAB_TASK_MAIN >> NULL ; -- A1 A
- << LAB_TASK_BLOCKLOOP >> NULL ; -- A3
-
- BEGIN
-
- << LAB_TASKBLOCK_BLOCK >> NULL ; -- B2 B
- << LAB_TASKBLOCK_LOOP >> NULL ; -- B4
-
- FOR I IN 1..2 LOOP
- << LAB_TASKBLOCKLOOP_BLOCK >>NULL ; -- C2 C
- << LAB_TASKBLOCKLOOP_BLOCKLOOP >>
- NULL ; -- C3
- END LOOP;
-
- END ;
-
- ACCEPT E1 DO
- << LAB_TASKACCEPT_MAIN >> NULL ; -- D1 D
- << LAB_TASKACCEPT_LOOP >> NULL ; -- D4
- END E1 ;
-
- END TASK1 ;
-
-BEGIN
-
- TEST( "A83A02B" , "CHECK THAT A LABEL IN A NESTED TASK" &
- " CAN BE IDENTICAL TO A LABEL" &
- " OUTSIDE THE TASK" );
-
- << LAB_TASK_MAIN >> NULL ; -- A1 1
- << LAB_TASKACCEPT_MAIN >> NULL ; -- D1
-
-
- BEGIN
-
- << LAB_TASKBLOCK_BLOCK >> NULL ; -- B2 2
- << LAB_TASKBLOCKLOOP_BLOCK >> NULL ; -- C2
-
- FOR I IN 1..2 LOOP
- << LAB_TASK_BLOCKLOOP >> NULL ; -- A3 3
- << LAB_TASKBLOCKLOOP_BLOCKLOOP >> NULL ; -- C3
- END LOOP;
-
- END ;
-
- FOR I IN 1..2 LOOP
- << LAB_TASKBLOCK_LOOP >> NULL ; -- B4 4
- << LAB_TASKACCEPT_LOOP >> NULL ; -- D4
- END LOOP;
-
-
- RESULT ;
-
-
-END A83A02B ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83a06a.ada b/gcc/testsuite/ada/acats/tests/a/a83a06a.ada
deleted file mode 100644
index 3018fcd..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83a06a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- A83A06A.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 STATEMENT LABEL INSIDE A BLOCK BODY CAN BE THE
--- SAME AS A VARIABLE, CONSTANT, NAMED LITERAL, SUBPROGRAM,
--- ENUMERATION LITERAL, TYPE, OR PACKAGE DECLARED IN THE
--- ENCLOSING BODY.
-
-
--- RM 02/12/80
--- JBG 5/16/83
--- JBG 8/21/83
--- JRK 12/19/83
-
-WITH REPORT; USE REPORT;
-PROCEDURE A83A06A IS
-
- LAB_VAR : INTEGER;
- LAB_CONST : CONSTANT INTEGER := 12;
- LAB_NAMEDLITERAL : CONSTANT := 13;
- TYPE ENUM IS ( AA , BB , LAB_ENUMERAL );
- TYPE LAB_TYPE IS NEW INTEGER;
-
- PROCEDURE LAB_PROCEDURE IS
- BEGIN
- NULL;
- END LAB_PROCEDURE;
-
- FUNCTION LAB_FUNCTION RETURN INTEGER IS
- BEGIN
- RETURN 7;
- END LAB_FUNCTION;
-
- PACKAGE LAB_PACKAGE IS
- INT : INTEGER;
- END LAB_PACKAGE;
-
-BEGIN
-
- TEST ("A83A06A", "CHECK THAT STATEMENT LABELS INSIDE A BLOCK " &
- "BODY CAN BE THE SAME AS IDENTIFIERS DECLARED "&
- "OUTSIDE THE BODY");
-
- LAB_BLOCK_1 : BEGIN NULL; END LAB_BLOCK_1;
-
- LAB_LOOP_1 : LOOP EXIT; END LOOP LAB_LOOP_1;
-
- BEGIN
-
- << LAB_VAR >> -- OK.
- BEGIN NULL; END;
- << LAB_ENUMERAL >> NULL; -- OK.
-
- << LAB_PROCEDURE >> -- OK.
- FOR I IN INTEGER LOOP
- << LAB_CONST >> NULL; -- OK.
- << LAB_TYPE >> NULL; -- OK.
- << LAB_FUNCTION >> EXIT; -- OK.
- END LOOP;
-
- << LAB_NAMEDLITERAL >> NULL;
- << LAB_PACKAGE >> NULL;
- END;
-
- LAB_BLOCK_2 : -- OK.
- BEGIN NULL; END LAB_BLOCK_2;
-
- LAB_LOOP_2 : -- OK.
- LOOP EXIT; END LOOP LAB_LOOP_2;
-
- RESULT;
-
-END A83A06A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83a08a.ada b/gcc/testsuite/ada/acats/tests/a/a83a08a.ada
deleted file mode 100644
index 5cdc30e..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83a08a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- A83A08A.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:
--- A STATEMENT LABEL DECLARED OUTSIDE A BLOCK CAN HAVE THE SAME
--- IDENTIFIER AS AN ENTITY DECLARED IN THE BLOCK, AND A GOTO
--- STATEMENT USING THE LABEL IS LEGAL OUTSIDE THE BLOCK.
-
--- HISTORY:
--- PMW 09/20/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-
-PROCEDURE A83A08A IS
-
- PASSES : INTEGER := 0;
-
-BEGIN
- TEST ("A83A08A", "A STATEMENT LABEL DECLARED OUTSIDE A BLOCK " &
- "CAN HAVE THE SAME IDENTIFIER AS AN ENTITY " &
- "DECLARED IN THE BLOCK, AND A GOTO STATEMENT " &
- "USING THE LABEL IS LEGAL OUTSIDE THE BLOCK");
-
- GOTO LBLS;
-
- <<LBL>>
-
- DECLARE
- LBL : INTEGER := 1;
- BEGIN
- LBL := IDENT_INT (LBL);
- PASSES := PASSES + 1;
- END;
-
- <<LBLS>>
-
- BEGIN
- DECLARE
- TYPE STUFF IS (LBL, LBL_ONE, LBL_TWO);
- ITEM : STUFF := LBL;
-
- FUNCTION LBLS (ITEM : STUFF) RETURN BOOLEAN IS
- BEGIN
- <<LBL_2>>
- CASE ITEM IS
- WHEN LBL => RETURN TRUE;
- WHEN LBL_ONE => PASSES := PASSES + 1;
- WHEN LBL_TWO => RETURN FALSE;
- END CASE;
- IF PASSES < 2 THEN
- PASSES := PASSES + 1;
- GOTO LBL_2;
- ELSE
- RETURN TRUE;
- END IF;
- END LBLS;
-
- BEGIN
- CASE PASSES IS
- WHEN 0 => ITEM := LBL;
- WHEN 1 => ITEM := LBL_ONE;
- WHEN OTHERS => ITEM := LBL_TWO;
- END CASE;
- IF NOT LBLS (ITEM) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- END;
-
-
- IF PASSES > 1 THEN
- GOTO ENOUGH;
- END IF;
- GOTO LBL;
-
- <<ENOUGH>>
-
- RESULT;
-
-END A83A08A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83c01c.ada b/gcc/testsuite/ada/acats/tests/a/a83c01c.ada
deleted file mode 100644
index 159f3cf..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83c01c.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- A83C01C.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 COMPONENT NAMES MAY BE THE SAME AS NAMES OF
--- FORMAL PARAMETERS, LABELS, LOOP PARAMETERS,
--- VARIABLES, CONSTANTS, SUBPROGRAMS, PACKAGES, TYPES.
--- (NAMES OF COMPONENTS IN LOGICALLY NESTED RECORDS ARE TESTED IN
--- C83C01B.ADA .)
--- (NAMES OF TASKS ARE TESTED IN A83C01T.ADA .)
-
--- RM 24 JUNE 1980
--- JRK 10 NOV 1980
--- RM 01 JAN 1982
-
-WITH REPORT;
-PROCEDURE A83C01C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A83C01C" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" &
- " NAMES OF VARIABLES AND CONSTANTS " ) ;
-
-
-
- DECLARE
-
- VAR1 , VAR2 : INTEGER := 27 ;
- CONST1 : CONSTANT INTEGER := 13 ;
- CONST2 : CONSTANT BOOLEAN := FALSE ;
-
- TYPE R1A IS
- RECORD
- VAR1,VAR2,CONST1:INTEGER ;
- END RECORD ;
-
- TYPE R1 IS
- RECORD
- VAR1 : INTEGER ;
- VAR2 : BOOLEAN ;
- CONST1 : BOOLEAN ;
- A : R1A ;
- END RECORD ;
-
- A : R1 := ( VAR1 => VAR1 , A => ( VAR1 => VAR2 ,
- VAR2 => VAR2 ,
- CONST1 => VAR1 ) ,
- VAR2 => CONST2 , CONST1 => CONST2 ) ;
-
- BEGIN
-
- VAR1 := A.A.VAR2 ;
- A.CONST1 := CONST2 ;
- A.A.CONST1 := A.VAR1 + VAR2 ;
-
- END ;
-
-
- RESULT;
-
-END A83C01C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83c01h.ada b/gcc/testsuite/ada/acats/tests/a/a83c01h.ada
deleted file mode 100644
index f50ce77..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83c01h.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- A83C01H.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 COMPONENT NAMES MAY BE THE SAME AS NAMES OF
--- LABELS.
-
--- RM 24 JUNE 1980
--- JRK 10 NOV 1980
--- RM 01 JAN 1982
-
-
-WITH REPORT;
-PROCEDURE A83C01H IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A83C01H" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" &
- " NAMES OF LABELS" ) ;
-
-
- -- TEST FOR LABELS
-
- DECLARE
-
- TYPE R1A IS
- RECORD
- LAB3 : INTEGER ;
- END RECORD ;
-
- TYPE R1 IS
- RECORD
- LAB1 : INTEGER ;
- LAB2 : R1A ;
- END RECORD ;
-
- A1 : R1 := ( 1 , ( LAB3 => 5 ) );
-
- BEGIN
-
- << LAB1 >>
- << LAB2 >>
- << LAB3 >>
-
- A1.LAB1 := A1.LAB2.LAB3 ;
-
- DECLARE
-
- TYPE R1A IS
- RECORD
- LAB3 : INTEGER ;
- LAB4 : INTEGER ;
- END RECORD ;
-
- TYPE R1 IS
- RECORD
- LAB1 : INTEGER ;
- LAB2 : R1A ;
- END RECORD ;
-
- A1 : R1 := ( 3 , ( 6 , 7 ) );
-
- BEGIN
-
- << LAB4 >>
-
- A1.LAB1 := A1.LAB2.LAB3 + A1.LAB2.LAB4 ;
-
- END ;
-
- END ;
-
-
-
- RESULT;
-
-END A83C01H;
diff --git a/gcc/testsuite/ada/acats/tests/a/a83c01i.ada b/gcc/testsuite/ada/acats/tests/a/a83c01i.ada
deleted file mode 100644
index 3a2ec2d..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a83c01i.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- A83C01I.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 COMPONENT NAMES MAY BE THE SAME AS NAMES OF
--- LOOP PARAMETERS.
-
--- RM 24 JUNE 1980
--- JRK 10 NOV 1980
--- RM 01 JAN 1982
-
-
-WITH REPORT;
-PROCEDURE A83C01I IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "A83C01I" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" &
- " NAMES OF LOOP PARAMETERS" ) ;
-
-
-
- -- TEST FOR LOOP PARAMETERS
-
-
- DECLARE
-
- TYPE R1A IS
- RECORD
- LOOP3 : INTEGER ;
- END RECORD ;
-
- TYPE R1 IS
- RECORD
- LOOP1 : INTEGER ;
- LOOP2 : R1A ;
- END RECORD ;
-
- A1 : R1 := ( 3 , ( LOOP3 => 7 ) );
-
- BEGIN
-
- FOR LOOP1 IN 0..1 LOOP
-
- FOR LOOP2 IN 0..2 LOOP
-
- FOR LOOP3 IN 0..3 LOOP
-
- A1.LOOP1 := A1.LOOP2.LOOP3 ;
-
- DECLARE
-
- TYPE R1A IS
- RECORD
- LOOP3 : INTEGER ;
- LOOP4 : INTEGER ;
- END RECORD ;
-
- TYPE R1 IS
- RECORD
- LOOP1 : INTEGER ;
- LOOP2 : R1A ;
- END RECORD ;
-
- A1 : R1 := ( 3 , ( 6 , 7 ) );
-
- BEGIN
-
- FOR LOOP4 IN 0..4 LOOP
-
- A1.LOOP1 := A1.LOOP2.LOOP3 +
- A1.LOOP2.LOOP4 ;
-
- END LOOP ;
-
- END ;
-
- END LOOP ;
-
- END LOOP ;
-
- END LOOP ;
-
- END ;
-
-
-
- RESULT;
-
-END A83C01I;
diff --git a/gcc/testsuite/ada/acats/tests/a/a85007d.ada b/gcc/testsuite/ada/acats/tests/a/a85007d.ada
deleted file mode 100644
index d86761d..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a85007d.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- A85007D.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, 'RANGE, 'ADDRESS, 'CONSTRAINED,
--- AND 'SIZE CAN BE APPLIED TO RENAMED NON-ACCESS OUT FORMAL PARAMETERS
--- AND RENAMED COMPONENTS OF NON-ACCESS OUT PARAMETERS.
-
--- SPS 02/21/84 (SEE A62006D-B.ADA)
--- EG 02/22/84
--- EG 05/30/84
--- JBG 12/2/84
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-
-PROCEDURE A85007D IS
-
- PROCEDURE Q (X : SYSTEM.ADDRESS) IS
- BEGIN
- NULL;
- END Q;
-
-BEGIN
-
- TEST ("A85007D", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " &
- "RENAMED NON-ACCESS FORMAL OUT PARAMETERS");
-
- DECLARE
-
- TYPE ARR IS ARRAY (1 .. 2) OF BOOLEAN;
- TYPE REC (D : INTEGER) IS RECORD
- Y : BOOLEAN;
- X : ARR;
- END RECORD;
-
- PROCEDURE PROC (C2 : OUT ARR;
- C3 : OUT REC) IS
-
- X : SYSTEM.ADDRESS;
- I : INTEGER;
-
- C21 : ARR RENAMES C2;
- C22 : ARR RENAMES C21;
- C31 : REC RENAMES C3;
- C32 : REC RENAMES C31;
- C33 : ARR RENAMES C3.X;
- C34 : ARR RENAMES C33;
- C35 : ARR RENAMES C32.X;
- C36 : BOOLEAN RENAMES C3.Y;
- C37 : BOOLEAN RENAMES C36;
- C38 : BOOLEAN RENAMES C32.Y;
-
- BEGIN
-
- I := C21'LENGTH;
- Q(C21'ADDRESS);
- I := C21'SIZE;
- I := C22'LENGTH;
- Q(C22'ADDRESS);
- I := C22'SIZE;
-
- FOR I IN C21'RANGE LOOP
- NULL;
- END LOOP;
- FOR I IN C22'RANGE LOOP
- NULL;
- END LOOP;
-
- FOR I IN C21'FIRST..C21'LAST LOOP
- NULL;
- END LOOP;
- FOR I IN C22'FIRST..C22'LAST LOOP
- NULL;
- END LOOP;
-
- I := C31.X'LENGTH;
- C3.Y := C31'CONSTRAINED;
- FOR J IN C31.X'RANGE LOOP
- NULL;
- END LOOP;
- FOR J IN C31.X'FIRST..C31.X'LAST LOOP
- NULL;
- END LOOP;
- I := C32.X'LENGTH;
- C31.Y := C32'CONSTRAINED;
- FOR J IN C32.X'RANGE LOOP
- NULL;
- END LOOP;
- FOR J IN C32.X'FIRST..C32.X'LAST LOOP
- NULL;
- END LOOP;
- I := C33'LENGTH;
- FOR J IN C33'RANGE LOOP
- NULL;
- END LOOP;
- FOR J IN C33'FIRST..C33'LAST LOOP
- NULL;
- END LOOP;
- I := C34'LENGTH;
- FOR J IN C34'RANGE LOOP
- NULL;
- END LOOP;
- FOR J IN C34'FIRST..C34'LAST LOOP
- NULL;
- END LOOP;
- I := C35'LENGTH;
- FOR J IN C35'RANGE LOOP
- NULL;
- END LOOP;
- FOR J IN C35'FIRST..C35'LAST LOOP
- NULL;
- END LOOP;
-
- Q(C31.Y'ADDRESS);
- I := C31.Y'SIZE;
- Q(C32.Y'ADDRESS);
- I := C32.Y'SIZE;
- Q(C36'ADDRESS);
- I := C36'SIZE;
- Q(C37'ADDRESS);
- I := C37'SIZE;
- Q(C38'ADDRESS);
- I := C38'SIZE;
-
- END PROC;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END A85007D;
diff --git a/gcc/testsuite/ada/acats/tests/a/a85013b.ada b/gcc/testsuite/ada/acats/tests/a/a85013b.ada
deleted file mode 100644
index 6b77ada..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a85013b.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- A85013B.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) A SUBPROGRAM OR ENTRY CAN BE RENAMED WITHIN ITS OWN BODY.
-
--- B) THE NEW NAME OF A SUBPROGRAM CAN BE USED IN A RENAMING
--- DECLARATION.
-
--- EG 02/22/84
-
-WITH REPORT;
-
-PROCEDURE A85013B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("A85013B","CHECK THAT A SUBPROGRAM CAN BE RENAMED WITHIN " &
- "ITS OWN BODY AND THAT THE NEW NAME CAN BE USED" &
- " IN A RENAMING DECLARATION");
-
- DECLARE
-
- PROCEDURE PROC1 (A : BOOLEAN) IS
- PROCEDURE PROC2 (B : BOOLEAN := FALSE) RENAMES PROC1;
- PROCEDURE PROC3 (C : BOOLEAN := FALSE) RENAMES PROC2;
- BEGIN
- IF A THEN
- PROC3;
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 (TRUE);
-
- END;
-
- DECLARE
-
- TASK T IS
- ENTRY E;
- END T;
-
- TASK BODY T IS
- PROCEDURE E1 RENAMES E;
- PROCEDURE E2 RENAMES E1;
- BEGIN
- ACCEPT E DO
- DECLARE
- PROCEDURE E3 RENAMES E;
- PROCEDURE E4 RENAMES E3;
- BEGIN
- NULL;
- END;
- END E;
- END T;
-
- BEGIN
- T.E;
- END;
-
- RESULT;
-
-END A85013B;
diff --git a/gcc/testsuite/ada/acats/tests/a/a87b59a.ada b/gcc/testsuite/ada/acats/tests/a/a87b59a.ada
deleted file mode 100644
index 3760e91..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a87b59a.ada
+++ /dev/null
@@ -1,250 +0,0 @@
--- A87B59A.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 BECAUSE A GENERIC ACTUAL PROGRAM PARAMETER MUST BE A
--- SUBPROGRAM, AN ENUMERATION LITERAL, OR AN ENTRY WITH THE SAME
--- PARAMETER AND RESULT TYPE PROFILE AS THE FORMAL PARAMETER, AN
--- OVERLOADED NAME APPEARING AS AN ACTUAL PARAMETER CAN BE RESOLVED.
-
--- R.WILLIAMS 9/24/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE A87B59A IS
-
-BEGIN
- TEST ( "A87B59A", "CHECK THAT BECAUSE A GENERIC ACTUAL PROGRAM " &
- "PARAMETER MUST BE A SUBPROGRAM, AN " &
- "ENUMERATION LITERAL, OR AN ENTRY WITH THE " &
- "SAME PARAMETER AND RESULT TYPE PROFILE AS " &
- "THE FORMAL PARAMETER, AN OVERLOADED NAME " &
- "APPEARING AS AN ACTUAL PARAMETER CAN BE " &
- "RESOLVED" );
-
- DECLARE -- A.
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (0);
- END F1;
-
- FUNCTION F1 RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (TRUE);
- END F1;
-
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION F RETURN T;
- PROCEDURE P;
-
- PROCEDURE P IS
- BEGIN
- NULL;
- END P;
-
- PROCEDURE P1 IS NEW P (INTEGER, F1);
- PROCEDURE P2 IS NEW P (BOOLEAN, F1);
-
- BEGIN
- P1;
- P2;
- END; -- A.
-
- DECLARE -- B.
- FUNCTION F1 (X : INTEGER; B : BOOLEAN) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (X);
- END F1;
-
- FUNCTION F1 (X : INTEGER; B : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (B);
- END F1;
-
- FUNCTION F1 (B : BOOLEAN; X : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (B);
- END F1;
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- WITH FUNCTION F (A : T1; B : T2) RETURN T1;
- PROCEDURE P1;
-
- PROCEDURE P1 IS
- BEGIN
- NULL;
- END P1;
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- WITH FUNCTION F (A : T1; B : T2) RETURN T2;
- PROCEDURE P2;
-
- PROCEDURE P2 IS
- BEGIN
- NULL;
- END P2;
-
- PROCEDURE PROC1 IS NEW P1 (INTEGER, BOOLEAN, F1);
- PROCEDURE PROC2 IS NEW P1 (BOOLEAN, INTEGER, F1);
- PROCEDURE PROC3 IS NEW P2 (INTEGER, BOOLEAN, F1);
-
- BEGIN
- PROC1;
- PROC2;
- END; -- B.
-
- DECLARE -- C.
- TYPE COLOR IS (RED, YELLOW, BLUE);
- C : COLOR;
-
- TYPE LIGHT IS (RED, YELLOW, GREEN);
- L : LIGHT;
-
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION F RETURN T;
- FUNCTION GF RETURN T;
-
- FUNCTION GF RETURN T IS
- BEGIN
- RETURN T'VAL (IDENT_INT (T'POS (F)));
- END GF;
-
- FUNCTION F1 IS NEW GF (COLOR, RED);
- FUNCTION F2 IS NEW GF (LIGHT, YELLOW);
- BEGIN
- C := F1;
- L := F2;
- END; -- C.
-
- DECLARE -- D.
- TASK TK IS
- ENTRY E (X : INTEGER);
- ENTRY E (X : BOOLEAN);
- ENTRY E (X : INTEGER; Y : BOOLEAN);
- ENTRY E (X : BOOLEAN; Y : INTEGER);
- END TK;
-
- TASK BODY TK IS
- BEGIN
- LOOP
- SELECT
- ACCEPT E (X : INTEGER);
- OR
- ACCEPT E (X : BOOLEAN);
- OR
- ACCEPT E (X : INTEGER; Y : BOOLEAN);
- OR
- ACCEPT E (X : BOOLEAN; Y : INTEGER);
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END TK;
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- WITH PROCEDURE P1 (X : T1);
- WITH PROCEDURE P2 (X : T1; Y : T2);
- PACKAGE PKG IS
- PROCEDURE P;
- END PKG;
-
- PACKAGE BODY PKG IS
- PROCEDURE P IS
- BEGIN
- IF EQUAL (3, 3) THEN
- P1 (T1'VAL (1));
- P2 (T1'VAL (0), T2'VAL (1));
- END IF;
- END P;
- END PKG;
-
- PACKAGE PK1 IS NEW PKG (INTEGER, BOOLEAN, TK.E, TK.E);
- PACKAGE PK2 IS NEW PKG (BOOLEAN, INTEGER, TK.E, TK.E);
-
- BEGIN
- PK1.P;
- PK2.P;
- END; -- D.
-
- DECLARE -- E.
- FUNCTION "+" (X, Y : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (X OR Y);
- END "+";
-
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION "+" (X, Y : T) RETURN T;
- PROCEDURE P;
-
- PROCEDURE P IS
- S : T;
- BEGIN
- S := "+" (T'VAL (0), T'VAL (1));
- END P;
-
- PROCEDURE P1 IS NEW P (BOOLEAN, "+");
- PROCEDURE P2 IS NEW P (INTEGER, "+");
-
- BEGIN
- P1;
- P2;
- END; -- E.
-
- DECLARE -- F.
- TYPE ADD_OPS IS ('+', '-', '&');
-
- GENERIC
- TYPE T1 IS (<>);
- TYPE T2 IS (<>);
- TYPE T3 IS ARRAY (POSITIVE RANGE <> ) OF T2;
- X2 : T2;
- X3 : T3;
- WITH FUNCTION F1 RETURN T1;
- WITH FUNCTION F2 (X : T2; Y : T3) RETURN T3;
- PROCEDURE P;
-
- PROCEDURE P IS
- A : T1;
- S : T3 (IDENT_INT (1) .. IDENT_INT (2));
- BEGIN
- A := F1;
- S := F2 (X2, X3);
- END P;
-
- PROCEDURE P1 IS NEW P (ADD_OPS, CHARACTER, STRING,
- '&', "&", '&', "&");
-
- BEGIN
- P1;
- END; -- F.
-
- RESULT;
-END A87B59A;
diff --git a/gcc/testsuite/ada/acats/tests/a/a95001c.ada b/gcc/testsuite/ada/acats/tests/a/a95001c.ada
deleted file mode 100644
index 3826e0b..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a95001c.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- A95001C.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 BOUNDS OF THE DISCRETE RANGE OF AN ENTRY FAMILY
--- ARE INTEGER LITERALS, NAMED NUMBERS, OR ATTRIBUTES HAVING TYPE
--- UNIVERSAL_INTEGER, BUT NOT EXPRESSIONS OF TYPE UNIVERSAL_INTEGER,
--- THE INDEX (IN AN ENTRY NAME OR ACCEPT STATEMENT) IS OF THE
--- PREDEFINED TYPE INTEGER.
-
--- WEI 3/4/82
--- RJK 2/1/84 ADDED TO ACVC
--- TBN 1/7/86 RENAMED FROM B950DHA-B.ADA. ADDED NAMED CONSTANTS
--- AND ATTRIBUTES AS KINDS OF BOUNDS, AND MADE TEST
--- EXECUTABLE.
--- RJW 4/11/86 RENAMED FROM C95001C-B.ADA.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE A95001C IS
-
- SUBTYPE T IS INTEGER RANGE 1 .. 10;
- I : INTEGER := 1;
- NAMED_INT1 : CONSTANT := 1;
- NAMED_INT2 : CONSTANT := 2;
-
- TASK T1 IS
- ENTRY E1 (1 .. 2);
- ENTRY E2 (NAMED_INT1 .. NAMED_INT2);
- ENTRY E3 (T'POS(1) .. T'POS(2));
- END T1;
-
- TASK BODY T1 IS
- I_INT : INTEGER := 1;
- I_POS : INTEGER := 2;
- BEGIN
- ACCEPT E1 (I_INT);
- ACCEPT E2 (I_POS);
- ACCEPT E3 (T'SUCC(1));
- END T1;
-
-BEGIN
- TEST ("A95001C", "CHECK THAT IF THE BOUNDS OF THE DISCRETE " &
- "RANGE OF AN ENTRY FAMILY ARE INTEGER " &
- "LITERALS, NAMED NUMBERS, OR " &
- "(UNIVERSAL_INTEGER) ATTRIBUTES, THE INDEX " &
- "IS OF THE PREDEFINED TYPE INTEGER");
-
- T1.E1 (I);
- T1.E2 (NAMED_INT2);
- T1.E3 (T'SUCC(I));
-
- RESULT;
-END A95001C;
diff --git a/gcc/testsuite/ada/acats/tests/a/a95074d.ada b/gcc/testsuite/ada/acats/tests/a/a95074d.ada
deleted file mode 100644
index 07c0032..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a95074d.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- A95074D.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 'ADDRESS, 'CONSTRAINED, 'SIZE, 'POSITION, 'FIRST_BIT,
--- AND 'LAST_BIT 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;
-WITH SYSTEM;
-PROCEDURE A95074D IS
-BEGIN
-
- TEST ("A95074D", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " &
- "NON-ACCESS FORMAL OUT PARAMETERS");
-
- DECLARE
-
- TYPE ARR IS ARRAY (1 .. 2) OF BOOLEAN;
-
- TYPE REC (D : INTEGER := 1) IS RECORD
- Y : BOOLEAN;
- X : ARR;
- END RECORD;
-
- TASK T IS
- ENTRY E (C1 : OUT ARR; C2 : OUT REC);
- END T;
-
- TASK BODY T IS
- X : SYSTEM.ADDRESS;
- I : INTEGER;
- BEGIN
- IF IDENT_BOOL (FALSE) THEN
- ACCEPT E (C1 : OUT ARR; C2 : OUT REC) DO
-
- C2.Y := C2'CONSTRAINED;
-
- X := C1'ADDRESS;
- X := C1(1)'ADDRESS;
- X := C2'ADDRESS;
- X := C2.Y'ADDRESS;
-
- I := C1'SIZE;
- I := C2.Y'SIZE;
-
- I := C2.X'POSITION;
- I := C2.Y'FIRST_BIT;
- I := C2.Y'LAST_BIT;
- END E;
- END IF;
- END T;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END A95074D;
diff --git a/gcc/testsuite/ada/acats/tests/a/a97106a.ada b/gcc/testsuite/ada/acats/tests/a/a97106a.ada
deleted file mode 100644
index c254032..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a97106a.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- A97106A.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 MAY HAVE MORE THAN ONE 'DELAY' ALTER-
--- NATIVE.
-
-
--- RM 4/27/1982
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE A97106A IS
-
-
-BEGIN
-
-
- TEST ( "A97106A" , "CHECK THAT A SELECTIVE_WAIT MAY HAVE" &
- " MORE THAN ONE 'DELAY' ALTERNATIVE" );
-
- -------------------------------------------------------------------
-
-
- DECLARE
-
-
- TASK TYPE TT IS
- ENTRY A ;
- END TT ;
-
-
- TASK BODY TT IS
- DUMMY : BOOLEAN := FALSE ;
- BEGIN
-
- SELECT
- ACCEPT A ;
- OR
- DELAY 2.5 ;
- OR
- ACCEPT A ;
- OR
- ACCEPT A ;
- OR
- DELAY 2.5 ; -- MULTIPLE 'DELAY'S PERMITTED (IF
- OR -- AND ONLY IF SINGLE 'DELAY'S
- DELAY 2.5 ; -- ARE PERMITTED).
- OR
- ACCEPT A ;
- END SELECT ;
-
- END TT ;
-
- BEGIN
- NULL ;
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END A97106A ;
diff --git a/gcc/testsuite/ada/acats/tests/a/a99006a.ada b/gcc/testsuite/ada/acats/tests/a/a99006a.ada
deleted file mode 100644
index d9822f4..0000000
--- a/gcc/testsuite/ada/acats/tests/a/a99006a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- A99006A.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 'COUNT RETURNS A UNIVERSAL INTEGER VALUE.
-
--- HISTORY:
--- DHH 03/28/88 CREATED ORIGINAL TEST.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE A99006A IS
-
- TASK CHOICE IS
- ENTRY START;
- ENTRY E1;
- ENTRY STOP;
- END CHOICE;
-
- TASK BODY CHOICE IS
- X : INTEGER;
- BEGIN
- ACCEPT START;
- ACCEPT E1 DO
- DECLARE
- TYPE Y IS NEW INTEGER RANGE -5 .. 5;
- T : Y := E1'COUNT;
- BEGIN
- X := E1'COUNT;
- END;
- END E1;
- ACCEPT STOP;
- END CHOICE;
-
-BEGIN
-
- TEST("A99006A", "CHECK THAT 'COUNT RETURNS A UNIVERSAL INTEGER " &
- "VALUE");
-
- CHOICE.START;
- CHOICE.E1;
- CHOICE.STOP;
-
- RESULT;
-END A99006A;
diff --git a/gcc/testsuite/ada/acats/tests/a/aa2010a.ada b/gcc/testsuite/ada/acats/tests/a/aa2010a.ada
deleted file mode 100644
index 7feee25..0000000
--- a/gcc/testsuite/ada/acats/tests/a/aa2010a.ada
+++ /dev/null
@@ -1,199 +0,0 @@
--- AA2010A.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 SUBUNIT NAMES CAN BE IDENTICAL TO IDENTIFIERS DECLARED IN
--- STANDARD, NAMELY, BOOLEAN, INTEGER, FLOAT, CHARACTER, ASCII,
--- NATURAL, POSITIVE, STRING, DURATION, CONSTRAINT_ERROR,
--- NUMERIC_ERROR, PROGRAM_ERROR, STORAGE_ERROR, AND TASKING_ERROR.
-
--- R.WILLIAMS 9/18/86
-
-PACKAGE AA2010A_TYPEDEF IS
- TYPE ENUM IS (E1, E2, E3);
-END AA2010A_TYPEDEF;
-
-WITH AA2010A_TYPEDEF; USE AA2010A_TYPEDEF;
-PACKAGE AA2010A_PARENT IS
-
- PROCEDURE BOOLEAN;
- FUNCTION INTEGER RETURN ENUM;
- PACKAGE FLOAT IS END FLOAT;
-
- PROCEDURE CHARACTER;
- FUNCTION ASCII RETURN ENUM;
-
- TASK NATURAL IS
- ENTRY E;
- END NATURAL;
-
- PROCEDURE POSITIVE;
- FUNCTION STRING RETURN ENUM;
- PACKAGE DURATION IS END DURATION;
-
- PROCEDURE CONSTRAINT_ERROR;
- FUNCTION NUMERIC_ERROR RETURN ENUM;
-
- TASK PROGRAM_ERROR IS
- ENTRY E;
- END PROGRAM_ERROR;
-
- PROCEDURE STORAGE_ERROR;
- FUNCTION TASKING_ERROR RETURN ENUM;
-
-END AA2010A_PARENT;
-
-PACKAGE BODY AA2010A_PARENT IS
-
- PROCEDURE BOOLEAN IS SEPARATE;
- FUNCTION INTEGER RETURN ENUM IS SEPARATE;
- PACKAGE BODY FLOAT IS SEPARATE;
-
- PROCEDURE CHARACTER IS SEPARATE;
- FUNCTION ASCII RETURN ENUM IS SEPARATE;
- TASK BODY NATURAL IS SEPARATE;
-
- PROCEDURE POSITIVE IS SEPARATE;
- FUNCTION STRING RETURN ENUM IS SEPARATE;
- PACKAGE BODY DURATION IS SEPARATE;
-
- PROCEDURE CONSTRAINT_ERROR IS SEPARATE;
- FUNCTION NUMERIC_ERROR RETURN ENUM IS SEPARATE;
- TASK BODY PROGRAM_ERROR IS SEPARATE;
-
- PROCEDURE STORAGE_ERROR IS SEPARATE;
- FUNCTION TASKING_ERROR RETURN ENUM IS SEPARATE;
-
-END AA2010A_PARENT;
-
-SEPARATE (AA2010A_PARENT)
-PROCEDURE BOOLEAN IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2010A_PARENT)
-FUNCTION INTEGER RETURN ENUM IS
-BEGIN
- RETURN E1;
-END;
-
-SEPARATE (AA2010A_PARENT)
-PACKAGE BODY FLOAT IS END;
-
-SEPARATE (AA2010A_PARENT)
-PROCEDURE CHARACTER IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2010A_PARENT)
-FUNCTION ASCII RETURN ENUM IS
-BEGIN
- RETURN E1;
-END;
-
-SEPARATE (AA2010A_PARENT)
-TASK BODY NATURAL IS
-BEGIN
- ACCEPT E;
-END;
-
-SEPARATE (AA2010A_PARENT)
-PROCEDURE POSITIVE IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2010A_PARENT)
-FUNCTION STRING RETURN ENUM IS
-BEGIN
- RETURN E1;
-END;
-
-SEPARATE (AA2010A_PARENT)
-PACKAGE BODY DURATION IS END;
-
-SEPARATE (AA2010A_PARENT)
-PROCEDURE CONSTRAINT_ERROR IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2010A_PARENT)
-FUNCTION NUMERIC_ERROR RETURN ENUM IS
-BEGIN
- RETURN E1;
-END;
-
-SEPARATE (AA2010A_PARENT)
-TASK BODY PROGRAM_ERROR IS
-BEGIN
- ACCEPT E;
-END;
-
-SEPARATE (AA2010A_PARENT)
-PROCEDURE STORAGE_ERROR IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2010A_PARENT)
-FUNCTION TASKING_ERROR RETURN ENUM IS
-BEGIN
- RETURN E1;
-END;
-
-WITH REPORT; USE REPORT;
-WITH AA2010A_TYPEDEF; USE AA2010A_TYPEDEF;
-WITH AA2010A_PARENT; USE AA2010A_PARENT;
-PROCEDURE AA2010A IS
- E : ENUM;
-BEGIN
- TEST ( "AA2010A", "CHECK THAT SUBUNIT NAMES CAN BE IDENTICAL " &
- "TO IDENTIFIERS DECLARED IN STANDARD, " &
- "NAMELY, BOOLEAN, INTEGER, FLOAT, " &
- "CHARACTER, ASCII, NATURAL, POSITIVE, " &
- "STRING, DURATION, CONSTRAINT_ERROR, " &
- "NUMERIC_ERROR, PROGRAM_ERROR, " &
- "STORAGE_ERROR, AND TASKING_ERROR" );
-
- AA2010A_PARENT.BOOLEAN;
- E := AA2010A_PARENT.INTEGER;
-
- AA2010A_PARENT.CHARACTER;
- E := AA2010A_PARENT.ASCII;
- AA2010A_PARENT.NATURAL.E;
-
- AA2010A_PARENT.POSITIVE;
- E := AA2010A_PARENT.STRING;
-
- AA2010A_PARENT.CONSTRAINT_ERROR;
- E := AA2010A_PARENT.NUMERIC_ERROR;
- AA2010A_PARENT.PROGRAM_ERROR.E;
-
- AA2010A_PARENT.STORAGE_ERROR;
- E := AA2010A_PARENT.TASKING_ERROR;
-
- RESULT;
-END AA2010A;
diff --git a/gcc/testsuite/ada/acats/tests/a/aa2012a.ada b/gcc/testsuite/ada/acats/tests/a/aa2012a.ada
deleted file mode 100644
index 0f72c30..0000000
--- a/gcc/testsuite/ada/acats/tests/a/aa2012a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- AA2012A.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 BODY STUB CAN SERVE AS AN IMPLICIT DECLARATION OF A
--- SUBPROGRAM, I.E., A PRECEDING SUBPROGRAM DECLARATION IS NOT
--- REQUIRED.
-
--- R.WILLIAMS 9/18/86
-
-PROCEDURE AA2012A1 IS
-
- I : INTEGER;
-
- PROCEDURE AA2012A2 IS SEPARATE;
-
- FUNCTION AA2012A3 RETURN INTEGER IS SEPARATE;
-
-BEGIN
- AA2012A2;
- I := AA2012A3;
-
-END AA2012A1;
-
-SEPARATE (AA2012A1)
-PROCEDURE AA2012A2 IS
-BEGIN
- NULL;
-END;
-
-SEPARATE (AA2012A1)
-FUNCTION AA2012A3 RETURN INTEGER IS
-BEGIN
- RETURN 5;
-END;
-
-WITH AA2012A1;
-WITH REPORT; USE REPORT;
-PROCEDURE AA2012A IS
-
-BEGIN
- TEST ( "AA2012A", "CHECK THAT A BODY STUB CAN SERVE AS AN " &
- "IMPLICIT DECLARATION OF A SUBPROGRAM, " &
- "I.E., A PRECEDING SUBPROGRAM DECLARATION " &
- "IS NOT REQUIRED" );
-
- AA2012A1;
-
- RESULT;
-END AA2012A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ac1015b.ada b/gcc/testsuite/ada/acats/tests/a/ac1015b.ada
deleted file mode 100644
index 0e83ca5..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ac1015b.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- AC1015B.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 WITHIN A GENERIC SUBPROGRAM THE NAME OF THE GENERIC
--- SUBPROGRAM CAN BE USED AS AN ACTUAL PARAMETER IN AN
--- INSTANTIATION.
-
--- HISTORY:
--- BCB 03/28/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE AC1015B IS
-
- GENERIC
- PROCEDURE P;
-
- PROCEDURE P IS
- GENERIC
- WITH PROCEDURE F;
- PROCEDURE T;
-
- PROCEDURE T IS
- BEGIN
- NULL;
- END T;
-
- PROCEDURE S IS NEW T(F => P);
-
- BEGIN
- NULL;
- END P;
-
- GENERIC
- FUNCTION D RETURN BOOLEAN;
-
- FUNCTION D RETURN BOOLEAN IS
- GENERIC
- WITH FUNCTION L RETURN BOOLEAN;
- FUNCTION A RETURN BOOLEAN;
-
- FUNCTION A RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END A;
-
- FUNCTION B IS NEW A(L => D);
-
- BEGIN
- RETURN TRUE;
- END D;
-
-BEGIN
- TEST ("AC1015B", "CHECK THAT WITHIN A GENERIC SUBPROGRAM THE " &
- "NAME OF THE GENERIC SUBPROGRAM CAN BE USED AS " &
- "AN ACTUAL PARAMETER IN AN INSTANTIATION");
-
- RESULT;
-END AC1015B;
diff --git a/gcc/testsuite/ada/acats/tests/a/ac3106a.ada b/gcc/testsuite/ada/acats/tests/a/ac3106a.ada
deleted file mode 100644
index 1b7099e..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ac3106a.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- AC3106A.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 ACTUAL GENERIC IN OUT PARAMETER CAN BE:
--- A) ANY SUBCOMPONENT THAT DOES NOT DEPEND ON A DISCRIMINANT,
--- EVEN IF THE ENCLOSING VARIABLE IS UNCONSTRAINED;
--- B) ANY SUBCOMPONENT OF AN UNCONSTAINED VARIABLE OF A
--- RECORD TYPE IF THE DISCRIMINANTS OF THE
--- VARIABLE DO NOT HAVE DEFAULTS AND THE VARIABLE IS NOT
--- A GENERIC FORMAL IN OUT PARAMETER;
--- C) ANY COMPONENT OF AN OBJECT DESIGNATED BY AN ACCESS
--- VALUE.
-
--- HISTORY:
--- RJW 11/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE AC3106A IS
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
-
- TYPE REC (D : INT := 0) IS RECORD
- A : INTEGER := 5;
- CASE D IS
- WHEN OTHERS =>
- V : INTEGER := 5;
- END CASE;
- END RECORD;
-
- TYPE AR_REC IS ARRAY (1 .. 10) OF REC;
-
- TYPE R_REC IS RECORD
- E : REC;
- END RECORD;
-
- TYPE A_STRING IS ACCESS STRING;
- TYPE A_REC IS ACCESS REC;
- TYPE A_AR_REC IS ACCESS AR_REC;
- TYPE A_R_REC IS ACCESS R_REC;
-
- TYPE DIS (L : INT := 1) IS RECORD
- S : STRING (1 .. L) := "A";
- R : REC (L);
- AS : A_STRING (1 .. L) := NEW STRING (1 .. L);
- AR : A_REC (L) := NEW REC (1);
- RC : REC (3);
- ARU : A_REC := NEW REC;
- V_AR : AR_REC;
- V_R : R_REC;
- AC_AR : A_AR_REC := NEW AR_REC;
- AC_R : A_R_REC := NEW R_REC;
- END RECORD;
-
- TYPE A_DIS IS ACCESS DIS;
- AD : A_DIS := NEW DIS;
-
- TYPE DIS2 (L : INT) IS RECORD
- S : STRING (1 .. L);
- R : REC (L);
- AS : A_STRING (1 .. L);
- AR : A_REC (L);
- END RECORD;
-
- X : DIS;
-
- SUBTYPE REC3 IS REC (3);
-
- GENERIC
- GREC3 : IN OUT REC3;
- PACKAGE PREC3 IS END PREC3;
-
- SUBTYPE REC0 IS REC (0);
-
- GENERIC
- GREC0 : IN OUT REC0;
- PACKAGE PREC0 IS END PREC0;
-
- GENERIC
- GINT : IN OUT INTEGER;
- PACKAGE PINT IS END PINT;
-
- GENERIC
- GA_REC : IN OUT A_REC;
- PACKAGE PA_REC IS END PA_REC;
-
- GENERIC
- GAR_REC : IN OUT AR_REC;
- PACKAGE PAR_REC IS END PAR_REC;
-
- GENERIC
- GR_REC : IN OUT R_REC;
- PACKAGE PR_REC IS END PR_REC;
-
- GENERIC
- GA_AR_REC : IN OUT A_AR_REC;
- PACKAGE PA_AR_REC IS END PA_AR_REC;
-
- GENERIC
- GA_R_REC : IN OUT A_R_REC;
- PACKAGE PA_R_REC IS END PA_R_REC;
-
- TYPE BUFFER (SIZE : INT) IS RECORD
- POS : NATURAL := 0;
- VAL : STRING (1 .. SIZE);
- END RECORD;
-
- SUBTYPE BUFF_5 IS BUFFER (5);
-
- GENERIC
- Y : IN OUT CHARACTER;
- PACKAGE P_CHAR IS END P_CHAR;
-
- SUBTYPE STRING5 IS STRING (1 .. 5);
- GENERIC
- GSTRING : STRING5;
- PACKAGE P_STRING IS END P_STRING;
-
- GENERIC
- GA_STRING : A_STRING;
- PACKAGE P_A_STRING IS END P_A_STRING;
-
- GENERIC
- X : IN OUT BUFF_5;
- PACKAGE P_BUFF IS
- RX : BUFF_5 RENAMES X;
- END P_BUFF;
-
- Z : BUFFER (1) := (SIZE => 1, POS =>82, VAL =>"R");
-BEGIN
- TEST ("AC3106A", "CHECK THE PERMITTED FORMS OF AN ACTUAL " &
- "GENERIC IN OUT PARAMETER");
-
- DECLARE -- A)
- PACKAGE NPINT3 IS NEW PINT (X.RC.A);
- PACKAGE NPINT4 IS NEW PINT (X.RC.V);
- PACKAGE NPREC3 IS NEW PREC3 (X.RC);
- PACKAGE NPA_REC IS NEW PA_REC (X.ARU);
- PACKAGE NPINT5 IS NEW PINT (X.ARU.A);
- PACKAGE NPINT6 IS NEW PINT (X.ARU.V);
- PACKAGE NPAR_REC IS NEW PAR_REC (X.V_AR);
- PACKAGE NPREC01 IS NEW PREC0 (X.V_AR (1));
- PACKAGE NPR_REC IS NEW PR_REC (X.V_R);
- PACKAGE NPREC02 IS NEW PREC0 (X.V_R.E);
- PACKAGE NPINT7 IS NEW PINT (X.V_R.E.A);
-
- PACKAGE NP_BUFF IS NEW P_BUFF (Z);
- USE NP_BUFF;
-
- PACKAGE NP_CHAR3 IS NEW P_CHAR (RX.VAL (1));
-
- PROCEDURE PROC (X : IN OUT BUFFER) IS
- PACKAGE NP_CHAR4 IS NEW P_CHAR (X.VAL (1));
- BEGIN
- NULL;
- END;
- BEGIN
- NULL;
- END; -- A)
-
- DECLARE -- B)
- PROCEDURE PROC (Y : IN OUT DIS2) IS
- PACKAGE NP_STRING IS NEW P_STRING (Y.S);
- PACKAGE NP_CHAR IS NEW P_CHAR (Y.S (1));
- PACKAGE NP_A_STRING IS NEW P_A_STRING (Y.AS);
- PACKAGE NP_CHAR2 IS NEW P_CHAR (Y.AS (1));
- PACKAGE NPINT3 IS NEW PINT (Y.R.A);
- PACKAGE NPINT4 IS NEW PINT (Y.R.V);
- PACKAGE NPREC3 IS NEW PREC3 (Y.R);
- PACKAGE NPA_REC IS NEW PA_REC (Y.AR);
- PACKAGE NPINT5 IS NEW PINT (Y.AR.A);
- PACKAGE NPINT6 IS NEW PINT (Y.AR.V);
- BEGIN
- NULL;
- END;
- BEGIN
- NULL;
- END; -- B)
-
- DECLARE -- C)
- PACKAGE NP_CHAR IS NEW P_CHAR (AD.S (1));
- PACKAGE NP_A_STRING IS NEW P_A_STRING (AD.AS);
- PACKAGE NP_CHAR2 IS NEW P_CHAR (AD.AS (1));
- PACKAGE NPINT3 IS NEW PINT (AD.R.A);
- PACKAGE NPINT4 IS NEW PINT (AD.R.V);
- PACKAGE NPREC3 IS NEW PREC3 (AD.R);
- PACKAGE NPA_REC IS NEW PA_REC (AD.AR);
- PACKAGE NPINT5 IS NEW PINT (AD.AR.A);
- PACKAGE NPINT6 IS NEW PINT (AD.AR.V);
- BEGIN
- NULL;
- END; -- C)
-
- RESULT;
-END AC3106A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ac3206a.ada b/gcc/testsuite/ada/acats/tests/a/ac3206a.ada
deleted file mode 100644
index df535a9..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ac3206a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- AC3206A.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 INSTANTIATION IS LEGAL IF A FORMAL PRIVATE TYPE IS
--- USED IN A CONSTANT DECLARATION AND THE ACTUAL PARAMETER IS A
--- TYPE WITH DISCRIMINANTS THAT DO AND DO NOT HAVE DEFAULTS. (CHECK
--- CASES THAT USED TO BE FORBIDDEN).
-
--- HISTORY:
--- DHH 09/16/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE AC3206A IS
-
-BEGIN
- TEST ("AC3206A", "CHECK THAT AN INSTANTIATION IS LEGAL IF A " &
- "FORMAL PRIVATE TYPE IS USED IN A CONSTANT " &
- "DECLARATION AND THE ACTUAL PARAMETER IS A " &
- "TYPE WITH DISCRIMINANTS THAT DO AND DO NOT " &
- "HAVE DEFAULTS");
-
- DECLARE -- CHECK DEFAULTS LEGAL UNDER AI-37.
-
- GENERIC
- TYPE GEN IS PRIVATE;
- INIT : GEN;
- PACKAGE GEN_PACK IS
- CONST : CONSTANT GEN := INIT;
- SUBTYPE NEW_GEN IS GEN;
- END GEN_PACK;
-
- TYPE REC(A : INTEGER := 4) IS
- RECORD
- X : INTEGER;
- Y : BOOLEAN;
- END RECORD;
-
- PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE));
- USE P;
-
- CON : CONSTANT P.NEW_GEN := (4, 5, FALSE);
-
- BEGIN
- NULL;
- END;
-
- DECLARE
-
- GENERIC
- TYPE GEN(DIS : INTEGER) IS PRIVATE;
- INIT : GEN;
- PACKAGE GEN_PACK IS
- CONST : CONSTANT GEN := INIT;
- SUBTYPE NEW_GEN IS GEN(4);
- END GEN_PACK;
-
- TYPE REC(A : INTEGER := 4) IS
- RECORD
- X : INTEGER;
- Y : BOOLEAN;
- END RECORD;
-
- PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE));
- USE P;
-
- CON : CONSTANT P.NEW_GEN := (4, 5, FALSE);
-
- BEGIN
- NULL;
- END;
-
- DECLARE
-
- GENERIC
- TYPE GEN(DIS : INTEGER) IS PRIVATE;
- INIT : GEN;
- PACKAGE GEN_PACK IS
- CONST : CONSTANT GEN := INIT;
- SUBTYPE NEW_GEN IS GEN(4);
- END GEN_PACK;
-
- TYPE REC(A : INTEGER) IS
- RECORD
- X : INTEGER;
- Y : BOOLEAN;
- END RECORD;
-
- PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE));
- USE P;
-
- CON : CONSTANT P.NEW_GEN := (4, 5, FALSE);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END AC3206A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ac3207a.ada b/gcc/testsuite/ada/acats/tests/a/ac3207a.ada
deleted file mode 100644
index 16057b9..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ac3207a.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- AC3207A.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 INSTANTIATION IS LEGAL IF A FORMAL PARAMETER
--- HAVING A LIMITED PRIVATE TYPE WITHOUT DISCRIMINANTS IS USED TO
--- DECLARE AN OBJECT IN A BLOCK THAT CONTAINS A SELECTIVE WAIT
--- WITH A TERMINATE ALTERNATIVE, AND THE ACTUAL PARAMETER'S BASE
--- TYPE IS A TASK TYPE OR A TYPE WITH A SUBCOMPONENT OF A TASK TYPE.
-
--- HISTORY:
--- DHH 09/16/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE AC3207A IS
-
- GENERIC
- TYPE PRIV IS LIMITED PRIVATE;
- PACKAGE GEN_P IS
- TASK T1 IS
- ENTRY E;
- END T1;
- END GEN_P;
-
- TASK TYPE TASK_T IS
- END TASK_T;
-
- TYPE REC IS
- RECORD
- OBJ : TASK_T;
- END RECORD;
-
- PACKAGE BODY GEN_P IS
- TASK BODY T1 IS
- BEGIN
- DECLARE
- OBJ : PRIV;
- BEGIN
- SELECT
- ACCEPT E;
- OR
- TERMINATE;
- END SELECT;
- END;
- END T1;
- END GEN_P;
-
- TASK BODY TASK_T IS
- BEGIN
- NULL;
- END;
-
- PACKAGE P IS NEW GEN_P(TASK_T);
- PACKAGE NEW_P IS NEW GEN_P(REC);
-
-BEGIN
- TEST ("AC3207A", "CHECK THAT AN INSTANTIATION IS LEGAL IF A " &
- "FORMAL PARAMETER HAVING A LIMITED PRIVATE " &
- "TYPE WITHOUT DISCRIMINANTS IS USED TO " &
- "DECLARE AN OBJECT IN A BLOCK THAT CONTAINS " &
- "A SELECTIVE WAIT WITH A TERMINATE " &
- "ALTERNATIVE, AND THE ACTUAL PARAMETER'S BASE " &
- "TYPE IS A TASK TYPE OR A TYPE WITH A " &
- "SUBCOMPONENT OF A TASK TYPE");
-
- P.T1.E;
-
- NEW_P.T1.E;
-
- RESULT;
-END AC3207A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7001b.ada b/gcc/testsuite/ada/acats/tests/a/ad7001b.ada
deleted file mode 100644
index 7e14d18..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7001b.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- AD7001B.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 DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE
--- IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR THE UNIT
--- CONTAINING THE REFERENCES.
-
--- HISTORY:
--- JET 09/08/87 CREATED ORIGINAL TEST.
--- VCL 03/30/88 CREATED NAMED NUMBERS WITH VALUES OF
--- SYSTEM.MIN_INT AND SYSTEM.MAX_INT. DELETED
--- ASSIGNMENTS OF MIN_INT AND MAX_INT TO INTEGER
--- VARIABLES.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7001B IS
-
- CHECK_ADDRESS : SYSTEM.ADDRESS;
- CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME;
- CHECK_PRIORITY : SYSTEM.PRIORITY;
- I : INTEGER;
- F : FLOAT;
- SMALL : CONSTANT := SYSTEM.MIN_INT;
- LARGE : CONSTANT := SYSTEM.MAX_INT;
- MEM : CONSTANT := SYSTEM.MEMORY_SIZE;
-
-BEGIN
-
- TEST ("AD7001B", "CHECK THAT A DECLARATION IN PACKAGE " &
- "SYSTEM IS ACCESSIBLE IF A WITH CLAUSE " &
- "NAMING SYSTEM IS PROVIDED FOR THE UNIT " &
- "CONTAINING THE REFERENCES");
-
- I := SYSTEM.STORAGE_UNIT;
- I := SYSTEM.MAX_DIGITS;
- I := SYSTEM.MAX_MANTISSA;
- F := SYSTEM.FINE_DELTA;
- F := SYSTEM.TICK;
-
- RESULT;
-
-END AD7001B;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada b/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada
deleted file mode 100644
index 7b46583..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- AD7001C0M.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 DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE
--- IN A LIBRARY PACKAGE BODY IF A WITH CLAUSE NAMING SYSTEM
--- IS PROVIDED FOR THE PACKAGE SPECIFICATION, ALTHOUGH IN A
--- SEPARATE FILE.
-
--- HISTORY:
--- JET 09/09/87 CREATED ORIGINAL TEST.
--- RJW 05/03/88 REVISED AND ENTERED TEST INTO ACVC.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
--- THIS FILE CONTAINS PACKAGE SPEC AD7001C_PACKAGE AND THE MAIN
--- PROCEDURE FOR TEST AD7001C. FILE AD7001C1.ADA CONTAINS
--- THE PACKAGE BODY FOR THE PACKAGE SPEC AND IS ALSO REQUIRED
--- FOR TEST EXECUTION.
-
-WITH SYSTEM;
-
-PACKAGE AD7001C_PACKAGE IS
-
- I : INTEGER;
- F : FLOAT;
-
- PROCEDURE REQUIRE_BODY;
-
-END AD7001C_PACKAGE;
-
-
-WITH AD7001C_PACKAGE; USE AD7001C_PACKAGE;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7001C0M IS
-
-BEGIN
- TEST ("AD7001C", "CHECK THAT A DECLARATION IN PACKAGE SYSTEM " &
- "IS ACCESSIBLE IN A LIBRARY PACKAGE BODY IF " &
- "A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR " &
- "THE PACKAGE SPECIFICATION, ALTHOUGH IN A " &
- "SEPARATE FILE");
- RESULT;
-END AD7001C0M;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada b/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada
deleted file mode 100644
index f7fd898..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- AD7001C1.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 DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE
--- IN A LIBRARY PACKAGE BODY IF A WITH CLAUSE NAMING SYSTEM
--- IS PROVIDED FOR THE PACKAGE SPECIFICATION, ALTHOUGH IN ANOTHER
--- FILE.
-
--- HISTORY:
--- JET 09/09/87 CREATED ORIGINAL TEST.
--- RJW 05/03/88 REVISED AND ENTERED IN ACVC.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
--- THIS FILE CONTAINS THE PACKAGE BODY FOR PACKAGE AD7001C_PACKAGE.
--- FILE AD7001C0M.ADA CONTAINS THE PACKAGE SPEC AND MAIN PROCEDURE
--- FOR TEST AD7001C AND IS ALSO REQUIRED FOR TEST EXECUTION.
-
-PACKAGE BODY AD7001C_PACKAGE IS
-
- CHECK_ADDRESS : SYSTEM.ADDRESS;
- CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME;
- CHECK_PRIORITY : SYSTEM.PRIORITY;
- MEM_SIZE : CONSTANT := SYSTEM.MEMORY_SIZE;
-
- TYPE INTRANGE IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
-BEGIN
- I := SYSTEM.STORAGE_UNIT;
- I := SYSTEM.MAX_DIGITS;
- I := SYSTEM.MAX_MANTISSA;
- F := SYSTEM.FINE_DELTA;
- F := SYSTEM.TICK;
-END AD7001C_PACKAGE;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada b/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada
deleted file mode 100644
index 0973e00..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- AD7001D0M.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 DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE
--- IN A SUBUNIT IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED
--- FOR THE MAIN UNIT CONTAINING THE SUBUNIT, ALTHOUGH IN A
--- SEPARATE FILE.
-
--- HISTORY:
--- JET 09/09/87 CREATED ORIGINAL TEST.
--- RJW 05/03/88 REVISED AND ENTERED TEST INTO ACVC.
-
--- THIS FILE CONTAINS THE MAIN PROCEDURE FOR TEST AD7001D. FILE
--- AD7001D1.ADA CONTAINS THE PACKAGE BODY FOR THE SUBUNIT PACKAGE
--- SPEC AND IS ALSO REQUIRED FOR TEST EXECUTION.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7001D0M IS
-
- PACKAGE AD7001D_PACKAGE IS
-
- I : INTEGER;
- F : FLOAT;
-
- END AD7001D_PACKAGE;
-
- PACKAGE BODY AD7001D_PACKAGE IS SEPARATE;
-
-BEGIN
- TEST ("AD7001D", "CHECK THAT A DECLARATION IN PACKAGE SYSTEM " &
- "IS ACCESSIBLE IN A SUBUNIT IF A WITH CLAUSE " &
- "NAMING SYSTEM IS PROVIDED FOR THE MAIN UNIT " &
- "CONTAINING THE SUBUNIT, ALTHOUGH IN A " &
- "SEPARATE FILE");
- RESULT;
-END AD7001D0M;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada b/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada
deleted file mode 100644
index fea236a..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- AD7001D1.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 DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE IN
--- A SUBUNIT IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR THE
--- MAIN UNIT CONTAINING THE SUBUNIT, ALTHOUGH IN A SEPARATE
--- FILE.
-
--- HISTORY:
--- JET 09/09/87 CREATED ORIGINAL TEST.
-
--- THIS FILE CONTAINS THE PACKAGE BODY FOR PACKAGE AD7001D_PACKAGE.
--- FILE AD7001D0M.ADA CONTAINS THE PACKAGE SPEC AND MAIN PROCEDURE
--- FOR TEST AD7001D AND IS ALSO REQUIRED FOR TEST EXECUTION.
-
-SEPARATE (AD7001D0M)
-
-PACKAGE BODY AD7001D_PACKAGE IS
-
- CHECK_ADDRESS : SYSTEM.ADDRESS;
- CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME;
- CHECK_PRIORITY : SYSTEM.PRIORITY;
- MEM_SIZE : CONSTANT := SYSTEM.MEMORY_SIZE;
-
- TYPE INTRANGE IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
-
-BEGIN
- I := SYSTEM.STORAGE_UNIT;
- I := SYSTEM.MAX_DIGITS;
- I := SYSTEM.MAX_MANTISSA;
- F := SYSTEM.FINE_DELTA;
- F := SYSTEM.TICK;
-END AD7001D_PACKAGE;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7006a.ada b/gcc/testsuite/ada/acats/tests/a/ad7006a.ada
deleted file mode 100644
index 1154fe3..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7006a.ada
+++ /dev/null
@@ -1,47 +0,0 @@
--- AD7006A.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 CONSTANT 'SYSTEM.MEMORY_SIZE' IS DECLARED AND
--- THAT IT IS A STATIC UNIVERSAL INTEGER.
-
--- HISTORY:
--- VCL 09/14/87 CREATED ORIGINAL TEST.
--- RJW 06/13/89 MODIFIED TEST AND REMOVED INTEGER VARIABLE.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE AD7006A IS
-BEGIN
- TEST ("AD7006A", "THE CONSTANT 'SYSTEM.MEMORY_SIZE' IS " &
- "DECLARED AND IT IS A STATIC UNIVERSAL " &
- "INTEGER");
-
- DECLARE
- MY_MSIZE : CONSTANT := SYSTEM.MEMORY_SIZE - 1;
- BEGIN
- RESULT;
- END;
-
-END AD7006A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7101a.ada b/gcc/testsuite/ada/acats/tests/a/ad7101a.ada
deleted file mode 100644
index d0ee568..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7101a.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- AD7101A.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 MIN_INT AND MAX_INT ARE DECLARED IN PACKAGE SYSTEM
--- AND THAT BOTH ARE STATIC AND HAVE TYPE <UNIVERSAL INTEGER>.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7101A IS
-
-U_MIN : CONSTANT := SYSTEM.MIN_INT;
-U_MAX : CONSTANT := SYSTEM.MAX_INT;
-
-TYPE S_MIN IS RANGE SYSTEM.MIN_INT .. 7;
-TYPE S_MAX IS RANGE 7 .. SYSTEM.MAX_INT;
-
-BEGIN
-
- TEST ("AD7101A", "CHECK THAT MIN_INT AND MAX_INT ARE DECLARED " &
- "IN PACKAGE SYSTEM AND THAT BOTH ARE STATIC " &
- "AND HAVE TYPE <UNIVERSAL INTEGER>");
-
- RESULT;
-
-END AD7101A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7101c.ada b/gcc/testsuite/ada/acats/tests/a/ad7101c.ada
deleted file mode 100644
index 7b65d75..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7101c.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- AD7101C.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 TYPE DEFINITIONS WITH RANGES -MAX_INT .. MAX_INT
--- AND MIN_INT .. MAX_INT ARE ACCEPTED.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
--- VCL 03/30/88 CHANGED INTEGER SUBTYPE DECLARATIONS TO TYPE
--- DEFINITIONS.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7101C IS
-
- TYPE CHECK1 IS RANGE -MAX_INT .. MAX_INT;
- TYPE CHECK2 IS RANGE MIN_INT .. MAX_INT;
-
-BEGIN
-
- TEST ("AD7101C", "CHECK THAT TYPE DEFINITIONS WITH RANGES " &
- "-MAX_INT .. MAX_INT AND MIN_INT .. MAX_INT " &
- "ARE ACCEPTED");
-
- RESULT;
-
-END AD7101C;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7102a.ada b/gcc/testsuite/ada/acats/tests/a/ad7102a.ada
deleted file mode 100644
index 8f517fc..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7102a.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- AD7102A.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 CONSTANT MAX_DIGITS IS DECLARED WITHIN THE
--- PACKAGE SYSTEM, THAT ITS TYPE IS <UNIVERSAL_INTEGER>, AND THAT
--- ITS VALUE IS STATIC.
-
--- HISTORY:
--- BCB 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7102A IS
-
- U_DIGITS : CONSTANT := SYSTEM.MAX_DIGITS;
-
- TYPE S_DIGITS IS RANGE 7 .. SYSTEM.MAX_DIGITS;
-
-BEGIN
-
- TEST ("AD7102A", "CHECK THAT THE CONSTANT MAX_DIGITS IS " &
- "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " &
- "TYPE IS <UNIVERSAL_INTEGER>, AND THAT ITS " &
- "VALUE IS STATIC");
- RESULT;
-
-END AD7102A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7103a.ada b/gcc/testsuite/ada/acats/tests/a/ad7103a.ada
deleted file mode 100644
index 55fc0c1..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7103a.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- AD7103A.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 CONSTANT MAX_MANTISSA IS DECLARED WITHIN THE
--- PACKAGE SYSTEM, THAT ITS TYPE IS <UNIVERSAL_INTEGER>, AND THAT
--- ITS VALUE IS STATIC.
-
--- HISTORY:
--- BCB 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7103A IS
-
- U_MANTISSA : CONSTANT := SYSTEM.MAX_MANTISSA;
-
- TYPE S_MANTISSA IS RANGE 7 .. SYSTEM.MAX_MANTISSA;
-
-BEGIN
-
- TEST ("AD7103A", "CHECK THAT THE CONSTANT MAX_MANTISSA IS " &
- "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " &
- "TYPE IS <UNIVERSAL_INTEGER>, AND THAT ITS " &
- "VALUE IS STATIC");
- RESULT;
-
-END AD7103A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7103c.ada b/gcc/testsuite/ada/acats/tests/a/ad7103c.ada
deleted file mode 100644
index 695eae3..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7103c.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- AD7103C.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 CONSTANT FINE_DELTA IS DECLARED WITHIN THE
--- PACKAGE SYSTEM, THAT ITS TYPE IS <UNIVERSAL_REAL>, AND THAT
--- ITS VALUE IS STATIC.
-
--- HISTORY:
--- BCB 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7103C IS
-
- U_DELTA : CONSTANT := SYSTEM.FINE_DELTA;
-
- TYPE S_DELTA IS DELTA SYSTEM.FINE_DELTA RANGE -1.0 .. 1.0;
-
-BEGIN
-
- TEST ("AD7103C", "CHECK THAT THE CONSTANT FINE_DELTA IS " &
- "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " &
- "TYPE IS <UNIVERSAL_REAL>, AND THAT ITS " &
- "VALUE IS STATIC");
- RESULT;
-
-END AD7103C;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7104a.ada b/gcc/testsuite/ada/acats/tests/a/ad7104a.ada
deleted file mode 100644
index 204a6e0..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7104a.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- AD7104A.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 CONSTANT TICK IS DECLARED WITHIN THE PACKAGE
--- SYSTEM, THAT ITS TYPE IS <UNIVERSAL_REAL>, AND THAT ITS VALUE
--- IS STATIC.
-
--- HISTORY:
--- BCB 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE AD7104A IS
-
- U_TICK: CONSTANT := SYSTEM.TICK;
-
- F : FLOAT := SYSTEM.TICK;
-
-BEGIN
-
- TEST ("AD7104A", "CHECK THAT THE CONSTANT TICK IS DECLARED " &
- "WITHIN THE PACKAGE SYSTEM, THAT ITS TYPE IS " &
- "<UNIVERSAL_REAL>, AND THAT ITS VALUE IS STATIC");
-
- RESULT;
-
-END AD7104A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7201a.ada b/gcc/testsuite/ada/acats/tests/a/ad7201a.ada
deleted file mode 100644
index e350277..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7201a.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- AD7201A.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 THE 'ADDRESS ATTRIBUTE CAN DENOTE A
--- PACKAGE, SUBPROGRAM, TASK TYPE, SINGLE TASK, AND LABEL.
-
--- HISTORY:
--- DHH 09/01/88 CREATED ORIGINAL TEST.
--- RJW 02/23/90 REMOVED TESTS FOR THE 'ADDRESS ATTRIBUTE APPLIED TO
--- A GENERIC UNIT. REMOVED DECLARATION OF TYPE
--- "COLOR".
--- DTN 11/22/91 DELETED SUBPART (A).
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE AD7201A IS
-
- SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS;
-
-BEGIN
- TEST ("AD7201A", "CHECK THAT THE PREFIX OF THE 'ADDRESS " &
- "ATTRIBUTE CAN DENOTE A PACKAGE, " &
- "SUBPROGRAM, TASK TYPE, SINGLE TASK, AND LABEL");
-
- DECLARE
- PACKAGE B IS
- END B;
- B1 : BOOLEAN := (B'ADDRESS IN MY_ADDRESS);
-
- PROCEDURE C;
- C1 : BOOLEAN := (C'ADDRESS IN MY_ADDRESS);
-
- FUNCTION D RETURN BOOLEAN;
- D1 : BOOLEAN := (D'ADDRESS IN MY_ADDRESS);
-
- TASK E IS
- END E;
- E1 : BOOLEAN := (E'ADDRESS IN MY_ADDRESS);
-
- TASK TYPE F IS
- END F;
- F1 : BOOLEAN := (F'ADDRESS IN MY_ADDRESS);
-
- G1 : BOOLEAN;
-
- PACKAGE BODY B IS
- BEGIN
- NULL;
- END B;
-
- PROCEDURE C IS
- BEGIN
- NULL;
- END C;
-
- FUNCTION D RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END D;
-
- TASK BODY E IS
- BEGIN
- NULL;
- END E;
-
- TASK BODY F IS
- BEGIN
- NULL;
- END F;
-
- BEGIN
-<<G>> G1 := (G'ADDRESS IN MY_ADDRESS);
- END;
-
- RESULT;
-END AD7201A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7203b.ada b/gcc/testsuite/ada/acats/tests/a/ad7203b.ada
deleted file mode 100644
index 47dd6b7..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7203b.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- AD7203B.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 THE 'SIZE' ATTRIBUTE CAN BE AN OBJECT,
--- A TYPE, OR A SUBTYPE.
-
--- HISTORY:
--- BCB 09/27/88 CREATED ORIGINAL TEST BY MODIFYING AND RENAMING
--- CD7203B.ADA.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE AD7203B IS
-
- TYPE I_REC IS
- RECORD
- I1, I2 : INTEGER;
- END RECORD;
-
- I : INTEGER;
- I_A : ARRAY (1 ..5) OF INTEGER;
- I_R : I_REC;
-
- I_SIZE : INTEGER := I'SIZE;
- I_A_SIZE : INTEGER := I_A'SIZE;
- I_R_SIZE : INTEGER := I_R'SIZE;
- I_A_1_SIZE : INTEGER := I_A(1)'SIZE;
- I_R_I1_SIZE : INTEGER := I_R.I1'SIZE;
-
- TYPE FIXED IS DELTA 0.01 RANGE -1.0 .. 1.0;
- TYPE FXD_REC IS
- RECORD
- FXD1, FXD2 : FIXED;
- END RECORD;
-
- FXD : FIXED;
- FXD_A : ARRAY (1 .. 5) OF FIXED;
- FXD_R : FXD_REC;
-
- FXD_SIZE : INTEGER := FXD'SIZE;
- FXD_A_SIZE : INTEGER := FXD_A'SIZE;
- FXD_R_SIZE : INTEGER := FXD_R'SIZE;
- FXD_A_1_SIZE : INTEGER := FXD_A(1)'SIZE;
- FXD_R_FXD1_SIZE : INTEGER := FXD_R.FXD1'SIZE;
-
- TYPE FLT_REC IS
- RECORD
- FLT1, FLT2 : FLOAT;
- END RECORD;
-
- FLT : FLOAT;
- FLT_A : ARRAY (1 .. 5) OF FLOAT;
- FLT_R : FLT_REC;
-
- FLT_SIZE : INTEGER := FLT'SIZE;
- FLT_A_SIZE : INTEGER := FLT_A'SIZE;
- FLT_R_SIZE : INTEGER := FLT_R'SIZE;
- FLT_A_1_SIZE : INTEGER := FLT_A(1)'SIZE;
- FLT_R_FLT1_SIZE : INTEGER := FLT_R.FLT1'SIZE;
-
- SUBTYPE TINY_INT IS INTEGER RANGE 0 .. 255;
- TYPE TI_REC IS
- RECORD
- TI1, TI2 : TINY_INT;
- END RECORD;
-
- TI : TINY_INT;
- TI_A : ARRAY (1 .. 5) OF TINY_INT;
- TI_R : TI_REC;
-
- TINY_INT_SIZE : INTEGER := TINY_INT'SIZE;
- TI_SIZE : INTEGER := TI'SIZE;
- TI_A_SIZE : INTEGER := TI_A'SIZE;
- TI_R_SIZE : INTEGER := TI_R'SIZE;
- TI_A_1_SIZE : INTEGER := TI_A(1)'SIZE;
- TI_R_TI1_SIZE : INTEGER := TI_R.TI1'SIZE;
-
- TYPE STR IS ARRAY (TINY_INT RANGE <>) OF CHARACTER;
- TYPE STR_2 IS ARRAY (1 .. 127) OF CHARACTER;
- TYPE STR_REC IS
- RECORD
- S1, S2 : STR (TINY_INT'FIRST .. TINY_INT'LAST);
- END RECORD;
-
- S : STR (TINY_INT'FIRST .. TINY_INT'LAST);
- S_A : ARRAY (1 .. 5) OF STR (TINY_INT'FIRST .. TINY_INT'LAST);
- S_R : STR_REC;
-
- STR_2_SIZE : INTEGER := STR_2'SIZE;
- S_SIZE : INTEGER := S'SIZE;
- S_A_SIZE : INTEGER := S_A'SIZE;
- S_R_SIZE : INTEGER := S_R'SIZE;
- S_A_1_SIZE : INTEGER := S_A(1)'SIZE;
- S_R_S1_SIZE : INTEGER := S_R.S1'SIZE;
-
- TYPE C_REC IS
- RECORD
- C1, C2 : CHARACTER;
- END RECORD;
-
- C : CHARACTER;
- C_A : ARRAY (1 .. 5) OF CHARACTER;
- C_R : C_REC;
-
- C_SIZE : INTEGER := C'SIZE;
- C_A_SIZE : INTEGER := C_A'SIZE;
- C_R_SIZE : INTEGER := C_R'SIZE;
- C_A_1_SIZE : INTEGER := C_A(1)'SIZE;
- C_R_C1_SIZE : INTEGER := C_R.C1'SIZE;
-
- TYPE B_REC IS
- RECORD
- B1, B2 : BOOLEAN;
- END RECORD;
-
- B : BOOLEAN;
- B_A : ARRAY (1 .. 5) OF BOOLEAN;
- B_R : B_REC;
-
- B_SIZE : INTEGER := B'SIZE;
- B_A_SIZE : INTEGER := B_A'SIZE;
- B_R_SIZE : INTEGER := B_R'SIZE;
- B_A_1_SIZE : INTEGER := B_A(1)'SIZE;
- B_R_B1_SIZE : INTEGER := B_R.B1'SIZE;
-
- TYPE DISCR IS RANGE 1 .. 2;
- TYPE DISCR_REC (D : DISCR := 1) IS
- RECORD
- CASE D IS
- WHEN 1 =>
- C1_I : INTEGER;
- WHEN 2 =>
- C2_I1 : INTEGER;
- C2_I2 : INTEGER;
- END CASE;
- END RECORD;
-
- DR_UC : DISCR_REC;
- DR_C : DISCR_REC (2);
- DR_A : ARRAY (1 .. 5) OF DISCR_REC;
-
- DR_UC_SIZE : INTEGER := DR_UC'SIZE;
- DR_C_SIZE : INTEGER := DR_C'SIZE;
- DR_A_SIZE : INTEGER := DR_A'SIZE;
- DR_UC_C1_I_SIZE : INTEGER := DR_UC.C1_I'SIZE;
- DR_A_1_SIZE : INTEGER := DR_A(1)'SIZE;
-
- TYPE ENUM IS (E1, E2, E3, E4);
- TYPE ENUM_REC IS
- RECORD
- E1, E2 : ENUM;
- END RECORD;
-
- E : ENUM;
- E_A : ARRAY (1 .. 5) OF ENUM;
- E_R : ENUM_REC;
-
- E_SIZE : INTEGER := E'SIZE;
- E_A_SIZE : INTEGER := E_A'SIZE;
- E_R_SIZE : INTEGER := E_R'SIZE;
- E_A_1_SIZE : INTEGER := E_A(1)'SIZE;
- E_R_E1_SIZE : INTEGER := E_R.E1'SIZE;
-
- TASK TYPE TSK IS END TSK;
- TYPE TSK_REC IS
- RECORD
- TSK1, TSK2 : TSK;
- END RECORD;
-
- T : TSK;
- T_A : ARRAY (1 .. 5) OF TSK;
- T_R : TSK_REC;
-
- T_SIZE : INTEGER := T'SIZE;
- T_A_SIZE : INTEGER := T_A'SIZE;
- T_R_SIZE : INTEGER := T_R'SIZE;
- T_A_1_SIZE : INTEGER := T_A(1)'SIZE;
- T_R_TSK1_SIZE : INTEGER := T_R.TSK1'SIZE;
-
- TYPE ACC IS ACCESS INTEGER;
- TYPE ACC_REC IS
- RECORD
- A1, A2 : ACC;
- END RECORD;
-
- A : ACC;
- A_A : ARRAY (1 .. 5) OF ACC;
- A_R : ACC_REC;
-
- A_SIZE : INTEGER := A'SIZE;
- A_A_SIZE : INTEGER := A_A'SIZE;
- A_R_SIZE : INTEGER := A_R'SIZE;
- A_A_1_SIZE : INTEGER := A_A(1)'SIZE;
- A_R_A1_SIZE : INTEGER := A_R.A1'SIZE;
-
- PACKAGE PK IS
- TYPE PRV IS PRIVATE;
- TYPE PRV_REC IS
- RECORD
- P1, P2 : PRV;
- END RECORD;
-
- TYPE LPRV IS LIMITED PRIVATE;
- TYPE LPRV_REC IS
- RECORD
- LP1, LP2 : LPRV;
- END RECORD;
- PRIVATE
- TYPE PRV IS NEW INTEGER;
-
- TYPE LPRV IS NEW INTEGER;
- END PK;
- USE PK;
-
- P : PRV;
- P_A : ARRAY (1 .. 5) OF PRV;
- P_R : PRV_REC;
-
- P_SIZE : INTEGER := P'SIZE;
- P_A_SIZE : INTEGER := P_A'SIZE;
- P_R_SIZE : INTEGER := P_R'SIZE;
- P_A_1_SIZE : INTEGER := P_A(1)'SIZE;
- P_R_P1_SIZE : INTEGER := P_R.P1'SIZE;
-
- LP : LPRV;
- LP_A : ARRAY (1 .. 5) OF LPRV;
- LP_R : LPRV_REC;
-
- LP_SIZE : INTEGER := LP'SIZE;
- LP_A_SIZE : INTEGER := LP_A'SIZE;
- LP_R_SIZE : INTEGER := LP_R'SIZE;
- LP_A_1_SIZE : INTEGER := LP_A(1)'SIZE;
- LP_R_LP1_SIZE : INTEGER := LP_R.LP1'SIZE;
-
- TASK BODY TSK IS
- BEGIN
- NULL;
- END TSK;
-
-BEGIN
- TEST ("AD7203B", "CHECK THAT THE PREFIX OF THE 'SIZE' ATTRIBUTE " &
- "CAN BE AN OBJECT, A TYPE, OR A SUBTYPE");
-
- RESULT;
-END AD7203B;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad7205b.ada b/gcc/testsuite/ada/acats/tests/a/ad7205b.ada
deleted file mode 100644
index d619750..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad7205b.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- AD7205B.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 THE 'STORAGE_SIZE ATTRIBUTE CAN BE AN
--- ACCESS TYPE, A TASK TYPE, A TASK OBJECT, OR A SINGLE TASK.
-
--- HISTORY:
--- JET 09/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE AD7205B IS
-
- B : BOOLEAN;
-
- TYPE A IS ACCESS INTEGER;
- TASK TYPE T;
- T1 : T;
- TASK T2;
-
- TASK BODY T IS
- BEGIN
- NULL;
- END T;
-
- TASK BODY T2 IS
- BEGIN
- NULL;
- END T2;
-
-BEGIN
-
- TEST ("AD7205B", "CHECK THAT THE PREFIX OF THE 'STORAGE_SIZE " &
- "ATTRIBUTE CAN BE AN ACCESS TYPE, A TASK TYPE, " &
- "A TASK OBJECT, OR A SINGLE TASK");
-
- B := A'STORAGE_SIZE = T'STORAGE_SIZE; -- ACCESS AND TASK TYPES.
- B := T1'STORAGE_SIZE = T2'STORAGE_SIZE; -- TASK OBJECT & SINGLE
- -- TASK.
-
- RESULT;
-
-END AD7205B;
diff --git a/gcc/testsuite/ada/acats/tests/a/ad8011a.tst b/gcc/testsuite/ada/acats/tests/a/ad8011a.tst
deleted file mode 100644
index 93f666c..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ad8011a.tst
+++ /dev/null
@@ -1,64 +0,0 @@
--- AD8011A.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.
---*
--- OBJECTIVE:
--- CHECK THAT CODE STATEMENTS ARE ALLOWED IN A PROCEDURE BODY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- MACHINE CODE INSERTIONS.
-
--- IF SUCH INSERTIONS ARE NOT SUPPORTED, THE "WITH MACHINE_CODE"
--- CLAUSE MUST BE REJECTED.
-
-
--- MACRO SUBSTITUTION:
--- IF MACHINE CODE INSERTIONS ARE SUPPORTED THEN THE MACRO
--- $MACHINE_CODE_STATEMENT MUST BE REPLACED BY A VALID CODE
--- STATEMENT.
-
--- IF MACHINE CODE INSERTIONS ARE NOT SUPPORTED, THEN SUBSTITUTE
--- THE ADA NULL STATEMENT (IE: NULL;) FOR $MACHINE_CODE_STATEMENT.
-
--- HISTORY:
--- DHH 08/30/88 CREATED ORIGINAL TEST.
-
-WITH MACHINE_CODE; -- N/A => ERROR.
-USE MACHINE_CODE;
-WITH REPORT; USE REPORT;
-PROCEDURE AD8011A IS
-
- PROCEDURE CODE IS
- BEGIN
- $MACHINE_CODE_STATEMENT
- END;
-
-BEGIN
- TEST("AD8011A", "CHECK THAT CODE STATEMENTS ARE ALLOWED IN " &
- "A PROCEDURE BODY");
-
- CODE;
-
- RESULT;
-END AD8011A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ada101a.ada b/gcc/testsuite/ada/acats/tests/a/ada101a.ada
deleted file mode 100644
index 84b69d9..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ada101a.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- ADA101A.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 UNCHECKED_DEALLOCATION CAN BE INSTANTIATED WITH ANY
--- TYPE AS THE OBJECT PARAMETER.
-
--- HISTORY:
--- JET 09/23/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH UNCHECKED_DEALLOCATION;
-PROCEDURE ADA101A IS
-
- TYPE ENUM IS (CURLY, MOE, LARRY);
- TYPE DER IS NEW INTEGER;
- SUBTYPE SUB IS CHARACTER RANGE 'A'..'Z';
- TASK TYPE TSK;
- TYPE ACC IS ACCESS INTEGER;
-
- PACKAGE P IS
- TYPE PRIV IS PRIVATE;
- PRIVATE
- TYPE PRIV IS RANGE -100..100;
- END P;
- USE P;
-
- TYPE ARR1 IS ARRAY (INTEGER RANGE 1..10) OF INTEGER;
- TYPE ARR2 IS ARRAY (INTEGER RANGE <>) OF CHARACTER;
-
- TYPE REC1 IS RECORD
- D, I : INTEGER;
- END RECORD;
-
- TYPE REC2 (D : INTEGER) IS RECORD
- C : CHARACTER;
- END RECORD;
-
- TYPE INTEGERA IS ACCESS INTEGER;
- TYPE FLOATA IS ACCESS FLOAT;
- TYPE ENUMA IS ACCESS ENUM;
- TYPE BOOLEANA IS ACCESS BOOLEAN;
- TYPE CHARACTERA IS ACCESS CHARACTER;
- TYPE DERA IS ACCESS DER;
- TYPE SUBA IS ACCESS SUB;
- TYPE TSKA IS ACCESS TSK;
- TYPE ACCA IS ACCESS ACC;
- TYPE PRIVA IS ACCESS PRIV;
- TYPE ARR1A IS ACCESS ARR1;
- TYPE ARR2A IS ACCESS ARR2;
- TYPE REC1A IS ACCESS REC1;
- TYPE REC2A IS ACCESS REC2;
-
- TASK BODY TSK IS
- BEGIN
- NULL;
- END TSK;
-
- PROCEDURE RLSI IS NEW UNCHECKED_DEALLOCATION(INTEGER, INTEGERA);
- PROCEDURE RLSF IS NEW UNCHECKED_DEALLOCATION(FLOAT, FLOATA);
- PROCEDURE RLSE IS NEW UNCHECKED_DEALLOCATION(ENUM, ENUMA);
- PROCEDURE RLSB IS NEW UNCHECKED_DEALLOCATION(BOOLEAN, BOOLEANA);
- PROCEDURE RLSC IS NEW UNCHECKED_DEALLOCATION(CHARACTER,CHARACTERA);
- PROCEDURE RLSD IS NEW UNCHECKED_DEALLOCATION(DER, DERA);
- PROCEDURE RLSS IS NEW UNCHECKED_DEALLOCATION(SUB, SUBA);
- PROCEDURE RLST IS NEW UNCHECKED_DEALLOCATION(TSK, TSKA);
- PROCEDURE RLSA IS NEW UNCHECKED_DEALLOCATION(ACC, ACCA);
- PROCEDURE RLSP IS NEW UNCHECKED_DEALLOCATION(PRIV, PRIVA);
- PROCEDURE RLSA1 IS NEW UNCHECKED_DEALLOCATION(ARR1, ARR1A);
- PROCEDURE RLSA2 IS NEW UNCHECKED_DEALLOCATION(ARR2, ARR2A);
- PROCEDURE RLSR1 IS NEW UNCHECKED_DEALLOCATION(REC1, REC1A);
- PROCEDURE RLSR2 IS NEW UNCHECKED_DEALLOCATION(REC2, REC2A);
-
-BEGIN
- TEST ("ADA101A", "CHECK THAT UNCHECKED_DEALLOCATION CAN BE " &
- "INSTANTIATED WITH ANY TYPE AS THE OBJECT " &
- "PARAMETER");
-
- RESULT;
-END ADA101A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae2113a.ada b/gcc/testsuite/ada/acats/tests/a/ae2113a.ada
deleted file mode 100644
index 4630d39..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae2113a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- AE2113A.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 SUBPROGRAMS CREATE, OPEN, CLOSE, DELETE, RESET, MODE,
--- NAME, FORM, AND IS_OPEN ARE AVAILABLE FOR DIRECT_IO AND THAT
--- SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER NAMES.
-
--- TBN 9/30/86
-
-WITH DIRECT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE AE2113A IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
-
- TEMP : FILE_TYPE;
-
-BEGIN
- TEST ("AE2113A", "CHECK THAT THE SUBPROGRAMS CREATE, OPEN, " &
- "CLOSE, DELETE, RESET, MODE, NAME, FORM, AND " &
- "IS_OPEN ARE AVAILABLE FOR DIRECT_IO AND THAT " &
- "SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER " &
- "NAMES");
- BEGIN
- CREATE (FILE=> TEMP, MODE=> OUT_FILE,
- NAME=> "AE2113A.DAT", FORM=> "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- RESET (FILE=> TEMP, MODE=> OUT_FILE);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- CLOSE (FILE=> TEMP);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- OPEN (FILE=> TEMP, MODE=> OUT_FILE,
- NAME=> "AE2113A.DAT", FORM=> "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF IS_OPEN (FILE=> TEMP) THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF MODE (FILE=> TEMP) /= OUT_FILE THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF NAME (FILE=> TEMP) /= "AE2113A.DAT" THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF FORM (FILE=> TEMP) /= "" THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE=> TEMP);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-END AE2113A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae2113b.ada b/gcc/testsuite/ada/acats/tests/a/ae2113b.ada
deleted file mode 100644
index 9698131..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae2113b.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- AE2113B.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 SUBPROGRAMS CREATE, OPEN, CLOSE, DELETE, RESET, MODE,
--- NAME, FORM, AND IS_OPEN ARE AVAILABLE FOR SEQUENTIAL_IO AND THAT
--- SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER NAMES.
-
--- TBN 9/30/86
-
-WITH SEQUENTIAL_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE AE2113B IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
-
- TEMP : FILE_TYPE;
-
-BEGIN
- TEST ("AE2113B", "CHECK THAT THE SUBPROGRAMS CREATE, OPEN, " &
- "CLOSE, DELETE, RESET, MODE, NAME, FORM, AND " &
- "IS_OPEN ARE AVAILABLE FOR SEQUENTIAL_IO AND " &
- "THAT SUBPROGRAMS HAVE THE CORRECT FORMAL " &
- "PARAMETER NAMES");
- BEGIN
- CREATE (FILE=> TEMP, MODE=> OUT_FILE,
- NAME=> "AE2113B.DAT", FORM=> "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- RESET (FILE=> TEMP, MODE=> OUT_FILE);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- CLOSE (FILE=> TEMP);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- OPEN (FILE=> TEMP, MODE=> OUT_FILE,
- NAME=> "AE2113B.DAT", FORM=> "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF IS_OPEN (FILE=> TEMP) THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF MODE (FILE=> TEMP) /= OUT_FILE THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF NAME (FILE=> TEMP) /= "AE2113B.DAT" THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF FORM (FILE=> TEMP) /= "" THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE=> TEMP);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-END AE2113B;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae3002g.ada b/gcc/testsuite/ada/acats/tests/a/ae3002g.ada
deleted file mode 100644
index 0a110cf..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae3002g.ada
+++ /dev/null
@@ -1,47 +0,0 @@
--- AE3002G.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 FILE_MODE IS VISIBLE AND HAS LITERALS IN_FILE AND
--- OUT_FILE. ASLO CHECK THAT TYPE_SET IS VISIBLE AND HAS LITERALS
--- LOWER_CASE AND UPPER_CASE.
-
--- TBN 10/3/86
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE AE3002G IS
-
- TEMP_FILE : FILE_TYPE;
- MODE : FILE_MODE := IN_FILE;
- LETTERS : TYPE_SET := LOWER_CASE;
-
-BEGIN
- TEST ("AE3002G", "CHECK THAT FILE_MODE AND TYPE_SET ARE VISIBLE " &
- "AND CHECK THEIR LITERALS");
-
- MODE := OUT_FILE;
- LETTERS := UPPER_CASE;
-
- RESULT;
-END AE3002G;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae3101a.ada b/gcc/testsuite/ada/acats/tests/a/ae3101a.ada
deleted file mode 100644
index d050ee0..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae3101a.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- AE3101A.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 CREATE, OPEN, CLOSE, DELETE, RESET, MODE, NAME,
--- FORM, IS_OPEN, AND END_OF_FILE ARE AVAILABLE FOR TEXT FILES.
--- ALSO CHECK THAT FORMAL PARAMETER NAMES ARE CORRECT.
-
--- HISTORY:
--- ABW 08/24/82
--- SPS 09/16/82
--- SPS 11/09/82
--- DWC 09/24/87 REMOVED DEPENDENCE ON FILE SUPPORT.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE AE3101A IS
-
- FILE1 : FILE_TYPE;
-
-BEGIN
-
- TEST ("AE3101A" , "CHECK THAT CREATE, OPEN, DELETE, " &
- "RESET, MODE, NAME, FORM, IS_OPEN, " &
- "AND END_OF_FILE ARE AVAILABLE " &
- "FOR TEXT FILE");
-
- BEGIN
- CREATE (FILE => FILE1,
- MODE => OUT_FILE,
- NAME => LEGAL_FILE_NAME,
- FORM => "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- RESET (FILE => FILE1, MODE => IN_FILE);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- CLOSE (FILE => FILE1);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- OPEN (FILE => FILE1,
- MODE => IN_FILE,
- NAME => LEGAL_FILE_NAME,
- FORM => "");
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- IF IS_OPEN (FILE => FILE1) THEN
- NULL;
- END IF;
-
- BEGIN
- IF MODE (FILE => FILE1) /= IN_FILE THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF NAME (FILE => FILE1) /= LEGAL_FILE_NAME THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF FORM (FILE => FILE1) /= "" THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- IF END_OF_FILE (FILE => FILE1) THEN
- NULL;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE => FILE1);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-
-END AE3101A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae3702a.ada b/gcc/testsuite/ada/acats/tests/a/ae3702a.ada
deleted file mode 100644
index a18b1a0..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae3702a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- AE3702A.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 INTEGER_IO CAN BE INSTANTIATED FOR USER DEFINED INTEGER
--- TYPES.
-
--- SPS 10/1/82
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE AE3702A IS
-BEGIN
-
- TEST ("AE3702A", "CHECK THAT INTEGER_IO CAN BE INSTANTIATED FOR " &
- "USER DEFINED TYPES");
-
- DECLARE
- TYPE I1 IS RANGE 6 .. 14;
- TYPE I2 IS NEW INTEGER;
- TYPE I3 IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- SUBTYPE S1 IS INTEGER RANGE 6 .. 14;
- SUBTYPE S2 IS INTEGER;
- SUBTYPE S3 IS INTEGER RANGE 0 .. INTEGER'LAST;
-
- PACKAGE NIO1 IS NEW INTEGER_IO (I1);
- PACKAGE NIO2 IS NEW INTEGER_IO (I2);
- PACKAGE NIO3 IS NEW INTEGER_IO (I3);
- PACKAGE NIO4 IS NEW INTEGER_IO (S1);
- PACKAGE NIO5 IS NEW INTEGER_IO (S2);
- PACKAGE NIO6 IS NEW INTEGER_IO (S3);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END AE3702A;
diff --git a/gcc/testsuite/ada/acats/tests/a/ae3709a.ada b/gcc/testsuite/ada/acats/tests/a/ae3709a.ada
deleted file mode 100644
index 5866120..0000000
--- a/gcc/testsuite/ada/acats/tests/a/ae3709a.ada
+++ /dev/null
@@ -1,56 +0,0 @@
--- AE3709A.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 NAMES OF THE FORMAL PARAMETERS.
-
--- JBG 3/30/83
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE AE3709A IS
-
- PACKAGE INT IS NEW INTEGER_IO(INTEGER);
- USE INT;
- FILE : FILE_TYPE;
- STR : STRING(1..3);
- LAST : POSITIVE;
- ITEM : INTEGER;
-
-BEGIN
-
- TEST ("AE3709A", "CHECK NAMES OF FORMAL PARAMETERS");
-
- IF EQUAL(2, 3) THEN
- GET (FILE => FILE, ITEM => ITEM, WIDTH => 0);
- GET (ITEM => ITEM, WIDTH => 0);
- PUT (FILE => FILE, ITEM => ITEM, WIDTH => 4, BASE => 4);
- PUT (ITEM => ITEM, WIDTH => 4, BASE => 4);
- GET (FROM => STR, ITEM => ITEM, LAST => LAST);
- PUT (TO => STR, ITEM => ITEM, BASE => 4);
- END IF;
-
- RESULT;
-
-END AE3709A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23001a.ada b/gcc/testsuite/ada/acats/tests/c2/c23001a.ada
deleted file mode 100644
index 55fa97c..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23001a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C23001A.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 UPPER AND LOWER CASE LETTERS ARE EQUIVALENT IN IDENTIFIERS
--- (INCLUDING RESERVED WORDS).
-
--- JRK 12/12/79
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C23001A IS
-
- USE REPORT;
-
- AN_IDENTIFIER : INTEGER := 1;
-
-BEGIN
- TEST ("C23001A", "UPPER/LOWER CASE EQUIVALENCE IN IDENTIFIERS");
-
- DECLARE
- an_identifier : INTEGER := 3;
- BEGIN
- IF an_identifier /= AN_IDENTIFIER THEN
- FAILED ("LOWER CASE NOT EQUIVALENT TO UPPER " &
- "IN DECLARABLE IDENTIFIERS");
- END IF;
- END;
-
- IF An_IdEnTIfieR /= AN_IDENTIFIER THEN
- FAILED ("MIXED CASE NOT EQUIVALENT TO UPPER IN " &
- "DECLARABLE IDENTIFIERS");
- END IF;
-
- if AN_IDENTIFIER = 1 ThEn
- AN_IDENTIFIER := 2;
- END IF;
- IF AN_IDENTIFIER /= 2 THEN
- FAILED ("LOWER AND/OR MIXED CASE NOT EQUIVALENT TO " &
- "UPPER IN RESERVED WORDS");
- END IF;
-
- RESULT;
-END C23001A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23003a.tst b/gcc/testsuite/ada/acats/tests/c2/c23003a.tst
deleted file mode 100644
index 26fe957..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23003a.tst
+++ /dev/null
@@ -1,104 +0,0 @@
--- C23003A.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 THAT VARIABLE IDENTIFIERS CAN BE AS LONG AS THE MAXIMUM LENGTH
--- IDENTIFIER PERMITTED AND THAT ALL CHARACTERS ARE SIGNIFICANT.
-
--- JRK 12/12/79
--- JRK 1/11/80
--- JWC 6/28/85 RENAMED TO -AB
--- KAS 12/04/95 CHANGED "INPUT LINE LENGTH" TO "LENGTH IDENTIFIER"
-
-WITH REPORT;
-PROCEDURE C23003A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C23003A", "MAXIMUM LENGTH VARIABLE IDENTIFIERS");
-
- -- BIG_ID1 AND BIG_ID2 ARE TWO MAXIMUM LENGTH IDENTIFIERS THAT
- -- DIFFER ONLY IN THEIR LAST CHARACTER.
-
- DECLARE
-$BIG_ID1
- -- BIG_ID1
- : INTEGER := 1;
- BEGIN
- DECLARE
-$BIG_ID2
- -- BIG_ID2
- : INTEGER := 2;
- BEGIN
-
- IF
-$BIG_ID1
- -- BIG_ID1
- +
-$BIG_ID2
- -- BIG_ID2
- /= 3 THEN
- FAILED ("IDENTIFIERS AS LONG AS " &
- "MAXIMUM INPUT LINE LENGTH " &
- "NOT PERMITTED OR NOT " &
- "DISTINGUISHED BY DISTINCT " &
- "SUFFIXES");
- END IF;
-
- END;
- END;
-
- -- BIG_ID3 AND BIG_ID4 ARE TWO MAXIMUM LENGTH IDENTIFIERS THAT
- -- DIFFER ONLY IN THEIR MIDDLE CHARACTER.
-
- DECLARE
-$BIG_ID3
- -- BIG_ID3
- : INTEGER := 3;
- BEGIN
- DECLARE
-$BIG_ID4
- -- BIG_ID4
- : INTEGER := 4;
- BEGIN
-
- IF
-$BIG_ID3
- -- BIG_ID3
- +
-$BIG_ID4
- -- BIG_ID4
- /= 7 THEN
- FAILED ("IDENTIFIERS AS LONG AS " &
- "MAXIMUM INPUT LINE LENGTH " &
- "NOT PERMITTED OR NOT " &
- "DISTINGUISHED BY DISTINCT " &
- "MIDDLES");
- END IF;
-
- END;
- END;
-
- RESULT;
-END C23003A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23003b.tst b/gcc/testsuite/ada/acats/tests/c2/c23003b.tst
deleted file mode 100644
index 00249b6..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23003b.tst
+++ /dev/null
@@ -1,103 +0,0 @@
--- C23003B.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 THAT THE NAME OF A LIBRARY UNIT PACKAGE AND THE NAME OF A LIBRARY
--- SUBPROGRAM CAN BE AS LONG AS THE LONGEST IDENTIFIER ALLOWED BY
--- AN IMPLEMENTATION.
-
--- JBG 5/26/85
--- DTN 3/25/92 CONSOLIDATION OF C23003B.TST AND C23003C.TST.
--- KAS 11/04/95 CHANGE "LINE" TO "IDENTIFIER"
-
-PACKAGE
-$BIG_ID1
-IS
- A : INTEGER := 1;
-END
-$BIG_ID1
-;
-PACKAGE
-$BIG_ID2
-IS
- B : INTEGER := 2;
-END
-$BIG_ID2
-;
-
-PROCEDURE
-$BIG_ID3
- (X : OUT INTEGER) IS
-BEGIN
- X := 1;
-END
-$BIG_ID3
-;
-PROCEDURE
-$BIG_ID4
- (X : OUT INTEGER) IS
-BEGIN
- X := 2;
-END
-$BIG_ID4
-;
-
-WITH
-$BIG_ID1
-,
-$BIG_ID2
-,
-$BIG_ID3
-,
-$BIG_ID4
-;
-USE
-$BIG_ID1
-,
-$BIG_ID2
-;
-
-WITH REPORT; USE REPORT;
-PROCEDURE C23003B IS
- X1, X2 : INTEGER := 0;
-BEGIN
- TEST ("C23003B", "CHECK LONGEST POSSIBLE IDENTIFIER CAN BE USED " &
- "FOR LIBRARY PACKAGE AND SUBPROGRAM");
-
- IF A + IDENT_INT(1) /= B THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION");
- END IF;
-
-
-$BIG_ID3
- (X1);
-$BIG_ID4
- (X2);
-
- IF X1 + IDENT_INT(1) /= X2 THEN
- FAILED ("INCORRECT PROCEDURE IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23003B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23003g.tst b/gcc/testsuite/ada/acats/tests/c2/c23003g.tst
deleted file mode 100644
index 5769937..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23003g.tst
+++ /dev/null
@@ -1,129 +0,0 @@
--- C23003G.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 THAT THE NAME OF A GENERIC LIBRARY UNIT PACKAGE AND THE NAME
--- OF A GENERIC LIBRARY UNIT SUBPROGRAM CAN BE AS LONG
-
--- JBG 5/26/85
--- DTN 3/25/92 CONSOLIDATION OF C23003G.TST AND C23003H.TST.
--- KAS 12/4/95 CHANGE "LINE" TO "IDENTIFIER"
-
-GENERIC
-PACKAGE
-$BIG_ID1
-IS
- A : INTEGER := 1;
-END
-$BIG_ID1
-;
-GENERIC
-PACKAGE
-$BIG_ID2
-IS
- B : INTEGER := 2;
-END
-$BIG_ID2
-;
-
-GENERIC
-FUNCTION
-$BIG_ID3
-RETURN INTEGER;
-
-FUNCTION
-$BIG_ID3
-RETURN INTEGER IS
-BEGIN
- RETURN 3;
-END
-$BIG_ID3
-;
-
-GENERIC
-FUNCTION
-$BIG_ID4
-RETURN INTEGER;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION
-$BIG_ID4
-RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END
-$BIG_ID4
-;
-
-WITH
-$BIG_ID3
-;
-PRAGMA ELABORATE (
-$BIG_ID3
-);
-FUNCTION F1 IS NEW
-$BIG_ID3
-;
-
-WITH
-$BIG_ID1
-;
-PRAGMA ELABORATE (
-$BIG_ID1
-);
-PACKAGE C23003G_PKG IS NEW
-$BIG_ID1
-;
-WITH C23003G_PKG, F1,
-$BIG_ID2
-,
-$BIG_ID4
-;
-USE C23003G_PKG;
-WITH REPORT; USE REPORT;
-PROCEDURE C23003G IS
-
- PACKAGE P2 IS NEW
-$BIG_ID2
-;
- USE P2;
- FUNCTION F2 IS NEW
-$BIG_ID4
-;
-
-BEGIN
- TEST ("C23003G", "CHECK LONGEST POSSIBLE IDENTIFIER CAN BE USED " &
- "FOR GENERIC LIBRARY PACKAGE AND SUBPROGRAM");
-
- IF A + IDENT_INT(1) /= B THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION");
- END IF;
-
-
- IF F1 + IDENT_INT(1) /= F2 THEN
- FAILED ("INCORRECT FUNCTION IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23003G;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23003i.tst b/gcc/testsuite/ada/acats/tests/c2/c23003i.tst
deleted file mode 100644
index 7439cf3..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23003i.tst
+++ /dev/null
@@ -1,71 +0,0 @@
--- C23003I.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 THAT THE LONGEST POSSIBLE IDENTIFIER CAN BE THE NAME OF A
--- LIBRARY PACKAGE CREATED BY A GENERIC INSTANTIATION.
-
--- JBG 5/26/85
--- DTN 3/25/92 DELETED TEST OF TWO MAXIMUM LENGTH PACKAGE NAMES THAT
--- DIFFER ONLY IN THEIR MIDDLE CHARACTER.
-
-GENERIC
- C : INTEGER;
-PACKAGE C23003I_PKG IS
- A : INTEGER := C;
-END C23003I_PKG;
-
-WITH C23003I_PKG;
-PRAGMA ELABORATE (C23003I_PKG);
-PACKAGE
-$BIG_ID1
- IS NEW C23003I_PKG (1);
-
-WITH REPORT; USE REPORT;
-WITH C23003I_PKG;
-PRAGMA ELABORATE (REPORT, C23003I_PKG);
-PACKAGE
-$BIG_ID2
- IS NEW C23003I_PKG (IDENT_INT(2));
-
-WITH
-$BIG_ID1
-,
-$BIG_ID2
-;
-WITH REPORT; USE REPORT;
-PROCEDURE C23003I IS
-BEGIN
- TEST ("C23003I", "CHECK THAT LONGEST POSSIBLE IDENTIFIER CAN BE " &
- "USED FOR A LIBRARY PACKAGE INSTANTIATION");
-
- IF
-$BIG_ID1
- .A + IDENT_INT(1) /=
-$BIG_ID2
- .A THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23003I;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006a.ada b/gcc/testsuite/ada/acats/tests/c2/c23006a.ada
deleted file mode 100644
index bad6b4e..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006a.ada
+++ /dev/null
@@ -1,48 +0,0 @@
--- C23006A.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 UNDERSCORES ARE SIGNIFICANT IN IDENTIFIERS.
-
--- JRK 12/12/79
--- JBG 5/25/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C23006A IS
-
- AN_IDENTIFIER : INTEGER := 1;
-
-BEGIN
- TEST ("C23006A", "UNDERSCORES ARE SIGNFICANT IN IDENTIFERS");
-
- DECLARE
- ANIDENTIFIER : INTEGER := 3;
- BEGIN
- IF ANIDENTIFIER = AN_IDENTIFIER THEN
- FAILED ("UNDERSCORE IGNORED " &
- "IN DECLARABLE IDENTIFIERS");
- END IF;
- END;
-
- RESULT;
-END C23006A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006b.ada b/gcc/testsuite/ada/acats/tests/c2/c23006b.ada
deleted file mode 100644
index 61ecb77..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006b.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C23006B.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 UNDERSCORES ARE SIGNIFICANT IN LIBRARY PACKAGE IDENTIFIERS
-
--- JBG 5/26/85
--- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-PACKAGE C23006B_PKG IS
- A : INTEGER := 1;
-END C23006B_PKG;
-
-PACKAGE C23006BPKG IS
- D : INTEGER := 4;
- PROCEDURE REQUIRE_BODY;
-END C23006BPKG;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY C23006BPKG IS
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- D := IDENT_INT (5);
-END C23006BPKG;
-
-WITH C23006BPKG, C23006B_PKG;
-USE C23006BPKG, C23006B_PKG;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006B IS
-BEGIN
- TEST ("C23006B", "CHECK UNDERSCORES ARE SIGNIFICANT " &
- "FOR LIBRARY PACKAGE IDENTIFIERS");
-
- IF A + IDENT_INT(4) /= D THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23006B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006c.ada b/gcc/testsuite/ada/acats/tests/c2/c23006c.ada
deleted file mode 100644
index ddfe5a6..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006c.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C23006C.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 UNDERSCORES ARE SIGNFICANT IN NAMES OF LIBRARY
--- SUBPROGRAMS.
-
--- JBG 5/26/85
-
-PROCEDURE C23006C_PROC (X : OUT INTEGER) IS
-BEGIN
- X := 1;
-END C23006C_PROC;
-
-PROCEDURE C23006CPROC (X : OUT INTEGER);
-
-PROCEDURE C23006CPROC (X : OUT INTEGER) IS
-BEGIN
- X := 2;
-END C23006CPROC;
-
-FUNCTION C23006C_FUNC RETURN INTEGER IS
-BEGIN
- RETURN 3;
-END C23006C_FUNC;
-
-FUNCTION C23006CFUNC RETURN INTEGER;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION C23006CFUNC RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END C23006CFUNC;
-
-WITH C23006C_PROC, C23006CPROC, C23006C_FUNC, C23006CFUNC;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006C IS
- X1, X2 : INTEGER;
-BEGIN
- TEST ("C23006C", "CHECK UNDERSCORES ARE SIGNIFICANT " &
- "FOR LIBRARY SUBPROGRAM");
-
- C23006C_PROC (X1);
- C23006CPROC (X2);
- IF X1 + IDENT_INT(1) /= X2 THEN
- FAILED ("INCORRECT PROCEDURE IDENTIFICATION");
- END IF;
-
- IF C23006C_FUNC + IDENT_INT(1) /= C23006CFUNC THEN
- FAILED ("INCORRECT FUNCTION IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23006C;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006d.ada b/gcc/testsuite/ada/acats/tests/c2/c23006d.ada
deleted file mode 100644
index 0df360f..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006d.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C23006D.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 UNDERSCORES ARE SIGNIFICANT IN THE NAMES OF GENERIC
--- LIBRARY PACKAGES
-
--- JBG 5/26/85
--- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-GENERIC
-PACKAGE C23006D_PKG IS
- A : INTEGER := 1;
-END C23006D_PKG;
-
-GENERIC
-PACKAGE C23006DPKG IS
- D : INTEGER := 2;
- PROCEDURE REQUIRE_BODY;
-END C23006DPKG;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY C23006DPKG IS
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- D := IDENT_INT (5);
-END C23006DPKG;
-
-WITH C23006D_PKG;
-PRAGMA ELABORATE (C23006D_PKG);
-PACKAGE C23006D_INST IS NEW C23006D_PKG;
-
-WITH C23006DPKG, C23006D_INST;
-USE C23006D_INST;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006D IS
-
- PACKAGE P2 IS NEW C23006DPKG;
- USE P2;
-
-BEGIN
- TEST ("C23006D", "CHECK UNDERSCORES ARE SIGNIFICANT " &
- "FOR GENERIC LIBRARY PACKAGE IDENTIFIERS");
-
- IF A + IDENT_INT(4) /= D THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION - 1");
- END IF;
-
- RESULT;
-END C23006D;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006e.ada b/gcc/testsuite/ada/acats/tests/c2/c23006e.ada
deleted file mode 100644
index cd49ba5..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006e.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C23006E.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 UNDERSCORES ARE SIGNIFICANT IN THE NAMES OF GENERIC
--- LIBRARY UNIT SUBPROGRAMS.
-
--- JBG 5/26/85
-
-GENERIC
-PROCEDURE C23006E_PROC (X : OUT INTEGER);
-
-PROCEDURE C23006E_PROC (X : OUT INTEGER) IS
-BEGIN
- X := 1;
-END C23006E_PROC;
-
-GENERIC
-PROCEDURE C230063PROC (X : OUT INTEGER);
-
-PROCEDURE C230063PROC (X : OUT INTEGER) IS
-BEGIN
- X := 2;
-END C230063PROC;
-
-GENERIC
-FUNCTION C23006E_GFUNC RETURN INTEGER;
-
-FUNCTION C23006E_GFUNC RETURN INTEGER IS
-BEGIN
- RETURN 3;
-END C23006E_GFUNC;
-
-GENERIC
-FUNCTION C23006EGFUNC RETURN INTEGER;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION C23006EGFUNC RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END C23006EGFUNC;
-
-WITH C23006E_PROC;
-PRAGMA ELABORATE (C23006E_PROC);
-PROCEDURE P1 IS NEW C23006E_PROC;
-
-WITH C23006E_GFUNC;
-PRAGMA ELABORATE (C23006E_GFUNC);
-FUNCTION F1 IS NEW C23006E_GFUNC;
-
-WITH P1, F1, C230063PROC, C23006EGFUNC;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006E IS
-
- X1, X2 : INTEGER;
- PROCEDURE P2 IS NEW C230063PROC;
- FUNCTION F2 IS NEW C23006EGFUNC;
-
-BEGIN
- TEST ("C23006E", "CHECK UNDERSCORES ARE SIGNIFICANT " &
- "FOR GENERIC LIBRARY SUBPROGRAM IDENTIFIERS");
-
- P1 (X1);
- P2 (X2);
- IF X1 + IDENT_INT(1) /= X2 THEN
- FAILED ("INCORRECT PROCEDURE IDENTIFICATION");
- END IF;
-
- IF F1 + IDENT_INT(1) /= F2 THEN
- FAILED ("INCORRECT FUNCTION IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23006E;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006f.ada b/gcc/testsuite/ada/acats/tests/c2/c23006f.ada
deleted file mode 100644
index 6848ce9..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006f.ada
+++ /dev/null
@@ -1,57 +0,0 @@
--- C23006F.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 UNDERSCORES ARE SIGNIFICANT IN LIBRARY PACKAGE NAMES
--- CREATED BY A GENERIC INSTANTIATION.
-
--- JBG 5/26/85
-
-GENERIC
- C : INTEGER;
-PACKAGE C23006F_PKG IS
- A : INTEGER := C;
-END C23006F_PKG;
-
-WITH C23006F_PKG;
-PRAGMA ELABORATE (C23006F_PKG);
-PACKAGE C23006F_INST IS NEW C23006F_PKG (1);
-
-WITH REPORT; USE REPORT;
-WITH C23006F_PKG;
-PRAGMA ELABORATE (REPORT, C23006F_PKG);
-PACKAGE C23006FINST IS NEW C23006F_PKG (IDENT_INT(2));
-
-WITH C23006F_INST, C23006FINST;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006F IS
-BEGIN
- TEST ("C23006F", "CHECK THAT UNDERSCORES ARE SIGNIFICANT IN " &
- "NAMES USED FOR A LIBRARY PACKAGE INSTANTIATION");
-
- IF C23006F_INST.A + IDENT_INT(1) /= C23006FINST.A THEN
- FAILED ("INCORRECT PACKAGE IDENTIFICATION - 1");
- END IF;
-
- RESULT;
-END C23006F;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c23006g.ada b/gcc/testsuite/ada/acats/tests/c2/c23006g.ada
deleted file mode 100644
index ee3ad28..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c23006g.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C23006G.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 UNDERSCORES ARE SIGNIFICANT IN LIBRARY SUBPROGRAM NAMES
--- CREATED BY A GENERIC INSTANTIATION.
-
--- JBG 5/26/85
-
-GENERIC
- C : INTEGER;
-PROCEDURE C23006G_PROC (X : OUT INTEGER);
-
-PROCEDURE C23006G_PROC (X : OUT INTEGER) IS
-BEGIN
- X := C;
-END C23006G_PROC;
-
-GENERIC
- C : INTEGER;
-FUNCTION C23006G_FUNC RETURN INTEGER;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION C23006G_FUNC RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(C);
-END C23006G_FUNC;
-
-WITH C23006G_PROC;
-PRAGMA ELABORATE (C23006G_PROC);
-PROCEDURE C23006G_INSTP IS NEW C23006G_PROC (1);
-
-WITH REPORT; USE REPORT;
-WITH C23006G_PROC;
-PRAGMA ELABORATE (REPORT, C23006G_PROC);
-PROCEDURE C23006GINSTP IS NEW C23006G_PROC (IDENT_INT(2));
-
-WITH C23006G_FUNC;
-PRAGMA ELABORATE (C23006G_FUNC);
-FUNCTION C23006G_INSTF IS NEW C23006G_FUNC (3);
-
-WITH C23006G_FUNC;
-PRAGMA ELABORATE (C23006G_FUNC);
-FUNCTION C23006GINSTF IS NEW C23006G_FUNC (4);
-
-WITH C23006G_INSTP, C23006GINSTP, C23006G_INSTF, C23006GINSTF;
-WITH REPORT; USE REPORT;
-PROCEDURE C23006G IS
- X1, X2 : INTEGER;
-BEGIN
- TEST ("C23006G", "CHECK THAT UNDERSCORES ARE SIGNFICANT IN NAMES "&
- "USED FOR A LIBRARY SUBPROGRAM INSTANTIATION");
- C23006G_INSTP (X1);
- C23006GINSTP (X2);
-
- IF X1 + IDENT_INT(1) /= X2 THEN
- FAILED ("INCORRECT PROCEDURE IDENTIFICATION");
- END IF;
-
- IF C23006G_INSTF + IDENT_INT(1) /= C23006GINSTF THEN
- FAILED ("INCORRECT FUNCTION IDENTIFICATION");
- END IF;
-
- RESULT;
-END C23006G;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24002d.ada b/gcc/testsuite/ada/acats/tests/c2/c24002d.ada
deleted file mode 100644
index 5a9b066..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24002d.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- C24002D.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 LOWER CASE E MAY BE USED IN INTEGER LITERALS, FLOATING POINT
--- LITERALS, AND FIXED POINT LITERALS.
--- CHECK THAT THESE NUMERIC LITERALS YIELD THE CORRECT VALUES.
-
--- WMC 03/16/92 CONSOLIDATION OF C24002A.ADA, C24002B.ADA, C24002C.ADA
-
-WITH REPORT;
-
-PROCEDURE C24002D IS
-
- USE REPORT;
-
-BEGIN
- TEST("C24002D", "CHECK THAT LOWER CASE E WORKS IN INTEGER, " &
- "FLOATING POINT, AND FIXED POINT LITERALS, " &
- "AND THAT THESE NUMERIC LITERALS YIELD THE " &
- "CORRECT VALUES");
-
- -- Integer Literals
- DECLARE
- X,Y : INTEGER;
- BEGIN
- X := 12e1;
- Y := 16#E#e1;
-
- IF (X /= 120) OR (Y /= 224) THEN
- FAILED("INCORRECT HANDLING OF LOWER CASE E " &
- "IN INTEGER LITERALS");
- END IF;
- END;
-
-
- -- Floating Point Literal
- DECLARE
- X : FLOAT;
- BEGIN
- X := 16#F.FF#e+2;
-
- IF (X /= 4095.0) THEN
- FAILED("INCORRECT HANDLING OF LOWER CASE E " &
- "IN BASED FLOATING POINT LITERALS");
- END IF;
- END;
-
-
- -- Fixed Point Literal
- DECLARE
- TYPE FIXED IS DELTA 0.1 RANGE 0.0 .. 300.0;
- X : FIXED;
- BEGIN
- X := 16#F.F#e1;
-
- IF (X /= 255.0) THEN
- FAILED("INCORRECT HANDLING OF LOWER CASE E " &
- "IN BASED FIXED POINT LITERALS");
- END IF;
- END;
-
- RESULT;
-
-END C24002D;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24003a.ada b/gcc/testsuite/ada/acats/tests/c2/c24003a.ada
deleted file mode 100644
index 61c6fa2..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24003a.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- C24003A.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 LEADING ZEROES IN INTEGRAL PARTS OF INTEGER LITERALS
--- ARE IGNORED.
-
--- JRK 12/12/79
--- JRK 12/16/80
--- TBN 10/16/85 RENAMED FROM C24003A.TST AND FIXED LINE LENGTH.
--- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST'
--- TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C24003A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C24003A", "LEADING ZEROES IN INTEGER LITERALS");
-
- IF 0000000000000000000000000000000000000000247 /= 247 THEN
- FAILED ("LEADING ZEROES IN INTEGER LITERALS NOT " &
- "IGNORED");
- END IF;
-
- IF 35E00000000000000000000000000000000000000001 /= 350 THEN
- FAILED ("LEADING ZEROES IN EXPONENTS NOT IGNORED");
- END IF;
-
- IF 000000000000000000000000000000000000000016#FF# /= 255 THEN
- FAILED ("LEADING ZEROES IN BASES NOT IGNORED");
- END IF;
-
- IF 16#0000000000000000000000000000000000000000FF# /= 255 THEN
- FAILED ("LEADING ZEROES IN BASED INTEGER LITERALS " &
- "NOT IGNORED");
- END IF;
-
- RESULT;
-END C24003A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24003b.ada b/gcc/testsuite/ada/acats/tests/c2/c24003b.ada
deleted file mode 100644
index c385973..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24003b.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C24003B.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 LEADING ZEROES IN INTEGRAL PARTS AND TRAILING ZEROES IN
--- FRACTIONAL PARTS OF FLOATING POINT LITERALS ARE IGNORED.
-
--- JRK 12/12/79
--- JRK 12/16/80
--- TBN 10/21/85 RENAMED FROM C24003B.TST AND FIXED LINE LENGTH.
--- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST'
--- TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C24003B IS
-
- USE REPORT;
-
- FL : FLOAT := 69.0E1;
-
-BEGIN
- TEST ("C24003B", "LEADING/TRAILING ZEROES IN " &
- "FLOATING POINT LITERALS");
-
- IF 000000000000000000000000000000000000000069.0E1 /= FL THEN
- FAILED ("LEADING ZEROES IN INTEGRAL PART OF FLOATING " &
- "POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 69.0000000000000000000000000000000000000000E1 /= FL THEN
- -- MIGHT RAISE NUMERIC_ERROR AT COMPILE-TIME.
- FAILED ("TRAILING ZEROES IN FRACTIONAL PART OF " &
- "FLOATING POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 0000000000000000000000000000000000000000690.00000 /= FL THEN
- FAILED ("LEADING/TRAILING ZEROES IN MANTISSA OF " &
- "FLOATING POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 69.0E00000000000000000000000000000000000000001 /= FL THEN
- FAILED ("LEADING ZEROES IN EXPONENT OF FLOATING " &
- "POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 16#00000000000000000000000000000000000000002B.2#E1 /= FL THEN
- FAILED ("LEADING ZEROES IN BASED FLOATING POINT " &
- "LITERAL NOT IGNORED");
- END IF;
-
- IF 16#2B.20000000000000000000000000000000000000000#E1 /= FL THEN
- FAILED ("TRAILING ZEROES IN BASED FLOATING POINT " &
- "LITERAL NOT IGNORED");
- END IF;
-
- RESULT;
-END C24003B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24003c.ada b/gcc/testsuite/ada/acats/tests/c2/c24003c.ada
deleted file mode 100644
index 1eb8dd2..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24003c.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C24003C.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 LEADING ZEROES IN INTEGRAL PARTS AND TRAILING ZEROES IN
--- FRACTIONAL PARTS OF FIXED POINT LITERALS ARE IGNORED.
-
--- JRK 12/12/79
--- JRK 12/16/80
--- TBN 10/21/85 RENAMED FROM C24003C.TST AND FIXED LINE LENGTH.
--- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST'
--- TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C24003C IS
-
- USE REPORT;
-
- TYPE FIXED IS DELTA 1.0 RANGE 0.0 .. 1000.0;
- FX : FIXED := 69.0E1;
-
-BEGIN
-
- TEST ("C24003C", "LEADING/TRAILING ZEROES IN " &
- "FIXED POINT LITERALS");
-
- IF 000000000000000000000000000000000000000069.0E1 /= FX THEN
- FAILED ("LEADING ZEROES IN INTEGRAL PART OF FIXED " &
- "POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 69.0000000000000000000000000000000000000000E1 /= FX THEN
- -- MIGHT RAISE NUMERIC_ERROR AT COMPILE-TIME.
- FAILED ("TRAILING ZEROES IN FRACTIONAL PART OF " &
- "FIXED POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 0000000000000000000000000000000000000000690.00000 /= FX THEN
- FAILED ("LEADING/TRAILING ZEROES IN MANTISSA OF " &
- "FIXED POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 69.0E00000000000000000000000000000000000000001 /= FX THEN
- FAILED ("LEADING ZEROES IN EXPONENT OF FIXED " &
- "POINT LITERAL NOT IGNORED");
- END IF;
-
- IF 16#00000000000000000000000000000000000000002B.2#E1 /= FX THEN
- FAILED ("LEADING ZEROES IN BASED FIXED POINT " &
- "LITERAL NOT IGNORED");
- END IF;
-
- IF 16#2B.20000000000000000000000000000000000000000#E1 /= FX THEN
- FAILED ("TRAILING ZEROES IN BASED FIXED POINT " &
- "LITERAL NOT IGNORED");
- END IF;
-
- RESULT;
-END C24003C;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24106a.ada b/gcc/testsuite/ada/acats/tests/c2/c24106a.ada
deleted file mode 100644
index fcecd06..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24106a.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C24106A.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 UNDERSCORE CHARACTERS ARE PERMITTED IN ANY PART OF
--- A NON-BASED DECIMAL LITERAL.
-
--- HISTORY:
--- DHH 01/19/88 CREATED ORIGINAL TEST
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C24106A IS
-
-BEGIN
- TEST("C24106A", "CHECK THAT UNDERSCORE CHARACTERS " &
- "ARE PERMITTED IN ANY PART OF " &
- "A NON-BASED DECIMAL LITERAL");
-
- IF 1.2_3_4_5_6 /= 1.23456 THEN
- FAILED("UNDERSCORES NOT PERMITTED IN FRACTIONAL PART " &
- "OF A NON_BASED LITERAL");
- END IF;
- IF 1_2_3_4_5.6 /= 12345.6 THEN
- FAILED("UNDERSCORES NOT PERMITTED IN INTEGRAL PART " &
- "OF A NON_BASED LITERAL");
- END IF;
- IF 0.12E1_2 /= 0.12E12 THEN
- FAILED("UNDERSCORES NOT PERMITTED IN EXPONENT PART " &
- "OF A NON_BASED LITERAL");
- END IF;
- IF 1_2_3_4_5 /= 12345 THEN
- FAILED("UNDERSCORES NOT PERMITTED IN INTEGRAL PART " &
- "OF A NON_BASED LITERAL INTEGER");
- END IF;
- IF 0E1_0 /= 0 THEN
- FAILED("UNDERSCORES NOT PERMITTED IN EXPONENT PART " &
- "OF A NON_BASED LITERAL INTEGER");
- END IF;
-
- RESULT;
-END C24106A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24202d.ada b/gcc/testsuite/ada/acats/tests/c2/c24202d.ada
deleted file mode 100644
index 65c3d21..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24202d.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C24202D.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 NON-CONSECUTIVE UNDERSCORES ARE PERMITTED
--- IN EVERY PART OF BASED INTEGER, FLOATING POINT, AND FIXED POINT LITERALS.
-
--- WMC 03/16/92 CONSOLIDATION OF C24202A.ADA, C24202B.ADA, C24202C.ADA
-
-WITH REPORT;
-
-PROCEDURE C24202D IS
-
- USE REPORT;
-
- TYPE FIXED1 IS DELTA 2.0**(-6) RANGE 0.0 .. 10.0;
-
- I1, I2 : INTEGER;
- F1, F2, F3 : FLOAT;
- F4, F5 : FIXED1;
-
-BEGIN
- TEST("C24202D", "UNDERSCORES ALLOWED IN NUMERIC LITERALS");
-
- I1 := 12_3;
- I2 := 16#D#E0_1;
-
- IF (I1 /= 123) OR (I2 /= 16#D#E01) THEN
- FAILED("UNDERSCORES IN INTEGER LITERALS NOT HANDLED CORRECTLY");
- END IF;
-
-
- F1 := 1.2_5E1;
- F2 := 8#1_3.5#;
- F3 := 8#3.4#E1_1;
-
- IF (F1 /= 1.25E1) OR (F2 /= 8#13.5#) OR (F3 /= 8#3.4#E11) THEN
- FAILED("UNDERSCORES IN FLOATING POINT LITERALS NOT " &
- "HANDLED CORRECTLY");
- END IF;
-
-
- F4 := 1_6#1.A#;
- F5 := 8#2.3_7#;
-
- IF (F4 /= 16#1.A#) OR (F5 /= 8#2.37#) THEN
- FAILED("UNDERSCORES IN FIXED POINT LITERALS NOT " &
- "HANDLED CORRECTLY");
- END IF;
-
- RESULT;
-
-END C24202D;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24203a.ada b/gcc/testsuite/ada/acats/tests/c2/c24203a.ada
deleted file mode 100644
index a97bb86..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24203a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C24203A.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 BASED INTEGER LITERALS WITH BASES 2 THROUGH 16 ALL
--- YIELD CORRECT VALUES.
-
--- JRK 12/12/79
--- JRK 10/27/80
--- JWC 6/28/85 RENAMED FROM C24103A.ADA
-
-WITH REPORT;
-PROCEDURE C24203A IS
-
- USE REPORT;
-
- I : INTEGER := 200;
-
-BEGIN
- TEST ("C24203A", "VALUES OF BASED INTEGER LITERALS");
-
- IF 2#11# /= 3 THEN
- FAILED ("INCORRECT VALUE FOR BASE 2 INTEGER");
- END IF;
-
- IF 3#22# /= 8 THEN
- FAILED ("INCORRECT VALUE FOR BASE 3 INTEGER");
- END IF;
-
- IF 4#33# /= 15 THEN
- FAILED ("INCORRECT VALUE FOR BASE 4 INTEGER");
- END IF;
-
- IF 5#44# /= 24 THEN
- FAILED ("INCORRECT VALUE FOR BASE 5 INTEGER");
- END IF;
-
- IF 6#55# /= 35 THEN
- FAILED ("INCORRECT VALUE FOR BASE 6 INTEGER");
- END IF;
-
- IF 7#66# /= 48 THEN
- FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER");
- END IF;
-
- IF 8#77# /= 63 THEN
- FAILED ("INCORRECT VALUE FOR BASE 8 INTEGER");
- END IF;
-
- IF 9#88# /= 80 THEN
- FAILED ("INCORRECT VALUE FOR BASE 9 INTEGER");
- END IF;
-
- IF 10#99# /= 99 THEN
- FAILED ("INCORRECT VALUE FOR BASE 10 INTEGER");
- END IF;
-
- IF 11#AA# /= 120 THEN
- FAILED ("INCORRECT VALUE FOR BASE 11 INTEGER");
- END IF;
-
- IF 12#BB# /= 143 THEN
- FAILED ("INCORRECT VALUE FOR BASE 12 INTEGER");
- END IF;
-
- IF 13#CC# /= 168 THEN
- FAILED ("INCORRECT VALUE FOR BASE 13 INTEGER");
- END IF;
-
- IF 14#DD# /= 195 THEN
- FAILED ("INCORRECT VALUE FOR BASE 14 INTEGER");
- END IF;
-
- IF 15#EE# /= 224 THEN
- FAILED ("INCORRECT VALUE FOR BASE 15 INTEGER");
- END IF;
-
- IF 16#FF# /= 255 THEN
- FAILED ("INCORRECT VALUE FOR BASE 16 INTEGER");
- END IF;
-
- ----------------------------------------
-
- IF 7#66#E1 /= 336 THEN
- FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER " &
- "WITH EXPONENT");
- END IF;
-
- RESULT;
-END C24203A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24203b.ada b/gcc/testsuite/ada/acats/tests/c2/c24203b.ada
deleted file mode 100644
index 8a56bf1..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24203b.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- C24203B.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 BASED REAL LITERALS WITH BASES 2 THROUGH 16 ALL
--- YIELD CORRECT VALUES.
-
--- THIS TEST USES MODEL NUMBERS OF DIGITS 6.
-
--- HISTORY:
--- DHH 06/15/88 CREATED ORIGINAL TEST.
--- DTN 11/30/95 REMOVED CONFORMANCE CHECKS WHERE RULES RELAXED.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C24203B IS
-
- TYPE CHECK IS DIGITS 6;
-
-BEGIN
- TEST("C24203B", "CHECK THAT BASED REAL LITERALS WITH BASES " &
- "2 THROUGH 16 ALL YIELD CORRECT VALUES");
-
- IF
- 2#0.0000000000000000000000000000000000000000000000000000000000001#
- /= 2.0 ** (-61) THEN
- FAILED ("INCORRECT VALUE FOR BASE 2 REAL LITERAL");
- END IF;
-
- IF 3#0.00000000001# <
- ((2.0 ** (-18)) + (251558.0 * (2.0 ** (-37)))) OR
- 3#0.00000000001# >
- ((2.0 ** (-18)) + (251559.0 * (2.0 ** (-37)))) THEN
- FAILED ("INCORRECT VALUE FOR BASE 3 REAL LITERAL");
- END IF;
-
- IF 4#13333333.213# /= 32767.609375 THEN
- FAILED ("INCORRECT VALUE FOR BASE 4 REAL LITERAL");
- END IF;
-
- IF 5#2021444.4241121# < 32749.90625 OR
- 5#2021444.4241121# > 32749.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 5 REAL LITERAL");
- END IF;
-
- IF 6#411355.531043# /= 32759.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 6 REAL LITERAL");
- END IF;
-
- IF 7#164366.625344# < 32780.90625 OR
- 7#164366.625344# > 32780.9375 THEN
- FAILED ("INCORRECT VALUE FOR BASE 7 REAL LITERAL");
- END IF;
-
- IF 8#77777.07# /= 32767.109375 THEN
- FAILED ("INCORRECT VALUE FOR BASE 8 REAL LITERAL");
- END IF;
-
- IF 9#48888.820314# < 32804.90625 OR
- 9#48888.820314# > 32804.9375 THEN
- FAILED ("INCORRECT VALUE FOR BASE 9 REAL LITERAL");
- END IF;
-
- IF 10#32767.921875# /= 32767.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 10 REAL LITERAL");
- END IF;
-
- IF 11#2267A.A06682# < 32757.90625 OR
- 11#2267A.A06682# > 32757.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 11 REAL LITERAL");
- END IF;
-
- IF 12#16B5B.B09# /= 32759.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 12 REAL LITERAL");
- END IF;
-
- IF 13#11B9C.BB616# < 32746.90625 OR
- 13#11B9C.BB616# > 32746.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 13 REAL LITERAL");
- END IF;
-
- IF 14#BD1D.CC98A7# /= 32759.921875 THEN
- FAILED ("INCORRECT VALUE FOR BASE 14 REAL LITERAL");
- END IF;
-
- IF 15#3D28188D45881111111111.0# <
- (((2.0 ** 21) -2.0) * (2.0 ** 63)) THEN
- FAILED ("INCORRECT VALUE FOR BASE 15 REAL LITERAL");
- END IF;
-
-
- RESULT;
-END C24203B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24207a.ada b/gcc/testsuite/ada/acats/tests/c2/c24207a.ada
deleted file mode 100644
index ca7e17f..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24207a.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C24207A.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 LETTERS IN A BASED LITERAL MAY APPEAR IN UPPER OR LOWER
--- CASE.
-
--- TBN 2/28/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C24207A IS
-
- TYPE FLOAT IS DIGITS 5;
- INT_1 : INTEGER := 15#AbC# ;
- INT_2 : INTEGER := 15#aBc# ;
- FLO_1 : FLOAT := 16#FeD.C#e1;
- FLO_2 : FLOAT := 16#fEd.c#E1;
-
-BEGIN
- TEST("C24207A", "CHECK THAT LETTERS IN A BASED LITERAL MAY " &
- "APPEAR IN UPPER OR LOWER CASE");
-
- IF INT_1 /= INT_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 1");
- END IF;
-
- IF FLO_1 /= FLO_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 2");
- END IF;
-
- INT_1 := 14#aBc#E1;
- INT_2 := 14#AbC#e1;
- FLO_1 := 16#CdEf.aB#E0;
- FLO_2 := 16#cDeF.Ab#e0;
-
- IF INT_1 /= INT_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 3");
- END IF;
-
- IF FLO_1 /= FLO_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 4");
- END IF;
-
- RESULT;
-END C24207A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c24211a.ada b/gcc/testsuite/ada/acats/tests/c2/c24211a.ada
deleted file mode 100644
index f04e033..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c24211a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C24211A.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 LEGAL FORMS INVOLVING A DIGIT FOLLOWED BY A COLON ARE
--- CORRECTLY ANALYZED USING A TWO CHARACTER LOOK-AHEAD.
-
--- HISTORY:
--- DHH 01/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C24211A IS
-
- TYPE FIXED IS DELTA 0.0125 RANGE -1.0 .. 100.0;
-
- A : INTEGER RANGE 0 .. 2:10::= 1;
- B : INTEGER RANGE 0 .. 2#10#:= 1;
- X : FIXED RANGE 0.0 .. 16:3.0::= 1.0;
- Y : FIXED RANGE 0.0 .. 16#3.0#:= 1.0;
- IN2 : INTEGER;
- BOOL : BOOLEAN:=3:10:=3:10:;
-
-BEGIN
-
- TEST("C24211A", "CHECK THAT LEGAL FORMS INVOLVING A DIGIT " &
- "FOLLOWED BY A COLON ARE CORRECTLY ANALYZED " &
- "USING A TWO CHARACTER LOOK-AHEAD");
-
- IF IDENT_INT(A) /= B THEN
- FAILED("CALCULATIONS OF BASED INTEGER LITERALS WHEN " &
- "REPRESENTED BY SHARPS DO NOT MATCH CALCULATIONS " &
- "OF BASED INTEGER LITERALS REPRESENTED BY COLONS");
- END IF;
- A := A + 1;
-
-
- IF EQUAL(3,3) THEN
- Y := X + Y;
- ELSE
- Y := X - Y;
- END IF;
-
- IF (2 * X) = Y THEN
- NULL;
- ELSE
- FAILED("CALCULATIONS OF BASED REAL LITERALS WHEN " &
- "REPRESENTED BY SHARPS DO NOT MATCH CALCULATIONS " &
- "OF BASED REAL LITERALS REPRESENTED BY COLONS");
- END IF;
- IF NOT BOOL THEN
- FAILED("BOOLEAN VALUE BASED ON REAL LITERAL WAS CALCULATED " &
- "INCORRECTLY");
- IN2:=2:10:;
- ELSE
- BOOL := FALSE;
- IN2:=3:10:;
- END IF;
- IF BOOL THEN
- A := A + 1;
- ELSE
- A := A - 1;
- END IF;
-
- RESULT;
-END C24211A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c250001.aw b/gcc/testsuite/ada/acats/tests/c2/c250001.aw
deleted file mode 100644
index fd53343..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c250001.aw
+++ /dev/null
@@ -1,167 +0,0 @@
--- C250001.AW
---
--- 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 wide character literals are supported.
--- Check that wide character string literals are supported.
---
--- TEST DESCRIPTION:
--- This test utilizes the brackets scheme for representing wide character
--- values in transportable 7 bit ASCII as proposed by Robert Dewar;
--- this test defines Wide_Character and Wide_String objects, and assigns
--- and tests several sample values.
---
--- SPECIAL REQUIREMENTS:
---
--- This file must be preprocessed before it can be executed as a test.
---
--- This test requires that all occurrences of the bracket escape
--- representation for wide characters be replaced, as appropriate, with
--- the corresponding wide character as represented by the implementation.
---
--- Characters above ASCII.Del are represented by an 8 character sequence:
---
--- ["xxxx"]
---
--- where the character code represented is specified by four hexadecimal
--- digits, (<xxxx>) upper case. For example the wide character with the
--- code 16#ABCD# is represented by the eight character sequence:
---
--- ["ABCD"]
---
--- The following function documents the translation algorithm:
---
--- function To_Wide( S:String ) return Wide_character is
--- Numerical : Natural := 0;
--- type Xlate is array(Character range '0'..'F') of Natural;
--- Xlation : Xlate
--- := ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4,
--- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9,
--- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14,
--- 'F' => 15, others => 0 );
--- begin
--- for I in S'Range loop
--- Numerical := Numerical * 16 + Xlation(S(I));
--- end loop;
--- return Wide_Character'Val(Numerical); -- the returned value is
--- implementation dependent
--- exception
--- when Constraint_Error => raise;
--- end To_Wide;
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial .Aversion
--- 11 APR 96 SAIC Minor robustness changes for 2.1
--- 12 NOV 96 SAIC Changed file extension to .AW
---
---!
-
------------------------------------------------------------------ C250001_0
-
-package C250001_0 is
-
- -- The wide characters used in this test are sequential starting with
- -- the character '["4F42"]' 16#0F42#
-
- Four_Eff_Four_Two : constant Wide_Character := '["4F42"]';
-
- Four_Eff_4_3_Through_9 : constant Wide_String :=
- "["4F43"]["4F44"]["4F45"]["4F46"]["4F47"]["4F48"]["4F49"]";
-
- Four_Eff_A_B : constant Wide_String := "["4F4A"]["4F4B"]";
-
-end C250001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- no package body C250001_0 is required or allowed
-
-------------------------------------------------------------------- C250001
-
-with Report;
-with C250001_0;
-with Ada.Tags;
-
-procedure C250001 is
- use C250001_0;
-
- function Hex( N: Natural ) return String is
- S : String := "xxxx";
- T : String := "0123456789ABCDEF";
- V : Natural := N;
- begin
- for I in reverse 1..4 loop
- S(I) := T(V rem 16 +1);
- V := V / 16;
- end loop;
- return S;
- end Hex;
-
- procedure Match( Check : Wide_Character; Matching : Natural ) is
- begin
- if Wide_Character'Pos( Check ) /= Matching then
- Report.Failed( "Didn't match for " & Hex(Matching) );
- end if;
- end Match;
-
- type Value_List is array(Positive range <>) of Natural;
-
- procedure Match( Check : Wide_String; Matching : Value_List ) is
- begin
- if Check'Length /= Matching'Length then
- Report.Failed( "Check'Length /= Matching'Length" );
- else
- for I in Check'Range loop
- Match( Check(I), Matching(I) );
- end loop;
- end if;
- end Match;
-
-begin -- Main test procedure.
-
- Report.Test ("C250001", "Check that wide character literals " &
- "are supported. Check that wide character " &
- "string literals are supported." );
-
- Match( Four_Eff_Four_Two, 16#4F42# );
-
- Match(Four_Eff_4_3_Through_9,
- (16#4F43#,16#4F44#,16#4F45#,16#4F46#,16#4F47#,16#4F48#,16#4F49#) );
-
- -- check catenations
-
- Match( Four_Eff_Four_Two & Four_Eff_Four_Two, (16#4F42#,16#4F42#) );
-
- Match( Four_Eff_Four_Two & Four_Eff_A_B, (16#4F42#,16#4F4A#,16#4F4B#) );
-
- Match( Four_Eff_A_B & Four_Eff_Four_Two, (16#4F4A#,16#4F4B#,16#4F42#) );
-
- Match( Four_Eff_A_B & Four_Eff_A_B,
- (16#4F4A#,16#4F4B#,16#4F4A#,16#4F4B#) );
-
- Report.Result;
-
-end C250001;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c250002.aw b/gcc/testsuite/ada/acats/tests/c2/c250002.aw
deleted file mode 100644
index fe22481..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c250002.aw
+++ /dev/null
@@ -1,213 +0,0 @@
--- C250002.AW
---
--- 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 characters in Latin-1 above ASCII.Del can be used in
--- identifiers, character literals and strings.
---
--- TEST DESCRIPTION:
--- This test utilizes the brackets scheme for representing Latin-1
--- character values in transportable 7 bit ASCII as proposed by
--- Robert Dewar; this test defines Character and String objects,
--- assigns and tests several sample values. Several Identifiers
--- used in this test also include Characters via the bracket escape
--- sequence scheme.
---
--- Note that C250001 checks Wide_Characters and Wide_Strings.
---
--- SPECIAL REQUIREMENTS:
---
--- This file must be preprocessed before it can be executed as a test.
---
--- This test requires that all occurrences of the bracket escaped
--- characters be replaced with the corresponding 8 bit character.
---
--- Characters above ASCII.Del are represented by a 6 character sequence:
---
--- ["xx"]
---
--- where the character code represented is specified by two hexadecimal
--- digits (<xx>) upper case. For example the Latin-1 character with the
--- code 16#AB# is represented by the six character sequence:
---
--- ["AB"]
---
--- None of the values used in this test should be interpreted as
--- a control character.
---
--- The following function documents the translation algorithm:
---
--- function To_Char( S:String ) return Character is
--- Numerical : Natural := 0;
--- type Xlate is array(Character range '0'..'F') of Natural;
--- Xlation : Xlate
--- := ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4,
--- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9,
--- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14,
--- 'F' => 15, others => 0 );
--- begin
--- for I in S'Range loop
--- Numerical := Numerical * 16 + Xlation(S(I));
--- end loop;
--- return Character'Val(Numerical);
--- end To_Char;
---
---
--- CHANGE HISTORY:
--- 10 JAN 96 SAIC Initial version
--- 12 NOV 96 SAIC Changed file extension to .AW
---
---!
-
------------------------------------------------------------------ C250002_0
-
-package C250002_0 is
-
- -- The extended characters used in this test start with
- -- the character '["A1"]' 16#A1# and increase from there
-
- type Tagged_["C0"]_Id is tagged record
- Length, Width: Natural;
- end record;
-
- X_Char_A2 : constant Character := '["A2"]';
-
- X_Char_A3_Through_A9 : constant String :=
- "["A3"]["A4"]["A5"]["A6"]["A7"]["A8"]["A9"]";
-
- X_Char_AA_AB : constant String := "["AA"]["AB"]";
-
-end C250002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- no package body C250002_0 is required or allowed
-
------------------------------------------------------------------ C250002_X
-
-with Ada.Characters.Latin_1;
-package C250002_["C1"] is
-
- type Enum is ( Item, 'A', '["AD"]', AE_["C6"]["E6"]_ae,
- '["2D"]', '["FF"]' );
-
- task type C2_["C2"] is
- entry C2_["C3"];
- end C2_["C2"];
-
-end C250002_["C1"];
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C250002_["C1"] is
-
- task body C2_["C2"] is
- begin
- accept C2_["C3"];
- end C2_["C2"];
-
-end C250002_["C1"];
-
-------------------------------------------------------------------- C250002
-
-with Report;
-with C250002_0;
-with C250002_["C1"];
-
-with Ada.Tags;
-
-procedure C250002 is
- use C250002_0;
-
- My_Task: C250002_["C1"].C2_["C2"];
-
- function Hex( N: Natural ) return String is
- S : String := "xx";
- T : String := "0123456789ABCDEF";
- begin
- S(1) := T(N / 16 +1);
- S(2) := T(N mod 16 +1);
- return S;
- end Hex;
-
- procedure Match( Check : Character; Matching : Natural ) is
- begin
- if Check /= Character'Val( Matching ) then
- Report.Failed( "Didn't match for " & Hex(Matching) );
- end if;
- end Match;
-
- type Value_List is array(Positive range <>) of Natural;
-
- procedure Match( Check : String; Matching : Value_List ) is
- begin
- if Check'Length /= Matching'Length then
- Report.Failed( "Check'Length /= Matching'Length" );
- else
- for I in Check'Range loop
- Match( Check(I), Matching(I - Check'First + Matching'First) );
- end loop;
- end if;
- end Match;
-
- TC_Count : Natural := 0;
-
-begin -- Main test procedure.
-
- Report.Test ("C250002", "Check that characters above ASCII.Del can be " &
- "used in identifiers, character literals and " &
- "strings" );
-
- Report.Comment( Ada.Tags.Expanded_Name(Tagged_["C0"]_Id'Tag) );
-
- for Specials in C250002_["C1"].Enum loop
- TC_Count := TC_Count +1;
- end loop;
-
- if TC_Count /= 6 then
- Report.Failed("Expected 6 literals in Enum");
- end if;
-
- Match( X_Char_A2, 16#A2# );
-
- Match(X_Char_A3_Through_A9,
- (16#A3#,16#A4#,16#A5#,16#A6#,16#A7#,16#A8#,16#A9#) );
-
- -- check catenations
-
- Match( X_Char_A2 & X_Char_A2, (16#A2#,16#A2#) );
-
- Match( X_Char_A2 & X_Char_AA_AB, (16#A2#,16#AA#,16#AB#) );
-
- Match( X_Char_AA_AB & X_Char_A2, (16#AA#,16#AB#,16#A2#) );
-
- Match( X_Char_AA_AB & X_Char_AA_AB,
- (16#AA#,16#AB#,16#AA#,16#AB#) );
-
- My_Task.C2_["C3"];
-
- Report.Result;
-
-end C250002;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c25001a.ada b/gcc/testsuite/ada/acats/tests/c2/c25001a.ada
deleted file mode 100644
index bb27be7..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c25001a.ada
+++ /dev/null
@@ -1,211 +0,0 @@
--- C25001A.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 CHARACTER LITERALS CAN BE WRITTEN.
-
--- CASE A: THE BASIC CHARACTER SET.
-
--- TBN 3/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C25001A IS
-
-BEGIN
- TEST ("C25001A", "CHECK THAT EACH CHARACTER IN THE BASIC " &
- "CHARACTER SET CAN BE WRITTEN");
-
- IF CHARACTER'POS('A') /= 65 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'A'");
- END IF;
- IF CHARACTER'POS('B') /= 66 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'B'");
- END IF;
- IF CHARACTER'POS('C') /= 67 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'C'");
- END IF;
- IF CHARACTER'POS('D') /= 68 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'D'");
- END IF;
- IF CHARACTER'POS('E') /= 69 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'E'");
- END IF;
- IF CHARACTER'POS('F') /= 70 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'F'");
- END IF;
- IF CHARACTER'POS('G') /= 71 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'G'");
- END IF;
- IF CHARACTER'POS('H') /= 72 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'H'");
- END IF;
- IF CHARACTER'POS('I') /= 73 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'I'");
- END IF;
- IF CHARACTER'POS('J') /= 74 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'J'");
- END IF;
- IF CHARACTER'POS('K') /= 75 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'K'");
- END IF;
- IF CHARACTER'POS('L') /= 76 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'L'");
- END IF;
- IF CHARACTER'POS('M') /= 77 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'M'");
- END IF;
- IF CHARACTER'POS('N') /= 78 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'N'");
- END IF;
- IF CHARACTER'POS('O') /= 79 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'O'");
- END IF;
- IF CHARACTER'POS('P') /= 80 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'P'");
- END IF;
- IF CHARACTER'POS('Q') /= 81 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'Q'");
- END IF;
- IF CHARACTER'POS('R') /= 82 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'R'");
- END IF;
- IF CHARACTER'POS('S') /= 83 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'S'");
- END IF;
- IF CHARACTER'POS('T') /= 84 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'T'");
- END IF;
- IF CHARACTER'POS('U') /= 85 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'U'");
- END IF;
- IF CHARACTER'POS('V') /= 86 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'V'");
- END IF;
- IF CHARACTER'POS('W') /= 87 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'W'");
- END IF;
- IF CHARACTER'POS('X') /= 88 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'X'");
- END IF;
- IF CHARACTER'POS('Y') /= 89 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'Y'");
- END IF;
- IF CHARACTER'POS('Z') /= 90 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'Z'");
- END IF;
-
- IF CHARACTER'POS('0') /= 48 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '0'");
- END IF;
- IF CHARACTER'POS('1') /= 49 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '1'");
- END IF;
- IF CHARACTER'POS('2') /= 50 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '2'");
- END IF;
- IF CHARACTER'POS('3') /= 51 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '3'");
- END IF;
- IF CHARACTER'POS('4') /= 52 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '4'");
- END IF;
- IF CHARACTER'POS('5') /= 53 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '5'");
- END IF;
- IF CHARACTER'POS('6') /= 54 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '6'");
- END IF;
- IF CHARACTER'POS('7') /= 55 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '7'");
- END IF;
- IF CHARACTER'POS('8') /= 56 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '8'");
- END IF;
- IF CHARACTER'POS('9') /= 57 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '9'");
- END IF;
-
- IF CHARACTER'POS('"') /= 34 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '""'");
- END IF;
- IF CHARACTER'POS('#') /= 35 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '#'");
- END IF;
- IF CHARACTER'POS('&') /= 38 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '&'");
- END IF;
- IF CHARACTER'POS(''') /= 39 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '''");
- END IF;
- IF CHARACTER'POS('(') /= 40 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '('");
- END IF;
- IF CHARACTER'POS(')') /= 41 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ')'");
- END IF;
- IF CHARACTER'POS('*') /= 42 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '*'");
- END IF;
- IF CHARACTER'POS('+') /= 43 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '+'");
- END IF;
- IF CHARACTER'POS(',') /= 44 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ','");
- END IF;
- IF CHARACTER'POS('-') /= 45 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '-'");
- END IF;
- IF CHARACTER'POS('.') /= 46 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '.'");
- END IF;
- IF CHARACTER'POS('/') /= 47 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '/'");
- END IF;
- IF CHARACTER'POS(':') /= 58 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ':'");
- END IF;
- IF CHARACTER'POS(';') /= 59 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ';'");
- END IF;
- IF CHARACTER'POS('<') /= 60 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '<'");
- END IF;
- IF CHARACTER'POS('=') /= 61 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '='");
- END IF;
- IF CHARACTER'POS('>') /= 62 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '>'");
- END IF;
- IF CHARACTER'POS('_') /= 95 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '_'");
- END IF;
- IF CHARACTER'POS('|') /= 124 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '|'");
- END IF;
-
- IF CHARACTER'POS(' ') /= 32 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ' '");
- END IF;
-
- RESULT;
-END C25001A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c25001b.ada b/gcc/testsuite/ada/acats/tests/c2/c25001b.ada
deleted file mode 100644
index d82547c..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c25001b.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C25001B.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 CHARACTER LITERALS CAN BE WRITTEN.
-
--- CASE B: THE LOWER CASE LETTERS AND THE OTHER
--- SPECIAL CHARACTERS.
-
--- TBN 8/1/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C25001B IS
-
-BEGIN
- TEST ("C25001B", "CHECK THAT EACH CHARACTER IN THE LOWER CASE " &
- "LETTERS AND THE OTHER SPECIAL CHARACTERS CAN " &
- "BE WRITTEN");
-
- IF CHARACTER'POS('a') /= 97 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'a'");
- END IF;
- IF CHARACTER'POS('b') /= 98 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'b'");
- END IF;
- IF CHARACTER'POS('c') /= 99 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'c'");
- END IF;
- IF CHARACTER'POS('d') /= 100 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'd'");
- END IF;
- IF CHARACTER'POS('e') /= 101 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'e'");
- END IF;
- IF CHARACTER'POS('f') /= 102 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'f'");
- END IF;
- IF CHARACTER'POS('g') /= 103 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'g'");
- END IF;
- IF CHARACTER'POS('h') /= 104 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'h'");
- END IF;
- IF CHARACTER'POS('i') /= 105 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'i'");
- END IF;
- IF CHARACTER'POS('j') /= 106 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'j'");
- END IF;
- IF CHARACTER'POS('k') /= 107 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'k'");
- END IF;
- IF CHARACTER'POS('l') /= 108 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'l'");
- END IF;
- IF CHARACTER'POS('m') /= 109 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'm'");
- END IF;
- IF CHARACTER'POS('n') /= 110 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'n'");
- END IF;
- IF CHARACTER'POS('o') /= 111 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'o'");
- END IF;
- IF CHARACTER'POS('p') /= 112 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'p'");
- END IF;
- IF CHARACTER'POS('q') /= 113 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'q'");
- END IF;
- IF CHARACTER'POS('r') /= 114 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'r'");
- END IF;
- IF CHARACTER'POS('s') /= 115 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 's'");
- END IF;
- IF CHARACTER'POS('t') /= 116 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 't'");
- END IF;
- IF CHARACTER'POS('u') /= 117 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'u'");
- END IF;
- IF CHARACTER'POS('v') /= 118 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'v'");
- END IF;
- IF CHARACTER'POS('w') /= 119 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'w'");
- END IF;
- IF CHARACTER'POS('x') /= 120 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'x'");
- END IF;
- IF CHARACTER'POS('y') /= 121 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'y'");
- END IF;
- IF CHARACTER'POS('z') /= 122 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR 'z'");
- END IF;
-
- IF CHARACTER'POS('!') /= 33 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '!'");
- END IF;
- IF CHARACTER'POS('$') /= 36 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '$'");
- END IF;
- IF CHARACTER'POS('%') /= 37 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '%'");
- END IF;
- IF CHARACTER'POS('?') /= 63 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '?'");
- END IF;
- IF CHARACTER'POS('@') /= 64 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '@'");
- END IF;
- IF CHARACTER'POS('[') /= 91 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '['");
- END IF;
- IF CHARACTER'POS('\') /= 92 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '\'");
- END IF;
- IF CHARACTER'POS(']') /= 93 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR ']'");
- END IF;
- IF CHARACTER'POS('^') /= 94 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '^'");
- END IF;
- IF CHARACTER'POS('`') /= 96 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '`'");
- END IF;
- IF CHARACTER'POS('{') /= 123 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '{'");
- END IF;
- IF CHARACTER'POS('}') /= 125 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '}'");
- END IF;
- IF CHARACTER'POS('~') /= 126 THEN
- FAILED ("INCORRECT POSITION NUMBER FOR '~'");
- END IF;
-
- RESULT;
-END C25001B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c26006a.ada b/gcc/testsuite/ada/acats/tests/c2/c26006a.ada
deleted file mode 100644
index b4e8ce6..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c26006a.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- C26006A.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 ASCII CHARACTERS CAN APPEAR IN THE MIDDLE OF A STRING
--- (I.E., NONE ARE USED IN THE INTERNAL REPRESENTATION TO TERMINATE THE
--- STRING).
-
--- JRK 12/12/79
-
-WITH REPORT;
-PROCEDURE C26006A IS
-
- USE REPORT;
-
- S1 : STRING (1..3) := "A 1";
- S2 : STRING (1..3) := "A 2";
-
-BEGIN
- TEST ("C26006A", "ALL ASCII CHARACTERS CAN APPEAR IN MIDDLE " &
- "OF STRINGS");
-
- FOR C IN CHARACTER'FIRST .. CHARACTER'LAST LOOP
- S1 (2) := C;
- S2 (2) := C;
- IF S1 = S2 THEN
- FAILED (CHARACTER'IMAGE(C) & " TERMINATED A " &
- "STRING = COMPARISON");
- END IF;
- END LOOP;
-
- RESULT;
-END C26006A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c26008a.ada b/gcc/testsuite/ada/acats/tests/c2/c26008a.ada
deleted file mode 100644
index 89bb549..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c26008a.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- C26008A.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 UPPER AND LOWER CASE LETTERS ARE DISTINCT WITHIN STRING
--- LITERALS.
-
--- JRK 12/12/79
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT;
-PROCEDURE C26008A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C26008A", "UPPER/LOWER CASE ARE DISTINCT IN STRING " &
- "LITERALS");
-
- IF CHARACTER'('a') = 'A' THEN
- FAILED ("LOWER CASE NOT DISTINCT FROM UPPER IN " &
- "CHARACTER LITERALS");
- END IF;
-
- IF STRING'("abcde") = "ABCDE" THEN
- FAILED ("LOWER CASE NOT DISTINCT FROM UPPER IN " &
- "STRING LITERALS");
- END IF;
-
- RESULT;
-END C26008A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada b/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada
deleted file mode 100644
index 27b8fe0..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C2A001A.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 NON-CONSECUTIVE UNDERSCORES ARE PERMITTED
--- IN EVERY PART OF A BASED INTEGER LITERAL WHEN SHARPS
--- ARE USED INSTEAD OF COLONS.
-
--- INTEGER LITERALS.
-
--- DCB 1/24/80
--- JRK 10/27/80
--- JBG 5/28/85
-
-WITH REPORT;
-PROCEDURE C2A001A IS
-
- USE REPORT;
-
- I1, I2, I3, I4 : INTEGER;
-
-BEGIN
- TEST("C2A001A", "UNDERSCORES ALLOWED IN BASED INTEGER LITERALS " &
- "THAT HAVE COLONS");
-
- I1 := 12_3;
- I2 := 1_6:D:;
- I3 := 2:1011_0101:;
- I4 := 16:D:E0_1;
-
- IF I1 = 123 AND I2 = 16:D: AND I3 = 2:10110101: AND
- I4 = 16:D:E01 THEN
- NULL;
- ELSE
- FAILED("UNDERSCORES IN INTEGER LITERALS NOT HANDLED " &
- "CORRECTLY");
- END IF;
-
- RESULT;
-END C2A001A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada b/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada
deleted file mode 100644
index ea1f1ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C2A001B.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 NON-CONSECUTIVE UNDERSCORES ARE PERMITTED
--- IN EVERY PART OF A BASED FLOATING POINT LITERAL THAT
--- USES COLONS INSTEAD OF SHARPS.
-
--- DCB 04/22/80
--- JRK 10/27/80
--- JBG 5/28/85
-
-WITH REPORT;
-PROCEDURE C2A001B IS
-
- USE REPORT;
-
- F1, F2, F3, F4, F5 : FLOAT;
-
-BEGIN
- TEST("C2A001B", "UNDERSCORES ALLOWED IN BASED FLOATING POINT " &
- "LITERALS THAT HAVE COLONS");
-
- F1 := 1.2_5E1;
- F2 := 1_6:1.A:;
- F3 := 8:1_3.5:;
- F4 := 8:2.3_7:;
- F5 := 8:3.4:E1_1;
-
- IF F1 = 1.25E1 AND F2 = 16:1.A: AND F3 = 8:13.5: AND
- F4 = 8:2.37: AND F5 = 8:3.4:E11 THEN
- NULL;
- ELSE
- FAILED("UNDERSCORES IN FLOATING POINT LITERALS NOT " &
- "HANDLED CORRECTLY");
- END IF;
-
- RESULT;
-END C2A001B;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada b/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada
deleted file mode 100644
index db3c98d..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C2A001C.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 NON-CONSECUTIVE UNDERSCORES ARE PERMITTED
--- IN EVERY PART OF A BASED FIXED POINT LITERAL THAT USES
--- COLONS INSTEAD OF SHARPS.
-
--- DCB 04/22/80
--- JRK 10/27/80
--- JBG 5/28/85
-
-WITH REPORT;
-PROCEDURE C2A001C IS
-
- USE REPORT;
-
- TYPE FIXED1 IS DELTA 2.0**(-6) RANGE 0.0 .. 10.0;
- TYPE FIXED2 IS DELTA 2.0**(-4) RANGE 0.0 .. 100.0;
-
- F2, F4 : FIXED1;
- F1, F3, F5 : FIXED2;
-
-BEGIN
- TEST("C2A001C", "UNDERSCORES ALLOWED IN BASED FIXED POINT " &
- "LITERALS THAT USE COLONS");
-
- F1 := 1.2_5E1;
- F2 := 1_6:1.A:;
- F3 := 8:1_3.5:;
- F4 := 8:2.3_7:;
- F5 := 8:3.4:E0_1;
-
- IF F1 = 1.25E1 AND F2 = 16:1.A: AND F3 = 8:13.5: AND
- F4 = 8:2.37: AND F5 = 8:3.4:E01 THEN
- NULL;
- ELSE
- FAILED("UNDERSCORES IN FIXED POINT LITERALS NOT " &
- "HANDLED CORRECTLY");
- END IF;
-
- RESULT;
-END C2A001C;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada b/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada
deleted file mode 100644
index cd7cd59..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C2A002A.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 BASED INTEGER LITERALS WITH BASES 2 THROUGH 16 ALL
--- YIELD CORRECT VALUES WHEN COLONS ARE USED INSTEAD OF SHARPS.
-
--- JRK 12/12/79
--- JRK 10/27/80
--- JBG 5/28/85
-
-WITH REPORT;
-PROCEDURE C2A002A IS
-
- USE REPORT;
-
- I : INTEGER := 200;
-
-BEGIN
- TEST ("C2A002A", "VALUES OF BASED INTEGER LITERALS WITH " &
- "COLONS");
-
- IF 2:11: /= 3 THEN
- FAILED ("INCORRECT VALUE FOR BASE 2 INTEGER");
- END IF;
-
- IF 3:22: /= 8 THEN
- FAILED ("INCORRECT VALUE FOR BASE 3 INTEGER");
- END IF;
-
- IF 4:33: /= 15 THEN
- FAILED ("INCORRECT VALUE FOR BASE 4 INTEGER");
- END IF;
-
- IF 5:44: /= 24 THEN
- FAILED ("INCORRECT VALUE FOR BASE 5 INTEGER");
- END IF;
-
- IF 6:55: /= 35 THEN
- FAILED ("INCORRECT VALUE FOR BASE 6 INTEGER");
- END IF;
-
- IF 7:66: /= 48 THEN
- FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER");
- END IF;
-
- IF 8:77: /= 63 THEN
- FAILED ("INCORRECT VALUE FOR BASE 8 INTEGER");
- END IF;
-
- IF 9:88: /= 80 THEN
- FAILED ("INCORRECT VALUE FOR BASE 9 INTEGER");
- END IF;
-
- IF 10:99: /= 99 THEN
- FAILED ("INCORRECT VALUE FOR BASE 10 INTEGER");
- END IF;
-
- IF 11:AA: /= 120 THEN
- FAILED ("INCORRECT VALUE FOR BASE 11 INTEGER");
- END IF;
-
- IF 12:BB: /= 143 THEN
- FAILED ("INCORRECT VALUE FOR BASE 12 INTEGER");
- END IF;
-
- IF 13:CC: /= 168 THEN
- FAILED ("INCORRECT VALUE FOR BASE 13 INTEGER");
- END IF;
-
- IF 14:DD: /= 195 THEN
- FAILED ("INCORRECT VALUE FOR BASE 14 INTEGER");
- END IF;
-
- IF 15:EE: /= 224 THEN
- FAILED ("INCORRECT VALUE FOR BASE 15 INTEGER");
- END IF;
-
- IF 16:FF: /= 255 THEN
- FAILED ("INCORRECT VALUE FOR BASE 16 INTEGER");
- END IF;
-
- ----------------------------------------
-
- IF 7:66:E1 /= 336 THEN
- FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER " &
- "WITH EXPONENT");
- END IF;
-
- RESULT;
-END C2A002A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada b/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada
deleted file mode 100644
index 70690c7..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- C2A008A.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 UPPER AND LOWER CASE "E" MAY APPEAR IN BASED LITERALS,
--- WHEN USING COLONS IN PLACE OF THE SHARP SIGN.
-
--- TBN 2/28/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C2A008A IS
-
- TYPE FLOAT IS DIGITS 5;
- INT_1 : INTEGER := 15:A:E1;
- INT_2 : INTEGER := 15:A:e1;
- FLO_1 : FLOAT := 16:FD.C:E1;
- FLO_2 : FLOAT := 16:FD.C:e1;
-
-BEGIN
- TEST("C2A008A", "CHECK THAT UPPER AND LOWER CASE ""E"" MAY " &
- "APPEAR IN BASED LITERALS, WHEN USING COLONS " &
- "IN PLACE OF THE SHARP SIGN");
-
- IF INT_1 /= INT_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 1");
- END IF;
-
- IF FLO_1 /= FLO_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 2");
- END IF;
-
- INT_1 := 14:BC:E1;
- INT_2 := 14:BC:e1;
- FLO_1 := 16:DEF.AB:E0;
- FLO_2 := 16:DEF.AB:e0;
-
- IF INT_1 /= INT_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 3");
- END IF;
-
- IF FLO_1 /= FLO_2 THEN
- FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 4");
- END IF;
-
- RESULT;
-END C2A008A;
diff --git a/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada b/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada
deleted file mode 100644
index 572e4ce..0000000
--- a/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada
+++ /dev/null
@@ -1,44 +0,0 @@
--- C2A021B.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 STRING LITERAL DELIMITED BY PERCENT SIGNS MUST CONTAIN A
--- DOUBLED PERCENT CHARACTER IF THE STRING VALUE IS TO CONTAIN A PERCENT
--- CHARACTER.
-
--- JBG 5/25/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C2A021B IS
- X : STRING (1..5) := %%%%%345%;
- Y : STRING (1..5) := IDENT_STR ("%%345");
-BEGIN
- TEST ("C2A021B", "CHECK USE OF PERCENT SIGN INSIDE STRINGS " &
- "DELIMITED WITH PERCENT SIGNS");
-
- IF X /= Y THEN
- FAILED ("STRING LITERALS NOT EQUAL");
- END IF;
-
- RESULT;
-END C2A021B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32001a.ada b/gcc/testsuite/ada/acats/tests/c3/c32001a.ada
deleted file mode 100644
index 5d90b62..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32001a.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C32001A.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 MULTIPLE OBJECT DECLARATIONS FOR SCALAR TYPES, THE
--- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED
--- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE
--- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS
--- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS.
-
--- RJW 7/16/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32001A IS
-
- BUMP : ARRAY (1 .. 8) OF INTEGER := (OTHERS => 0);
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- RETURN BUMP (I);
- END F;
-
-BEGIN
- TEST ("C32001A", "CHECK THAT IN MULTIPLE OBJECT DECLARATION " &
- "FOR SCALAR TYPES, THE SUBTYPE INDICATION " &
- "AND THE INITIALIZATION EXPRESSIONS ARE " &
- "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
- "IS DECLARED AND THE SUBTYPE INDICATION IS " &
- "EVALUATED FIRST. ALSO, CHECK THAT THE " &
- "EVALUATIONS YIELD THE SAME RESULT AS A " &
- "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
-
- DECLARE
-
- TYPE DAY IS (MON, TUES, WED, THURS, FRI);
- D1, D2 : DAY
- RANGE MON .. DAY'VAL (F (1)) :=
- DAY'VAL (F (1) - 1);
- CD1, CD2 : CONSTANT DAY
- RANGE MON .. DAY'VAL (F (2)) :=
- DAY'VAL (F (2) - 1);
-
- I1, I2 : INTEGER RANGE 0 .. F (3) :=
- F (3) - 1;
- CI1, CI2 : CONSTANT INTEGER RANGE 0 .. F (4)
- := F (4) - 1;
-
- TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
- FL1, FL2 : FLT RANGE 0.0 .. FLT (F (5)) :=
- FLT (F (5) - 1);
- CFL1, CFL2 : CONSTANT FLT
- RANGE 0.0 .. FLT (F (6)) :=
- FLT (F (6) - 1);
-
- TYPE FIX IS DELTA 1.0 RANGE -5.0 .. 5.0;
- FI1, FI2 : FIX RANGE 0.0 .. FIX (F (7)) :=
- FIX (F (7) - 1);
- CFI1, CFI2 : CONSTANT FIX
- RANGE 0.0 .. FIX (F (8)) :=
- FIX (F (8) - 1);
-
- BEGIN
- IF D1 /= TUES THEN
- FAILED ( "D1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF D2 /= THURS THEN
- FAILED ( "D2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CD1 /= TUES THEN
- FAILED ( "CD1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CD2 /= THURS THEN
- FAILED ( "CD2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF I1 /= 1 THEN
- FAILED ( "I1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF I2 /= 3 THEN
- FAILED ( "I2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CI1 /= 1 THEN
- FAILED ( "CI1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CI2 /= 3 THEN
- FAILED ( "CI2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF FL1 /= 1.0 THEN
- FAILED ( "FL1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF FL2 /= 3.0 THEN
- FAILED ( "FL2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CFL1 /= 1.0 THEN
- FAILED ( "CFL1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CFL2 /= 3.0 THEN
- FAILED ( "CFL2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF FI1 /= 1.0 THEN
- FAILED ( "FI1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF FI2 /= 3.0 THEN
- FAILED ( "FI2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CFI1 /= 1.0 THEN
- FAILED ( "CFI1 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- IF CFI2 /= 3.0 THEN
- FAILED ( "CFI2 NOT INITIALIZED TO CORRECT VALUE" );
- END IF;
-
- END;
-
- RESULT;
-END C32001A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32001b.ada b/gcc/testsuite/ada/acats/tests/c3/c32001b.ada
deleted file mode 100644
index c4d5acc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32001b.ada
+++ /dev/null
@@ -1,249 +0,0 @@
--- C32001B.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 IN MULTIPLE OBJECT DECLARATIONS FOR ARRAY TYPES, THE
--- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE
--- EVALUATED ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE
--- SUBTYPE INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE
--- EVALUATIONS YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT
--- DECLARATIONS.
-
--- HISTORY:
--- RJW 07/16/86 CREATED ORIGINAL TEST.
--- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED
--- COMMENTS FOR S4 AND CS4 TO READ THAT THE BOUNDS ARE
--- 1 .. 6 AND THE COMPONENT TYPE ARR IS 1 .. 5.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32001B IS
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
-
- BUMP : ARRAY (1 .. 4) OF INTEGER := (0, 0, 0, 0);
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- RETURN BUMP (I);
- END F;
-
-BEGIN
- TEST ("C32001B", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
- "FOR ARRAY TYPES, THE SUBTYPE INDICATION " &
- "AND THE INITIALIZATION EXPRESSIONS ARE " &
- "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
- "IS DECLARED AND THE SUBTYPE INDICATION IS " &
- "EVALUATED FIRST. ALSO, CHECK THAT THE " &
- "EVALUATIONS YIELD THE SAME RESULT AS A " &
- "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
-
- DECLARE
-
- S1, S2 : ARR (1 .. F (1)) := (OTHERS => F (1));
- CS1, CS2 : CONSTANT ARR (1 .. F (2)) := (OTHERS => F (2));
-
- PROCEDURE CHECK (A, B : ARR; STR1, STR2 : STRING) IS
- BEGIN
- IF A'LAST /= 1 THEN
- FAILED ( "INCORRECT UPPER BOUND FOR " & STR1 );
- END IF;
-
- IF A (1) /= 2 THEN
- FAILED ( "INCORRECT INITIAL VALUE FOR " & STR1 );
- END IF;
-
- IF B'LAST /= 3 THEN
- FAILED ( "INCORRECT UPPER BOUND FOR " & STR2 );
- END IF;
-
- BEGIN
- IF B (1 .. 3) = (4, 5, 6) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(4, 5, 6)" );
- ELSIF B (1 .. 3) = (5, 4, 6) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(5, 4, 6)" );
- ELSIF B (1 .. 3) = (4, 6, 5) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(4, 6, 5)" );
- ELSIF B (1 .. 3) = (6, 4, 5) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(6, 4, 5)" );
- ELSIF B (1 .. 3) = (6, 5, 4) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(6, 5, 4)" );
- ELSIF B (1 .. 3) = (5, 6, 4) THEN
- COMMENT ( STR2 & " WAS INITIALIZED TO " &
- "(5, 6, 4)" );
- ELSE
- FAILED ( STR2 & " HAS INCORRECT INITIAL " &
- "VALUE" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED - " &
- STR2 );
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - " &
- STR2 );
- END;
- END;
-
- BEGIN
- CHECK (S1, S2, "S1", "S2");
- CHECK (CS1, CS2, "CS1", "CS2");
- END;
-
- DECLARE
-
- S3, S4 : ARRAY (1 .. F (3)) OF ARR (1 .. F (3)) :=
- (OTHERS => (OTHERS => F (3)));
-
- CS3, CS4 : CONSTANT ARRAY (1.. F (4)) OF
- ARR (1 .. F (4)) :=
- (OTHERS => (OTHERS => F (4)));
- BEGIN
- IF S3'LAST = 1 THEN
- IF S3 (1)'LAST = 2 THEN
- COMMENT ( "S3 HAS BOUNDS 1 .. 1 AND " &
- "COMPONENT TYPE ARR (1 .. 2)" );
- IF S3 (1)(1 .. 2) = (3, 4) THEN
- COMMENT ( "S3 HAS INITIAL VALUES " &
- "3 AND 4 - 1" );
- ELSIF S3 (1)(1 .. 2) = (4, 3) THEN
- COMMENT ( "S3 HAS INITIAL VALUES " &
- "4 AND 3 - 1" );
- ELSE
- FAILED ( "S3 HAS WRONG INITIAL VALUES - 1" );
- END IF;
- ELSE
- FAILED ( "S3 HAS WRONG COMPONENT TYPE - 1" );
- END IF;
- ELSIF S3'LAST = 2 THEN
- IF S3 (1)'LAST = 1 THEN
- COMMENT ( "S3 HAS BOUNDS 1 .. 2 AND " &
- "COMPONENT TYPE ARR (1 .. 1)" );
- IF S3 (1) (1) = 3 AND S3 (2) (1) = 4 THEN
- COMMENT ( "S3 HAS INITIAL VALUES " &
- "3 AND 4 - 2" );
- ELSIF S3 (1) (1) = 4 AND S3 (2) (1) = 3 THEN
- COMMENT ( "S3 HAS INITIAL VALUES " &
- "4 AND 3 - 2" );
- ELSE
- FAILED ( "S3 HAS WRONG INITIAL VALUES - 2" );
- END IF;
- ELSE
- FAILED ( "S3 HAS WRONG COMPONENT TYPE - 2" );
- END IF;
- ELSE
- FAILED ( "S3 HAS INCORRECT BOUNDS" );
- END IF;
-
- IF S4'LAST = 5 THEN
- IF S4 (1)'LAST = 6 THEN
- COMMENT ( "S4 HAS BOUNDS 1 .. 5 AND " &
- "COMPONENT TYPE ARR (1 .. 6)" );
- ELSE
- FAILED ( "S4 HAS WRONG COMPONENT TYPE - 1" );
- END IF;
- ELSIF S4'LAST = 6 THEN
- IF S4 (1)'FIRST = 1 AND S4 (1)'LAST = 5 THEN
- COMMENT ( "S4 HAS BOUNDS 1 .. 6 AND " &
- "COMPONENT TYPE ARR (1 .. 5)" );
- ELSE
- FAILED ( "S4 HAS WRONG COMPONENT TYPE - 2" );
- END IF;
- ELSE
- FAILED ( "S4 HAS INCORRECT BOUNDS" );
- END IF;
-
- IF BUMP (3) /= 36 THEN
- FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " &
- "TIMES TO INITIALIZE S4" );
- END IF;
-
- IF CS3'FIRST = 1 AND CS3'LAST = 1 THEN
- IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 2 THEN
- COMMENT ( "CS3 HAS BOUNDS 1 .. 1 AND " &
- "COMPONENT TYPE ARR (1 .. 2)" );
- IF CS3 (1)(1 .. 2) = (3, 4) THEN
- COMMENT ( "CS3 HAS INITIAL VALUES " &
- "3 AND 4 - 1" );
- ELSIF CS3 (1)(1 .. 2) = (4, 3) THEN
- COMMENT ( "CS3 HAS INITIAL VALUES " &
- "4 AND 3 - 1" );
- ELSE
- FAILED ( "CS3 HAS WRONG INITIAL VALUES - 1" );
- END IF;
- ELSE
- FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 1" );
- END IF;
- ELSIF CS3'FIRST = 1 AND CS3'LAST = 2 THEN
- IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 1 THEN
- COMMENT ( "CS3 HAS BOUNDS 1 .. 2 AND " &
- "COMPONENT TYPE ARR (1 .. 1)" );
- IF CS3 (1) (1) = 3 AND CS3 (2) (1) = 4 THEN
- COMMENT ( "CS3 HAS INITIAL VALUES " &
- "3 AND 4 - 2" );
- ELSIF CS3 (1) (1) = 4 AND CS3 (2) (1) = 3 THEN
- COMMENT ( "CS3 HAS INITIAL VALUES " &
- "4 AND 3 - 2" );
- ELSE
- FAILED ( "CS3 HAS WRONG INITIAL VALUES - 2" );
- END IF;
- ELSE
- FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 2" );
- END IF;
- ELSE
- FAILED ( "CS3 HAS INCORRECT BOUNDS" );
- END IF;
-
- IF CS4'FIRST = 1 AND CS4'LAST = 5 THEN
- IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 6 THEN
- COMMENT ( "CS4 HAS BOUNDS 1 .. 5 AND " &
- "COMPONENT TYPE ARR (1 .. 6)" );
- ELSE
- FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 1" );
- END IF;
- ELSIF CS4'FIRST = 1 AND CS4'LAST = 6 THEN
- IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 5 THEN
- COMMENT ( "CS4 HAS BOUNDS 1 .. 6 AND " &
- "COMPONENT TYPE ARR (1 .. 5)" );
- ELSE
- FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 2" );
- END IF;
- ELSE
- FAILED ( "CS4 HAS INCORRECT BOUNDS" );
- END IF;
-
- IF BUMP (4) /= 36 THEN
- FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " &
- "TIMES TO INITIALIZE CS4" );
- END IF;
- END;
-
- RESULT;
-END C32001B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32001c.ada b/gcc/testsuite/ada/acats/tests/c3/c32001c.ada
deleted file mode 100644
index bc70568..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32001c.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C32001C.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 MULTIPLE OBJECT DECLARATIONS FOR RECORD TYPES, THE
--- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED
--- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE
--- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS
--- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS.
-
--- RJW 7/16/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32001C IS
-
- TYPE ARR IS ARRAY (1 .. 2) OF INTEGER;
- F1, G1 : ARR;
- BUMP : ARR := (0, 0);
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP(I) + 1;
- F1 (I) := BUMP (I);
- RETURN BUMP (I);
- END F;
-
- FUNCTION G (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP(I) + 1;
- G1 (I) := BUMP (I);
- RETURN BUMP (I);
- END G;
-
- FUNCTION H (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP(I) + 1;
- RETURN BUMP (I);
- END H;
-
-BEGIN
- TEST ("C32001C", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
- "FOR RECORD TYPES, THE SUBTYPE INDICATION " &
- "AND THE INITIALIZATION EXPRESSIONS ARE " &
- "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
- "IS DECLARED AND THE SUBTYPE INDICATION IS " &
- "EVALUATED FIRST. ALSO, CHECK THAT THE " &
- "EVALUATIONS YIELD THE SAME RESULT AS A " &
- "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
-
- DECLARE
-
- TYPE REC (D1, D2 : INTEGER) IS
- RECORD
- VALUE : INTEGER;
- END RECORD;
-
- R1, R2 : REC (F (1), G (1)) :=
- (F1 (1), G1 (1), VALUE => H (1));
- CR1, CR2 : CONSTANT REC (F (2), G (2)) :=
- (F1 (2), G1 (2), VALUE => H (2));
-
- PROCEDURE CHECK
- (R : REC; V1, V2, VAL : INTEGER; S : STRING) IS
- BEGIN
- IF R.D1 = V1 THEN
- IF R.D2 = V2 THEN
- COMMENT ( S & ".D1 INITIALIZED TO " &
- INTEGER'IMAGE (V1) & " AND " &
- S & ".D2 INITIALIZED TO " &
- INTEGER'IMAGE (V2));
- ELSE
- FAILED ( S &
- ".D2 INITIALIZED INCORRECTLY - 1" );
- END IF;
- ELSIF R.D1 = V2 THEN
- IF R.D2 =V1 THEN
- COMMENT ( S & ".D1 INITIALIZED TO " &
- INTEGER'IMAGE (V2) & " AND " &
- S & ".D2 INITIALIZED TO " &
- INTEGER'IMAGE (V1));
- ELSE
- FAILED ( S &
- ".D2 INITIALIZED INCORRECTLY - 2" );
- END IF;
- ELSE
- FAILED ( S & ".D1 INITIALIZED INCORRECTLY TO " &
- INTEGER'IMAGE (R.D1) );
- END IF;
-
- IF R.VALUE /= VAL THEN
- FAILED ( S & ".VALUE INITIALIZED INCORRECTLY" );
- END IF;
- END CHECK;
-
- BEGIN
- CHECK (R1, 1, 2, 3, "R1");
- CHECK (R2, 4, 5, 6, "R2");
-
- CHECK (CR1, 1, 2, 3, "CR1");
- CHECK (CR2, 4, 5, 6, "CR2");
- END;
-
- RESULT;
-END C32001C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32001d.ada b/gcc/testsuite/ada/acats/tests/c3/c32001d.ada
deleted file mode 100644
index e8a6a20..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32001d.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C32001D.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 MULTIPLE OBJECT DECLARATIONS FOR ACCESS TYPES, THE
--- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED
--- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE
--- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS
--- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS.
-
--- RJW 7/16/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32001D IS
-
- TYPE ARR IS ARRAY (1 .. 2) OF INTEGER;
- BUMP : ARR := (0, 0);
- F1 : ARR;
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- F1 (I) := BUMP (I);
- RETURN BUMP (I);
- END F;
-
- FUNCTION G (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- RETURN BUMP (I);
- END G;
-
-BEGIN
- TEST ("C32001D", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
- "FOR ACCESS TYPES, THE SUBTYPE INDICATION " &
- "AND THE INITIALIZATION EXPRESSIONS ARE " &
- "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
- "IS DECLARED AND THE SUBTYPE INDICATION IS " &
- "EVALUATED FIRST. ALSO, CHECK THAT THE " &
- "EVALUATIONS YIELD THE SAME RESULT AS A " &
- "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
-
- DECLARE
-
- TYPE CELL (SIZE : INTEGER) IS
- RECORD
- VALUE : INTEGER;
- END RECORD;
-
- TYPE LINK IS ACCESS CELL;
-
- L1, L2 : LINK (F (1)) := NEW CELL'(F1 (1), G (1));
-
- CL1, CL2 : CONSTANT LINK (F (2)) := NEW CELL'(F1 (2), G (2));
-
- PROCEDURE CHECK (L : LINK; V1, V2 : INTEGER; S : STRING) IS
- BEGIN
- IF L.SIZE /= V1 THEN
- FAILED ( S & ".SIZE INITIALIZED INCORRECTLY TO " &
- INTEGER'IMAGE (L.SIZE));
- END IF;
-
- IF L.VALUE /= V2 THEN
- FAILED ( S & ".VALUE INITIALIZED INCORRECTLY TO " &
- INTEGER'IMAGE (L.VALUE));
- END IF;
- END CHECK;
-
- BEGIN
- CHECK (L1, 1, 2, "L1");
- CHECK (L2, 3, 4, "L2");
-
- CHECK (CL1, 1, 2, "CL1");
- CHECK (CL2, 3, 4, "CL2");
- END;
-
- RESULT;
-END C32001D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32001e.ada b/gcc/testsuite/ada/acats/tests/c3/c32001e.ada
deleted file mode 100644
index 253acc5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32001e.ada
+++ /dev/null
@@ -1,253 +0,0 @@
--- C32001E.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 MULTIPLE OBJECT DECLARATIONS FOR PRIVATE TYPES, THE
--- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED
--- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE
--- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS
--- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS.
-
--- RJW 7/18/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32001E IS
-
- BUMP : ARRAY (1 .. 10) OF INTEGER := (OTHERS => 0);
- G1 : ARRAY (5 .. 6) OF INTEGER;
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- RETURN BUMP (I);
- END F;
-
- FUNCTION G (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BUMP (I) := BUMP (I) + 1;
- G1 (I) := BUMP (I);
- RETURN BUMP (I);
- END G;
-
-BEGIN
- TEST ("C32001E", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
- "FOR PRIVATE TYPES, THE SUBTYPE INDICATION " &
- "AND THE INITIALIZATION EXPRESSIONS ARE " &
- "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
- "IS DECLARED AND THE SUBTYPE INDICATION IS " &
- "EVALUATED FIRST. ALSO, CHECK THAT THE " &
- "EVALUATIONS YIELD THE SAME RESULT AS A " &
- "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE PBOOL IS PRIVATE;
- TYPE PINT IS PRIVATE;
- TYPE PREC (D : INTEGER) IS PRIVATE;
- TYPE PARR IS PRIVATE;
- TYPE PACC IS PRIVATE;
-
- FUNCTION INIT1 (I : INTEGER) RETURN PBOOL;
- FUNCTION INIT2 (I : INTEGER) RETURN PINT;
- FUNCTION INIT3 (I : INTEGER) RETURN PREC;
- FUNCTION INIT4 (I : INTEGER) RETURN PARR;
- FUNCTION INIT5 (I : INTEGER) RETURN PACC;
-
- PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING);
- PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING);
- PROCEDURE CHECK3 (R : PREC; I, J : INTEGER;
- S : STRING);
- PROCEDURE CHECK4 (A : PARR; I, J : INTEGER;
- S : STRING);
- PROCEDURE CHECK5 (V : PACC; S : STRING);
- PROCEDURE CHECK6 (V : PACC; S : STRING);
-
- PRIVATE
- TYPE PBOOL IS NEW BOOLEAN;
- TYPE PINT IS NEW INTEGER;
-
- TYPE PREC (D : INTEGER) IS
- RECORD
- VALUE : INTEGER;
- END RECORD;
-
- TYPE PARR IS ARRAY (1 .. 2) OF INTEGER;
-
- TYPE VECTOR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
- TYPE PACC IS ACCESS VECTOR;
- END PKG1;
-
- PACKAGE BODY PKG1 IS
- FUNCTION INIT1 (I : INTEGER) RETURN PBOOL IS
- BEGIN
- RETURN PBOOL'VAL (F (I) - 1);
- END INIT1;
-
- FUNCTION INIT2 (I : INTEGER) RETURN PINT IS
- BEGIN
- RETURN PINT'VAL (F (I));
- END INIT2;
-
- FUNCTION INIT3 (I : INTEGER) RETURN PREC IS
- PR : PREC (G1 (I)) := (G1 (I), F (I));
- BEGIN
- RETURN PR;
- END INIT3;
-
- FUNCTION INIT4 (I : INTEGER) RETURN PARR IS
- PA : PARR := (1 .. 2 => F (I));
- BEGIN
- RETURN PA;
- END INIT4;
-
- FUNCTION INIT5 (I : INTEGER) RETURN PACC IS
- ACCV : PACC := NEW VECTOR'(1 .. F (I) => F (I));
- BEGIN
- RETURN ACCV;
- END INIT5;
-
- PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING) IS
- BEGIN
- IF B /= PBOOL'VAL (I) THEN
- FAILED ( S & " HAS AN INCORRECT VALUE OF " &
- PBOOL'IMAGE (B));
- END IF;
- END CHECK1;
-
- PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING) IS
- BEGIN
- IF I /= PINT'VAL (J) THEN
- FAILED ( S & " HAS AN INCORRECT VALUE OF " &
- PINT'IMAGE (I));
- END IF;
- END CHECK2;
-
- PROCEDURE CHECK3 (R : PREC; I, J : INTEGER;
- S : STRING) IS
- BEGIN
- IF R.D /= I THEN
- FAILED ( S & ".D HAS AN INCORRECT VALUE OF "
- & INTEGER'IMAGE (R.D));
- END IF;
-
- IF R.VALUE /= J THEN
- FAILED ( S & ".VALUE HAS AN INCORRECT " &
- "VALUE OF " &
- INTEGER'IMAGE (R.VALUE));
- END IF;
- END CHECK3;
-
- PROCEDURE CHECK4 (A : PARR; I, J : INTEGER;
- S : STRING) IS
- BEGIN
- IF A /= (I, J) AND A /= (J, I) THEN
- FAILED ( S & " HAS AN INCORRECT VALUE" );
- END IF;
- END CHECK4;
-
- PROCEDURE CHECK5 (V : PACC; S : STRING) IS
- BEGIN
- IF V'LAST /= 1 THEN
- FAILED ( S & " HAS AN INCORRECT UPPER BOUND "
- & "OF " & INTEGER'IMAGE (V'LAST));
- END IF;
-
- IF V (1) /= 2 THEN
- FAILED ( S & " HAS AN INCORRECT COMPONENT " &
- "VALUE" );
- END IF;
- END CHECK5;
-
- PROCEDURE CHECK6 (V : PACC; S : STRING) IS
- BEGIN
- IF V'LAST /= 3 THEN
- FAILED ( S & " HAS AN INCORRECT UPPER BOUND "
- & "OF " & INTEGER'IMAGE (V'LAST));
- END IF;
-
- IF V.ALL = (4, 5, 6) OR V.ALL = (5, 4, 6) OR
- V.ALL = (4, 6, 5) OR V.ALL = (6, 4, 5) OR
- V.ALL = (5, 6, 4) OR V.ALL = (6, 5, 4) THEN
- NULL;
- ELSE
- FAILED ( S & " HAS AN INCORRECT COMPONENT " &
- "VALUE" );
- END IF;
- END CHECK6;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- B1, B2 : PBOOL := INIT1 (1);
- CB1, CB2 : CONSTANT PBOOL := INIT1 (2);
-
- I1, I2 : PINT := INIT2 (3);
- CI1, CI2 : CONSTANT PINT := INIT2 (4);
-
- R1, R2 : PREC (G (5)) := INIT3 (5);
- CR1, CR2 : CONSTANT PREC (G (6)) := INIT3 (6);
-
- A1, A2 : PARR := INIT4 (7);
- CA1, CA2 : CONSTANT PARR := INIT4 (8);
-
- V1, V2 : PACC := INIT5 (9);
- CV1, CV2 : CONSTANT PACC := INIT5 (10);
-
- BEGIN
- CHECK1 (B1, 0, "B1");
- CHECK1 (B2, 1, "B2");
- CHECK1 (CB1, 0, "CB1");
- CHECK1 (CB2, 1, "CB2");
-
- CHECK2 (I1, 1, "I1");
- CHECK2 (I2, 2, "I2");
- CHECK2 (CI1, 1, "CI1");
- CHECK2 (CI2, 2, "CI2");
-
- CHECK3 (R1, 1, 2, "R1");
- CHECK3 (R2, 3, 4, "R2");
- CHECK3 (CR1, 1, 2, "CR1");
- CHECK3 (CR2, 3, 4, "CR2");
-
- CHECK4 (A1, 1, 2, "A1");
- CHECK4 (A2, 3, 4, "A2");
- CHECK4 (CA1, 1, 2, "CA1");
- CHECK4 (CA2, 3, 4, "CA2");
-
- CHECK5 (V1, "V1");
- CHECK6 (V2, "V2");
- CHECK5 (CV1, "CV1");
- CHECK6 (CV2, "CV2");
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C32001E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32107a.ada b/gcc/testsuite/ada/acats/tests/c3/c32107a.ada
deleted file mode 100644
index fd4ed09..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32107a.ada
+++ /dev/null
@@ -1,363 +0,0 @@
--- C32107A.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 OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR
--- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION
--- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE
--- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT
--- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY
--- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE
--- EVALUATED.
-
--- R.WILLIAMS 9/24/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C32107A IS
-
- BUMP : INTEGER := 0;
-
- ORDER_CHECK : INTEGER;
-
- G1, H1, I1 : INTEGER;
-
- FIRST_CALL : BOOLEAN := TRUE;
-
- TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
-
- TYPE ARR1_NAME IS ACCESS ARR1;
-
- TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF
- INTEGER;
-
- TYPE REC (D : INTEGER) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- TYPE REC_NAME IS ACCESS REC;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN BUMP;
- END F;
-
- FUNCTION G RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- G1 := BUMP;
- RETURN BUMP;
- END G;
-
- FUNCTION H RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- H1 := BUMP;
- RETURN BUMP;
- END H;
-
- FUNCTION I RETURN INTEGER IS
- BEGIN
- IF FIRST_CALL THEN
- BUMP := BUMP + 1;
- I1 := BUMP;
- FIRST_CALL := FALSE;
- END IF;
- RETURN I1;
- END I;
-
-BEGIN
- TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " &
- "ELABORATED IN THE ORDER OF THEIR " &
- "OCCURRENCE, I.E., THAT EXPRESSIONS " &
- "ASSOCIATED WITH ONE DECLARATION (INCLUDING " &
- "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " &
- "EVALUATED BEFORE ANY EXPRESSION BELONGING " &
- "TO THE NEXT DECLARATION. ALSO, CHECK THAT " &
- "EXPRESSIONS IN THE SUBTYPE INDICATION OR " &
- "THE CONSTRAINED ARRAY DEFINITION ARE " &
- "EVALUATED BEFORE ANY INITIALIZATION " &
- "EXPRESSIONS ARE EVALUATED" );
-
- DECLARE -- (A).
- I1 : INTEGER := 10000 * F;
- A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) :=
- (1 .. H1 => (G1 * 100, I * 10));
- I2 : CONSTANT INTEGER := F * 1000;
- BEGIN
- ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP;
- IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " &
- "15242 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
- END IF;
- END; -- (A).
-
- BUMP := 0;
-
- DECLARE -- (B).
- A : ARR2 (1 .. F, 1 .. F * 10);
- R : REC (G * 100) := (G1 * 100, F * 1000);
- I : INTEGER RANGE 1 .. H;
- S : REC (F * 10);
- BEGIN
- ORDER_CHECK :=
- A'LAST (1) + A'LAST (2) + R.D + R.COMP;
- IF (H1 + S.D = 65) AND
- (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN
- COMMENT ( "ORDER_CHECK HAS VALUE 65 " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " &
- "65 4312 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (H1 + S.D) &
- INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
- END IF;
- END; -- (B).
-
- BUMP := 0;
-
- DECLARE -- (C).
- I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F;
- A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000;
- BEGIN
- ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000);
- IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " &
- "3412 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
- END IF;
- END; -- (C).
-
- BUMP := 0;
- FIRST_CALL := TRUE;
-
- DECLARE -- (D).
- A1 : ARRAY (1 .. G) OF REC (H * 10000) :=
- (1 .. G1 => (H1 * 10000, I * 100));
- R1 : CONSTANT REC := (F * 1000, F * 10);
-
- BEGIN
- ORDER_CHECK :=
- A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP;
- IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR
- ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 25341, " &
- "24351, 15342 OR 14352 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
- END IF;
- END; -- (D).
-
- BUMP := 0;
-
- DECLARE -- (E).
- A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10);
- R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000);
-
- BEGIN
- ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP;
- IF ORDER_CHECK /= 4321 THEN
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4321 " &
- "-- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (E)" );
- END IF;
- END; -- (E).
-
- BUMP := 0;
- FIRST_CALL := TRUE;
-
- DECLARE -- (F).
- A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 :=
- (1 .. G1 => I * 10);
- A2 : ARR1 (1 .. F * 1000);
- BEGIN
- ORDER_CHECK :=
- A1'LAST + (H1 * 100) + A1 (1) + A2'LAST;
- IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " &
- "4132 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
- END IF;
- END; -- (F).
-
- BUMP := 0;
-
- DECLARE -- (G).
- A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1);
- R1 : CONSTANT REC_NAME (H * 10) :=
- NEW REC'(H1 * 10, F * 100);
- BEGIN
- ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP;
- IF ORDER_CHECK /= 321 THEN
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 321 OR " &
- "-- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (G)" );
- END IF;
- END; -- (G).
-
- BUMP := 0;
-
- DECLARE -- (H).
- TYPE REC (D : INTEGER := F) IS
- RECORD
- COMP : INTEGER := F * 10;
- END RECORD;
-
- R1 : REC;
- R2 : REC (G * 100) := (G1 * 100, F * 1000);
- BEGIN
- ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP;
- IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
- ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
- "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
- END IF;
- END; -- (H).
-
- BUMP := 0;
-
- DECLARE -- (I).
- TYPE REC2 (D1, D2 : INTEGER) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- R1 : REC2 (G * 1000, H * 10000) :=
- (G1 * 1000, H1 * 10000, F * 100);
- R2 : REC2 (F, F * 10);
- BEGIN
- ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2;
- IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR
- ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 21354, " &
- "21345, 12354, OR 12345 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
- END IF;
-
- END; -- (I).
-
- BUMP := 0;
-
- DECLARE -- (J).
- PACKAGE P IS
- TYPE PRIV (D : INTEGER) IS PRIVATE;
-
- P1 : CONSTANT PRIV;
- P2 : CONSTANT PRIV;
-
- FUNCTION GET_A (P : PRIV) RETURN INTEGER;
- PRIVATE
- TYPE PRIV (D : INTEGER) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
- P1 : CONSTANT PRIV := (F , F * 10);
- P2 : CONSTANT PRIV := (F * 100, F * 1000);
- END P;
-
- PACKAGE BODY P IS
- FUNCTION GET_A (P : PRIV) RETURN INTEGER IS
- BEGIN
- RETURN P.COMP;
- END GET_A;
- END P;
-
- USE P;
- BEGIN
- ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2);
- IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
- ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
- "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
- END IF;
- END; -- (J).
-
- BUMP := 0;
-
- DECLARE -- (K).
- PACKAGE P IS
- TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE;
-
- PRIVATE
- TYPE PRIV (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END P;
-
- USE P;
-
- P1 : PRIV (F, F * 10);
- P2 : PRIV (F * 100, F * 1000);
-
- BEGIN
- ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2;
- IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
- ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
- "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " &
- "3421, OR 3412 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
- END IF;
-
- END; -- (K).
-
- RESULT;
-END C32107A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32107c.ada b/gcc/testsuite/ada/acats/tests/c3/c32107c.ada
deleted file mode 100644
index 3129535..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32107c.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C32107C.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.
---*
--- FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE ACTUAL PARAMETER IS A
--- TYPE WITH DEFAULT VALUES, CHECK THAT OBJECT DECLARATIONS ARE
--- ELABORATED IN THE ORDER OF THEIR OCCURRENCE, I.E., THAT EXPRESSIONS
--- ASSOCIATED WITH ONE DECLARATION (INCLUDING DEFAULT EXPRESSIONS) ARE
--- EVALUATED BEFORE ANY EXPRESSION BELONGING TO THE NEXT DECLARATION.
-
--- R.WILLIAMS 9/24/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C32107C IS
-
- BUMP : INTEGER := 0;
-
- G1, H1 : INTEGER;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN BUMP;
- END F;
-
- FUNCTION G RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- G1 := BUMP;
- RETURN BUMP;
- END G;
-
- FUNCTION H RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- H1 := BUMP;
- RETURN BUMP;
- END H;
-
-BEGIN
- TEST ( "C32107C", "FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE " &
- "ACTUAL PARAMETER IS A TYPE WITH DEFAULT " &
- "VALUES, CHECK THAT OBJECT DECLARATIONS ARE " &
- "ELABORATED IN THE ORDER OF THEIR " &
- "OCCURRENCE, I.E., THAT EXPRESSIONS " &
- "ASSOCIATED WITH ONE DECLARATION (INCLUDING " &
- "DEFAULT EXPRESSIONS) ARE EVALUATED BEFORE " &
- "ANY EXPRESSION BELONGING TO THE NEXT " &
- "DECLARATION" );
-
- DECLARE -- (A).
- TYPE REC (D : INTEGER := F) IS
- RECORD
- A : INTEGER := F;
- END RECORD;
-
- FUNCTION GET_A (R : REC) RETURN INTEGER IS
- BEGIN
- RETURN R.A;
- END GET_A;
-
- GENERIC
- TYPE T IS (<>);
- TYPE PRIV (D : T) IS PRIVATE;
- WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>;
- PROCEDURE P;
-
- PROCEDURE P IS
- P1 : PRIV (T'VAL (F));
- P2 : PRIV (T'VAL (F * 100));
- ORDER_CHECK : INTEGER;
-
- BEGIN
- ORDER_CHECK :=
- T'POS (P1.D) + T'POS (P2.D) +
- (GET_A (P1) * 10) + (GET_A (P2) * 1000);
- IF ORDER_CHECK /= 4321 THEN
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER " &
- "ORDER VALUE OF ORDER_CHECK SHOULD BE " &
- "4321 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
- END IF;
- END P;
-
- PROCEDURE PROC IS NEW P (INTEGER, REC);
-
- BEGIN
- PROC;
- END; -- (A).
-
- BUMP := 0;
-
- DECLARE -- (B).
- TYPE REC (D1 : INTEGER := F; D2 : INTEGER := F) IS
- RECORD
- A : INTEGER := F;
- END RECORD;
-
- FUNCTION GET_A (R : REC) RETURN INTEGER IS
- BEGIN
- RETURN R.A;
- END GET_A;
-
- GENERIC
- TYPE T IS (<>);
- TYPE PRIV (D1 : T; D2 : T) IS PRIVATE;
- WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>;
- PROCEDURE P;
-
- PROCEDURE P IS
- P1 : PRIV (T'VAL (F * 1000), T'VAL (F * 10000));
- P2 : PRIV (T'VAL (F), T'VAL (F * 10));
- ORDER_CHECK : INTEGER;
-
- BEGIN
- ORDER_CHECK :=
- T'POS (P1.D1) + T'POS (P1.D2) +
- T'POS (P2.D1) + T'POS (P2.D2) +
- (GET_A (P1) * 100);
- IF (GET_A (P2) = 6) AND
- (ORDER_CHECK = 12345 OR ORDER_CHECK = 21345 OR
- ORDER_CHECK = 21354 OR ORDER_CHECK = 12354) THEN
- COMMENT ( "ORDER_CHECK HAS VALUE " &
- INTEGER'IMAGE (ORDER_CHECK) &
- " - (B)" );
- ELSE
- FAILED ( "OBJECTS NOT ELABORATED IN PROPER " &
- "ORDER VALUE OF ORDER_CHECK SHOULD BE " &
- "6 12345, 6 21345, 6 21354, OR " &
- "6 12354 -- ACTUAL VALUE IS " &
- INTEGER'IMAGE (GET_A (P2)) &
- INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
- END IF;
-
- END P;
-
- PROCEDURE PROC IS NEW P (INTEGER, REC);
-
- BEGIN
- PROC;
- END; -- (B).
-
- RESULT;
-END C32107C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32108a.ada b/gcc/testsuite/ada/acats/tests/c3/c32108a.ada
deleted file mode 100644
index 4742358..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32108a.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- C32108A.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 DEFAULT EXPRESSIONS ARE NOT EVALUATED, IF INITIALIZATION
--- EXPRESSIONS ARE GIVEN FOR THE OBJECT DECLARATIONS.
-
--- TBN 3/20/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C32108A IS
-
- FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS
- BEGIN
- IF NUMBER /= 0 THEN
- FAILED ("DEFAULT EXPRESSIONS ARE EVALUATED -" &
- INTEGER'IMAGE (NUMBER));
- END IF;
- RETURN (1);
- END DEFAULT_CHECK;
-
-BEGIN
- TEST ("C32108A", "CHECK THAT DEFAULT EXPRESSIONS ARE NOT " &
- "EVALUATED, IF INITIALIZATION EXPRESSIONS ARE " &
- "GIVEN FOR THE OBJECT DECLARATIONS");
-
- DECLARE -- (A)
-
- TYPE REC_TYP1 IS
- RECORD
- AGE : INTEGER := DEFAULT_CHECK (1);
- END RECORD;
-
- REC1 : REC_TYP1 := (AGE => DEFAULT_CHECK (0));
-
-
- TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK (2)) IS
- RECORD
- NULL;
- END RECORD;
-
- REC2 : REC_TYP2 (DEFAULT_CHECK (0));
-
-
- TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK (3)) IS
- RECORD
- A : INTEGER := DEFAULT_CHECK (4);
- END RECORD;
-
- REC3 : REC_TYP3 := (D => DEFAULT_CHECK (0),
- A => DEFAULT_CHECK (0));
-
- BEGIN -- (A)
- NULL;
- END; -- (A)
-
- RESULT;
-END C32108A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32108b.ada b/gcc/testsuite/ada/acats/tests/c3/c32108b.ada
deleted file mode 100644
index 1089578..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32108b.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C32108B.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 DEFAULT EXPRESSION IS EVALUATED FOR A COMPONENT, NO
--- DEFAULT EXPRESSIONS ARE EVALUATED FOR ANY SUBCOMPONENTS.
-
--- TBN 3/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C32108B IS
-
- FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS
- BEGIN
- IF NUMBER /= 0 THEN
- FAILED ("SUBCOMPONENT DEFAULT EXPRESSIONS ARE " &
- "EVALUATED -" & INTEGER'IMAGE (NUMBER));
- END IF;
- RETURN (1);
- END DEFAULT_CHECK;
-
-BEGIN
- TEST ("C32108B", "CHECK THAT IF A DEFAULT EXPRESSION IS " &
- "EVALUATED FOR A COMPONENT, NO DEFAULT " &
- "EXPRESSIONS ARE EVALUATED FOR ANY " &
- "SUBCOMPONENTS");
-
- DECLARE -- (A)
-
- TYPE REC_TYP1 IS
- RECORD
- AGE : INTEGER := DEFAULT_CHECK (1);
- END RECORD;
-
- TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK(2)) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK(3)) IS
- RECORD
- A : INTEGER := DEFAULT_CHECK(4);
- END RECORD;
-
- TYPE REC_TYP4 IS
- RECORD
- ONE : REC_TYP1 := (AGE => DEFAULT_CHECK (0));
- TWO : REC_TYP2 (DEFAULT_CHECK(0));
- THREE : REC_TYP3 := (D => DEFAULT_CHECK (0),
- A => DEFAULT_CHECK (0));
- END RECORD;
-
- REC4 : REC_TYP4;
-
- BEGIN -- (A)
- NULL;
- END; -- (A)
-
- RESULT;
-END C32108B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32111a.ada b/gcc/testsuite/ada/acats/tests/c3/c32111a.ada
deleted file mode 100644
index 3cbce09..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32111a.ada
+++ /dev/null
@@ -1,282 +0,0 @@
--- C32111A.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 WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION,
--- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL VALUE,
--- CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES OUTSIDE THE
--- RANGE OF THE SUBTYPE.
-
--- HISTORY:
--- RJW 07/20/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 IMPROVED DEFEAT OF COMPILER OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32111A IS
-
- TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI);
- SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED;
-
- SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9';
-
- SUBTYPE SHORT IS INTEGER RANGE -100 .. 100;
-
- TYPE INT IS RANGE -10 .. 10;
- SUBTYPE PINT IS INT RANGE 1 .. 10;
-
- TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
- SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0;
-
- TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0;
- SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0;
-
-BEGIN
- TEST ("C32111A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " &
- "HAVING AN ENUMERATION, INTEGER, FLOAT OR " &
- "FIXED TYPE IS DECLARED WITH AN INITIAL " &
- "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " &
- "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " &
- "SUBTYPE" );
-
- BEGIN
- DECLARE
- D : MIDWEEK := WEEKDAY'VAL (IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'D'" );
- IF D = TUES THEN
- COMMENT ("VARIABLE 'D' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'D'" );
- END;
-
- BEGIN
- DECLARE
- D : CONSTANT WEEKDAY RANGE WED .. WED :=
- WEEKDAY'VAL (IDENT_INT (3));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'D'" );
- IF D = TUES THEN
- COMMENT ("INITIALIZE VARIABLE 'D'");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'D'" );
- END;
-
- BEGIN
- DECLARE
- P : CONSTANT DIGIT := IDENT_CHAR ('/');
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'P'" );
- IF P = '0' THEN
- COMMENT ("VARIABLE 'P' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'P'" );
- END;
-
- BEGIN
- DECLARE
- Q : CHARACTER RANGE 'A' .. 'E' := IDENT_CHAR ('F');
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'Q'" );
- IF Q = 'A' THEN
- COMMENT ("VARIABLE 'Q' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'Q'" );
- END;
-
- BEGIN
- DECLARE
- I : SHORT := IDENT_INT (-101);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'I'" );
- IF I = 1 THEN
- COMMENT ("VARIABLE 'I' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'I'" );
- END;
-
- BEGIN
- DECLARE
- J : CONSTANT INTEGER RANGE 0 .. 100 := IDENT_INT (101);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'J'" );
- IF J = -1 THEN
- COMMENT ("VARIABLE 'J' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'J'" );
- END;
-
- BEGIN
- DECLARE
- K : INT RANGE 0 .. 1 := INT (IDENT_INT (2));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'K'" );
- IF K = 2 THEN
- COMMENT ("VARIABLE 'K' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'K'" );
- END;
-
- BEGIN
- DECLARE
- L : CONSTANT PINT := INT (IDENT_INT (0));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'L'" );
- IF L = 1 THEN
- COMMENT ("VARIABLE 'L' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'L'" );
- END;
-
- BEGIN
- DECLARE
- FL : SFLT := FLT (IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FL'" );
- IF FL = 3.14 THEN
- COMMENT ("VARIABLE 'FL' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FL'" );
- END;
-
- BEGIN
- DECLARE
- FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 :=
- FLT (IDENT_INT (-1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FL1'" );
- IF FL1 = 0.0 THEN
- COMMENT ("VARIABLE 'FL1' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FL1'" );
- END;
-
- BEGIN
- DECLARE
- FI : FIXED RANGE 0.0 .. 0.0 := IDENT_INT (1) * 0.5;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FI'" );
- IF FI = 0.5 THEN
- COMMENT ("VARIABLE 'FI' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FI'" );
- END;
-
- BEGIN
- DECLARE
- FI1 : CONSTANT SFIXED := IDENT_INT (-1) * 0.5;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FI1'" );
- IF FI1 = 0.5 THEN
- COMMENT ("VARIABLE 'FI1' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FI1'" );
- END;
-
- RESULT;
-END C32111A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32111b.ada b/gcc/testsuite/ada/acats/tests/c3/c32111b.ada
deleted file mode 100644
index 85ff55e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32111b.ada
+++ /dev/null
@@ -1,282 +0,0 @@
--- C32111B.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 WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION,
--- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL STATIC
--- VALUE, CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES
--- OUTSIDE THE RANGE OF THE SUBTYPE.
-
--- HISTORY:
--- JET 08/04/87 CREATED ORIGINAL TEST BASED ON C32111A BY RJW
--- BUT WITH STATIC VALUES INSTEAD OF DYNAMIC
--- IDENTITY FUNCTION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32111B IS
-
- TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI);
- SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED;
-
- SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9';
-
- SUBTYPE SHORT IS INTEGER RANGE -100 .. 100;
-
- TYPE INT IS RANGE -10 .. 10;
- SUBTYPE PINT IS INT RANGE 1 .. 10;
-
- TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
- SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0;
-
- TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0;
- SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0;
-
-BEGIN
- TEST ("C32111B", "CHECK THAT WHEN A VARIABLE OR CONSTANT " &
- "HAVING AN ENUMERATION, INTEGER, FLOAT OR " &
- "FIXED TYPE IS DECLARED WITH AN INITIAL STATIC " &
- "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " &
- "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " &
- "SUBTYPE" );
-
- BEGIN
- DECLARE
- D : MIDWEEK := WEEKDAY'VAL (1);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'D'" );
- IF D = TUES THEN
- COMMENT ("VARIABLE 'D' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'D'" );
- END;
-
- BEGIN
- DECLARE
- D : CONSTANT WEEKDAY RANGE WED .. WED :=
- WEEKDAY'VAL (3);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'D'" );
- IF D = TUES THEN
- COMMENT ("INITIALIZE VARIABLE 'D'");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'D'" );
- END;
-
- BEGIN
- DECLARE
- P : CONSTANT DIGIT := '/';
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'P'" );
- IF P = '0' THEN
- COMMENT ("VARIABLE 'P' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'P'" );
- END;
-
- BEGIN
- DECLARE
- Q : CHARACTER RANGE 'A' .. 'E' := 'F';
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'Q'" );
- IF Q = 'A' THEN
- COMMENT ("VARIABLE 'Q' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'Q'" );
- END;
-
- BEGIN
- DECLARE
- I : SHORT := -101;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'I'" );
- IF I = 1 THEN
- COMMENT ("VARIABLE 'I' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'I'" );
- END;
-
- BEGIN
- DECLARE
- J : CONSTANT INTEGER RANGE 0 .. 100 := 101;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'J'" );
- IF J = -1 THEN
- COMMENT ("VARIABLE 'J' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'J'" );
- END;
-
- BEGIN
- DECLARE
- K : INT RANGE 0 .. 1 := 2;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'K'" );
- IF K = 2 THEN
- COMMENT ("VARIABLE 'K' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'K'" );
- END;
-
- BEGIN
- DECLARE
- L : CONSTANT PINT := 0;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'L'" );
- IF L = 1 THEN
- COMMENT ("VARIABLE 'L' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'L'" );
- END;
-
- BEGIN
- DECLARE
- FL : SFLT := 1.0;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FL'" );
- IF FL = 3.14 THEN
- COMMENT ("VARIABLE 'FL' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FL'" );
- END;
-
- BEGIN
- DECLARE
- FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 := -1.0;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FL1'" );
- IF FL1 = 0.0 THEN
- COMMENT ("VARIABLE 'FL1' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FL1'" );
- END;
-
- BEGIN
- DECLARE
- FI : FIXED RANGE 0.0 .. 0.0 := 0.5;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FI'" );
- IF FI = 0.5 THEN
- COMMENT ("VARIABLE 'FI' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'FI'" );
- END;
-
- BEGIN
- DECLARE
- FI1 : CONSTANT SFIXED := -0.5;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FI1'" );
- IF FI1 = 0.5 THEN
- COMMENT ("VARIABLE 'FI1' INITIALIZED");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'FI1'" );
- END;
-
- RESULT;
-END C32111B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32112b.ada b/gcc/testsuite/ada/acats/tests/c3/c32112b.ada
deleted file mode 100644
index e2aeeb6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32112b.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- C32112B.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 THE DECLARATION OF A NULL
--- ARRAY OBJECT IF THE INITIAL VALUE IS NOT A NULL ARRAY.
-
--- RJW 7/20/86
--- GMT 7/01/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
--- CHANGED THE RANGE VALUES OF A FEW DIMENSIONS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32112B IS
-
- TYPE ARR1 IS ARRAY (NATURAL RANGE <>) OF INTEGER;
- SUBTYPE NARR1 IS ARR1 (IDENT_INT (2) .. IDENT_INT (1));
-
-
- TYPE ARR2 IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
- OF INTEGER;
- SUBTYPE NARR2 IS ARR2 (IDENT_INT (1) .. IDENT_INT (2),
- IDENT_INT (1) .. IDENT_INT (0));
-
-BEGIN
- TEST ("C32112B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "THE DECLARATION OF A NULL ARRAY OBJECT IF " &
- "THE INITIAL VALUE IS NOT A NULL ARRAY");
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT(1) .. IDENT_INT(2));
- N1A : NARR1 := (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1A'");
- A(1) := IDENT_INT(N1A(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1A'");
- END;
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT (1) .. IDENT_INT (2));
- N1B : CONSTANT NARR1 := (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1B'");
- A(1) := IDENT_INT(N1B(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1B'");
- END;
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT (1) .. IDENT_INT (1));
- N1C : CONSTANT NARR1 := (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1C'");
- A(1) := IDENT_INT(N1C(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1C'");
- END;
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT (1) .. IDENT_INT (1));
- N1D : NARR1 := (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1D'");
- A(1) := IDENT_INT(N1D(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1D'");
- END;
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT (0) .. IDENT_INT (1));
- N1E : ARR1 (IDENT_INT (1) .. IDENT_INT (0)) :=
- (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1E'");
- A(1) := IDENT_INT(N1E(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N1E'");
- END;
-
- BEGIN
- DECLARE
- A : ARR1 (IDENT_INT (0) .. IDENT_INT (1));
- N1F : CONSTANT ARR1 (IDENT_INT (1) .. IDENT_INT (0)) :=
- (A'RANGE => 0);
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1F'");
- A(1) := IDENT_INT(N1F(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N1F'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (2),
- IDENT_INT (0) .. IDENT_INT (1));
- N2A : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2'");
- A(1,1) := IDENT_INT(N2A(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2A'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (2),
- IDENT_INT (0) .. IDENT_INT (1));
- N2B : NARR2 := (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2B'");
- A(1,1) := IDENT_INT(N2B(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2B'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (3),
- IDENT_INT (1) .. IDENT_INT (1));
- N2C : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2C'");
- A(1,1) := IDENT_INT(N2C(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2C'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (3),
- IDENT_INT (1) .. IDENT_INT (1));
- N2D : NARR2 := (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2D'");
- A(1,1) := IDENT_INT(N2D(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2D'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (1));
- N2E : CONSTANT ARR2 (IDENT_INT (2) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (1)) :=
- (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2E'");
- A(1,1) := IDENT_INT(N2E(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'N2E'");
- END;
-
- BEGIN
- DECLARE
- A : ARR2 (IDENT_INT (1) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (1));
- N2F : ARR2 (IDENT_INT (2) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (1)) :=
- (A'RANGE => (A'RANGE (2) =>0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2F'");
- A(1,1) := IDENT_INT(N2F(1,1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'N2F'");
- END;
-
- RESULT;
-END C32112B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32113a.ada b/gcc/testsuite/ada/acats/tests/c3/c32113a.ada
deleted file mode 100644
index 60f8d66..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32113a.ada
+++ /dev/null
@@ -1,534 +0,0 @@
--- C32113A.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 WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED TYPE
--- WITH DISCRIMINANTS IS DECLARED WITH AN INITIAL VALUE,
--- CONSTRAINT_ERROR IS RAISED IF THE CORRESPONDING DISCRIMINANTS OF
--- THE INITIAL VALUE AND THE SUBTYPE DO NOT HAVE THE SAME VALUE.
-
--- HISTORY:
--- RJW 07/20/86
--- DWC 06/22/87 ADDED SUBTYPE PRIVAS. ADDED CODE TO PREVENT DEAD
--- VARIABLE OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32113A IS
-
- PACKAGE PKG IS
- TYPE PRIVA (D : INTEGER := 0) IS PRIVATE;
- SUBTYPE PRIVAS IS PRIVA (IDENT_INT (1));
- PRA1 : CONSTANT PRIVAS;
-
- TYPE PRIVB (D1, D2 : INTEGER) IS PRIVATE;
- PRB12 : CONSTANT PRIVB;
-
- PRIVATE
- TYPE PRIVA (D : INTEGER := 0) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE PRIVB (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- PRA1 : CONSTANT PRIVAS := (D => (IDENT_INT (1)));
- PRB12 : CONSTANT PRIVB := (IDENT_INT (1), IDENT_INT (2));
- END PKG;
-
- USE PKG;
-
- TYPE RECA (D : INTEGER := 0) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE RECB (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- RA1 : CONSTANT RECA (IDENT_INT (1)) := (D => (IDENT_INT (1)));
-
- RB12 : CONSTANT RECB := (IDENT_INT (1), IDENT_INT (2));
-
-BEGIN
- TEST ("C32113A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " &
- "HAVING A CONSTRAINED TYPE IS DECLARED WITH " &
- "AN INITIAL VALUE, CONSTRAINT_ERROR IS " &
- "RAISED IF THE CORRESPONDING DISCRIMINANTS " &
- "OF THE INITIAL VALUE AND THE SUBTYPE DO " &
- "NOT HAVE THE SAME VALUE" );
-
- BEGIN
- DECLARE
- PR1 : CONSTANT PRIVA (IDENT_INT (0)) := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR1'" );
- IF PR1 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR1'" );
- END;
-
- BEGIN
- DECLARE
- PR2 : CONSTANT PRIVA (IDENT_INT (2)) := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR2'" );
- IF PR2 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR2'" );
- END;
-
- BEGIN
- DECLARE
- PR3 : PRIVA (IDENT_INT (0)) := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR3'" );
- IF PR3 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR3'" );
- END;
-
- BEGIN
- DECLARE
- PR4 : PRIVA (IDENT_INT (2)) := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR4'" );
- IF PR4 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR4'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SPRIVA IS PRIVA (IDENT_INT (-1));
- PR5 : CONSTANT SPRIVA := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR5'" );
- IF PR5 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR5'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SPRIVA IS PRIVA (IDENT_INT (3));
- PR6 : SPRIVA := PRA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR6'" );
- IF PR6 = PRA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR6'" );
- END;
-
- BEGIN
- DECLARE
- PR7 : CONSTANT PRIVB (IDENT_INT (1), IDENT_INT (1)) :=
- PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR7'" );
- IF PR7 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR7'" );
- END;
-
- BEGIN
- DECLARE
- PR8 : CONSTANT PRIVB (IDENT_INT (2), IDENT_INT (2)) :=
- PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR8'" );
- IF PR8 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR8'" );
- END;
-
- BEGIN
- DECLARE
- PR9 : PRIVB (IDENT_INT (1), IDENT_INT (1)) := PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR9'" );
- IF PR9 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR9'" );
- END;
-
- BEGIN
- DECLARE
- PR10 : PRIVB (IDENT_INT (2), IDENT_INT (2)) := PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR10'" );
- IF PR10 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR10'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SPRIVB IS
- PRIVB (IDENT_INT (-1), IDENT_INT (-2));
- PR11 : CONSTANT SPRIVB := PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR11'" );
- IF PR11 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'PR11'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SPRIVB IS PRIVB (IDENT_INT (2), IDENT_INT (1));
- PR12 : SPRIVB := PRB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR12'" );
- IF PR12 = PRB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'PR12'" );
- END;
-
- BEGIN
- DECLARE
- R1 : CONSTANT RECA (IDENT_INT (0)) := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R1'" );
- IF R1 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R1'" );
- END;
-
- BEGIN
- DECLARE
- R2 : CONSTANT RECA (IDENT_INT (2)) := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R2'" );
- IF R2 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R2'" );
- END;
-
- BEGIN
- DECLARE
- R3 : RECA (IDENT_INT (0)) := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R3'" );
- IF R3 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R3'" );
- END;
-
- BEGIN
- DECLARE
- R4 : RECA (IDENT_INT (2)) := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R4'" );
- IF R4 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R4'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SRECA IS RECA (IDENT_INT (-1));
- R5 : CONSTANT SRECA := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R5'" );
- IF R5 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R5'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SRECA IS RECA (IDENT_INT (3));
- R6 : SRECA := RA1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R6'" );
- IF R6 = RA1 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R6'" );
- END;
-
- BEGIN
- DECLARE
- R7 : CONSTANT RECB (IDENT_INT (1), IDENT_INT (1)) :=
- RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R7'" );
- IF R7 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R7'" );
- END;
-
- BEGIN
- DECLARE
- R8 : CONSTANT RECB (IDENT_INT (2), IDENT_INT (2)) :=
- RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R8'" );
- IF R8 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R8'" );
- END;
-
- BEGIN
- DECLARE
- R9 : RECB (IDENT_INT (1), IDENT_INT (1)) := RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R9'" );
- IF R9 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R9'" );
- END;
-
- BEGIN
- DECLARE
- R10 : RECB (IDENT_INT (2), IDENT_INT (2)) := RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R10'" );
- IF R10 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R10'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SRECB IS
- RECB (IDENT_INT (-1), IDENT_INT (-2));
- R11 : CONSTANT SRECB := RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R11'" );
- IF R11 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'R11'" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SRECB IS RECB (IDENT_INT (2), IDENT_INT (1));
- R12 : SRECB := RB12;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R12'" );
- IF R12 = RB12 THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'R12'" );
- END;
-
- RESULT;
-END C32113A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32115a.ada b/gcc/testsuite/ada/acats/tests/c3/c32115a.ada
deleted file mode 100644
index 826bd24..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32115a.ada
+++ /dev/null
@@ -1,338 +0,0 @@
--- C32115A.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 WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED
--- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE,
--- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT
--- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING
--- VALUE SPECIFIED FOR THE ACCESS SUBTYPE.
-
--- HISTORY:
--- RJW 07/20/86 CREATED ORIGINAL TEST.
--- JET 08/05/87 ADDED DEFEAT OF DEAD VARIABLE OPTIMIZATION.
--- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32115A IS
-
- PACKAGE PKG IS
- TYPE PRIV (D : INTEGER) IS PRIVATE;
-
- PRIVATE
- TYPE PRIV (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG;
-
- USE PKG;
-
- TYPE ACCP IS ACCESS PRIV (IDENT_INT (1));
-
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCR IS ACCESS REC (IDENT_INT (2));
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
-
- TYPE ACCA IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (2));
-
- TYPE ACCN IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (0));
-
-BEGIN
- TEST ("C32115A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " &
- "HAVING A CONSTRAINED ACCESS TYPE IS " &
- "DECLARED WITH AN INITIAL NON-NULL ACCESS " &
- "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " &
- "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " &
- "DESIGNATED OBJECT DOES NOT EQUAL THE " &
- "CORRESPONDING VALUE SPECIFIED FOR THE " &
- "ACCESS SUBTYPE" );
-
- BEGIN
- DECLARE
- AC1 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (2)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC1'" );
- IF AC1 /= NULL THEN
- COMMENT ("DEFEAT 'AC1' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC1'" );
- END;
-
- BEGIN
- DECLARE
- AC2 : ACCP := NEW PRIV (D => (IDENT_INT (2)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC2'" );
- IF AC2 /= NULL THEN
- COMMENT ("DEFEAT 'AC2' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC2'" );
- END;
-
- BEGIN
- DECLARE
- AC3 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (0)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC3'" );
- IF AC3 /= NULL THEN
- COMMENT ("DEFEAT 'AC3' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC3'" );
- END;
-
- BEGIN
- DECLARE
- AC4 : ACCP := NEW PRIV (D => (IDENT_INT (0)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC4'" );
- IF AC4 /= NULL THEN
- COMMENT ("DEFEAT 'AC4' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC4'" );
- END;
-
- BEGIN
- DECLARE
- AC5 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (1)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC5'" );
- IF AC5 /= NULL THEN
- COMMENT ("DEFEAT 'AC5' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC5'" );
- END;
-
- BEGIN
- DECLARE
- AC6 : ACCR := NEW REC' (D => (IDENT_INT (1)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC6'" );
- IF AC6 /= NULL THEN
- COMMENT ("DEFEAT 'AC6' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC6'" );
- END;
-
- BEGIN
- DECLARE
- AC7 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (3)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC7'" );
- IF AC7 /= NULL THEN
- COMMENT ("DEFEAT 'AC7' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC7'" );
- END;
-
- BEGIN
- DECLARE
- AC8 : ACCR := NEW REC' (D => (IDENT_INT (3)));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC8'" );
- IF AC8 /= NULL THEN
- COMMENT ("DEFEAT 'AC8' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC8'" );
- END;
-
- BEGIN
- DECLARE
- AC9 : CONSTANT ACCA :=
- NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC9'" );
- IF AC9 /= NULL THEN
- COMMENT ("DEFEAT 'AC9' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC9'" );
- END;
-
- BEGIN
- DECLARE
- AC10 : ACCA :=
- NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC10'" );
- IF AC10 /= NULL THEN
- COMMENT ("DEFEAT 'AC10' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC10'" );
- END;
-
- BEGIN
- DECLARE
- AC11 : CONSTANT ACCA :=
- NEW ARR' (IDENT_INT (0) .. IDENT_INT (2) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC11'" );
- IF AC11 /= NULL THEN
- COMMENT ("DEFEAT 'AC11' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC11'" );
- END;
-
- BEGIN
- DECLARE
- AC12 : ACCA :=
- NEW ARR'(IDENT_INT (0) .. IDENT_INT (2) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC12'" );
- IF AC12 /= NULL THEN
- COMMENT ("DEFEAT 'AC12' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC12'" );
- END;
-
-
- BEGIN
- DECLARE
- AC15 : CONSTANT ACCN :=
- NEW ARR' (IDENT_INT (0) .. IDENT_INT (0) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC15'" );
- IF AC15 /= NULL THEN
- COMMENT ("DEFEAT 'AC15' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC15'" );
- END;
-
- BEGIN
- DECLARE
- AC16 : ACCN :=
- NEW ARR'(IDENT_INT (0) .. IDENT_INT (0) => 0);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC16'" );
- IF AC16 /= NULL THEN
- COMMENT ("DEFEAT 'AC16' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC16'" );
- END;
-
- RESULT;
-END C32115A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c32115b.ada b/gcc/testsuite/ada/acats/tests/c3/c32115b.ada
deleted file mode 100644
index d1819c5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c32115b.ada
+++ /dev/null
@@ -1,376 +0,0 @@
--- C32115B.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 WHEN A VARIABLE OR CONSTANT HAVING AN UNCONSTRAINED
--- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE,
--- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT
--- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING
--- VALUE SPECIFIED FOR THE ACCESS SUBTYPE OF THE OBJECT.
-
--- HISTORY:
--- JET 08/05/87 CREATED ORIGINAL TEST BASED ON C32115A BY RJW
--- BUT WITH UNCONSTRAINED ACCESS TYPES AND
--- CONSTRAINED VARIABLE/CONSTANT DECLARATIONS.
--- KAS 12/4/95 FIXED TYPO IN CALL TO REPORT.TEST
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C32115B IS
-
- PACKAGE PKG IS
- TYPE PRIV (D : INTEGER) IS PRIVATE;
-
- PRIVATE
- TYPE PRIV (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG;
-
- USE PKG;
-
- TYPE ACCP IS ACCESS PRIV;
-
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCR IS ACCESS REC;
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
-
- TYPE ACCA IS ACCESS ARR;
-
- TYPE ACCN IS ACCESS ARR;
-
-BEGIN
- TEST ("C32115B", "CHECK THAT WHEN CONSTRAINED VARIABLE OR " &
- "CONSTANT HAVING AN UNCONSTRAINED ACCESS TYPE " &
- "IS DECLARED WITH AN INITIAL NON-NULL ACCESS " &
- "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " &
- "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " &
- "DESIGNATED OBJECT DOES NOT EQUAL THE " &
- "CORRESPONDING VALUE SPECIFIED FOR THE " &
- "ACCESS SUBTYPE OF THE OBJECT" );
-
- BEGIN
- DECLARE
- AC1 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (2));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC1'" );
- IF AC1 /= NULL THEN
- COMMENT ("DEFEAT 'AC1' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC1'" );
- END;
-
- BEGIN
- DECLARE
- AC2 : ACCP(1) := NEW PRIV (IDENT_INT (2));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC2'" );
- IF AC2 /= NULL THEN
- COMMENT ("DEFEAT 'AC2' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC2'" );
- END;
-
- BEGIN
- DECLARE
- AC3 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (0));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC3'" );
- IF AC3 /= NULL THEN
- COMMENT ("DEFEAT 'AC3' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC3'" );
- END;
-
- BEGIN
- DECLARE
- AC4 : ACCP(1) := NEW PRIV (IDENT_INT (0));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC4'" );
- IF AC4 /= NULL THEN
- COMMENT ("DEFEAT 'AC4' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC4'" );
- END;
-
- BEGIN
- DECLARE
- AC5 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC5'" );
- IF AC5 /= NULL THEN
- COMMENT ("DEFEAT 'AC5' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC5'" );
- END;
-
- BEGIN
- DECLARE
- AC6 : ACCR(2) := NEW REC (IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC6'" );
- IF AC6 /= NULL THEN
- COMMENT ("DEFEAT 'AC6' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC6'" );
- END;
-
- BEGIN
- DECLARE
- AC7 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (3));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC7'" );
- IF AC7 /= NULL THEN
- COMMENT ("DEFEAT 'AC7' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC7'" );
- END;
-
- BEGIN
- DECLARE
- AC8 : ACCR(2) := NEW REC (IDENT_INT (3));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC8'" );
- IF AC8 /= NULL THEN
- COMMENT ("DEFEAT 'AC8' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC8'" );
- END;
-
- BEGIN
- DECLARE
- AC9 : CONSTANT ACCA(1 .. 2) :=
- NEW ARR(IDENT_INT(1) .. IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC9'" );
- IF AC9 /= NULL THEN
- COMMENT ("DEFEAT 'AC9' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC9'" );
- END;
-
- BEGIN
- DECLARE
- AC10 : ACCA (1..2) :=
- NEW ARR(IDENT_INT (1) .. IDENT_INT (1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC10'" );
- IF AC10 /= NULL THEN
- COMMENT ("DEFEAT 'AC10' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC10'" );
- END;
-
- BEGIN
- DECLARE
- AC11 : CONSTANT ACCA(1..2) :=
- NEW ARR(IDENT_INT (0) .. IDENT_INT (2));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC11'" );
- IF AC11 /= NULL THEN
- COMMENT ("DEFEAT 'AC11' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC11'" );
- END;
-
- BEGIN
- DECLARE
- AC12 : ACCA(1..2) :=
- NEW ARR(IDENT_INT (0) .. IDENT_INT (2));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC12'" );
- IF AC12 /= NULL THEN
- COMMENT ("DEFEAT 'AC12' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC12'" );
- END;
-
- BEGIN
- DECLARE
- AC13 : CONSTANT ACCA (1..2) :=
- NEW ARR(IDENT_INT (2) .. IDENT_INT (3));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC13'" );
- IF AC13 /= NULL THEN
- COMMENT ("DEFEAT 'AC13' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC13'" );
- END;
-
- BEGIN
- DECLARE
- AC14 : ACCA(1..2) :=
- NEW ARR(IDENT_INT (2) .. IDENT_INT (3));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC14'" );
- IF AC14 /= NULL THEN
- COMMENT ("DEFEAT 'AC14' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC14'" );
- END;
-
- BEGIN
- DECLARE
- AC15 : CONSTANT ACCN(1..0) :=
- NEW ARR(IDENT_INT (0) .. IDENT_INT (0));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC15'" );
- IF AC15 /= NULL THEN
- COMMENT ("DEFEAT 'AC15' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF CONSTANT 'AC15'" );
- END;
-
- BEGIN
- DECLARE
- AC16 : ACCN(1..0) :=
- NEW ARR(IDENT_INT (0) .. IDENT_INT (0));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC16'" );
- IF AC16 /= NULL THEN
- COMMENT ("DEFEAT 'AC16' OPTIMIZATION");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " &
- "OF VARIABLE 'AC16'" );
- END;
-
- RESULT;
-END C32115B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330001.a b/gcc/testsuite/ada/acats/tests/c3/c330001.a
deleted file mode 100644
index 218896d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c330001.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- C330001.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 variable object of an indefinite type is properly
--- initialized/constrained by an initial value assignment that is
--- a) an aggregate, b) a function, or c) an object. Check that objects
--- of the above types do not need explicit constraints if they have
--- initial values.
---
--- TEST DESCRIPTION:
--- An indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants.
--- c) A subtype with unconstrained discriminants without defaults.
---
--- Declare several indefinite types in a parent package specification.
--- In the private part, complete one type with a discriminant without
--- default (indefinite) and the other with a default discriminant
--- (definite). Declare objects of both indefinite and definite subtypes
--- in children (private and public) with initialization expressions. The
--- test verifies all values of the objects. It also verifies that
--- Constraint_Error is raised if an attempt is made to change the
--- discriminants of the objects of the indefinite subtypes.
---
---
--- CHANGE HISTORY:
--- 15 Jan 95 SAIC Initial version for ACVC 2.1
--- 25 Jul 96 SAIC Modified test description. Deleted use C330001_0.
--- 20 Nov 98 RLB Added Elaborate pragmas to avoid problems
--- with an unconventional, but legal, elaboration
--- order.
---!
-
-package C330001_0 is
-
- subtype Sub_Type is Integer range 1 .. 20;
-
- type Tag_W_Disc (D : Sub_Type) is tagged record
- C1 : String (1 .. D);
- end record;
-
- -- Indefinite type declarations.
-
- type FullViewDefinite_Unknown_Disc (<>) is private;
-
- type Indefinite_No_Disc is array (Positive range <>) of Integer;
-
- type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged
- record
- C1 : Boolean := False;
- end record;
-
- type Indefinite_New_W_Disc (ND : Sub_Type) is new
- Indefinite_Tag_W_Disc (ND) with record
- C2 : Integer := 9;
- end record;
-
- type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with
- record
- S : Sub_Type := 18;
- end record;
-
- type Indefinite_W_Inherit_Disc_2 is
- new Tag_W_Disc with private;
-
- function Indef_Func_1 return FullViewDefinite_Unknown_Disc;
-
- function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;
-
-private
-
- type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is
- record
- S : String (1 .. D) := "Hi";
- end record;
-
- type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with
- record
- S : Sub_Type;
- end record;
-
-end C330001_0;
-
- --==================================================================--
-
-package body C330001_0 is
-
- function Indef_Func_1 return FullViewDefinite_Unknown_Disc is
- Var_1 : FullViewDefinite_Unknown_Disc; -- No need for explicit
- -- constraints, use initial
- begin -- values.
- return Var_1;
- end Indef_Func_1;
-
- ------------------------------------------------------------------
- function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is
- Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);
- begin
- return Var_2;
- end Indef_Func_2;
-
-end C330001_0;
-
- --==================================================================--
-
-with C330001_0;
-pragma Elaborate(C330001_0); -- Insure that the functions can be called.
-private
-package C330001_0.C330001_1 is
-
- PrivateChild_Obj : Tag_W_Disc := (D => 4, C1 => "ACVC");
-
- PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1
- := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);
-
- -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in
- -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization
- -- expression.
-
- PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);
-
- -- Since full view of FullViewDefinite_Unknown_Disc is definite in the
- -- parent package, no initialization expression needed for
- -- PrivateChild_Obj_03.
-
- PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;
-
- PrivateChild_Obj_04 : Indefinite_No_Disc := (12, 15);
-
-end C330001_0.C330001_1;
-
- --==================================================================--
-
-with C330001_0;
-pragma Elaborate(C330001_0); -- Insure that the functions can be called.
-package C330001_0.C330001_2 is
-
- PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;
-
- PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (4);
-
- PublicChild_Obj_03 : Indefinite_No_Disc := (38, 72, 21, 59);
-
- PublicChild_Obj_04 : Indefinite_Tag_W_Disc := (D => 7, C1 => True);
-
- PublicChild_Obj_05 : Indefinite_Tag_W_Disc := PublicChild_Obj_04;
-
- PublicChild_Obj_06 : Indefinite_New_W_Disc (6);
-
- procedure Assign_Private_Obj_3;
-
- function Raised_CE_PublicChild_Obj return Boolean;
-
- function Raised_CE_PrivateChild_Obj return Boolean;
-
- -- The following functions check the private types defined in the parent
- -- and the private child package from within the client program.
-
- function Verify_Public_Obj_1 return Boolean;
-
- function Verify_Public_Obj_2 return Boolean;
-
- function Verify_Private_Obj_1 return Boolean;
-
- function Verify_Private_Obj_2 return Boolean;
-
- function Verify_Private_Obj_3 return Boolean;
-
-end C330001_0.C330001_2;
-
- --==================================================================--
-
-with Report;
-with C330001_0.C330001_1;
-package body C330001_0.C330001_2 is
-
- procedure Assign_Private_Obj_3 is
- begin
- C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");
- end Assign_Private_Obj_3;
-
- ------------------------------------------------------------------
- function Raised_CE_PublicChild_Obj return Boolean is
- begin
- PublicChild_Obj_03 := (16, 13); -- C_E, can't change constraints
- -- of PublicChild_Obj_03.
-
- Report.Failed ("Constraint_Error not raised - Public child");
-
- -- Next line prevents dead assignment.
-
- Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image
- (PublicChild_Obj_03'First) );
- return False;
-
- exception
- when Constraint_Error =>
- return True; -- Exception is expected.
- when others =>
- return False;
- end Raised_CE_PublicChild_Obj;
-
- ------------------------------------------------------------------
- function Raised_CE_PrivateChild_Obj return Boolean is
- begin
- C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);
- -- C_E, can't change constraints
- -- of PrivateChild_Obj_04.
-
- Report.Failed ("Constraint_Error not raised - Private child");
-
- -- Next line prevents dead assignment.
-
- Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image
- (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );
- return False;
-
- exception
- when Constraint_Error =>
- return True; -- Exception is expected.
- when others =>
- return False;
- end Raised_CE_PrivateChild_Obj;
-
- ------------------------------------------------------------------
- function Verify_Public_Obj_1 return Boolean is
- begin
- return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");
-
- end Verify_Public_Obj_1;
-
- ------------------------------------------------------------------
- function Verify_Public_Obj_2 return Boolean is
- begin
- return (PublicChild_Obj_02.D = 5 and
- PublicChild_Obj_02.C1 = "Hello" and
- PublicChild_Obj_02.S = 4);
-
- end Verify_Public_Obj_2;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_1 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_01.D = 4 and
- C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and
- C330001_0.C330001_1.PrivateChild_Obj_01.S = 15);
-
- end Verify_Private_Obj_1;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_2 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_02.D = 5 and
- C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and
- C330001_0.C330001_1.PrivateChild_Obj_02.S = 19);
-
- end Verify_Private_Obj_2;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_3 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and
- C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");
-
- end Verify_Private_Obj_3;
-
-end C330001_0.C330001_2;
-
- --==================================================================--
-
-with C330001_0.C330001_2;
-with Report;
-
-use C330001_0.C330001_2;
-
-procedure C330001 is
-begin
- Report.Test ("C330001", "Check that a variable object of an indefinite " &
- "type is properly initialized/constrained by an initial " &
- "value assignment that is a) an aggregate, b) a function, " &
- "or c) an object. Check that objects of the above types " &
- "do not need explicit constraints if they have initial " &
- "values");
-
- -- Verify values of public child objects.
-
- if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then
- Report.Failed ("Wrong values for PublicChild_Obj_01 or " &
- "PublicChild_Obj_02");
- end if;
-
- if PublicChild_Obj_03'First /= 1 or
- PublicChild_Obj_03'Last /= 4 then
- Report.Failed ("Wrong values for PublicChild_Obj_03");
- end if;
-
- if PublicChild_Obj_05.D /= 7 or
- not PublicChild_Obj_05.C1 then
- Report.Failed ("Wrong values for PublicChild_Obj_05");
- end if;
-
- if PublicChild_Obj_06.ND /= 6 or
- PublicChild_Obj_06.C2 /= 9 or
- PublicChild_Obj_06.C1 then
- Report.Failed ("Wrong values for PublicChild_Obj_06");
- end if;
-
- -- Definite object can have its discriminant changed by assignment to
- -- the entire object.
-
- Assign_Private_Obj_3;
-
- -- Verify values of private child objects.
-
- if not Verify_Private_Obj_1 or not
- Verify_Private_Obj_2 or not
- Verify_Private_Obj_3 then
- Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &
- "PrivateChild_Obj_02 or PrivateChild_Obj_03");
- end if;
-
- -- Attempt to change the discriminants of the objects of the indefinite
- -- subtypes: Constraint_Error.
-
- if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then
- Report.Failed ("Constraint_Error not raised");
- end if;
-
- Report.Result;
-
-end C330001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330002.a b/gcc/testsuite/ada/acats/tests/c3/c330002.a
deleted file mode 100644
index 1403d55..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c330002.a
+++ /dev/null
@@ -1,326 +0,0 @@
--- C330002.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 subtype indication of a variable object defines an
--- indefinite subtype, then there is an initialization expression.
--- Check that the object remains so constrained throughout its lifetime.
--- Check for cases of tagged record, arrays and generic formal type.
---
--- TEST DESCRIPTION:
--- An indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants (this includes class-wide
--- types).
--- c) A subtype with unconstrained discriminants without defaults.
---
--- Declare tagged types with unconstrained discriminants without
--- defaults. Declare an unconstrained array. Declare a generic formal
--- type with an unknown discriminant and a formal object of this type.
--- In the generic package, declare an object of the formal type using
--- the formal object as its initial value. In the main program,
--- declare objects of tagged types. Instantiate the generic package.
--- The test checks that Constraint_Error is raised if an attempt is
--- made to change bounds as well as discriminants of the objects of the
--- indefinite subtypes.
---
---
--- CHANGE HISTORY:
--- 01 Nov 95 SAIC Initial prerelease version.
--- 27 Jul 96 SAIC Modified test description & Report.Test. Added
--- code to prevent dead variable optimization.
---
---!
-
-package C330002_0 is
-
- subtype Small_Num is Integer range 1 .. 20;
-
- -- Types with unconstrained discriminants without defaults.
-
- type Tag_Type (Disc : Small_Num) is tagged
- record
- S : String (1 .. Disc);
- end record;
-
- function Tag_Value return Tag_Type;
-
- procedure Assign_Tag (A : out Tag_Type);
-
- procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);
-
- ---------------------------------------------------------------------
- -- An unconstrained array type.
-
- type Array_Type is array (Positive range <>) of Integer;
-
- function Array_Value return Array_Type;
-
- procedure Assign_Array (A : out Array_Type);
-
- ---------------------------------------------------------------------
- generic
- -- Type with an unknown discriminant.
- type Formal_Type (<>) is private;
- FT_Obj : Formal_Type;
- package Gen is
- Gen_Obj : Formal_Type := FT_Obj;
- end Gen;
-
-end C330002_0;
-
- --==================================================================--
-
-with Report;
-package body C330002_0 is
-
- procedure Assign_Tag (A : out Tag_Type) is
- begin
- A := (3, "Bye");
- end Assign_Tag;
-
- ----------------------------------------------------------------------
- procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is
- Default : Tag_Type := (1, "!"); -- Unique value.
- begin
- if P = Default then -- Both If branches can't do the same thing.
- Report.Failed (Msg & ": Constraint_Error not raised");
- else -- Subtests should always select this path.
- Report.Failed ("Constraint_Error not raised " & Msg);
- end if;
- end Avoid_Optimization_and_Fail;
-
- ----------------------------------------------------------------------
- function Tag_Value return Tag_Type is
- TO : Tag_Type := (4 , "ACVC");
- begin
- return TO;
- end Tag_Value;
-
- ----------------------------------------------------------------------
- function Array_Value return Array_Type is
- IA : Array_Type := (20, 31);
- begin
- return IA;
- end Array_Value;
-
- ----------------------------------------------------------------------
- procedure Assign_Array (A : out Array_Type) is
- begin
- A := (84, 36);
- end Assign_Array;
-
-end C330002_0;
-
- --==================================================================--
-
-with Report;
-with C330002_0;
-use C330002_0;
-
-procedure C330002 is
-
-begin
- Report.Test ("C330002", "Check that if a subtype indication of a " &
- "variable object defines an indefinite subtype, then " &
- "there is an initialization expression. Check that " &
- "the object remains so constrained throughout its " &
- "lifetime. Check that Constraint_Error is raised " &
- "if an attempt is made to change bounds as well as " &
- "discriminants of the objects of the indefinite " &
- "subtypes. Check for cases of tagged record and generic " &
- "formal types");
-
- TagObj_Block:
- declare
- TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is
- -- aggregate.
- TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is
- -- an object.
- TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is
- -- function return value.
- Ren_Obj : Tag_Type renames TObj_ByAgg;
-
- begin
-
- begin
- if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then
- Report.Failed ("Wrong initial values for TObj_ByAgg");
- end if;
-
- TObj_ByAgg := (2, "Hi"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 1");
- end;
-
-
- begin
- Assign_Tag (Ren_Obj); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 2");
- end;
-
-
- begin
- if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then
- Report.Failed ("Wrong initial values for TObj_ByObj");
- end if;
-
- TObj_ByObj := (3, "Bye"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 3");
- end;
-
-
- begin
- if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then
- Report.Failed ("Wrong initial values for TObj_ByFunc");
- end if;
-
- TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 4");
- end;
-
- end TagObj_Block;
-
-
- ArrObj_Block:
- declare
- Arr_Const : constant Array_Type
- := (9, 7, 6, 8);
- Arr_ByAgg : Array_Type -- Initial assignment is
- := (10, 11, 12); -- aggregate.
- Arr_ByFunc : Array_Type -- Initial assignment is
- := Array_Value; -- function return value.
- Arr_ByObj : Array_Type -- Initial assignment is
- := Arr_ByAgg; -- object.
-
- Arr_Obj : array (Positive range <>) of Integer
- := (1, 2, 3, 4, 5);
- begin
-
- begin
- if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then
- Report.Failed ("Wrong bounds for Arr_Const");
- end if;
-
- if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then
- Report.Failed ("Wrong bounds for Arr_ByAgg");
- end if;
-
- if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then
- Report.Failed ("Wrong bounds for Arr_ByFunc");
- end if;
-
- if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then
- Report.Failed ("Wrong bounds for Arr_ByObj");
- end if;
-
- Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are
- -- 1..3.
-
- Report.Failed ("Constraint_Error not raised - Subtest 5");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 5");
- end;
-
-
- begin
- if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then
- Report.Failed ("Wrong bounds for Arr_Obj");
- end if;
-
- for I in 0 .. 5 loop
- Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are
- end loop; -- 1..5.
-
- Report.Failed ("Constraint_Error not raised - Subtest 6");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 6");
- end;
-
- end ArrObj_Block;
-
-
- GenericObj_Block:
- declare
- type Rec (Disc : Small_Num) is
- record
- S : Small_Num := Disc;
- end record;
-
- Rec_Obj : Rec := (2, 2);
- package IGen is new Gen (Rec, Rec_Obj);
-
- begin
- IGen.Gen_Obj := (3, 3); -- C_E, can't change the
- -- value of the discriminant.
-
- Report.Failed ("Constraint_Error not raised - Subtest 7");
-
- -- Next line prevents dead assignment.
- Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 7");
-
- end GenericObj_Block;
-
- Report.Result;
-
-end C330002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c332001.a b/gcc/testsuite/ada/acats/tests/c3/c332001.a
deleted file mode 100644
index 21d6573..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c332001.a
+++ /dev/null
@@ -1,226 +0,0 @@
--- C332001.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 static expression given for a number declaration may be
--- of any numeric type. Check that the type of a named number is
--- universal_integer or universal_real regardless of the type of the
--- static expression that provides its value.
---
--- TEST DESCRIPTION:
--- This test defines a large cross section of mixed type named numbers.
--- Well, obviously the named numbers don't have types (other than
--- universal_integer and universal_real) associated with them.
--- This test uses typed static values in the definition of several named
--- numbers, and then mixes the named numbers to ensure that their typed
--- origins do not interfere with the use of their values.
---
---
--- CHANGE HISTORY:
--- 10 OCT 95 SAIC Initial version
--- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1
--- 24 NOV 98 RLB Removed decimal types to insure that this
--- test is applicable to all implementations.
---
---!
-
------------------------------------------------------------------ C332001_0
-
-package C332001_0 is
-
- type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun );
-
- type Integer_Type is range 0..1023;
-
- type Modular_Type is mod 256;
-
- type Floating_Type is digits 4;
-
- type Fixed_Type is delta 0.125 range -10.0 .. 10.0;
-
- type Mod_Array is array(Modular_Type) of Floating_Type;
-
- type Int_Array is array(Integer_Type) of Fixed_Type;
-
- type Record_Type is record
- Pinkie : Integer_Type;
- Ring : Modular_Type;
- Middle : Floating_Type;
- Index : Fixed_Type;
- end record;
-
- Mod_Array_Object : Mod_Array;
- Int_Array_Object : Int_Array;
-
- Record_Object : Record_Type;
-
- -- numeric_literals
-
- Nothing_New_Integer : constant := 1;
- Nothing_New_Real : constant := 1.0;
-
- -- static constants
-
- Integ : constant Integer_Type := 2;
- Modul : constant Modular_Type := 2;
- Float : constant Floating_Type := 2.0; -- bad practice, good test
- Fixed : constant Fixed_Type := 2.0;
-
- Named_Integer : constant := Integ; -- 2
- Named_Modular : constant := Modul; -- 2
- Named_Float : constant := Float; -- 2.0
- Named_Fixed : constant := Fixed; -- 2.0
-
- -- function calls
- -- parenthetical expressions
-
- Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4
- Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4
- Fn_Float : constant := (Float ** 2); -- 4.0
- Fn_Fixed : constant := - Fixed; -- -2.0
- -- attributes
-
- ITF : constant := Integer_Type'First; -- 0
- MTL : constant := Modular_Type'Last; -- 255
- MTM : constant := Modular_Type'Modulus; -- 256
- ENP : constant := Enumeration_Type'Pos(Ay); -- 3
- MTP : constant := Modular_Type'Pred(Modul); -- 1
- FTS : constant := Fixed_Type'Size; -- # impdef
- ITS : constant := Integer_Type'Succ(Integ); -- 3
-
- -- array attributes 'First, 'Last, 'Length
-
- MAFirst : constant := Mod_Array_Object'First; -- 0
- IALast : constant := Int_Array_Object'Last; -- 1023
- MAL : constant := Mod_Array_Object'Length; -- 255
- IAL : constant := Int_Array_Object'Length; -- 1024
-
- -- type conversions
- --
- -- F\T Int Mod Flt Fix
- -- Int . X O X
- -- Mod O . X O
- -- Flt X O . X
- -- Fix O X O .
-
- Int2Mod : constant := Modular_Type (Integ); -- 2
- Int2Fix : constant := Fixed_Type (Integ); -- 2.0
- Mod2Flt : constant := Floating_Type (Modul); -- 2.0
- Flt2Int : constant := Integer_Type(Float); -- 2
- Flt2Fix : constant := Fixed_Type (Float); -- 2.0
- Fix2Mod : constant := Modular_Type (Fixed); -- 2
-
- procedure Check_Values;
-
- -- TRANSITION CHECKS
- --
- -- The following were illegal in Ada83; they are now legal in Ada95
- --
-
- Int_Base_First : constant := Integer'Base'First; -- # impdef
- Int_First : constant := Integer'First; -- # impdef
- Int_Last : constant := Integer'Last; -- # impdef
- Int_Val : constant := Integer'Val(17); -- 17
-
- -- END OF TRANSITION CHECKS
-
-end C332001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C332001_0 is
-
- procedure Assert( Truth : Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed("Assertion " & Message & " not true" );
- end if;
- end Assert;
-
- procedure Check_Values is
- begin
-
- Assert( Nothing_New_Integer * Named_Integer = Named_Modular,
- "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2
- Assert( Nothing_New_Real * Named_Float = Named_Fixed,
- "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0
-
- Assert( Fn_Integer = Int2Mod + Flt2Int,
- "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2
- Assert( Fn_Modular = Flt2Int * 2,
- "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2
- Assert( Fn_Float = Mod2Flt ** Fix2Mod,
- "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2
- Assert( Fn_Fixed = (- Mod2Flt),
- "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0)
-
- Assert( ITF = Modular_Type'First,
- "ITF = Modular_Type'First" ); -- 0 = 0
- Assert( MTL < Integer_Type'Last,
- "MTL < Integer_Type'Last" ); -- 255 < 1023
- Assert( MTM < Integer_Type'Last,
- "MTM < Integer_Type'Last" ); -- 256 < 1023
- Assert( ENP > MTP,
- "ENP > MTP" ); -- 3 > 1
- Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef...
- "(FTS < MTL) or (FTS >= MTL)" ); -- True
- Assert( FTS > ITS,
- "FTS > ITS" ); -- impdef > 3
-
- Assert( MAFirst = Int_Array_Object'First,
- "MAFirst = Int_Array_Object'First" ); -- 0 = 0
- Assert( IALast > MAFirst,
- "IALast > MAFirst" ); -- 1023 > 0
- Assert( MAL < IAL,
- "MAL < IAL" ); -- 255 < 1024
-
- Assert( Mod2Flt = Flt2Fix,
- "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0
-
- end Check_Values;
-
-end C332001_0;
-
-------------------------------------------------------------------- C332001
-
-with Report;
-with C332001_0;
-procedure C332001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C332001", "Check that the static expression given for a " &
- "number declaration may be of any numeric type. " &
- "Check that the type of the named number is " &
- "universal_integer of universal_real regardless " &
- "of the type of the static expression that " &
- "provides its value" );
-
- C332001_0.Check_Values;
-
- Report.Result;
-
-end C332001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340001.a b/gcc/testsuite/ada/acats/tests/c3/c340001.a
deleted file mode 100644
index dce98bd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340001.a
+++ /dev/null
@@ -1,470 +0,0 @@
--- C340001.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 user-defined equality operators are inherited by a
--- derived type except when the derived type is a nonlimited record
--- extension. In the latter case, ensure that the primitive
--- equality operation of the record extension compares any extended
--- components according to the predefined equality operators of the
--- component types. Also check that the parent portion of the extended
--- type is compared using the user-defined equality operation of the
--- parent type.
---
--- TEST DESCRIPTION:
--- Declares a nonlimited tagged record and a limited tagged record
--- type, each in a separate package. A user-defined "=" operation is
--- defined for each type. Each type is extended with one new record
--- component added.
---
--- Objects are declared for each parent and extended types and are
--- assigned values. For the limited type, modifier operations defined
--- in the package are used to assign values.
---
--- To verify the use of the user-defined "=", values are assigned so
--- that predefined equality will return the opposite result if called.
--- Similarly, values are assigned to the extended type objects so that
--- one comparison will verify that the inherited components from the
--- parent are compared using the user-defined equality operation.
---
--- A second comparison sets the values of the inherited components to
--- be the same so that equality based on the extended component may be
--- verified. For the nonlimited type, the test for equality should
--- fail, as the "=" defined for this type should include testing
--- equality of the extended component. For the limited type, "=" of the
--- parent should be inherited as-is, so the test for equality should
--- succeed even though the records differ in the extended component.
---
--- A third package declares a discriminated tagged record. Equality
--- is user-defined and ignores the discriminant value. A type
--- extension is declared which also contains a discriminant. Since
--- an inherited discriminant may not be referenced other than in a
--- "new" discriminant, the type extension is also discriminated. The
--- discriminant is used as the constraint for the parent type.
---
--- A variant part is declared in the type extension based on the new
--- discriminant. Comparisons are made to confirm that the user-defined
--- equality operator is used to compare values of the type extension.
--- Two record objects are given values so that user-defined equality
--- for the parent portion of the record succeeds, but the variant
--- parts in the type extended object differ. These objects are checked
--- to ensure that they are not equal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
-
-with Ada.Calendar;
-package C340001_0 is
-
- type DB_Record is tagged record
- Key : Natural range 1 .. 9999;
- Data : String (1..10);
- end record;
-
- function "=" (L, R : in DB_Record) return Boolean;
-
- type Dated_Record is new DB_Record with record
- Retrieval_Time : Ada.Calendar.Time;
- end record;
-
-end C340001_0;
-
-package body C340001_0 is
-
- function "=" (L, R : in DB_Record) return Boolean is
- -- Key is ignored in determining equality of records
- begin
- return L.Data = R.Data;
- end "=";
-
-end C340001_0;
-
-package C340001_1 is
-
- type List_Contents is array (1..10) of Integer;
- type List is tagged limited record
- Length : Natural range 0..10 := 0;
- Contents : List_Contents := (others => 0);
- end record;
-
- procedure Add_To (L : in out List; New_Value : in Integer);
- procedure Remove_From (L : in out List);
-
- function "=" (L, R : in List) return Boolean;
-
- subtype Revision_Mark is Character range 'A' .. 'Z';
- type Revisable_List is new List with record
- Revision : Revision_Mark := 'A';
- end record;
-
- procedure Revise (L : in out Revisable_List);
-
-end C340001_1;
-
-package body C340001_1 is
-
- -- Note: This is not a complete abstraction of a list. Exceptions
- -- are not defined and boundary checks are not made.
-
- procedure Add_To (L : in out List; New_Value : in Integer) is
- begin
- L.Length := L.Length + 1;
- L.Contents (L.Length) := New_Value;
- end Add_To;
-
- procedure Remove_From (L : in out List) is
- -- The list length is decremented. "Old" values are left in the
- -- array. They are overwritten when a new value is added.
- begin
- L.Length := L.Length - 1;
- end Remove_From;
-
- function "=" (L, R : in List) return Boolean is
- -- Two lists are equal if they are the same length and
- -- the component values within that length are the same.
- -- Values stored past the end of the list are ignored.
- begin
- return L.Length = R.Length
- and then L.Contents (1..L.Length) = R.Contents (1..R.Length);
- end "=";
-
- procedure Revise (L : in out Revisable_List) is
- begin
- L.Revision := Character'Succ (L.Revision);
- end Revise;
-
-end C340001_1;
-
-package C340001_2 is
-
- type Media is (Paper, Electronic);
-
- type Transaction (Medium : Media) is tagged record
- ID : Natural range 1000 .. 9999;
- end record;
-
- function "=" (L, R : in Transaction) return Boolean;
-
- type Authorization (Kind : Media) is new Transaction (Medium => Kind)
- with record
- case Kind is
- when Paper =>
- Signature_On_File : Boolean;
- when Electronic =>
- Paper_Backup : Boolean; -- to retain opposing value
- end case;
- end record;
-
-end C340001_2;
-
-package body C340001_2 is
-
- function "=" (L, R : in Transaction) return Boolean is
- -- There may be electronic and paper copies of the same transaction.
- -- The ID uniquely identifies a transaction. The medium (stored in
- -- the discriminant) is ignored.
- begin
- return L.ID = R.ID;
- end "=";
-
-end C340001_2;
-
-
-with C340001_0; -- nonlimited tagged record declarations
-with C340001_1; -- limited tagged record declarations
-with C340001_2; -- tagged variant declarations
-with Ada.Calendar;
-with Report;
-procedure C340001 is
-
- DB_Rec1 : C340001_0.DB_Record := (Key => 1,
- Data => "aaaaaaaaaa");
- DB_Rec2 : C340001_0.DB_Record := (Key => 55,
- Data => "aaaaaaaaaa");
- -- DB_Rec1 = DB_Rec2 using user-defined equality
- -- DB_Rec1 /= DB_Rec2 using predefined equality
-
- Some_Time : Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993);
-
- Another_Time : Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993);
-
- Dated_Rec1 : C340001_0.Dated_Record := (Key => 2,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Some_Time);
- Dated_Rec2 : C340001_0.Dated_Record := (Key => 77,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Some_Time);
- Dated_Rec3 : C340001_0.Dated_Record := (Key => 77,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Another_Time);
- -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion
- -- Dated_Rec2 /= Dated_Rec3 if extended component is compared
- -- using Ada.Calendar.Time."="
-
- List1 : C340001_1.List;
- List2 : C340001_1.List;
-
- RList1 : C340001_1.Revisable_List;
- RList2 : C340001_1.Revisable_List;
- RList3 : C340001_1.Revisable_List;
-
- Current : C340001_2.Transaction (C340001_2.Paper) :=
- (C340001_2.Paper, 2001);
- Last : C340001_2.Transaction (C340001_2.Electronic) :=
- (C340001_2.Electronic, 2001);
- -- Current = Last using user-defined equality
- -- Current /= Last using predefined equality
-
- Approval1 : C340001_2.Authorization (C340001_2.Paper)
- := (Kind => C340001_2.Paper,
- ID => 1040,
- Signature_On_File => True);
- Approval2 : C340001_2.Authorization (C340001_2.Paper)
- := (Kind => C340001_2.Paper,
- ID => 2167,
- Signature_On_File => False);
- Approval3 : C340001_2.Authorization (C340001_2.Electronic)
- := (Kind => C340001_2.Electronic,
- ID => 2167,
- Paper_Backup => False);
- -- Approval1 /= Approval2 if user-defined equality extended with
- -- component equality.
- -- Approval2 /= Approval3 if differing variant parts checked
-
- -- Direct visibility to operator symbols
- use type C340001_0.DB_Record;
- use type C340001_0.Dated_Record;
-
- use type C340001_1.List;
- use type C340001_1.Revisable_List;
-
- use type C340001_2.Transaction;
- use type C340001_2.Authorization;
-
-begin
-
- Report.Test ("C340001", "Inheritance of user-defined ""=""");
-
- -- Approval1 /= Approval2 if user-defined equality extended with
- -- component equality.
- -- Approval2 /= Approval3 if differing variant parts checked
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
-
- if not (DB_Rec1 = DB_Rec2) then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality did not override predefined " &
- "equality");
- end if;
-
- if DB_Rec1 /= DB_Rec2 then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality did not override predefined " &
- "inequality as well");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the type extension use the user-defined
- -- equality operations from the parent to compare the inherited
- -- components
- ---------------------------------------------------------------------
-
- if not (Dated_Rec1 = Dated_Rec2) then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality was not used to compare " &
- "components inherited from parent");
- end if;
-
- if Dated_Rec1 /= Dated_Rec2 then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined inequality was not used to compare " &
- "components inherited from parent");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that equality and inequality for the type extension incorporate
- -- the predefined equality operators for the extended component type
- ---------------------------------------------------------------------
- if Dated_Rec2 = Dated_Rec3 then
- Report.Failed ("Nonlimited tagged record: " &
- "Record equality was not extended with component " &
- "equality");
- end if;
-
- if not (Dated_Rec2 /= Dated_Rec3) then
- Report.Failed ("Nonlimited tagged record: " &
- "Record inequality was not extended with component " &
- "equality");
- end if;
-
- ---------------------------------------------------------------------
- C340001_1.Add_To (List1, 1);
- C340001_1.Add_To (List1, 2);
- C340001_1.Add_To (List1, 3);
- C340001_1.Remove_From (List1);
-
- C340001_1.Add_To (List2, 1);
- C340001_1.Add_To (List2, 2);
-
- -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0))
- -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0))
-
- -- List1 = List2 using user-defined equality
- -- List1 /= List2 using predefined equality
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
- if not (List1 = List2) then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality incorrectly implemented " );
- end if;
-
- if List1 /= List2 then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality incorrectly implemented " );
- end if;
-
- ---------------------------------------------------------------------
- -- RList1 and RList2 are made equal but "different" by adding
- -- a nonzero value to RList1 then removing it. Removal updates
- -- the list Length only, not its contents. The two lists will be
- -- equal according to the defined list abstraction, but the records
- -- will contain differing component values.
-
- C340001_1.Add_To (RList1, 1);
- C340001_1.Add_To (RList1, 2);
- C340001_1.Add_To (RList1, 3);
- C340001_1.Remove_From (RList1);
-
- C340001_1.Add_To (RList2, 1);
- C340001_1.Add_To (RList2, 2);
-
- C340001_1.Add_To (RList3, 1);
- C340001_1.Add_To (RList3, 2);
-
- C340001_1.Revise (RList3);
-
- -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A')
- -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A')
- -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B')
-
- -- RList1 = RList2 if List."=" inherited
- -- RList2 /= RList3 if List."=" inherited and extended with Character "="
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" are the user-defined operations inherited
- -- from the parent type.
- ---------------------------------------------------------------------
- if not (RList1 = RList2) then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality was not inherited");
- end if;
-
- if RList1 /= RList2 then
- Report.Failed ("Limited tagged record : " &
- "User-defined inequality was not inherited");
- end if;
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the type extension are NOT extended
- -- with the predefined equality operators for the extended component.
- -- A limited type extension should inherit the parent equality operation
- -- as is.
- ---------------------------------------------------------------------
- if not (RList2 = RList3) then
- Report.Failed ("Limited tagged record : " &
- "Inherited equality operation was extended with " &
- "component equality");
- end if;
-
- if RList2 /= RList3 then
- Report.Failed ("Limited tagged record : " &
- "Inherited inequality operation was extended with " &
- "component equality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
- if not (Current = Last) then
- Report.Failed ("Variant record : " &
- "User-defined equality did not override predefined " &
- "equality");
- end if;
-
- if Current /= Last then
- Report.Failed ("Variant record : " &
- "User-defined inequality did not override predefined " &
- "inequality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that user-defined equality was incorporated and extended
- -- with equality of extended components.
- ---------------------------------------------------------------------
- if not (Approval1 /= Approval2) then
- Report.Failed ("Variant record : " &
- "Inequality was not extended with component " &
- "inequality");
- end if;
-
- if Approval1 = Approval2 then
- Report.Failed ("Variant record : " &
- "Equality was not extended with component " &
- "equality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that equality and inequality for the type extension
- -- succeed despite the presence of differing variant parts.
- ---------------------------------------------------------------------
- if Approval2 = Approval3 then
- Report.Failed ("Variant record : " &
- "Equality succeeded even though variant parts " &
- "in type extension differ");
- end if;
-
- if not (Approval2 /= Approval3) then
- Report.Failed ("Variant record : " &
- "Inequality failed even though variant parts " &
- "in type extension differ");
- end if;
-
- ---------------------------------------------------------------------
- Report.Result;
- ---------------------------------------------------------------------
-
-end C340001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34001a.ada b/gcc/testsuite/ada/acats/tests/c3/c34001a.ada
deleted file mode 100644
index c66d7dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34001a.ada
+++ /dev/null
@@ -1,186 +0,0 @@
--- C34001A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES.
-
--- JRK 8/20/86
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34001A IS
-
- TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6);
-
- SUBTYPE SUBPARENT IS PARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (E2))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (E5)));
-
- TYPE T IS NEW SUBPARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (E3))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (E4)));
-
- X : T := E3;
- W : PARENT := E1;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (T'POS (X), T'POS (X)) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN T'FIRST;
- END IDENT;
-
-BEGIN
- TEST ("C34001A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES");
-
- X := IDENT (E4);
- IF X /= E4 THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= E4 THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= E4 THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := E3;
- END IF;
- IF T (W) /= E3 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= E4 OR PARENT (T'VAL (0)) /= E1 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF IDENT ('A') /= 'A' THEN
- FAILED ("INCORRECT 'A'");
- END IF;
-
- IF IDENT (E3) /= E3 OR IDENT (E4) = E1 THEN
- FAILED ("INCORRECT ENUMERATION LITERAL");
- END IF;
-
- IF X = IDENT ('A') OR X = E1 THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (E4) OR NOT (X /= E1) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT (E4) OR X < E1 THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT (E4) OR X > E6 THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT ('A') OR X <= E1 THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF IDENT ('A') >= X OR X >= E6 THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR E1 IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (E1 NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'BASE'SIZE < 3 THEN
- FAILED ("INCORRECT 'BASE'SIZE");
- END IF;
-
- IF T'FIRST /= E3 OR T'BASE'FIRST /= E1 THEN
- FAILED ("INCORRECT 'FIRST");
- END IF;
-
- IF T'IMAGE (X) /= "E4" OR T'IMAGE (E1) /= "E1" THEN
- FAILED ("INCORRECT 'IMAGE");
- END IF;
-
- IF T'LAST /= E4 OR T'BASE'LAST /= E6 THEN
- FAILED ("INCORRECT 'LAST");
- END IF;
-
- IF T'POS (X) /= 4 OR T'POS (E1) /= 0 THEN
- FAILED ("INCORRECT 'POS");
- END IF;
-
- IF T'PRED (X) /= 'A' OR T'PRED (E2) /= E1 THEN
- FAILED ("INCORRECT 'PRED");
- END IF;
-
- IF T'SIZE < 2 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < 2 THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- IF T'SUCC (IDENT ('A')) /= X OR T'SUCC (E1) /= E2 THEN
- FAILED ("INCORRECT 'SUCC");
- END IF;
-
- IF T'VAL (IDENT_INT (4)) /= X OR T'VAL (0) /= E1 THEN
- FAILED ("INCORRECT 'VAL");
- END IF;
-
- IF T'VALUE (IDENT_STR ("E4")) /= X OR T'VALUE ("E1") /= E1 THEN
- FAILED ("INCORRECT 'VALUE");
- END IF;
-
- IF T'WIDTH /= 3 OR T'BASE'WIDTH /= 3 THEN
- FAILED ("INCORRECT 'WIDTH");
- END IF;
-
- RESULT;
-END C34001A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34001c.ada b/gcc/testsuite/ada/acats/tests/c3/c34001c.ada
deleted file mode 100644
index a4509db..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34001c.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C34001C.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.
---*
--- FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 8/20/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34001C IS
-
- TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6);
-
- TYPE T IS NEW PARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (E3))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (E4)));
-
- SUBTYPE SUBPARENT IS PARENT RANGE E3 .. E4;
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
-BEGIN
- TEST ("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF T'BASE'FIRST /= E1 OR T'BASE'LAST /= E6 OR
- S'BASE'FIRST /= E1 OR S'BASE'LAST /= E6 THEN
- FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
- END IF;
-
- IF T'PRED (E2) /= E1 OR T'SUCC (E1) /= E2 OR
- S'PRED (E2) /= E1 OR S'SUCC (E1) /= E2 THEN
- FAILED ("INCORRECT 'PRED OR 'SUCC");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= E3 OR T'LAST /= E4 OR
- S'FIRST /= E3 OR S'LAST /= E4 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := E3;
- Y := E3;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
- X := E4;
- Y := E4;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := E2;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E2");
- IF X = E2 THEN -- USE X.
- COMMENT ("X ALTERED -- X := E2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := E2");
- END;
-
- BEGIN
- X := E5;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E5");
- IF X = E5 THEN -- USE X.
- COMMENT ("X ALTERED -- X := E5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := E5");
- END;
-
- BEGIN
- Y := E2;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E2");
- IF Y = E2 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := E2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := E2");
- END;
-
- BEGIN
- Y := E5;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E5");
- IF Y = E5 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := E5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := E5");
- END;
-
- RESULT;
-END C34001C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34001d.ada b/gcc/testsuite/ada/acats/tests/c3/c34001d.ada
deleted file mode 100644
index 7b98328..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34001d.ada
+++ /dev/null
@@ -1,209 +0,0 @@
--- C34001D.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED BOOLEAN TYPES.
-
--- JRK 8/20/86
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34001D IS
-
- SUBTYPE PARENT IS BOOLEAN;
-
- SUBTYPE SUBPARENT IS PARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (TRUE)));
-
- TYPE T IS NEW SUBPARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (TRUE)));
-
- X : T := TRUE;
- W : PARENT := FALSE;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (T'POS (X), T'POS (X)) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN T'FIRST;
- END IDENT;
-
-BEGIN
- TEST ("C34001D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "BOOLEAN TYPES");
-
- X := IDENT (TRUE);
- IF X /= TRUE THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= TRUE THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= TRUE THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := TRUE;
- END IF;
- IF T (W) /= TRUE THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= TRUE OR PARENT (T'VAL (0)) /= FALSE THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF IDENT (TRUE) /= TRUE OR IDENT (TRUE) = FALSE THEN
- FAILED ("INCORRECT ENUMERATION LITERAL");
- END IF;
-
- IF NOT X /= FALSE OR NOT FALSE /= X THEN
- FAILED ("INCORRECT ""NOT""");
- END IF;
-
- IF (X AND IDENT (TRUE)) /= TRUE OR (X AND FALSE) /= FALSE THEN
- FAILED ("INCORRECT ""AND""");
- END IF;
-
- IF (X OR IDENT (TRUE)) /= TRUE OR (FALSE OR X) /= TRUE THEN
- FAILED ("INCORRECT ""OR""");
- END IF;
-
- IF (X XOR IDENT (TRUE)) /= FALSE OR (X XOR FALSE) /= TRUE THEN
- FAILED ("INCORRECT ""XOR""");
- END IF;
-
- IF (X AND THEN IDENT (TRUE)) /= TRUE OR
- (X AND THEN FALSE) /= FALSE THEN
- FAILED ("INCORRECT ""AND THEN""");
- END IF;
-
- IF (X OR ELSE IDENT (TRUE)) /= TRUE OR
- (FALSE OR ELSE X) /= TRUE THEN
- FAILED ("INCORRECT ""OR ELSE""");
- END IF;
-
- IF NOT (X = IDENT (TRUE)) OR X = FALSE THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (TRUE) OR NOT (X /= FALSE) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT (TRUE) OR X < FALSE THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT (TRUE) OR FALSE > X THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF NOT (X <= IDENT (TRUE)) OR X <= FALSE THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF NOT (X >= IDENT (TRUE)) OR FALSE >= X THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR FALSE IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (FALSE NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'BASE'SIZE < 1 THEN
- FAILED ("INCORRECT 'BASE'SIZE");
- END IF;
-
- IF T'FIRST /= TRUE OR T'BASE'FIRST /= FALSE THEN
- FAILED ("INCORRECT 'FIRST");
- END IF;
-
- IF T'IMAGE (X) /= "TRUE" OR T'IMAGE (FALSE) /= "FALSE" THEN
- FAILED ("INCORRECT 'IMAGE");
- END IF;
-
- IF T'LAST /= TRUE OR T'BASE'LAST /= TRUE THEN
- FAILED ("INCORRECT 'LAST");
- END IF;
-
- IF T'POS (X) /= 1 OR T'POS (FALSE) /= 0 THEN
- FAILED ("INCORRECT 'POS");
- END IF;
-
- IF T'PRED (X) /= FALSE THEN
- FAILED ("INCORRECT 'PRED");
- END IF;
-
- IF T'SIZE < 1 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < 1 THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- IF T'SUCC (T'VAL (IDENT_INT (0))) /= X THEN
- FAILED ("INCORRECT 'SUCC");
- END IF;
-
- IF T'VAL (IDENT_INT (1)) /= X OR T'VAL (0) /= FALSE THEN
- FAILED ("INCORRECT 'VAL");
- END IF;
-
- IF T'VALUE (IDENT_STR ("TRUE")) /= X OR
- T'VALUE ("FALSE") /= FALSE THEN
- FAILED ("INCORRECT 'VALUE");
- END IF;
-
- IF T'WIDTH /= 4 OR T'BASE'WIDTH /= 5 THEN
- FAILED ("INCORRECT 'WIDTH");
- END IF;
-
- RESULT;
-END C34001D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34001f.ada b/gcc/testsuite/ada/acats/tests/c3/c34001f.ada
deleted file mode 100644
index 6226e72..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34001f.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- C34001F.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.
---*
--- FOR DERIVED BOOLEAN TYPES:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 8/20/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34001F IS
-
- SUBTYPE PARENT IS BOOLEAN;
-
- TYPE T IS NEW PARENT RANGE
- PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) ..
- PARENT'VAL (IDENT_INT (PARENT'POS (FALSE)));
-
- SUBTYPE SUBPARENT IS PARENT RANGE TRUE .. TRUE;
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
-BEGIN
- TEST ("C34001F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "BOOLEAN TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF T'BASE'FIRST /= FALSE OR T'BASE'LAST /= TRUE OR
- S'BASE'FIRST /= FALSE OR S'BASE'LAST /= TRUE THEN
- FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
- END IF;
-
- IF T'PRED (TRUE) /= FALSE OR T'SUCC (FALSE) /= TRUE OR
- S'PRED (TRUE) /= FALSE OR S'SUCC (FALSE) /= TRUE THEN
- FAILED ("INCORRECT 'PRED OR 'SUCC");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= FALSE OR T'LAST /= FALSE OR
- S'FIRST /= TRUE OR S'LAST /= TRUE THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := FALSE;
- Y := TRUE;
- IF NOT PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := TRUE;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := TRUE");
- IF X = TRUE THEN -- USE X.
- COMMENT ("X ALTERED -- X := TRUE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := TRUE");
- END;
-
- BEGIN
- Y := FALSE;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := FALSE");
- IF Y = FALSE THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := FALSE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := FALSE");
- END;
-
- RESULT;
-END C34001F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34002a.ada b/gcc/testsuite/ada/acats/tests/c3/c34002a.ada
deleted file mode 100644
index 8b5690e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34002a.ada
+++ /dev/null
@@ -1,265 +0,0 @@
--- C34002A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED INTEGER TYPES.
-
--- JRK 8/21/86
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34002A IS
-
- TYPE PARENT IS RANGE -100 .. 100;
-
- SUBTYPE SUBPARENT IS PARENT RANGE
- PARENT'VAL (IDENT_INT (-50)) ..
- PARENT'VAL (IDENT_INT ( 50));
-
- TYPE T IS NEW SUBPARENT RANGE
- PARENT'VAL (IDENT_INT (-30)) ..
- PARENT'VAL (IDENT_INT ( 30));
-
- TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0;
-
- X : T := -30;
- W : PARENT := -100;
- N : CONSTANT := 1;
- M : CONSTANT := 100;
- B : BOOLEAN := FALSE;
- F : FLOAT := 0.0;
- G : FIXED := 0.0;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (T'POS (X), T'POS (X)) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN T'FIRST;
- END IDENT;
-
-BEGIN
- TEST ("C34002A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "INTEGER TYPES");
-
- X := IDENT (30);
- IF X /= 30 THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= 30 THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= 30 THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := -30;
- END IF;
- IF T (W) /= -30 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= 30 OR PARENT (T'VAL (-100)) /= -100 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF T (IDENT_INT (-30)) /= -30 THEN
- FAILED ("INCORRECT CONVERSION FROM INTEGER");
- END IF;
-
- IF INTEGER (X) /= 30 OR INTEGER (T'VAL (-100)) /= -100 THEN
- FAILED ("INCORRECT CONVERSION TO INTEGER");
- END IF;
-
- IF EQUAL (3, 3) THEN
- F := -30.0;
- END IF;
- IF T (F) /= -30 THEN
- FAILED ("INCORRECT CONVERSION FROM FLOAT");
- END IF;
-
- IF FLOAT (X) /= 30.0 OR FLOAT (T'VAL (-100)) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FLOAT");
- END IF;
-
- IF EQUAL (3, 3) THEN
- G := -30.0;
- END IF;
- IF T (G) /= -30 THEN
- FAILED ("INCORRECT CONVERSION FROM FIXED");
- END IF;
-
- IF FIXED (X) /= 30.0 OR FIXED (T'VAL (-100)) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FIXED");
- END IF;
-
- IF IDENT (N) /= 1 OR X = M THEN
- FAILED ("INCORRECT IMPLICIT CONVERSION");
- END IF;
-
- IF IDENT (30) /= 30 OR X = 100 THEN
- FAILED ("INCORRECT INTEGER LITERAL");
- END IF;
-
- IF X = IDENT (0) OR X = 100 THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (30) OR NOT (X /= 100) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT (30) OR 100 < X THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT (30) OR X > 100 THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT (0) OR 100 <= X THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF IDENT (0) >= X OR X >= 100 THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR 100 IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (100 NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- IF +X /= 30 OR +T'VAL(-100) /= -100 THEN
- FAILED ("INCORRECT UNARY +");
- END IF;
-
- IF -X /= 0 - 30 OR -T'VAL(-100) /= 100 THEN
- FAILED ("INCORRECT UNARY -");
- END IF;
-
- IF ABS X /= 30 OR ABS T'VAL (-100) /= 100 THEN
- FAILED ("INCORRECT ABS");
- END IF;
-
- IF X + IDENT (-1) /= 29 OR X + 70 /= 100 THEN
- FAILED ("INCORRECT BINARY +");
- END IF;
-
- IF X - IDENT (30) /= 0 OR X - 100 /= -70 THEN
- FAILED ("INCORRECT BINARY -");
- END IF;
-
- IF X * IDENT (-1) /= -30 OR IDENT (2) * 50 /= 100 THEN
- FAILED ("INCORRECT *");
- END IF;
-
- IF X / IDENT (3) /= 10 OR 90 / X /= 3 THEN
- FAILED ("INCORRECT /");
- END IF;
-
- IF X MOD IDENT (7) /= 2 OR 100 MOD X /= 10 THEN
- FAILED ("INCORRECT MOD");
- END IF;
-
- IF X REM IDENT (7) /= 2 OR 100 REM X /= 10 THEN
- FAILED ("INCORRECT REM");
- END IF;
-
- IF X ** IDENT_INT (1) /= 30 OR
- T'VAL (100) ** IDENT_INT (1) /= 100 THEN
- FAILED ("INCORRECT **");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'BASE'SIZE < 8 THEN
- FAILED ("INCORRECT 'BASE'SIZE");
- END IF;
-
- IF T'FIRST /= -30 OR
- T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) THEN
- FAILED ("INCORRECT 'FIRST");
- END IF;
-
- IF T'IMAGE (X) /= " 30" OR T'IMAGE (-100) /= "-100" THEN
- FAILED ("INCORRECT 'IMAGE");
- END IF;
-
- IF T'LAST /= 30 OR
- T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN
- FAILED ("INCORRECT 'LAST");
- END IF;
-
- IF T'POS (X) /= 30 OR T'POS (-100) /= -100 THEN
- FAILED ("INCORRECT 'POS");
- END IF;
-
- IF T'PRED (X) /= 29 OR T'PRED (100) /= 99 THEN
- FAILED ("INCORRECT 'PRED");
- END IF;
-
- IF T'SIZE < 6 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < 6 THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- IF T'SUCC (IDENT (29)) /= X OR T'SUCC (99) /= 100 THEN
- FAILED ("INCORRECT 'SUCC");
- END IF;
-
- IF T'VAL (IDENT_INT (30)) /= X OR T'VAL (100) /= 100 THEN
- FAILED ("INCORRECT 'VAL");
- END IF;
-
- IF T'VALUE (IDENT_STR ("30")) /= X OR T'VALUE ("100") /= 100 THEN
- FAILED ("INCORRECT 'VALUE");
- END IF;
-
- IF T'WIDTH /= 3 OR T'BASE'WIDTH < 4 THEN
- FAILED ("INCORRECT 'WIDTH");
- END IF;
-
- RESULT;
-END C34002A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34002c.ada b/gcc/testsuite/ada/acats/tests/c3/c34002c.ada
deleted file mode 100644
index a14459d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34002c.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C34002C.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.
---*
--- FOR DERIVED INTEGER TYPES:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 8/21/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34002C IS
-
- TYPE PARENT IS RANGE -100 .. 100;
-
- TYPE T IS NEW PARENT RANGE
- PARENT'VAL (IDENT_INT (-30)) ..
- PARENT'VAL (IDENT_INT ( 30));
-
- SUBTYPE SUBPARENT IS PARENT RANGE -30 .. 30;
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
-BEGIN
- TEST ("C34002C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "INTEGER TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR
- S'POS (S'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR
- T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) OR
- S'POS (S'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN
- FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
- END IF;
-
- IF T'PRED (100) /= 99 OR T'SUCC (99) /= 100 OR
- S'PRED (100) /= 99 OR S'SUCC (99) /= 100 THEN
- FAILED ("INCORRECT 'PRED OR 'SUCC");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= -30 OR T'LAST /= 30 OR
- S'FIRST /= -30 OR S'LAST /= 30 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := -30;
- Y := -30;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
- X := 30;
- Y := 30;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := -31;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31");
- IF X = -31 THEN -- USE X.
- COMMENT ("X ALTERED -- X := -31");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := -31");
- END;
-
- BEGIN
- X := 31;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31");
- IF X = 31 THEN -- USE X.
- COMMENT ("X ALTERED -- X := 31");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := 31");
- END;
-
- BEGIN
- Y := -31;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31");
- IF Y = -31 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := -31");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := -31");
- END;
-
- BEGIN
- Y := 31;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31");
- IF Y = 31 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := 31");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := 31");
- END;
-
- RESULT;
-END C34002C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34003a.ada b/gcc/testsuite/ada/acats/tests/c3/c34003a.ada
deleted file mode 100644
index ed37d05..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34003a.ada
+++ /dev/null
@@ -1,260 +0,0 @@
--- C34003A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED FLOATING POINT TYPES.
-
--- JRK 9/4/86
--- GJD 11/14/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTES.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34003A IS
-
- TYPE PARENT IS DIGITS 5;
-
- SUBTYPE SUBPARENT IS PARENT RANGE
- PARENT (IDENT_INT (-50)) ..
- PARENT (IDENT_INT ( 50));
-
- TYPE T IS NEW SUBPARENT DIGITS 4 RANGE
- PARENT (IDENT_INT (-30)) ..
- PARENT (IDENT_INT ( 30));
-
- TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0;
-
- X : T := -30.0;
- W : PARENT := -100.0;
- R : CONSTANT := 1.0;
- M : CONSTANT := 100.0;
- B : BOOLEAN := FALSE;
- F : FLOAT := 0.0;
- G : FIXED := 0.0;
-
- Z : CONSTANT T := 0.0;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN T'FIRST;
- END IDENT;
-
-BEGIN
- TEST ("C34003A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "FLOATING POINT TYPES");
-
- X := IDENT (30.0);
- IF X /= 30.0 THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= 30.0 THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= 30.0 THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := -30.0;
- END IF;
- IF T (W) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF T (IDENT_INT (-30)) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM INTEGER");
- END IF;
-
- IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN
- FAILED ("INCORRECT CONVERSION TO INTEGER");
- END IF;
-
- IF EQUAL (3, 3) THEN
- F := -30.0;
- END IF;
- IF T (F) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM FLOAT");
- END IF;
-
- IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FLOAT");
- END IF;
-
- IF EQUAL (3, 3) THEN
- G := -30.0;
- END IF;
- IF T (G) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM FIXED");
- END IF;
-
- IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FIXED");
- END IF;
-
- IF IDENT (R) /= 1.0 OR X = M THEN
- FAILED ("INCORRECT IMPLICIT CONVERSION");
- END IF;
-
- IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN
- FAILED ("INCORRECT REAL LITERAL");
- END IF;
-
- IF X = IDENT (0.0) OR X = 100.0 THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT (30.0) OR 100.0 < X THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT (30.0) OR X > 100.0 THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT (0.0) OR 100.0 <= X THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF IDENT (0.0) >= X OR X >= 100.0 THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR 100.0 IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (100.0 NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT UNARY +");
- END IF;
-
- IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN
- FAILED ("INCORRECT UNARY -");
- END IF;
-
- IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN
- FAILED ("INCORRECT ABS");
- END IF;
-
- IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN
- FAILED ("INCORRECT BINARY +");
- END IF;
-
- IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN
- FAILED ("INCORRECT BINARY -");
- END IF;
-
- IF X * IDENT (-1.0) /= -30.0 OR IDENT (2.0) * 50.0 /= 100.0 THEN
- FAILED ("INCORRECT *");
- END IF;
-
- IF X / IDENT (3.0) /= 10.0 OR 90.0 / X /= 3.0 THEN
- FAILED ("INCORRECT /");
- END IF;
-
- IF X ** IDENT_INT (1) /= 30.0 OR
- (Z + 100.0) ** IDENT_INT (1) /= 100.0 THEN
- FAILED ("INCORRECT **");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'BASE'SIZE < 27 THEN
- FAILED ("INCORRECT 'BASE'SIZE");
- END IF;
-
- IF T'DIGITS /= 4 OR T'BASE'DIGITS < 5 THEN
- FAILED ("INCORRECT 'DIGITS");
- END IF;
-
- IF T'FIRST /= -30.0 THEN
- FAILED ("INCORRECT 'FIRST");
- END IF;
-
- IF T'LAST /= 30.0 THEN
- FAILED ("INCORRECT 'LAST");
- END IF;
-
- IF T'MACHINE_EMAX < 1 OR T'BASE'MACHINE_EMAX /= T'MACHINE_EMAX THEN
- FAILED ("INCORRECT 'MACHINE_EMAX");
- END IF;
-
- IF T'MACHINE_EMIN > -1 OR T'BASE'MACHINE_EMIN /= T'MACHINE_EMIN THEN
- FAILED ("INCORRECT 'MACHINE_EMIN");
- END IF;
-
- IF T'MACHINE_MANTISSA < 1 OR
- T'BASE'MACHINE_MANTISSA /= T'MACHINE_MANTISSA THEN
- FAILED ("INCORRECT 'MACHINE_MANTISSA");
- END IF;
-
- IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN
- FAILED ("INCORRECT 'MACHINE_OVERFLOWS");
- END IF;
-
- IF T'MACHINE_RADIX < 2 OR
- T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN
- FAILED ("INCORRECT 'MACHINE_RADIX");
- END IF;
-
- IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN
- FAILED ("INCORRECT 'MACHINE_ROUNDS");
- END IF;
-
- IF T'SIZE < 23 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < 23 THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34003A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34003c.ada b/gcc/testsuite/ada/acats/tests/c3/c34003c.ada
deleted file mode 100644
index 9de3574..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34003c.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C34003C.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.
---*
--- FOR DERIVED FLOATING POINT TYPES:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 9/4/86
--- GJD 11/15/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTE (SAFE_LARGE).
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34003C IS
-
- TYPE PARENT IS DIGITS 5;
-
- TYPE T IS NEW PARENT DIGITS 4 RANGE
- PARENT (IDENT_INT (-30)) ..
- PARENT (IDENT_INT ( 30));
-
- SUBTYPE SUBPARENT IS PARENT DIGITS 4 RANGE -30.0 .. 30.0;
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
-BEGIN
- TEST ("C34003C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "FLOATING POINT TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF T'BASE'DIGITS < 5 OR S'BASE'DIGITS < 5 THEN
- FAILED ("INCORRECT 'BASE'DIGITS");
- END IF;
-
- IF 12344.0 + T'(1.0) + 1.0 /= 12346.0 OR
- 12344.0 + S'(1.0) + 1.0 /= 12346.0 OR
- -12344.0 - T'(1.0) - 1.0 /= -12346.0 OR
- -12344.0 - S'(1.0) - 1.0 /= -12346.0 THEN
- FAILED ("INCORRECT + OR -");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'DIGITS /= 4 OR S'DIGITS /= 4 THEN
- FAILED ("INCORRECT 'DIGITS");
- END IF;
-
- IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR
- S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := -30.0;
- Y := -30.0;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
- X := 30.0;
- Y := 30.0;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := -31.0;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31.0");
- IF X = -31.0 THEN -- USE X.
- COMMENT ("X ALTERED -- X := -31.0");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := -31.0");
- END;
-
- BEGIN
- X := 31.0;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31.0");
- IF X = 31.0 THEN -- USE X.
- COMMENT ("X ALTERED -- X := 31.0");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := 31.0");
- END;
-
- BEGIN
- Y := -31.0;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31.0");
- IF Y = -31.0 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := -31.0");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := -31.0");
- END;
-
- BEGIN
- Y := 31.0;
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31.0");
- IF Y = 31.0 THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := 31.0");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := 31.0");
- END;
-
- RESULT;
-END C34003C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34004a.ada b/gcc/testsuite/ada/acats/tests/c3/c34004a.ada
deleted file mode 100644
index 735776a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34004a.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- C34004A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED FIXED POINT TYPES.
-
--- HISTORY:
--- JRK 09/08/86 CREATED ORIGINAL TEST.
--- JET 08/06/87 FIXED BUGS IN DELTAS AND RANGE ERROR.
--- JET 09/22/88 CHANGED USAGE OF X'SIZE.
--- RDH 04/16/90 ADDED TEST FOR REAL VARIABLE VALUES.
--- THS 09/25/90 REMOVED ALL REFERENCES TO B, MODIFIED CHECK OF
--- '=', INITIALIZED Z NON-STATICALLY, MOVED BINARY
--- CHECKS.
--- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES.
--- KAS 03/04/96 REMOVED COMPARISON OF T'SMALL TO T'BASE'SMALL
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34004A IS
-
- TYPE PARENT IS DELTA 2.0 ** (-7) RANGE -100.0 .. 100.0;
-
- SUBTYPE SUBPARENT IS PARENT RANGE
- IDENT_INT (1) * (-50.0) ..
- IDENT_INT (1) * ( 50.0);
-
- TYPE T IS NEW SUBPARENT DELTA 2.0 ** (-4) RANGE
- IDENT_INT (1) * (-30.0) ..
- IDENT_INT (1) * ( 30.0);
-
- TYPE FIXED IS DELTA 2.0 ** (-4) RANGE -1000.0 .. 1000.0;
-
- X : T := -30.0;
- I : INTEGER := X'SIZE; --CHECK FOR THE AVAILABILITY OF 'SIZE.
- W : PARENT := -100.0;
- R : CONSTANT := 1.0;
- M : CONSTANT := 100.0;
- F : FLOAT := 0.0;
- G : FIXED := 0.0;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN T'FIRST;
- END IDENT;
-
-BEGIN
-
- DECLARE
- Z : CONSTANT T := IDENT(0.0);
- BEGIN
- TEST ("C34004A", "CHECK THAT THE REQUIRED PREDEFINED " &
- "OPERATIONS ARE DECLARED (IMPLICITLY) " &
- "FOR DERIVED FIXED POINT TYPES");
-
- X := IDENT (30.0);
- IF X /= 30.0 THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN
- FAILED ("INCORRECT BINARY +");
- END IF;
-
- IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN
- FAILED ("INCORRECT BINARY -");
- END IF;
-
- IF T'(X) /= 30.0 THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= 30.0 THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := -30.0;
- END IF;
- IF T (W) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF T (IDENT_INT (-30)) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM INTEGER");
- END IF;
-
- IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN
- FAILED ("INCORRECT CONVERSION TO INTEGER");
- END IF;
-
- IF EQUAL (3, 3) THEN
- F := -30.0;
- END IF;
- IF T (F) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM FLOAT");
- END IF;
-
- IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FLOAT");
- END IF;
-
- IF EQUAL (3, 3) THEN
- G := -30.0;
- END IF;
- IF T (G) /= -30.0 THEN
- FAILED ("INCORRECT CONVERSION FROM FIXED");
- END IF;
-
- IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT CONVERSION TO FIXED");
- END IF;
-
- IF IDENT (R) /= 1.0 OR X = M THEN
- FAILED ("INCORRECT IMPLICIT CONVERSION");
- END IF;
-
- IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN
- FAILED ("INCORRECT REAL LITERAL");
- END IF;
-
- IF NOT (X = IDENT (30.0)) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT (30.0) OR 100.0 < X THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT (30.0) OR X > 100.0 THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT (0.0) OR 100.0 <= X THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF IDENT (0.0) >= X OR X >= 100.0 THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR 100.0 IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (100.0 NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN
- FAILED ("INCORRECT UNARY +");
- END IF;
-
- IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN
- FAILED ("INCORRECT UNARY -");
- END IF;
-
- IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN
- FAILED ("INCORRECT ABS");
- END IF;
-
- IF T (X * IDENT (-1.0)) /= -30.0 OR
- T (IDENT (2.0) * (Z + 15.0)) /= 30.0 THEN
- FAILED ("INCORRECT * (FIXED, FIXED)");
- END IF;
-
- IF X * IDENT_INT (-1) /= -30.0 OR
- (Z + 50.0) * 2 /= 100.0 THEN
- FAILED ("INCORRECT * (FIXED, INTEGER)");
- END IF;
-
- IF IDENT_INT (-1) * X /= -30.0 OR
- 2 * (Z + 50.0) /= 100.0 THEN
- FAILED ("INCORRECT * (INTEGER, FIXED)");
- END IF;
-
- IF T (X / IDENT (3.0)) /= 10.0 OR
- T ((Z + 90.0) / X) /= 3.0 THEN
- FAILED ("INCORRECT / (FIXED, FIXED)");
- END IF;
-
- IF X / IDENT_INT (3) /= 10.0 OR (Z + 90.0) / 30 /= 3.0 THEN
- FAILED ("INCORRECT / (FIXED, INTEGER)");
- END IF;
-
- A (X'ADDRESS);
-
- IF T'AFT /= 2 OR T'BASE'AFT < 3 THEN
- FAILED ("INCORRECT 'AFT");
- END IF;
-
- IF T'BASE'SIZE < 15 THEN
- FAILED ("INCORRECT 'BASE'SIZE");
- END IF;
-
- IF T'DELTA /= 2.0 ** (-4) OR T'BASE'DELTA > 2.0 ** (-7) THEN
- FAILED ("INCORRECT 'DELTA");
- END IF;
-
-
- IF T'FORE /= 3 OR T'BASE'FORE < 4 THEN
- FAILED ("INCORRECT 'FORE");
- END IF;
-
-
-
- IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN
- FAILED ("INCORRECT 'MACHINE_OVERFLOWS");
- END IF;
-
- IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN
- FAILED ("INCORRECT 'MACHINE_ROUNDS");
- END IF;
-
-
-
-
- IF T'SIZE < 10 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF T'SMALL > 2.0 ** (-4) OR T'BASE'SMALL > 2.0 ** (-7) THEN
- FAILED ("INCORRECT 'SMALL");
- END IF;
- END;
-
- RESULT;
-END C34004A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34004c.ada b/gcc/testsuite/ada/acats/tests/c3/c34004c.ada
deleted file mode 100644
index d3b699f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34004c.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C34004C.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:
--- FOR DERIVED FIXED POINT TYPES:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 09/08/86
--- JLH 09/25/87 REFORMATTED HEADER.
--- JRL 03/13/92 MODIFIED TO DEFEAT OPTIMIZATION WHEN ATTEMPTING TO
--- RAISE CONSTRAINT_ERROR.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
--- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34004C IS
-
- TYPE PARENT IS DELTA 0.01 RANGE -100.0 .. 100.0;
-
- TYPE T IS NEW PARENT DELTA 0.1 RANGE
- IDENT_INT (1) * (-30.0) ..
- IDENT_INT (1) * ( 30.0);
-
- SUBTYPE SUBPARENT IS PARENT DELTA 0.1 RANGE -30.0 .. 30.0;
-
- TYPE S IS NEW SUBPARENT;
-
- X,XA : T;
- Y,YA : S;
-
-
- FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : T ) RETURN BOOLEAN IS
- BEGIN
- IF ( VAR1 + VAR2 ) IN T THEN
- RETURN FALSE ;
- ELSE
- RETURN TRUE ;
- END IF ;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- RETURN TRUE ;
- END OUT_OF_BOUNDS ;
-
-
- FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : S ) RETURN BOOLEAN IS
- BEGIN
- IF ( VAR1 + VAR2 ) IN S THEN
- RETURN FALSE ;
- ELSE
- RETURN TRUE ;
- END IF ;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- RETURN TRUE ;
- END OUT_OF_BOUNDS ;
-
-
-BEGIN
- TEST ("C34004C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "FIXED POINT TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- DECLARE
- TBD : CONSTANT := BOOLEAN'POS (T'BASE'DELTA <= 0.01);
- SBD : CONSTANT := BOOLEAN'POS (S'BASE'DELTA <= 0.01);
- BEGIN
- IF TBD = 0 OR SBD = 0 THEN
- FAILED ("INCORRECT 'BASE'DELTA");
- END IF;
- END;
-
-
- DECLARE
- N : INTEGER := IDENT_INT (8);
- BEGIN
- IF 98.0 + T'(1.0) + N * 0.0078125 /= 99.0625 OR
- 98.0 + S'(1.0) + 8 * 0.0078125 /= 99.0625 OR
- -98.0 - T'(1.0) - N * 0.0078125 /= -99.0625 OR
- -98.0 - S'(1.0) - 8 * 0.0078125 /= -99.0625 THEN
- FAILED ("INCORRECT + OR -");
- END IF;
- END;
-
-
- IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR
- S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := -30.0;
- Y := -30.0;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
- X := 30.0;
- Y := 30.0;
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
-
- BEGIN
- X := -30.0 ;
- XA := -0.0625 ;
- IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := -30.0625" ) ;
- END IF ;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := -30.0625");
- END;
-
-
- BEGIN
- X := 30.0 ;
- XA := 0.0625 ;
- IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := 30.0625" ) ;
- END IF ;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := 30.0625");
- END;
-
-
- BEGIN
- Y := -30.0 ;
- YA := -0.0625 ;
- IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := -30.0625" ) ;
- END IF ;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := -30.0625");
- END;
-
-
- BEGIN
- Y := 30.0 ;
- YA := 0.0625 ;
- IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := 30.0625" ) ;
- END IF ;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := 30.0625");
- END;
-
- RESULT;
-END C34004C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005a.ada b/gcc/testsuite/ada/acats/tests/c3/c34005a.ada
deleted file mode 100644
index 5da6fc9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005a.ada
+++ /dev/null
@@ -1,410 +0,0 @@
--- C34005A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES
--- WHOSE COMPONENT TYPE IS A NON-LIMITED, NON-DISCRETE TYPE.
-
--- HISTORY:
--- JRK 9/10/86 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005A IS
-
- SUBTYPE COMPONENT IS FLOAT;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT;
- SUBTYPE ARR IS ARRT (2 .. 4);
-
- X : T := (OTHERS => 2.0);
- W : PARENT (5 .. 7) := (OTHERS => 2.0);
- C : COMPONENT := 1.0;
- B : BOOLEAN := FALSE;
- U : ARR := (OTHERS => C);
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN (OTHERS => C);
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1.0;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (OTHERS => -1.0);
- END IDENT;
-
-BEGIN
- TEST ("C34005A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE");
-
- X := IDENT ((1.0, 2.0, 3.0));
- IF X /= (1.0, 2.0, 3.0) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= (1.0, 2.0, 3.0) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= (1.0, 2.0, 3.0) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := (1.0, 2.0, 3.0);
- END IF;
- IF T (W) /= (1.0, 2.0, 3.0) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= (1.0, 2.0, 3.0) OR
- PARENT (CREATE (2, 3, 4.0, X)) /= (4.0, 5.0) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF EQUAL (3, 3) THEN
- U := (1.0, 2.0, 3.0);
- END IF;
- IF T (U) /= (1.0, 2.0, 3.0) THEN
- FAILED ("INCORRECT CONVERSION FROM ARRAY");
- END IF;
-
- BEGIN
- IF ARR (X) /= (1.0, 2.0, 3.0) OR
- ARRT (CREATE (1, 2, 3.0, X)) /= (3.0, 4.0) THEN
- FAILED ("INCORRECT CONVERSION TO ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- IF IDENT ((1.0, 2.0, 3.0)) /= (1.0, 2.0, 3.0) OR
- X = (1.0, 2.0) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X (IDENT_INT (5)) /= 1.0 OR
- CREATE (2, 3, 4.0, X) (3) /= 5.0 THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X (IDENT_INT (7)) := 4.0;
- IF X /= (1.0, 2.0, 4.0) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- BEGIN
- X := IDENT ((1.0, 2.0, 3.0));
- IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2.0, 3.0) OR
- CREATE (1, 4, 4.0, X) (1 .. 3) /= (4.0, 5.0, 6.0) THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 4");
- END;
-
- X (IDENT_INT (5) .. IDENT_INT (6)) := (4.0, 5.0);
- IF X /= (4.0, 5.0, 3.0) THEN
- FAILED ("INCORRECT SLICE (ASSIGNMENT)");
- END IF;
-
- X := IDENT ((1.0, 2.0, 3.0));
- IF X = IDENT ((1.0, 2.0, 4.0)) OR X = (1.0, 2.0) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ((1.0, 2.0, 3.0)) OR NOT (X /= (2.0, 3.0)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR (1.0, 2.0) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT ((1.0, 2.0) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- BEGIN
- IF X & (4.0, 5.0, 6.0) /= (1.0, 2.0, 3.0, 4.0, 5.0, 6.0) OR
- CREATE (2, 3, 2.0, X) & (4.0, 5.0) /=
- (2.0, 3.0, 4.0, 5.0) THEN
- FAILED ("INCORRECT & (ARRAY, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 5");
- END;
-
- BEGIN
- IF X & 4.0 /= (1.0, 2.0, 3.0, 4.0) OR
- CREATE (2, 3, 2.0, X) & 4.0 /= (2.0, 3.0, 4.0) THEN
- FAILED ("INCORRECT & (ARRAY, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 6");
- END;
-
- BEGIN
- IF 4.0 & X /= (4.0, 1.0, 2.0, 3.0) OR
- 2.0 & CREATE (2, 3, 3.0, X) /= (2.0, 3.0, 4.0) THEN
- FAILED ("INCORRECT & (COMPONENT, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 7");
- END;
-
- IF EQUAL (3, 3) THEN
- C := 2.0;
- END IF;
-
- BEGIN
- IF C & 3.0 /= CREATE (2, 3, 2.0, X) THEN
- FAILED ("INCORRECT & (COMPONENT, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 8");
- END;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (T'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34005A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005c.ada b/gcc/testsuite/ada/acats/tests/c3/c34005c.ada
deleted file mode 100644
index 2af86af..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005c.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C34005C.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:
--- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
--- NON-LIMITED, NON-DISCRETE TYPE:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/10/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005C IS
-
- SUBTYPE COMPONENT IS FLOAT;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (OTHERS => 2.0);
- Y : S := (OTHERS => 2.0);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1.0;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34005C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (2, 3, 4.0, X) /= (4.0, 5.0) OR
- CREATE (2, 3, 4.0, Y) /= (4.0, 5.0) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION");
- END;
-
- IF X & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) OR
- Y & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) THEN
- FAILED ("INCORRECT &");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 5 OR T'LAST /= 7 OR
- S'FIRST /= 5 OR S'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := (1.0, 2.0, 3.0);
- Y := (1.0, 2.0, 3.0);
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := (1.0, 2.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1.0, 2.0)");
- IF X = (1.0, 2.0) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (1.0, 2.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := (1.0, 2.0)");
- END;
-
- BEGIN
- X := (1.0, 2.0, 3.0, 4.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (1.0, 2.0, 3.0, 4.0)");
- IF X = (1.0, 2.0, 3.0, 4.0) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (1.0, 2.0, 3.0, 4.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (1.0, 2.0, 3.0, 4.0)");
- END;
-
- BEGIN
- Y := (1.0, 2.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1.0, 2.0)");
- IF Y = (1.0, 2.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (1.0, 2.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := (1.0, 2.0)");
- END;
-
- BEGIN
- Y := (1.0, 2.0, 3.0, 4.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (1.0, 2.0, 3.0, 4.0)");
- IF Y = (1.0, 2.0, 3.0, 4.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (1.0, 2.0, 3.0, 4.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (1.0, 2.0, 3.0, 4.0)");
- END;
-
- RESULT;
-END C34005C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005d.ada b/gcc/testsuite/ada/acats/tests/c3/c34005d.ada
deleted file mode 100644
index b549be3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005d.ada
+++ /dev/null
@@ -1,425 +0,0 @@
--- C34005D.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES
--- WHOSE COMPONENT TYPE IS A DISCRETE TYPE.
-
--- HISTORY:
--- JRK 9/12/86 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005D IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT;
- SUBTYPE ARR IS ARRT (2 .. 4);
-
- X : T := (OTHERS => 2);
- W : PARENT (5 .. 7) := (OTHERS => 2);
- C : COMPONENT := 1;
- B : BOOLEAN := FALSE;
- U : ARR := (OTHERS => C);
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN (OTHERS => C);
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (OTHERS => -1);
- END IDENT;
-
-BEGIN
- TEST ("C34005D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A DISCRETE TYPE");
-
- X := IDENT ((1, 2, 3));
- IF X /= (1, 2, 3) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= (1, 2, 3) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= (1, 2, 3) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := (1, 2, 3);
- END IF;
- IF T (W) /= (1, 2, 3) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= (1, 2, 3) OR
- PARENT (CREATE (2, 3, 4, X)) /= (4, 5) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF EQUAL (3, 3) THEN
- U := (1, 2, 3);
- END IF;
- IF T (U) /= (1, 2, 3) THEN
- FAILED ("INCORRECT CONVERSION FROM ARRAY");
- END IF;
-
- BEGIN
- IF ARR (X) /= (1, 2, 3) OR
- ARRT (CREATE (1, 2, 3, X)) /= (3, 4) THEN
- FAILED ("INCORRECT CONVERSION TO ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- IF IDENT ((1, 2, 3)) /= (1, 2, 3) OR
- X = (1, 2) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X (IDENT_INT (5)) /= 1 OR
- CREATE (2, 3, 4, X) (3) /= 5 THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X (IDENT_INT (7)) := 4;
- IF X /= (1, 2, 4) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- BEGIN
- X := IDENT ((1, 2, 3));
- IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR
- CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 4");
- END;
-
- X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5);
- IF X /= (4, 5, 3) THEN
- FAILED ("INCORRECT SLICE (ASSIGNMENT)");
- END IF;
-
- X := IDENT ((1, 2, 3));
- IF X = IDENT ((1, 2, 4)) OR X = (1, 2) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ((1, 2, 3)) OR NOT (X /= (2, 3)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT ((1, 2, 3)) OR X < (1, 2) THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT ((1, 2, 3)) OR X > (1, 3) THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT ((1, 2, 2)) OR X <= (1, 2, 2, 4) THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF X >= IDENT ((1, 2, 4)) OR X >= (1, 2, 3, 1) THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR (1, 2) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT ((1, 2) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- BEGIN
- IF X & (4, 5, 6) /= (1, 2, 3, 4, 5, 6) OR
- CREATE (2, 3, 2, X) & (4, 5) /= (2, 3, 4, 5) THEN
- FAILED ("INCORRECT & (ARRAY, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 5");
- END;
-
- BEGIN
- IF X & 4 /= (1, 2, 3, 4) OR
- CREATE (2, 3, 2, X) & 4 /= (2, 3, 4) THEN
- FAILED ("INCORRECT & (ARRAY, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 6");
- END;
-
- BEGIN
- IF 4 & X /= (4, 1, 2, 3) OR
- 2 & CREATE (2, 3, 3, X) /= (2, 3, 4) THEN
- FAILED ("INCORRECT & (COMPONENT, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 7");
- END;
-
- IF EQUAL (3, 3) THEN
- C := 2;
- END IF;
-
- BEGIN
- IF C & 3 /= CREATE (2, 3, 2, X) THEN
- FAILED ("INCORRECT & (COMPONENT, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 8");
- END;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (T'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34005D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005f.ada b/gcc/testsuite/ada/acats/tests/c3/c34005f.ada
deleted file mode 100644
index 1971bf4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005f.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C34005F.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:
--- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
--- DISCRETE TYPE:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/12/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005F IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (OTHERS => 2);
- Y : S := (OTHERS => 2);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34005F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A DISCRETE TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (2, 3, 4, X) /= (4, 5) OR
- CREATE (2, 3, 4, Y) /= (4, 5) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION");
- END;
-
- IF X & (3, 4) /= (2, 2, 2, 3, 4) OR
- Y & (3, 4) /= (2, 2, 2, 3, 4) THEN
- FAILED ("INCORRECT &");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 5 OR T'LAST /= 7 OR
- S'FIRST /= 5 OR S'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := (1, 2, 3);
- Y := (1, 2, 3);
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := (1, 2);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1, 2)");
- IF X = (1, 2) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (1, 2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := (1, 2)");
- END;
-
- BEGIN
- X := (1, 2, 3, 4);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (1, 2, 3, 4)");
- IF X = (1, 2, 3, 4) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (1, 2, 3, 4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (1, 2, 3, 4)");
- END;
-
- BEGIN
- Y := (1, 2);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1, 2)");
- IF Y = (1, 2) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (1, 2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := (1, 2)");
- END;
-
- BEGIN
- Y := (1, 2, 3, 4);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (1, 2, 3, 4)");
- IF Y = (1, 2, 3, 4) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (1, 2, 3, 4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (1, 2, 3, 4)");
- END;
-
- RESULT;
-END C34005F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005g.ada b/gcc/testsuite/ada/acats/tests/c3/c34005g.ada
deleted file mode 100644
index fd8f8ff..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005g.ada
+++ /dev/null
@@ -1,423 +0,0 @@
--- C34005G.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES
--- WHOSE COMPONENT TYPE IS A CHARACTER TYPE.
-
--- HISTORY:
--- JRK 9/15/86 CREATED ORIGINAL TEST.
--- RJW 8/21/89 MODIFIED CHECKS FOR OBJECT AND TYPE SIZES.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005G IS
-
- TYPE COMPONENT IS NEW CHARACTER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT;
- SUBTYPE ARR IS ARRT (2 .. 4);
-
- X : T := (OTHERS => 'B');
- W : PARENT (5 .. 7) := (OTHERS => 'B');
- C : COMPONENT := 'A';
- B : BOOLEAN := FALSE;
- U : ARR := (OTHERS => C);
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN (OTHERS => C);
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := COMPONENT'SUCC (B);
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (OTHERS => '-');
- END IDENT;
-
-BEGIN
- TEST ("C34005G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A CHARACTER TYPE");
-
- X := IDENT ("ABC");
- IF X /= "ABC" THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= "ABC" THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= "ABC" THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := "ABC";
- END IF;
- IF T (W) /= "ABC" THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= "ABC" OR
- PARENT (CREATE (2, 3, 'D', X)) /= "DE" THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF EQUAL (3, 3) THEN
- U := "ABC";
- END IF;
- IF T (U) /= "ABC" THEN
- FAILED ("INCORRECT CONVERSION FROM ARRAY");
- END IF;
-
- BEGIN
- IF ARR (X) /= "ABC" OR
- ARRT (CREATE (1, 2, 'C', X)) /= "CD" THEN
- FAILED ("INCORRECT CONVERSION TO ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- IF IDENT ("ABC") /= ('A', 'B', 'C') OR
- X = "AB" THEN
- FAILED ("INCORRECT STRING LITERAL");
- END IF;
-
- IF IDENT (('A', 'B', 'C')) /= "ABC" OR
- X = ('A', 'B') THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X (IDENT_INT (5)) /= 'A' OR
- CREATE (2, 3, 'D', X) (3) /= 'E' THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X (IDENT_INT (7)) := 'D';
- IF X /= "ABD" THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- BEGIN
- X := IDENT ("ABC");
- IF X (IDENT_INT (6) .. IDENT_INT (7)) /= "BC" OR
- CREATE (1, 4, 'D', X) (1 .. 3) /= "DEF" THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 4");
- END;
-
- X (IDENT_INT (5) .. IDENT_INT (6)) := "DE";
- IF X /= "DEC" THEN
- FAILED ("INCORRECT SLICE (ASSIGNMENT)");
- END IF;
-
- X := IDENT ("ABC");
- IF X = IDENT ("ABD") OR X = "AB" THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ("ABC") OR NOT (X /= "BC") THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT ("ABC") OR X < "AB" THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT ("ABC") OR X > "AC" THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT ("ABB") OR X <= "ABBD" THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF X >= IDENT ("ABD") OR X >= "ABCA" THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR "AB" IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT ("AB" NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- BEGIN
- IF X & "DEF" /= "ABCDEF" OR
- CREATE (2, 3, 'B', X) & "DE" /= "BCDE" THEN
- FAILED ("INCORRECT & (ARRAY, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 5");
- END;
-
- BEGIN
- IF X & 'D' /= "ABCD" OR
- CREATE (2, 3, 'B', X) & 'D' /= "BCD" THEN
- FAILED ("INCORRECT & (ARRAY, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 6");
- END;
-
- BEGIN
- IF 'D' & X /= "DABC" OR
- 'B' & CREATE (2, 3, 'C', X) /= "BCD" THEN
- FAILED ("INCORRECT & (COMPONENT, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 7");
- END;
-
- IF EQUAL (3, 3) THEN
- C := 'B';
- END IF;
-
- BEGIN
- IF C & 'C' /= CREATE (2, 3, 'B', X) THEN
- FAILED ("INCORRECT & (COMPONENT, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 8");
- END;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (T'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- RESULT;
-END C34005G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005i.ada b/gcc/testsuite/ada/acats/tests/c3/c34005i.ada
deleted file mode 100644
index 580880e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005i.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C34005I.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:
--- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
--- CHARACTER TYPE:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/15/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005I IS
-
- TYPE COMPONENT IS NEW CHARACTER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (OTHERS => 'B');
- Y : S := (OTHERS => 'B');
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := COMPONENT'SUCC (B);
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34005I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A CHARACTER TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (2, 3, 'D', X) /= "DE" OR
- CREATE (2, 3, 'D', Y) /= "DE" THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION");
- END;
-
- IF X & "CD" /= "BBBCD" OR
- Y & "CD" /= "BBBCD" THEN
- FAILED ("INCORRECT &");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 5 OR T'LAST /= 7 OR
- S'FIRST /= 5 OR S'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := "ABC";
- Y := "ABC";
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := "AB";
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := ""AB""");
- IF X = "AB" THEN -- USE X.
- COMMENT ("X ALTERED -- X := ""AB""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := ""AB""");
- END;
-
- BEGIN
- X := "ABCD";
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := ""ABCD""");
- IF X = "ABCD" THEN -- USE X.
- COMMENT ("X ALTERED -- X := ""ABCD""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := ""ABCD""");
- END;
-
- BEGIN
- Y := "AB";
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := ""AB""");
- IF Y = "AB" THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := ""AB""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := ""AB""");
- END;
-
- BEGIN
- Y := "ABCD";
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := ""ABCD""");
- IF Y = "ABCD" THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := ""ABCD""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := ""ABCD""");
- END;
-
- RESULT;
-END C34005I;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005j.ada b/gcc/testsuite/ada/acats/tests/c3/c34005j.ada
deleted file mode 100644
index 67910aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005j.ada
+++ /dev/null
@@ -1,482 +0,0 @@
--- C34005J.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES
--- WHOSE COMPONENT TYPE IS A BOOLEAN TYPE.
-
--- HISTORY:
--- JRK 9/16/86 CREATED ORIGINAL TEST.
--- RJW 8/21/89 MODIFIED CHECKS FOR TYPE AND OBJECT SIZES.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005J IS
-
- SUBTYPE COMPONENT IS BOOLEAN;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT;
- SUBTYPE ARR IS ARRT (2 .. 4);
-
- X : T := (OTHERS => TRUE);
- W : PARENT (5 .. 7) := (OTHERS => TRUE);
- C : COMPONENT := FALSE;
- B : BOOLEAN := FALSE;
- U : ARR := (OTHERS => C);
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN (OTHERS => C);
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := NOT B;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (OTHERS => FALSE);
- END IDENT;
-
-BEGIN
- TEST ("C34005J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A BOOLEAN TYPE");
-
- X := IDENT ((TRUE, FALSE, TRUE));
- IF X /= (TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= (TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= (TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := (TRUE, FALSE, TRUE);
- END IF;
- IF T (W) /= (TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= (TRUE, FALSE, TRUE) OR
- PARENT (CREATE (2, 3, FALSE, X)) /= (FALSE, TRUE) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF EQUAL (3, 3) THEN
- U := (TRUE, FALSE, TRUE);
- END IF;
- IF T (U) /= (TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT CONVERSION FROM ARRAY");
- END IF;
-
- BEGIN
- IF ARR (X) /= (TRUE, FALSE, TRUE) OR
- ARRT (CREATE (1, 2, TRUE, X)) /= (TRUE, FALSE) THEN
- FAILED ("INCORRECT CONVERSION TO ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- IF IDENT ((TRUE, FALSE, TRUE)) /= (TRUE, FALSE, TRUE) OR
- X = (TRUE, FALSE) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X (IDENT_INT (5)) /= TRUE OR
- CREATE (2, 3, FALSE, X) (3) /= TRUE THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X (IDENT_INT (7)) := FALSE;
- IF X /= (TRUE, FALSE, FALSE) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- BEGIN
- X := IDENT ((TRUE, FALSE, TRUE));
- IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (FALSE, TRUE) OR
- CREATE (1, 4, FALSE, X) (1 .. 3) /=
- (FALSE, TRUE, FALSE) THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 4");
- END;
-
- X (IDENT_INT (5) .. IDENT_INT (6)) := (FALSE, TRUE);
- IF X /= (FALSE, TRUE, TRUE) THEN
- FAILED ("INCORRECT SLICE (ASSIGNMENT)");
- END IF;
-
- BEGIN
- X := IDENT ((TRUE, FALSE, TRUE));
- IF NOT X /= (FALSE, TRUE, FALSE) OR
- NOT CREATE (2, 3, FALSE, X) /= (TRUE, FALSE) THEN
- FAILED ("INCORRECT ""NOT""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 5");
- END;
-
- BEGIN
- IF (X AND IDENT ((TRUE, TRUE, FALSE))) /=
- (TRUE, FALSE, FALSE) OR
- (CREATE (1, 4, FALSE, X) AND
- (FALSE, FALSE, TRUE, TRUE)) /=
- (FALSE, FALSE, FALSE, TRUE) THEN
- FAILED ("INCORRECT ""AND""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 6");
- END;
-
- BEGIN
- IF (X OR IDENT ((TRUE, FALSE, FALSE))) /=
- (TRUE, FALSE, TRUE) OR
- (CREATE (1, 4, FALSE, X) OR (FALSE, FALSE, TRUE, TRUE)) /=
- (FALSE, TRUE, TRUE, TRUE) THEN
- FAILED ("INCORRECT ""OR""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 7");
- END;
-
- BEGIN
- IF (X XOR IDENT ((TRUE, TRUE, FALSE))) /=
- (FALSE, TRUE, TRUE) OR
- (CREATE (1, 4, FALSE, X) XOR
- (FALSE, FALSE, TRUE, TRUE)) /=
- (FALSE, TRUE, TRUE, FALSE) THEN
- FAILED ("INCORRECT ""XOR""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 8");
- END;
-
- IF X = IDENT ((TRUE, FALSE, FALSE)) OR X = (TRUE, FALSE) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ((TRUE, FALSE, TRUE)) OR
- NOT (X /= (FALSE, TRUE)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF X < IDENT ((TRUE, FALSE, TRUE)) OR X < (TRUE, FALSE) THEN
- FAILED ("INCORRECT <");
- END IF;
-
- IF X > IDENT ((TRUE, FALSE, TRUE)) OR X > (TRUE, TRUE) THEN
- FAILED ("INCORRECT >");
- END IF;
-
- IF X <= IDENT ((TRUE, FALSE, FALSE)) OR
- X <= (TRUE, FALSE, FALSE, TRUE) THEN
- FAILED ("INCORRECT <=");
- END IF;
-
- IF X >= IDENT ((TRUE, TRUE, FALSE)) OR
- X >= (TRUE, FALSE, TRUE, FALSE) THEN
- FAILED ("INCORRECT >=");
- END IF;
-
- IF NOT (X IN T) OR (TRUE, FALSE) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT ((TRUE, FALSE) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- BEGIN
- IF X & (FALSE, TRUE, FALSE) /=
- (TRUE, FALSE, TRUE, FALSE, TRUE, FALSE) OR
- CREATE (2, 3, FALSE, X) & (FALSE, TRUE) /=
- (FALSE, TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT & (ARRAY, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 9");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 9");
- END;
-
- BEGIN
- IF X & FALSE /= (TRUE, FALSE, TRUE, FALSE) OR
- CREATE (2, 3, FALSE, X) & FALSE /=
- (FALSE, TRUE, FALSE) THEN
- FAILED ("INCORRECT & (ARRAY, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 10");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 10");
- END;
-
- BEGIN
- IF FALSE & X /= (FALSE, TRUE, FALSE, TRUE) OR
- FALSE & CREATE (2, 3, TRUE, X) /=
- (FALSE, TRUE, FALSE) THEN
- FAILED ("INCORRECT & (COMPONENT, ARRAY)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 11");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 11");
- END;
-
- IF EQUAL (3, 3) THEN
- C := FALSE;
- END IF;
-
- BEGIN
- IF C & TRUE /= CREATE (2, 3, FALSE, X) THEN
- FAILED ("INCORRECT & (COMPONENT, COMPONENT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 12");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 12");
- END;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (T'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- RESULT;
-END C34005J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005l.ada b/gcc/testsuite/ada/acats/tests/c3/c34005l.ada
deleted file mode 100644
index 2aba733..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005l.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C34005L.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:
--- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
--- BOOLEAN TYPE:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/16/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005L IS
-
- SUBTYPE COMPONENT IS BOOLEAN;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (OTHERS => TRUE);
- Y : S := (OTHERS => TRUE);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := NOT B;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34005L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A BOOLEAN TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (2, 3, FALSE, X) /= (FALSE, TRUE) OR
- CREATE (2, 3, FALSE, Y) /= (FALSE, TRUE) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION");
- END;
-
- IF X & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) OR
- Y & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) THEN
- FAILED ("INCORRECT &");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 5 OR T'LAST /= 7 OR
- S'FIRST /= 5 OR S'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := (TRUE, FALSE, TRUE);
- Y := (TRUE, FALSE, TRUE);
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := (TRUE, FALSE);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (TRUE, FALSE)");
- IF X = (TRUE, FALSE) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (TRUE, FALSE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- X := (TRUE, FALSE)");
- END;
-
- BEGIN
- X := (TRUE, FALSE, TRUE, FALSE);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (TRUE, FALSE, TRUE, FALSE)");
- IF X = (TRUE, FALSE, TRUE, FALSE) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (TRUE, FALSE, TRUE, FALSE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (TRUE, FALSE, TRUE, FALSE)");
- END;
-
- BEGIN
- Y := (TRUE, FALSE);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (TRUE, FALSE)");
- IF Y = (TRUE, FALSE) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (TRUE, FALSE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- Y := (TRUE, FALSE)");
- END;
-
- BEGIN
- Y := (TRUE, FALSE, TRUE, FALSE);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (TRUE, FALSE, TRUE, FALSE)");
- IF Y = (TRUE, FALSE, TRUE, FALSE) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (TRUE, FALSE, TRUE, FALSE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (TRUE, FALSE, TRUE, FALSE)");
- END;
-
- RESULT;
-END C34005L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005m.ada b/gcc/testsuite/ada/acats/tests/c3/c34005m.ada
deleted file mode 100644
index 51d3192..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005m.ada
+++ /dev/null
@@ -1,353 +0,0 @@
--- C34005M.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE
--- COMPONENT TYPE IS A NON-LIMITED TYPE.
-
--- HISTORY:
--- JRK 9/17/86 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005M IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 10;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
- COMPONENT;
-
- FUNCTION CREATE ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- COMPONENT;
-
- SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4);
-
- X : T := (OTHERS => (OTHERS => 2));
- W : PARENT (4 .. 5, 6 .. 8) := (OTHERS => (OTHERS => 2));
- C : COMPONENT := 1;
- B : BOOLEAN := FALSE;
- U : ARR := (OTHERS => (OTHERS => C));
- N : CONSTANT := 2;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN (OTHERS => (OTHERS => C));
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F1 .. L1, F2 .. L2);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- A (I, J) := B;
- B := B + 1;
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (OTHERS => (OTHERS => -1));
- END IDENT;
-
-BEGIN
- TEST ("C34005M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A NON-LIMITED TYPE");
-
- X := IDENT (((1, 2, 3), (4, 5, 6)));
- IF X /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := ((1, 2, 3), (4, 5, 6));
- END IF;
- IF T (W) /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= ((1, 2, 3), (4, 5, 6)) OR
- PARENT (CREATE (6, 9, 2, 3, 4, X)) /=
- ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF EQUAL (3, 3) THEN
- U := ((1, 2, 3), (4, 5, 6));
- END IF;
- IF T (U) /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT CONVERSION FROM ARRAY");
- END IF;
-
- BEGIN
- IF ARR (X) /= ((1, 2, 3), (4, 5, 6)) OR
- ARRT (CREATE (7, 9, 2, 5, 3, X)) /=
- ((3, 4, 5, 6), (7, 8, 9, 10), (11, 12, 13, 14)) THEN
- FAILED ("INCORRECT CONVERSION TO ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- IF IDENT (((1, 2, 3), (4, 5, 6))) /= ((1, 2, 3), (4, 5, 6)) OR
- X = ((1, 2), (3, 4), (5, 6)) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR
- CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X (IDENT_INT (5), IDENT_INT (8)) := 7;
- IF X /= ((1, 2, 3), (4, 5, 7)) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- X := IDENT (((1, 2, 3), (4, 5, 6)));
- IF X = IDENT (((1, 2, 3), (4, 5, 7))) OR
- X = ((1, 2), (4, 5)) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT (((1, 2, 3), (4, 5, 6))) OR
- NOT (X /= ((1, 2, 3), (4, 5, 6), (7, 8, 9))) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR ((1, 2), (3, 4)) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR
- NOT (((1, 2, 3), (4, 5, 6), (7, 8, 9)) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 4 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 4 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 4 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 5 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 8 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 2 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 2 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 2 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, T'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, X'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, V'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34005M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005o.ada b/gcc/testsuite/ada/acats/tests/c3/c34005o.ada
deleted file mode 100644
index a45d5dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005o.ada
+++ /dev/null
@@ -1,277 +0,0 @@
--- C34005O.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:
--- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE
--- IS A NON-LIMITED TYPE:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/17/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005O IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 10;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
- COMPONENT;
-
- FUNCTION CREATE ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (OTHERS => (OTHERS => 2));
- Y : S := (OTHERS => (OTHERS => 2));
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F1 .. L1, F2 .. L2);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- A (I, J) := B;
- B := B + 1;
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A NON-LIMITED TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (6, 9, 2, 3, 1, X) /=
- ((1, 2), (3, 4), (5, 6), (7, 8)) OR
- CREATE (6, 9, 2, 3, 1, Y) /=
- ((1, 2), (3, 4), (5, 6), (7, 8)) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION");
- END;
-
- IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR
- ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 4 OR T'LAST /= 5 OR
- S'FIRST /= 4 OR S'LAST /= 5 OR
- T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR
- S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := ((1, 2, 3), (4, 5, 6));
- Y := ((1, 2, 3), (4, 5, 6));
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := (4 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (4 => (6 .. 8 => 0))");
- IF X = (4 => (6 .. 8 => 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := (4 => (6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (4 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- X := (4 .. 6 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (4 .. 6 => (6 .. 8 => 0))");
- IF X = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := (4 .. 6 => (6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (4 .. 6 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- X := (4 .. 5 => (6 .. 7 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (4 .. 5 => (6 .. 7 => 0))");
- IF X = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := (4 .. 5 => (6 .. 7 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (4 .. 5 => (6 .. 7 => 0))");
- END;
-
- BEGIN
- X := (4 .. 5 => (6 .. 9 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (4 .. 5 => (6 .. 9 => 0))");
- IF X = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := (4 .. 5 => (6 .. 9 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (4 .. 5 => (6 .. 9 => 0))");
- END;
-
- BEGIN
- Y := (4 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (4 => (6 .. 8 => 0))");
- IF Y = (4 => (6 .. 8 => 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := (4 => (6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (4 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- Y := (4 .. 6 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (4 .. 6 => (6 .. 8 => 0))");
- IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := (4 .. 6 => (6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (4 .. 6 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- Y := (4 .. 5 => (6 .. 7 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (4 .. 5 => (6 .. 7 => 0))");
- IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := (4 .. 5 => (6 .. 7 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (4 .. 5 => (6 .. 7 => 0))");
- END;
-
- BEGIN
- Y := (4 .. 5 => (6 .. 9 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (4 .. 5 => (6 .. 9 => 0))");
- IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := (4 .. 5 => (6 .. 9 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (4 .. 5 => (6 .. 9 => 0))");
- END;
-
- RESULT;
-END C34005O;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005p.ada b/gcc/testsuite/ada/acats/tests/c3/c34005p.ada
deleted file mode 100644
index 31e67a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005p.ada
+++ /dev/null
@@ -1,405 +0,0 @@
--- C34005P.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE
--- COMPONENT TYPE IS A LIMITED TYPE.
-
--- HISTORY:
--- JRK 08/17/87 CREATED ORIGINAL TEST.
--- VCL 07/01/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
--- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
--- SIZES. ADDED EXCEPTION HANDLERS TO CATCH INCORRECT
--- TYPE CONVERSIONS TO DERIVED SUBTYPES.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
--- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
--- SUPPORTING CODE.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005P IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
- C2 : CONSTANT LP;
- C3 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
- C6 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
- C2 : CONSTANT LP := 2;
- C3 : CONSTANT LP := 3;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
- C6 : CONSTANT LP := 6;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT;
-
- FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- X : T;
- W : PARENT (5 .. 7);
- C : COMPONENT;
- B : BOOLEAN := FALSE;
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- RESULT : T;
- BEGIN
- FOR I IN RESULT'RANGE LOOP
- ASSIGN (RESULT (I), C);
- END LOOP;
- RETURN RESULT;
- END V;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER (X);
- END VALUE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT;
- BEGIN
- ASSIGN (B, C);
- FOR I IN F .. L LOOP
- ASSIGN (A (I), B);
- ASSIGN (B, CREATE (VALUE (B) + 1));
- END LOOP;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- IF NOT EQUAL (X (I),
- Y (I - X'FIRST + Y'FIRST)) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
- FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS
- RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1);
- BEGIN
- ASSIGN (RESULT (INDEX'FIRST ), X);
- ASSIGN (RESULT (INDEX'FIRST + 1), Y);
- RETURN RESULT;
- END AGGR;
-
- FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT IS
- RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 2);
- BEGIN
- ASSIGN (RESULT (INDEX'FIRST ), X);
- ASSIGN (RESULT (INDEX'FIRST + 1), Y);
- ASSIGN (RESULT (INDEX'FIRST + 2), Z);
- RETURN RESULT;
- END AGGR;
-
- END PKG_P;
-
-BEGIN
- TEST ("C34005P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A LIMITED TYPE");
-
- ASSIGN (X (IDENT_INT (5)), CREATE (1));
- ASSIGN (X (IDENT_INT (6)), CREATE (2));
- ASSIGN (X (IDENT_INT (7)), CREATE (3));
-
- ASSIGN (W (5), CREATE (1));
- ASSIGN (W (6), CREATE (2));
- ASSIGN (W (7), CREATE (3));
-
- ASSIGN (C, CREATE (2));
-
- IF NOT EQUAL (T'(X), AGGR (C1, C2, C3)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
-
- BEGIN
- IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)),
- AGGR (C4, C5)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
- "VALUES OUTSIDE OF THE SUBTYPE T - 1");
- END;
-
- IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
-
- BEGIN
- IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
- AGGR (C2, C3)) OR
- NOT EQUAL (CREATE (1, 4, C4, X)(1..3),
- AGGR (C4, C5, C6)) THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES");
- END;
-
- IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 7 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (T'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF X'SIZE < T'SIZE THEN
- COMMENT ("X'SIZE < T'SIZE");
- ELSIF X'SIZE = T'SIZE THEN
- COMMENT ("X'SIZE = T'SIZE");
- ELSE
- COMMENT ("X'SIZE > T'SIZE");
- END IF;
-
- RESULT;
-END C34005P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005r.ada b/gcc/testsuite/ada/acats/tests/c3/c34005r.ada
deleted file mode 100644
index 8b36d59..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005r.ada
+++ /dev/null
@@ -1,346 +0,0 @@
--- C34005R.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:
--- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
--- LIMITED TYPE:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
--- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
--- IS CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
--- ALSO IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 08/19/87 CREATED ORIGINAL TEST.
--- VCL 07/01/88 ADDED EXCEPTION HANDLERS TO CATCH INCORRECT TYPE
--- CONVERSIONS TO DERIVED SUBTYPES.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005R IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
- C2 : CONSTANT LP;
- C3 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
- C2 : CONSTANT LP := 2;
- C3 : CONSTANT LP := 3;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 100;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
-
- FUNCTION CREATE ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT;
-
- FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER (X);
- END VALUE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( F, L : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F .. L);
- B : COMPONENT;
- BEGIN
- ASSIGN (B, C);
- FOR I IN F .. L LOOP
- ASSIGN (A (I), B);
- ASSIGN (B, CREATE (VALUE (B) + 1));
- END LOOP;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- IF NOT EQUAL (X (I),
- Y (I - X'FIRST + Y'FIRST)) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
- FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS
- RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1);
- BEGIN
- ASSIGN (RESULT (INDEX'FIRST ), X);
- ASSIGN (RESULT (INDEX'FIRST + 1), Y);
- RETURN RESULT;
- END AGGR;
-
- FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT IS
- RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 3);
- BEGIN
- ASSIGN (RESULT (INDEX'FIRST ), W);
- ASSIGN (RESULT (INDEX'FIRST + 1), X);
- ASSIGN (RESULT (INDEX'FIRST + 2), Y);
- ASSIGN (RESULT (INDEX'FIRST + 3), Z);
- RETURN RESULT;
- END AGGR;
-
- END PKG_P;
-
- PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- ASSIGN (X (I), Y (I));
- END LOOP;
- END ASSIGN;
-
- PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- ASSIGN (X (I), Y (I));
- END LOOP;
- END ASSIGN;
-
-BEGIN
- TEST ("C34005R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A LIMITED TYPE");
-
- ASSIGN (X (IDENT_INT (5)), CREATE (2));
- ASSIGN (X (IDENT_INT (6)), CREATE (3));
- ASSIGN (X (IDENT_INT (7)), CREATE (4));
-
- ASSIGN (Y (5), C2);
- ASSIGN (Y (6), C3);
- ASSIGN (Y (7), C4);
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF NOT EQUAL (CREATE (2, 3, C4, X), AGGR (C4, C5)) THEN
- FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " &
- "OF THE SUBTYPE T");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
- "VALUES OUTSIDE OF THE SUBTYPE T");
- END;
-
- BEGIN
- IF NOT EQUAL (CREATE (2, 3, C4, Y), AGGR (C4, C5)) THEN
- FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " &
- "OF THE SUBTYPE S");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
- "VALUES OUTSIDE OF THE SUBTYPE S");
- END;
-
- BEGIN
- IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
- AGGR (C3, C4)) THEN
- FAILED ("INCORRECT SLICE OF X (VALUE)");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF X");
- END;
-
- BEGIN
- IF NOT EQUAL (AGGR (C3, C4),
- Y(IDENT_INT (6)..IDENT_INT (7))) THEN
- FAILED ("INCORRECT SLICE OF Y (VALUE)");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF Y");
- END;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 5 OR T'LAST /= 7 OR
- S'FIRST /= 5 OR S'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- ASSIGN (X, CREATE (5, 7, C1, X));
- ASSIGN (Y, CREATE (5, 7, C1, Y));
- IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
- END;
-
- BEGIN
- ASSIGN (X, AGGR (C1, C2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, AGGR (C1, C2))");
- IF EQUAL (X, AGGR (C1, C2)) THEN -- USE X.
- COMMENT ("X ALTERED -- ASSIGN (X, AGGR (C1, C2))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, AGGR (C1, C2))");
- END;
-
- BEGIN
- ASSIGN (X, AGGR (C1, C2, C3, C4));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, AGGR (C1, C2, C3, C4))");
- IF EQUAL (X, AGGR (C1, C2, C3, C4)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, AGGR (C1, C2, C3, C4))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, AGGR (C1, C2, C3, C4))");
- END;
-
- BEGIN
- ASSIGN (Y, AGGR (C1, C2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, AGGR (C1, C2))");
- IF EQUAL (Y, AGGR (C1, C2)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- ASSIGN (Y, AGGR (C1, C2))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, AGGR (C1, C2))");
- END;
-
- BEGIN
- ASSIGN (Y, AGGR (C1, C2, C3, C4));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
- IF EQUAL (Y, AGGR (C1, C2, C3, C4)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, AGGR (C1, C2, C3, C4))");
- END;
-
- RESULT;
-END C34005R;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005s.ada b/gcc/testsuite/ada/acats/tests/c3/c34005s.ada
deleted file mode 100644
index 5158166..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005s.ada
+++ /dev/null
@@ -1,404 +0,0 @@
--- C34005S.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE
--- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 1 OF 2
--- TESTS WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST
--- C34005V.
-
--- HISTORY:
--- JRK 08/20/87 CREATED ORIGINAL TEST.
--- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34005S.ADA AND
--- C34005V.ADA
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005S IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
- C2 : CONSTANT LP;
- C3 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
- C6 : CONSTANT LP;
- C7 : CONSTANT LP;
- C8 : CONSTANT LP;
- C9 : CONSTANT LP;
- C10 : CONSTANT LP;
- C11 : CONSTANT LP;
- C12 : CONSTANT LP;
- C13 : CONSTANT LP;
- C14 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
- C2 : CONSTANT LP := 2;
- C3 : CONSTANT LP := 3;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
- C6 : CONSTANT LP := 6;
- C7 : CONSTANT LP := 7;
- C8 : CONSTANT LP := 8;
- C9 : CONSTANT LP := 9;
- C10 : CONSTANT LP := 10;
- C11 : CONSTANT LP := 11;
- C12 : CONSTANT LP := 12;
- C13 : CONSTANT LP := 13;
- C14 : CONSTANT LP := 14;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 10;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
- COMPONENT;
-
- FUNCTION CREATE ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- COMPONENT;
-
- SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4);
-
- X : T;
- W : PARENT (4 .. 5, 6 .. 8);
- C : COMPONENT;
- B : BOOLEAN := FALSE;
- U : ARR;
- N : CONSTANT := 2;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- RESULT : T;
- BEGIN
- FOR I IN RESULT'RANGE LOOP
- FOR J IN RESULT'RANGE(2) LOOP
- ASSIGN (RESULT (I, J), C);
- END LOOP;
- END LOOP;
- RETURN RESULT;
- END V;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER (X);
- END VALUE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F1 .. L1, F2 .. L2);
- B : COMPONENT;
- BEGIN
- ASSIGN (B, C);
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- ASSIGN (A (I, J), B);
- ASSIGN (B, CREATE (VALUE (B) + 1));
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH OR
- X'LENGTH(2) /= Y'LENGTH(2) THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- IF NOT EQUAL (X (I, J),
- Y (I - X'FIRST + Y'FIRST,
- J - X'FIRST(2) +
- Y'FIRST(2))) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
- END PKG_P;
-
- FUNCTION EQUAL (X, Y : ARRT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH OR X'LENGTH(2) /= Y'LENGTH(2) THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- IF NOT EQUAL (X (I, J),
- Y (I - X'FIRST + Y'FIRST,
- J - X'FIRST(2) +
- Y'FIRST(2))) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
-BEGIN
- TEST ("C34005S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A LIMITED TYPE. THIS TEST IS PART " &
- "1 OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " &
- "SECOND PART IS IN TEST C34005V");
-
- ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1));
- ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2));
- ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6));
-
- ASSIGN (W (4, 6), CREATE (1));
- ASSIGN (W (4, 7), CREATE (2));
- ASSIGN (W (4, 8), CREATE (3));
- ASSIGN (W (5, 6), CREATE (4));
- ASSIGN (W (5, 7), CREATE (5));
- ASSIGN (W (5, 8), CREATE (6));
-
- ASSIGN (C, CREATE (2));
-
- ASSIGN (U (8, 2), CREATE (1));
- ASSIGN (U (8, 3), CREATE (2));
- ASSIGN (U (8, 4), CREATE (3));
- ASSIGN (U (9, 2), CREATE (4));
- ASSIGN (U (9, 3), CREATE (5));
- ASSIGN (U (9, 4), CREATE (6));
-
- IF NOT EQUAL (X (IDENT_INT (4), IDENT_INT (6)), C1) OR
- NOT EQUAL (CREATE (6, 9, 2, 3, C4, X) (9, 3), C11) THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF T'FIRST /= 4 THEN
- FAILED ("INCORRECT TYPE'FIRST");
- END IF;
-
- IF X'FIRST /= 4 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 4 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF T'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT TYPE'FIRST (N)");
- END IF;
-
- IF X'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF T'LAST /= 5 THEN
- FAILED ("INCORRECT TYPE'LAST");
- END IF;
-
- IF X'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF T'LAST (N) /= 8 THEN
- FAILED ("INCORRECT TYPE'LAST (N)");
- END IF;
-
- IF X'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF T'LENGTH /= 2 THEN
- FAILED ("INCORRECT TYPE'LENGTH");
- END IF;
-
- IF X'LENGTH /= 2 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 2 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF T'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT TYPE'LENGTH (N)");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : PARENT (T'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT TYPE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (X'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (V'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, T'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT TYPE'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, X'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : PARENT (1 .. 2, V'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34005S;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005u.ada b/gcc/testsuite/ada/acats/tests/c3/c34005u.ada
deleted file mode 100644
index ed77f3b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005u.ada
+++ /dev/null
@@ -1,408 +0,0 @@
--- C34005U.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:
--- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS
--- A LIMITED TYPE:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
--- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
--- IS CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
--- ALSO IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 08/21/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005U IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
- C2 : CONSTANT LP;
- C3 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
- C6 : CONSTANT LP;
- C7 : CONSTANT LP;
- C8 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
- C2 : CONSTANT LP := 2;
- C3 : CONSTANT LP := 3;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
- C6 : CONSTANT LP := 6;
- C7 : CONSTANT LP := 7;
- C8 : CONSTANT LP := 8;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 10;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
- COMPONENT;
-
- FUNCTION CREATE ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
- RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER (X);
- END VALUE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F1 .. L1, F2 .. L2);
- B : COMPONENT;
- BEGIN
- ASSIGN (B, C);
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- ASSIGN (A (I, J), B);
- ASSIGN (B, CREATE (VALUE (B) + 1));
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH OR
- X'LENGTH(2) /= Y'LENGTH(2) THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- IF NOT EQUAL (X (I, J),
- Y (I - X'FIRST + Y'FIRST,
- J - X'FIRST(2) +
- Y'FIRST(2))) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
- RETURN PARENT IS
- X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3,
- INDEX'FIRST .. INDEX'FIRST + 1);
- BEGIN
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F);
- ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G);
- ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H);
- RETURN X;
- END AGGR;
-
- END PKG_P;
-
- PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- ASSIGN (X (I, J), Y (I, J));
- END LOOP;
- END LOOP;
- END ASSIGN;
-
- PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- ASSIGN (X (I, J), Y (I, J));
- END LOOP;
- END LOOP;
- END ASSIGN;
-
-BEGIN
- TEST ("C34005U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A LIMITED TYPE");
-
- FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- ASSIGN (X (I, J), C2);
- ASSIGN (Y (I, J), C2);
- END LOOP;
- END LOOP;
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
- BEGIN
- IF NOT EQUAL (CREATE (6, 9, 2, 3, C1, X),
- AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) OR
- NOT EQUAL (CREATE (6, 9, 2, 3, C1, Y),
- AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " &
- "TYPE VALUES OUTSIDE THE SUBTYPE");
- WHEN OTHERS =>
- FAILED ("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " &
- "VALUES OUTSIDE THE SUBTYPE");
- END;
-
- IF AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN T OR
- AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF T'FIRST /= 4 OR T'LAST /= 5 OR
- S'FIRST /= 4 OR S'LAST /= 5 OR
- T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR
- S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- ASSIGN (X, CREATE (4, 5, 6, 8, C1, X));
- ASSIGN (Y, CREATE (4, 5, 6, 8, C1, Y));
- IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
- END;
-
- BEGIN
- ASSIGN (X, CREATE (4, 4, 6, 8, C1, X));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
- IF EQUAL (X, CREATE (4, 4, 6, 8, C1, X)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
- END;
-
- BEGIN
- ASSIGN (X, CREATE (4, 6, 6, 8, C1, X));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
- IF EQUAL (X, CREATE (4, 6, 6, 8, C1, X)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
- END;
-
- BEGIN
- ASSIGN (X, CREATE (4, 5, 6, 7, C1, X));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
- IF EQUAL (X, CREATE (4, 5, 6, 7, C1, X)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
- END;
-
- BEGIN
- ASSIGN (X, CREATE (4, 5, 6, 9, C1, X));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
- IF EQUAL (X, CREATE (4, 5, 6, 9, C1, X)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
- END;
-
- BEGIN
- ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
- IF EQUAL (Y, CREATE (4, 4, 6, 8, C1, Y)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
- END;
-
- BEGIN
- ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
- IF EQUAL (Y, CREATE (4, 6, 6, 8, C1, Y)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
- END;
-
- BEGIN
- ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
- IF EQUAL (Y, CREATE (4, 5, 6, 7, C1, Y)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
- END;
-
- BEGIN
- ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
- IF EQUAL (Y, CREATE (4, 5, 6, 9, C1, Y)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");
- END;
-
- RESULT;
-END C34005U;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34005v.ada b/gcc/testsuite/ada/acats/tests/c3/c34005v.ada
deleted file mode 100644
index cb59125..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34005v.ada
+++ /dev/null
@@ -1,336 +0,0 @@
--- C34005V.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE
--- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 OF 2
--- TESTS WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST
--- C34005S.
-
--- HISTORY:
--- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA.
--- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
--- SUPPORTING CODE.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34005V IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
- C2 : CONSTANT LP;
- C3 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
- C6 : CONSTANT LP;
- C7 : CONSTANT LP;
- C8 : CONSTANT LP;
- C9 : CONSTANT LP;
- C10 : CONSTANT LP;
- C11 : CONSTANT LP;
- C12 : CONSTANT LP;
- C13 : CONSTANT LP;
- C14 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
- C2 : CONSTANT LP := 2;
- C3 : CONSTANT LP := 3;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
- C6 : CONSTANT LP := 6;
- C7 : CONSTANT LP := 7;
- C8 : CONSTANT LP := 8;
- C9 : CONSTANT LP := 9;
- C10 : CONSTANT LP := 10;
- C11 : CONSTANT LP := 11;
- C12 : CONSTANT LP := 12;
- C13 : CONSTANT LP := 13;
- C14 : CONSTANT LP := 14;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- FIRST : CONSTANT := 0;
- LAST : CONSTANT := 10;
-
- SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
-
- TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
- COMPONENT;
-
- FUNCTION CREATE ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT;
-
- FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
- RETURN PARENT;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
- RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- X : T;
- W : PARENT (4 .. 5, 6 .. 8);
- C : COMPONENT;
- B : BOOLEAN := FALSE;
- N : CONSTANT := 2;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- RESULT : T;
- BEGIN
- FOR I IN RESULT'RANGE LOOP
- FOR J IN RESULT'RANGE(2) LOOP
- ASSIGN (RESULT (I, J), C);
- END LOOP;
- END LOOP;
- RETURN RESULT;
- END V;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION VALUE (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER (X);
- END VALUE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( F1, L1 : INDEX;
- F2, L2 : INDEX;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (F1 .. L1, F2 .. L2);
- B : COMPONENT;
- BEGIN
- ASSIGN (B, C);
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- ASSIGN (A (I, J), B);
- ASSIGN (B, CREATE (VALUE (B) + 1));
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X'LENGTH /= Y'LENGTH OR
- X'LENGTH(2) /= Y'LENGTH(2) THEN
- RETURN FALSE;
- ELSE FOR I IN X'RANGE LOOP
- FOR J IN X'RANGE(2) LOOP
- IF NOT EQUAL (X (I, J),
- Y (I - X'FIRST + Y'FIRST,
- J - X'FIRST(2) +
- Y'FIRST(2))) THEN
- RETURN FALSE;
- END IF;
- END LOOP;
- END LOOP;
- END IF;
- RETURN TRUE;
- END EQUAL;
-
- FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS
- X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
- INDEX'FIRST .. INDEX'FIRST + 1);
- BEGIN
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
- RETURN X;
- END AGGR;
-
- FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS
- X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
- INDEX'FIRST .. INDEX'FIRST + 2);
- BEGIN
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
- RETURN X;
- END AGGR;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
- RETURN PARENT IS
- X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3,
- INDEX'FIRST .. INDEX'FIRST + 1);
- BEGIN
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F);
- ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G);
- ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H);
- RETURN X;
- END AGGR;
-
- FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
- RETURN PARENT IS
- X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2,
- INDEX'FIRST .. INDEX'FIRST + 2);
- BEGIN
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B);
- ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
- ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), G);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H);
- ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I);
- RETURN X;
- END AGGR;
-
- END PKG_P;
-
-BEGIN
- TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
- "TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 " &
- "OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " &
- "FIRST PART IS IN TEST C34005S");
-
- ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1));
- ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2));
- ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5));
- ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6));
-
- ASSIGN (W (4, 6), CREATE (1));
- ASSIGN (W (4, 7), CREATE (2));
- ASSIGN (W (4, 8), CREATE (3));
- ASSIGN (W (5, 6), CREATE (4));
- ASSIGN (W (5, 7), CREATE (5));
- ASSIGN (W (5, 8), CREATE (6));
-
- ASSIGN (C, CREATE (2));
-
- IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR
- NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)),
- AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " &
- "TO PARENT");
- WHEN OTHERS =>
- FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " &
- "TO PARENT");
- END;
-
- IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR
- NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- RESULT;
-END C34005V;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006a.ada b/gcc/testsuite/ada/acats/tests/c3/c34006a.ada
deleted file mode 100644
index c5d4675..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006a.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- C34006A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS
--- AND WITH NON-LIMITED COMPONENT TYPES.
-
--- HISTORY:
--- JRK 09/22/86 CREATED ORIGINAL TEST.
--- BCB 09/26/88 REMOVED COMPARISONS INVOLVING SIZE.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006A IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE PARENT IS
- RECORD
- C : COMPONENT;
- B : BOOLEAN := TRUE;
- END RECORD;
-
- TYPE T IS NEW PARENT;
-
- X : T := (2, FALSE);
- K : INTEGER := X'SIZE;
- W : PARENT := (2, FALSE);
- C : COMPONENT := 1;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X.C, X.C) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (-1, FALSE);
- END IDENT;
-
-BEGIN
- TEST ("C34006A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH " &
- "NON-LIMITED COMPONENT TYPES");
-
- X := IDENT ((1, TRUE));
- IF X /= (1, TRUE) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= (1, TRUE) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= (1, TRUE) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := (1, TRUE);
- END IF;
- IF T (W) /= (1, TRUE) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= (1, TRUE) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF IDENT ((1, TRUE)) /= (1, TRUE) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- IF X.C /= 1 OR X.B /= TRUE THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
-
- X.C := IDENT_INT (3);
- X.B := IDENT_BOOL (FALSE);
- IF X /= (3, FALSE) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- X := IDENT ((1, TRUE));
- IF X = IDENT ((1, FALSE)) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ((1, TRUE)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF X.C'FIRST_BIT < 0 THEN
- FAILED ("INCORRECT 'FIRST_BIT");
- END IF;
-
- IF X.C'LAST_BIT < 0 OR
- X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
- FAILED ("INCORRECT 'LAST_BIT");
- END IF;
-
- IF X.C'POSITION < 0 THEN
- FAILED ("INCORRECT 'POSITION");
- END IF;
-
-
- RESULT;
-END C34006A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006d.ada b/gcc/testsuite/ada/acats/tests/c3/c34006d.ada
deleted file mode 100644
index 614a830..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006d.ada
+++ /dev/null
@@ -1,238 +0,0 @@
--- C34006D.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH
--- NON-LIMITED COMPONENT TYPES.
-
--- HISTORY:
--- JRK 09/22/86 CREATED ORIGINAL TEST.
--- BCB 11/13/87 CHANGED TEST SO AN OBJECT'S SIZE MAY BE LESS THAN
--- THAT OF ITS TYPE.
--- RJW 08/21/89 MODIFIED CHECKS FOR SIZE.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006D IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T := (TRUE, 3, 2, "AAA", 2);
- W : PARENT := (TRUE, 3, 2, "AAA", 2);
- C : COMPONENT := 1;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (X.I, X.I) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN (TRUE, 3, -1, "---", -1);
- END IDENT;
-
-BEGIN
- TEST ("C34006D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "RECORD TYPES WITH DISCRIMINANTS AND WITH " &
- "NON-LIMITED COMPONENT TYPES");
-
- X := IDENT ((TRUE, 3, 1, "ABC", 4));
- IF X /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := (TRUE, 3, 1, "ABC", 4);
- END IF;
- IF T (W) /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- BEGIN
- IF PARENT (X) /= (TRUE, 3, 1, "ABC", 4) OR
- PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /=
- (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- IF IDENT ((TRUE, 3, 1, "ABC", 4)) /= (TRUE, 3, 1, "ABC", 4) OR
- X = (FALSE, 3, 1, 4.0) THEN
- FAILED ("INCORRECT AGGREGATE");
- END IF;
-
- BEGIN
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- BEGIN
- IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
- END;
-
- X.I := IDENT_INT (7);
- X.S := IDENT_STR ("XYZ");
- X.C := IDENT_INT (9);
- IF X /= (TRUE, 3, 7, "XYZ", 9) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- X := IDENT ((TRUE, 3, 1, "ABC", 4));
- IF X = IDENT ((TRUE, 3, 1, "ABC", 5)) OR
- X = (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= IDENT ((TRUE, 3, 1, "ABC", 4)) OR
- NOT (X /= (FALSE, 2, 3, 6.0)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR (FALSE, 2, 3, 6.0) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT ((FALSE, 2, 3, 6.0) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF NOT X'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- IF X.C'FIRST_BIT < 0 THEN
- FAILED ("INCORRECT 'FIRST_BIT");
- END IF;
-
- IF X.C'LAST_BIT < 0 OR
- X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
- FAILED ("INCORRECT 'LAST_BIT");
- END IF;
-
- IF X.C'POSITION < 0 THEN
- FAILED ("INCORRECT 'POSITION");
- END IF;
-
- RESULT;
-END C34006D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006f.ada b/gcc/testsuite/ada/acats/tests/c3/c34006f.ada
deleted file mode 100644
index 3ee3745..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006f.ada
+++ /dev/null
@@ -1,228 +0,0 @@
--- C34006F.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:
--- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED
--- COMPONENT TYPES:
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
--- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 9/22/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006F IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := (TRUE, 3, 2, "AAA", 2);
- Y : S := (TRUE, 3, 2, "AAA", 2);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "RECORD TYPES WITH DISCRIMINANTS AND WITH " &
- "NON-LIMITED COMPONENT TYPES");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- BEGIN
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /=
- (FALSE, 2, 3, 6.0) OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /=
- (FALSE, 2, 3, 6.0) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
- "SUBTYPE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 1");
- END;
-
- BEGIN
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("CALL TO CREATE RAISED EXCEPTION - 2");
- END;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- BEGIN
- X := (TRUE, 3, 1, "ABC", 4);
- Y := (TRUE, 3, 1, "ABC", 4);
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := (FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (FALSE, 3, 2, 6.0)");
- IF X = (FALSE, 3, 2, 6.0) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- X := (TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
- IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X.
- COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := (TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- BEGIN
- Y := (FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (FALSE, 3, 2, 6.0)");
- IF Y = (FALSE, 3, 2, 6.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- Y := (TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
- IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := (TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- RESULT;
-END C34006F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006g.ada b/gcc/testsuite/ada/acats/tests/c3/c34006g.ada
deleted file mode 100644
index ebb6c51..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006g.ada
+++ /dev/null
@@ -1,199 +0,0 @@
--- C34006G.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS AND
--- WITH A LIMITED COMPONENT TYPE.
-
--- HISTORY:
--- JRK 08/24/87 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006G IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C1 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C1 : CONSTANT LP := 1;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- TYPE PARENT IS
- RECORD
- C : COMPONENT;
- B : BOOLEAN := TRUE;
- END RECORD;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT;
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- RETURN EQUAL (X.C, Y.C) AND X.B = Y.B;
- END EQUAL;
-
- FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT IS
- RESULT : PARENT;
- BEGIN
- ASSIGN (RESULT.C, C);
- RESULT.B := B;
- RETURN RESULT;
- END AGGR;
-
- END PKG_P;
-
-BEGIN
- TEST ("C34006G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH A " &
- "LIMITED COMPONENT TYPE");
-
- ASSIGN (X.C, CREATE (1));
- X.B := IDENT_BOOL (TRUE);
-
- ASSIGN (W.C, CREATE (1));
- W.B := IDENT_BOOL (TRUE);
-
- IF NOT EQUAL (T'(X), AGGR (C1, TRUE)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T (X), AGGR (C1, TRUE)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF NOT EQUAL (T (W), AGGR (C1, TRUE)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF NOT EQUAL (PARENT (X), AGGR (C1, TRUE)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF NOT EQUAL (X.C, C1) OR X.B /= TRUE THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
-
- X.B := IDENT_BOOL (FALSE);
- IF NOT EQUAL (X, AGGR (C1, FALSE)) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- X.B := IDENT_BOOL (TRUE);
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF X.C'FIRST_BIT < 0 THEN
- FAILED ("INCORRECT 'FIRST_BIT");
- END IF;
-
- IF X.C'LAST_BIT < 0 OR
- X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
- FAILED ("INCORRECT 'LAST_BIT");
- END IF;
-
- IF X.C'POSITION < 0 THEN
- FAILED ("INCORRECT 'POSITION");
- END IF;
-
- IF X'SIZE < T'SIZE OR
- X.C'SIZE < COMPONENT'SIZE OR
- X.B'SIZE < BOOLEAN'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34006G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006j.ada b/gcc/testsuite/ada/acats/tests/c3/c34006j.ada
deleted file mode 100644
index 597bf63..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006j.ada
+++ /dev/null
@@ -1,311 +0,0 @@
--- C34006J.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH
--- A LIMITED COMPONENT TYPE.
-
--- HISTORY:
--- JRK 08/25/87 CREATED ORIGINAL TEST.
--- VCL 06/28/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
--- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
--- SIZES.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006J IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT
- ) RETURN PARENT;
-
- FUNCTION AGGR ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (B, L);
- BEGIN
- A.I := I;
- CASE B IS
- WHEN TRUE =>
- A.S := S;
- ASSIGN (A.C, C);
- WHEN FALSE =>
- A.F := F;
- END CASE;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
- RETURN FALSE;
- END IF;
- CASE X.B IS
- WHEN TRUE =>
- RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
- WHEN FALSE =>
- RETURN X.F = Y.F;
- END CASE;
- END EQUAL;
-
- FUNCTION AGGR
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT
- ) RETURN PARENT
- IS
- RESULT : PARENT (B, L);
- BEGIN
- RESULT.I := I;
- RESULT.S := S;
- ASSIGN (RESULT.C, C);
- RETURN RESULT;
- END AGGR;
-
- FUNCTION AGGR
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- RESULT : PARENT (B, L);
- BEGIN
- RESULT.I := I;
- RESULT.F := F;
- RETURN RESULT;
- END AGGR;
-
- END PKG_P;
-
-BEGIN
- TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
- "LIMITED COMPONENT TYPE");
-
- X.I := IDENT_INT (1);
- X.S := IDENT_STR ("ABC");
- ASSIGN (X.C, CREATE (4));
-
- W.I := IDENT_INT (1);
- W.S := IDENT_STR ("ABC");
- ASSIGN (W.C, CREATE (4));
-
- IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4)) OR
- NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)),
- AGGR (FALSE, 2, 3, 6.0)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
-
- IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR
- CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR
- CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
-
- X.I := IDENT_INT (7);
- X.S := IDENT_STR ("XYZ");
- IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- X.I := IDENT_INT (1);
- X.S := IDENT_STR ("ABC");
- IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF NOT X'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- IF X.C'FIRST_BIT < 0 THEN
- FAILED ("INCORRECT 'FIRST_BIT");
- END IF;
-
- IF X.C'LAST_BIT < 0 OR
- X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
- FAILED ("INCORRECT 'LAST_BIT");
- END IF;
-
- IF X.C'POSITION < 0 THEN
- FAILED ("INCORRECT 'POSITION");
- END IF;
-
- IF X'SIZE < T'SIZE THEN
- COMMENT ("X'SIZE < T'SIZE");
- ELSIF X'SIZE = T'SIZE THEN
- COMMENT ("X'SIZE = T'SIZE");
- ELSE
- COMMENT ("X'SIZE > T'SIZE");
- END IF;
-
- RESULT;
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " &
- "OPERATIONS");
- RESULT;
-END C34006J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34006l.ada b/gcc/testsuite/ada/acats/tests/c3/c34006l.ada
deleted file mode 100644
index 65a21f9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34006l.ada
+++ /dev/null
@@ -1,345 +0,0 @@
--- C34006L.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:
--- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH A LIMITED
--- COMPONENT TYPE:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
--- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
--- IS CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
--- ALSO IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 08/26/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34006L IS
-
- PACKAGE PKG_L IS
-
- TYPE LP IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN LP;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP);
-
- C2 : CONSTANT LP;
- C4 : CONSTANT LP;
- C5 : CONSTANT LP;
- C6 : CONSTANT LP;
-
- PRIVATE
-
- TYPE LP IS NEW INTEGER;
-
- C2 : CONSTANT LP := 2;
- C4 : CONSTANT LP := 4;
- C5 : CONSTANT LP := 5;
- C6 : CONSTANT LP := 6;
-
- END PKG_L;
-
- USE PKG_L;
-
- SUBTYPE COMPONENT IS LP;
-
- PACKAGE PKG_P IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- FUNCTION AGGR ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT
- ) RETURN PARENT;
-
- FUNCTION AGGR ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
- PACKAGE BODY PKG_L IS
-
- FUNCTION CREATE (X : INTEGER) RETURN LP IS
- BEGIN
- RETURN LP (IDENT_INT (X));
- END CREATE;
-
- FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG_L;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- A : PARENT (B, L);
- BEGIN
- A.I := I;
- CASE B IS
- WHEN TRUE =>
- A.S := S;
- ASSIGN (A.C, C);
- WHEN FALSE =>
- A.F := F;
- END CASE;
- RETURN A;
- END CREATE;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
- RETURN FALSE;
- END IF;
- CASE X.B IS
- WHEN TRUE =>
- RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
- WHEN FALSE =>
- RETURN X.F = Y.F;
- END CASE;
- END EQUAL;
-
- FUNCTION AGGR
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT
- ) RETURN PARENT
- IS
- RESULT : PARENT (B, L);
- BEGIN
- RESULT.I := I;
- RESULT.S := S;
- ASSIGN (RESULT.C, C);
- RETURN RESULT;
- END AGGR;
-
- FUNCTION AGGR
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- RESULT : PARENT (B, L);
- BEGIN
- RESULT.I := I;
- RESULT.F := F;
- RETURN RESULT;
- END AGGR;
-
- END PKG_P;
-
- PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS
- BEGIN
- X.I := Y.I;
- X.S := Y.S;
- ASSIGN (X.C, Y.C);
- END ASSIGN;
-
- PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS
- BEGIN
- X.I := Y.I;
- X.S := Y.S;
- ASSIGN (X.C, Y.C);
- END ASSIGN;
-
-BEGIN
- TEST ("C34006L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
- "LIMITED COMPONENT TYPE");
-
- ASSIGN (X.C, CREATE (2));
- ASSIGN (Y.C, C2);
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X),
- AGGR (FALSE, 2, 3, 6.0)) OR
- NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y),
- AGGR (FALSE, 2, 3, 6.0)) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- BEGIN
- ASSIGN (X, AGGR (TRUE, 3, 1, "ABC", C4));
- ASSIGN (Y, AGGR (TRUE, 3, 1, "ABC", C4));
- IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
- END;
-
- BEGIN
- ASSIGN (X, AGGR (FALSE, 3, 2, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
- IF EQUAL (X, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))");
- END;
-
- BEGIN
- ASSIGN (X, AGGR (TRUE, 4, 2, "ZZZZ", C6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- IF EQUAL (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- END;
-
- BEGIN
- ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
- IF EQUAL (Y, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))");
- END;
-
- BEGIN
- ASSIGN (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- IF EQUAL (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))");
- END;
-
- RESULT;
-END C34006L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007a.ada b/gcc/testsuite/ada/acats/tests/c3/c34007a.ada
deleted file mode 100644
index d75c8cc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007a.ada
+++ /dev/null
@@ -1,181 +0,0 @@
--- C34007A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS
--- NOT AN ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A TYPE WITH
--- DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/24/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007A IS
-
- TYPE DESIGNATED IS RANGE -100 .. 100;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED RANGE
- DESIGNATED'VAL (IDENT_INT (-50)) ..
- DESIGNATED'VAL (IDENT_INT ( 50));
-
- TYPE PARENT IS ACCESS SUBDESIGNATED RANGE
- DESIGNATED'VAL (IDENT_INT (-30)) ..
- DESIGNATED'VAL (IDENT_INT ( 30));
-
- TYPE T IS NEW PARENT;
-
- X : T := NEW DESIGNATED'(-30);
- K : INTEGER := X'SIZE;
- Y : T := NEW DESIGNATED'( 30);
- W : PARENT := NEW DESIGNATED'( 30);
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE
- EQUAL (DESIGNATED'POS (X.ALL), DESIGNATED'POS (X.ALL)) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW DESIGNATED;
- END IDENT;
-
-BEGIN
- TEST ("C34007A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS NOT AN " &
- "ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A " &
- "TYPE WITH DISCRIMINANTS");
-
- IF Y = NULL OR ELSE Y.ALL /= 30 THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW DESIGNATED'(-30);
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= -30 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE W.ALL /= 30 OR ELSE T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW DESIGNATED'(30));
- IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= 30 THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (Y);
- IF X.ALL /= 30 THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := DESIGNATED'VAL (IDENT_INT (10));
- IF X /= Y OR Y.ALL /= 10 THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := 30;
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = 0 THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL OF COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007d.ada b/gcc/testsuite/ada/acats/tests/c3/c34007d.ada
deleted file mode 100644
index 9378a2b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007d.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- C34007D.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 1 OF 2 TESTS
--- WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST C34007V.
-
--- HISTORY:
--- JRK 09/25/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34007D.ADA AND
--- C34007V.ADA. PUT CHECK FOR 'STORAGE_SIZE IN
--- EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007D IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) ..
- IDENT_INT (7));
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- X : T := NEW SUBDESIGNATED'(OTHERS => 2);
- K : INTEGER := X'SIZE;
- Y : T := NEW SUBDESIGNATED'(1, 2, 3);
- W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2);
- C : COMPONENT := 1;
- N : CONSTANT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN NEW SUBDESIGNATED'(OTHERS => C);
- END V;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE
- EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW SUBDESIGNATED;
- END IDENT;
-
-BEGIN
- TEST ("C34007D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " &
- "PART 1 OF 2 TESTS WHICH COVER THE OBJECTIVE. " &
- "THE SECOND PART IS IN TEST C34007V");
-
- IF Y = NULL OR ELSE Y.ALL /= (1, 2, 3) THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW SUBDESIGNATED'(1, 2, 3);
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE W.ALL /= (1, 2, 3) OR ELSE T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW SUBDESIGNATED'(1, 2, 3));
- IF (X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3)) OR
- X = NEW DESIGNATED'(1, 2) THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = (0, 0, 0) THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- X (IDENT_INT (7)) := 4;
- IF X /= Y OR Y.ALL /= (1, 2, 4) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (1, 2, 3);
- X := IDENT (Y);
- X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5);
- IF X /= Y OR Y.ALL /= (4, 5, 3) THEN
- FAILED ("INCORRECT SLICE (ASSIGNMENT)");
- END IF;
-
- A (X'ADDRESS);
-
- IF X'FIRST /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF X'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 5 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF X'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF X'LAST (N) /= 7 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 7 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF X'LENGTH /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : DESIGNATED (X'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (V'RANGE);
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (X'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (V'RANGE (N));
- BEGIN
- IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < 1 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007f.ada b/gcc/testsuite/ada/acats/tests/c3/c34007f.ada
deleted file mode 100644
index 0e9222b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007f.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- C34007F.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.
---*
--- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A ONE-DIMENSIONAL
--- ARRAY TYPE:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 9/25/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007F IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (5 .. 7);
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( F, L : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- SUBTYPE SUBPARENT IS PARENT (5 .. 7);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := NEW SUBDESIGNATED'(OTHERS => 2);
- Y : S := NEW SUBDESIGNATED'(OTHERS => 2);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT := NEW DESIGNATED (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34007F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "ONE-DIMENSIONAL ARRAY TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF CREATE (2, 3, 4, X) . ALL /= (4, 5) OR
- CREATE (2, 3, 4, Y) . ALL /= (4, 5) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (2, 3, 4, X) IN T OR
- CREATE (2, 3, 4, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X'FIRST /= 5 OR X'LAST /= 7 OR
- Y'FIRST /= 5 OR Y'LAST /= 7 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := NEW SUBDESIGNATED'(1, 2, 3);
- Y := NEW SUBDESIGNATED'(1, 2, 3);
- IF PARENT (X) = PARENT (Y) OR -- USE X AND Y.
- X.ALL /= Y.ALL THEN
- FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(6 .. 8 => 0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'(6 .. 8 => 0)");
- IF X = NULL OR ELSE X.ALL = (0, 0, 0) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'(6 .. 8 => 0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'(6 .. 8 => 0)");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(6 .. 8 => 0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'(6 .. 8 => 0)");
- IF Y = NULL OR ELSE Y.ALL = (0, 0, 0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'(6 .. 8 => 0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'(6 .. 8 => 0)");
- END;
-
- RESULT;
-END C34007F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007g.ada b/gcc/testsuite/ada/acats/tests/c3/c34007g.ada
deleted file mode 100644
index 85c0f2a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007g.ada
+++ /dev/null
@@ -1,350 +0,0 @@
--- C34007G.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- MULTI-DIMENSIONAL ARRAY TYPE.
-
--- HISTORY:
--- JRK 09/25/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007G IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF
- COMPONENT;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED
- (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( F1, L1 : NATURAL;
- F2, L2 : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
- Y : T := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
- W : PARENT := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
- C : COMPONENT := 1;
- N : CONSTANT := 2;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN NEW SUBDESIGNATED'(OTHERS => (OTHERS => C));
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F1, L1 : NATURAL;
- F2, L2 : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- A (I, J) := B;
- B := B + 1;
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE
- EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW SUBDESIGNATED;
- END IDENT;
-
-BEGIN
- TEST ("C34007G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "MULTI-DIMENSIONAL ARRAY TYPE");
-
- IF Y = NULL OR ELSE Y.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE W.ALL /= ((1, 2, 3), (4, 5, 6)) OR ELSE
- T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
-
- W := PARENT (CREATE (6, 9, 2, 3, 4, X));
- IF W = NULL OR ELSE
- W.ALL /= ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)));
- IF (X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= ((1, 2, 3), (4, 5, 6))) OR
- X = NEW DESIGNATED'((1, 2), (3, 4), (5, 6)) THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (Y);
- IF X.ALL /= ((1, 2, 3), (4, 5, 6)) OR
- CREATE (6, 9, 2, 3, 4, X) . ALL /=
- ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := ((10, 11, 12), (13, 14, 15));
- IF X /= Y OR Y.ALL /= ((10, 11, 12), (13, 14, 15)) THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := ((1, 2, 3), (4, 5, 6));
- BEGIN
- CREATE (6, 9, 2, 3, 4, X) . ALL :=
- ((20, 21), (22, 23), (24, 25), (26, 27));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
- END;
-
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = ((0, 0, 0), (0, 0, 0)) THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR
- CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
-
- X (IDENT_INT (5), IDENT_INT (8)) := 7;
- IF X /= Y OR Y.ALL /= ((1, 2, 3), (4, 5, 7)) THEN
- FAILED ("INCORRECT INDEX (ASSIGNMENT)");
- END IF;
-
- Y.ALL := ((1, 2, 3), (4, 5, 6));
- X := IDENT (Y);
- BEGIN
- CREATE (6, 9, 2, 3, 4, X) (6, 2) := 15;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)");
- END;
-
- IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
- X = CREATE (6, 9, 2, 3, 4, X) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) OR
- NOT (X /= CREATE (7, 9, 2, 4, 1, X)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR CREATE (2, 3, 4, 5, 1, X) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (CREATE (7, 9, 2, 4, 1, X) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- IF X'FIRST /= 4 THEN
- FAILED ("INCORRECT OBJECT'FIRST");
- END IF;
-
- IF V'FIRST /= 4 THEN
- FAILED ("INCORRECT VALUE'FIRST");
- END IF;
-
- IF X'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT OBJECT'FIRST (N)");
- END IF;
-
- IF V'FIRST (N) /= 6 THEN
- FAILED ("INCORRECT VALUE'FIRST (N)");
- END IF;
-
- IF X'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'LAST");
- END IF;
-
- IF V'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'LAST");
- END IF;
-
- IF X'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'LAST (N)");
- END IF;
-
- IF V'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'LAST (N)");
- END IF;
-
- IF X'LENGTH /= 2 THEN
- FAILED ("INCORRECT OBJECT'LENGTH");
- END IF;
-
- IF V'LENGTH /= 2 THEN
- FAILED ("INCORRECT VALUE'LENGTH");
- END IF;
-
- IF X'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT OBJECT'LENGTH (N)");
- END IF;
-
- IF V'LENGTH (N) /= 3 THEN
- FAILED ("INCORRECT VALUE'LENGTH (N)");
- END IF;
-
- DECLARE
- Y : DESIGNATED (X'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT OBJECT'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (V'RANGE, 1 .. 3);
- BEGIN
- IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
- FAILED ("INCORRECT VALUE'RANGE");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (1 .. 2, X'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT OBJECT'RANGE (N)");
- END IF;
- END;
-
- DECLARE
- Y : DESIGNATED (1 .. 2, V'RANGE (N));
- BEGIN
- IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
- FAILED ("INCORRECT VALUE'RANGE (N)");
- END IF;
- END;
-
- IF T'SIZE < 1 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < T'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007i.ada b/gcc/testsuite/ada/acats/tests/c3/c34007i.ada
deleted file mode 100644
index 55bc2c4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007i.ada
+++ /dev/null
@@ -1,213 +0,0 @@
--- C34007I.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.
---*
--- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A MULTI-DIMENSIONAL
--- ARRAY TYPE:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 9/25/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007I IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF
- COMPONENT;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (4 .. 5, 6 .. 8);
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( F1, L1 : NATURAL;
- F2, L2 : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
- IDENT_INT (6) .. IDENT_INT (8));
-
- SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
- Y : S := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F1, L1 : NATURAL;
- F2, L2 : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F1 .. L1 LOOP
- FOR J IN F2 .. L2 LOOP
- A (I, J) := B;
- B := B + 1;
- END LOOP;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34007I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "MULTI-DIMENSIONAL ARRAY TYPE");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF CREATE (6, 9, 2, 3, 1, X) . ALL /=
- ((1, 2), (3, 4), (5, 6), (7, 8)) OR
- CREATE (6, 9, 2, 3, 1, Y) . ALL /=
- ((1, 2), (3, 4), (5, 6), (7, 8)) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (6, 9, 2, 3, 1, X) IN T OR
- CREATE (6, 9, 2, 3, 1, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X'FIRST /= 4 OR X'LAST /= 5 OR
- Y'FIRST /= 4 OR Y'LAST /= 5 OR
- X'FIRST (2) /= 6 OR X'LAST (2) /= 8 OR
- Y'FIRST (2) /= 6 OR Y'LAST (2) /= 8 THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST");
- END IF;
-
- BEGIN
- X := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
- Y := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
- IF PARENT (X) = PARENT (Y) OR -- USE X AND Y.
- X.ALL /= Y.ALL THEN
- FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
- IF X = NULL OR ELSE
- X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'(5 .. 6 => " &
- "(6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
- IF X = NULL OR ELSE
- X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'(4 .. 5 => " &
- "(5 .. 7 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
- IF Y = NULL OR ELSE
- Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'(5 .. 6 => " &
- "(6 .. 8 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
- IF Y = NULL OR ELSE
- Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'(4 .. 5 => " &
- "(5 .. 7 => 0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))");
- END;
-
- RESULT;
-END C34007I;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007j.ada b/gcc/testsuite/ada/acats/tests/c3/c34007j.ada
deleted file mode 100644
index 1ce054c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007j.ada
+++ /dev/null
@@ -1,258 +0,0 @@
--- C34007J.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE
--- IS A TASK TYPE.
-
--- HISTORY:
--- JRK 09/26/86 CREATED ORIGINAL TEST.
--- JLH 09/25/87 REFORMATTED HEADER.
--- BCB 09/26/88 REMOVED COMPARISION INVOLVING OBJECT SIZE.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007J IS
-
- TASK TYPE DESIGNATED IS
- ENTRY E (I : IN OUT INTEGER);
- ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER);
- ENTRY R (I : OUT INTEGER);
- ENTRY W (I : INTEGER);
- END DESIGNATED;
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- TYPE T IS NEW PARENT;
-
- X : T;
- K : INTEGER := X'SIZE;
- Y : T;
- W : PARENT;
- I : INTEGER := 0;
- J : INTEGER := 0;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN NEW DESIGNATED;
- END V;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF (X = NULL OR ELSE X'CALLABLE) OR IDENT_BOOL (TRUE) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW DESIGNATED;
- END IDENT;
-
- TASK BODY DESIGNATED IS
- N : INTEGER := 1;
- BEGIN
- LOOP
- SELECT
- ACCEPT E (I : IN OUT INTEGER) DO
- I := I + N;
- END E;
- OR
- ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO
- J := I + N;
- END F;
- OR
- ACCEPT R (I : OUT INTEGER) DO
- I := N;
- END R;
- OR
- ACCEPT W (I : INTEGER) DO
- N := I;
- END W;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END DESIGNATED;
-
-BEGIN
- TEST ("C34007J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "TASK TYPE");
-
- X := NEW DESIGNATED;
- Y := NEW DESIGNATED;
- W := NEW DESIGNATED;
-
- IF Y = NULL THEN
- FAILED ("INCORRECT INITIALIZATION - 1");
- ELSE Y.W (2);
- Y.R (I);
- IF I /= 2 THEN
- FAILED ("INCORRECT INITIALIZATION - 2");
- END IF;
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW DESIGNATED;
- W.W (3);
- END IF;
- X := T (W);
- IF X = NULL OR X = Y THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT - 1");
- ELSE I := 5;
- X.E (I);
- IF I /= 8 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT - 2");
- END IF;
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- ELSE I := 5;
- W.E (I);
- IF I /= 7 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW DESIGNATED);
- IF X = NULL OR X = Y THEN
- FAILED ("INCORRECT ALLOCATOR - 1");
- ELSE I := 5;
- X.E (I);
- IF I /= 6 THEN
- FAILED ("INCORRECT ALLOCATOR - 2");
- END IF;
- END IF;
-
- X := IDENT (Y);
- I := 5;
- X.E (I);
- IF I /= 7 THEN
- FAILED ("INCORRECT SELECTION (ENTRY)");
- END IF;
-
- I := 5;
- X.F (IDENT_INT (2)) (I, J);
- IF J /= 7 THEN
- FAILED ("INCORRECT SELECTION (FAMILY)");
- END IF;
-
- I := 5;
- X.ALL.E (I);
- IF I /= 7 THEN
- FAILED ("INCORRECT .ALL");
- END IF;
-
- X := IDENT (NULL);
- BEGIN
- IF X.ALL'CALLABLE THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- IF NOT X'CALLABLE THEN
- FAILED ("INCORRECT OBJECT'CALLABLE");
- END IF;
-
- IF NOT V'CALLABLE THEN
- FAILED ("INCORRECT VALUE'CALLABLE");
- END IF;
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- IF X'TERMINATED THEN
- FAILED ("INCORRECT OBJECT'TERMINATED");
- END IF;
-
- IF V'TERMINATED THEN
- FAILED ("INCORRECT VALUE'TERMINATED");
- END IF;
-
- RESULT;
-END C34007J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007m.ada b/gcc/testsuite/ada/acats/tests/c3/c34007m.ada
deleted file mode 100644
index e266f57..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007m.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C34007M.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- RECORD TYPE WITHOUT DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/29/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007M IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS
- RECORD
- C : COMPONENT;
- B : BOOLEAN := TRUE;
- END RECORD;
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- TYPE T IS NEW PARENT;
-
- X : T := NEW DESIGNATED'(2, FALSE);
- K : INTEGER := X'SIZE;
- Y : T := NEW DESIGNATED'(1, TRUE);
- W : PARENT := NEW DESIGNATED'(2, FALSE);
- C : COMPONENT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE EQUAL (X.C, X.C) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW DESIGNATED'(-1, FALSE);
- END IDENT;
-
-BEGIN
- TEST ("C34007M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "RECORD TYPE WITHOUT DISCRIMINANTS");
-
- IF Y = NULL OR ELSE Y.ALL /= (1, TRUE) THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW DESIGNATED'(1, TRUE);
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE W.ALL /= (1, TRUE) OR ELSE T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW DESIGNATED'(1, TRUE));
- IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (Y);
- IF X.C /= 1 OR X.B /= TRUE THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
-
- X.C := IDENT_INT (3);
- X.B := IDENT_BOOL (FALSE);
- IF X /= Y OR Y.ALL /= (3, FALSE) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (1, TRUE);
- X := IDENT (Y);
- IF X.ALL /= (1, TRUE) THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := (10, FALSE);
- IF X /= Y OR Y.ALL /= (10, FALSE) THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (1, TRUE);
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = (0, FALSE) THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007p.ada b/gcc/testsuite/ada/acats/tests/c3/c34007p.ada
deleted file mode 100644
index a6d85b0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007p.ada
+++ /dev/null
@@ -1,283 +0,0 @@
--- C34007P.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- RECORD TYPE WITH DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/29/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007P IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10;
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE),
- IDENT_INT (3));
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2);
- K : INTEGER := X'SIZE;
- Y : T := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4);
- W : PARENT := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2);
- C : COMPONENT := 1;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN NEW DESIGNATED'(TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN NEW DESIGNATED'(FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE EQUAL (X.I, X.I) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW DESIGNATED'(TRUE, 3, -1, "---", -1);
- END IDENT;
-
-BEGIN
- TEST ("C34007P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "RECORD TYPE WITH DISCRIMINANTS");
-
- IF Y = NULL OR ELSE Y.ALL /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4);
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE W.ALL /= (TRUE, 3, 1, "ABC", 4) OR ELSE
- T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
-
- W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X));
- IF W = NULL OR ELSE W.ALL /= (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4));
- IF (X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= (TRUE, 3, 1, "ABC", 4)) OR
- X = NEW DESIGNATED'(FALSE, 3, 1, 4.0) THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (Y);
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
-
- IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN
- FAILED ("INCORRECT SELECTION (VALUE)");
- END IF;
-
- X.I := IDENT_INT (7);
- X.S := IDENT_STR ("XYZ");
- X.C := IDENT_INT (9);
- IF X /= Y OR Y.ALL /= (TRUE, 3, 7, "XYZ", 9) THEN
- FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (TRUE, 3, 1, "ABC", 4);
- X := IDENT (Y);
- BEGIN
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I := 10;
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F := 10.0;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR SELECTION (ASSIGNMENT)");
- END;
-
- IF X.ALL /= (TRUE, 3, 1, "ABC", 4) OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /=
- (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := (TRUE, 3, 10, "ZZZ", 15);
- IF X /= Y OR Y.ALL /= (TRUE, 3, 10, "ZZZ", 15) THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (TRUE, 3, 1, "ABC", 4);
- BEGIN
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL :=
- (FALSE, 2, 10, 15.0);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
- END;
-
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = (FALSE, 0, 0, 0.0) THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
- X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) OR
- NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR
- NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- IF T'SIZE < 1 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007r.ada b/gcc/testsuite/ada/acats/tests/c3/c34007r.ada
deleted file mode 100644
index 096d845..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007r.ada
+++ /dev/null
@@ -1,218 +0,0 @@
--- C34007R.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.
---*
--- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A RECORD TYPE
--- WITH DISCRIMINANTS:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 9/29/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007R IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10;
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- C : COMPONENT;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2);
- Y : S := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2);
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN NEW DESIGNATED'(TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN NEW DESIGNATED'(FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG;
-
-BEGIN
- TEST ("C34007R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "RECORD TYPE WITH DISCRIMINANTS");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) . ALL /=
- (FALSE, 2, 3, 6.0) OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) . ALL /=
- (FALSE, 2, 3, 6.0) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- BEGIN
- X := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4);
- Y := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4);
- IF PARENT (X) = PARENT (Y) OR -- USE X AND Y.
- X.ALL /= Y.ALL THEN
- FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- IF X = NULL OR ELSE X.ALL = (FALSE, 3, 2, 6.0) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)");
- IF X = NULL OR ELSE
- X.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'" &
- "(TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- IF Y = NULL OR ELSE Y.ALL = (FALSE, 3, 2, 6.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)");
- IF Y = NULL OR ELSE
- Y.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'" &
- "(TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- RESULT;
-END C34007R;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007s.ada b/gcc/testsuite/ada/acats/tests/c3/c34007s.ada
deleted file mode 100644
index 54a2f33..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007s.ada
+++ /dev/null
@@ -1,299 +0,0 @@
--- C34007S.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- PRIVATE TYPE WITH DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/30/86 CREATED ORIGINAL TEST.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO
--- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
--- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF
--- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007S IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG_D IS
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10;
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT
- ) RETURN DESIGNATED;
-
- PRIVATE
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- C : COMPONENT := 2;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG_D;
-
- USE PKG_D;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE),
- IDENT_INT (3));
-
- PACKAGE PKG_P IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T := NEW DESIGNATED (TRUE, 3);
- K : INTEGER := X'SIZE;
- Y : T := NEW DESIGNATED (TRUE, 3);
- W : PARENT := NEW DESIGNATED (TRUE, 3);
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- NULL;
- END A;
-
- PACKAGE BODY PKG_D IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT
- ) RETURN DESIGNATED
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG_D;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F));
- END CREATE;
-
- END PKG_P;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE EQUAL (X.L, X.L) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW DESIGNATED'(CREATE (TRUE, 3, -1, "---", -1, -1.0));
- END IDENT;
-
-BEGIN
- TEST ("C34007S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "PRIVATE TYPE WITH DISCRIMINANTS");
-
- Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0);
- IF Y = NULL OR ELSE
- Y.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- X := IDENT (Y);
- IF X /= Y THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= Y THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= Y THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0));
- END IF;
- X := T (W);
- IF X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- X := IDENT (Y);
- W := PARENT (X);
- IF W = NULL OR ELSE
- W.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR ELSE
- T (W) /= Y THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 1");
- END IF;
-
- W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X));
- IF W = NULL OR ELSE
- W.ALL /= CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
-
- IF IDENT (NULL) /= NULL OR X = NULL THEN
- FAILED ("INCORRECT NULL");
- END IF;
-
- X := IDENT (NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)));
- IF (X = NULL OR ELSE X = Y OR ELSE
- X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0)) OR
- X = NEW DESIGNATED'(CREATE (FALSE, 3, 1, "XXX", 5, 4.0)) THEN
- FAILED ("INCORRECT ALLOCATOR");
- END IF;
-
- X := IDENT (Y);
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
-
- IF X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /=
- CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := CREATE (TRUE, 3, 10, "ZZZ", 15, 1.0);
- IF X /= Y OR Y.ALL /= CREATE (TRUE, 3, 10, "ZZZ", 15, 2.0) THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0);
- BEGIN
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL :=
- CREATE (FALSE, 2, 10, "ZZ", 7, 15.0);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
- END;
-
- X := IDENT (NULL);
- BEGIN
- IF X.ALL = CREATE (FALSE, 0, 0, "", 0, 0.0) THEN
- FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
- ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION FOR NULL.ALL");
- END;
-
- X := IDENT (Y);
- IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
- X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) OR
- NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR
- NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- A (X'ADDRESS);
-
- IF T'SIZE < 1 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- BEGIN
- IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
- FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
- "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED FOR " &
- "UNDEFINED STORAGE_SIZE (AI-00608)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
- END;
-
- RESULT;
-END C34007S;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007u.ada b/gcc/testsuite/ada/acats/tests/c3/c34007u.ada
deleted file mode 100644
index 05c6990..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007u.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- C34007U.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.
---*
--- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A PRIVATE TYPE
--- WITH DISCRIMINANTS:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
--- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
--- CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
--- IMPOSED ON THE DERIVED SUBTYPE.
-
--- JRK 9/30/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007U IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- PACKAGE PKG_D IS
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10;
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT
- ) RETURN DESIGNATED;
-
- PRIVATE
-
- TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- C : COMPONENT := 2;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG_D;
-
- USE PKG_D;
-
- PACKAGE PKG_P IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG_P;
-
- USE PKG_P;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T := NEW DESIGNATED (TRUE, 3);
- Y : S := NEW DESIGNATED (TRUE, 3);
-
- PACKAGE BODY PKG_D IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT
- ) RETURN DESIGNATED
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, C);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- END PKG_D;
-
- PACKAGE BODY PKG_P IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- C : COMPONENT;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F));
- END CREATE;
-
- END PKG_P;
-
-BEGIN
- TEST ("C34007U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "PRIVATE TYPE WITH DISCRIMINANTS");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF CREATE (FALSE, 2, 3, "WW", 5, 6.0, X) . ALL /=
- CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) OR
- CREATE (FALSE, 2, 3, "WW", 5, 6.0, Y) . ALL /=
- CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- BEGIN
- X := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0));
- Y := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0));
- IF PARENT (X) = PARENT (Y) OR -- USE X AND Y.
- X.ALL /= Y.ALL THEN
- FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- IF X = NULL OR ELSE
- X.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- END;
-
- BEGIN
- X := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- IF X = NULL OR ELSE
- X.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- IF Y = NULL OR ELSE
- Y.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))");
- END;
-
- BEGIN
- Y := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- IF Y = NULL OR ELSE
- Y.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := NEW DESIGNATED'" &
- "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))");
- END;
-
- RESULT;
-END C34007U;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34007v.ada b/gcc/testsuite/ada/acats/tests/c3/c34007v.ada
deleted file mode 100644
index 8ee4bf8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34007v.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- C34007V.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
--- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 2 OF 2 TESTS
--- WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST C34007D.
-
--- HISTORY:
--- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34007D.ADA.
--- THS 09/18/90 REMOVED DECLARATION OF B, DELETED PROCEDURE A,
--- AND REMOVED ALL REFERENCES TO B.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34007V IS
-
- SUBTYPE COMPONENT IS INTEGER;
-
- TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT;
-
- SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) ..
- IDENT_INT (7));
-
- PACKAGE PKG IS
-
- TYPE PARENT IS ACCESS DESIGNATED;
-
- FUNCTION CREATE ( F, L : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
-
- X : T := NEW SUBDESIGNATED'(OTHERS => 2);
- K : INTEGER := X'SIZE;
- Y : T := NEW SUBDESIGNATED'(1, 2, 3);
- W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2);
- C : COMPONENT := 1;
- N : CONSTANT := 1;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN NEW SUBDESIGNATED'(OTHERS => C);
- END V;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( F, L : NATURAL;
- C : COMPONENT;
- DUMMY : PARENT
- ) RETURN PARENT
- IS
- A : PARENT := NEW DESIGNATED (F .. L);
- B : COMPONENT := C;
- BEGIN
- FOR I IN F .. L LOOP
- A (I) := B;
- B := B + 1;
- END LOOP;
- RETURN A;
- END CREATE;
-
- END PKG;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF X = NULL OR ELSE
- EQUAL (X'LENGTH, X'LENGTH) THEN
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN NEW SUBDESIGNATED;
- END IDENT;
-
-BEGIN
- TEST ("C34007V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
- "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " &
- "PART 2 OF 2 TESTS WHICH COVER THE OBJECTIVE. " &
- "THE FIRST PART IS IN TEST C34007V");
-
- W := PARENT (CREATE (2, 3, 4, X));
- IF W = NULL OR ELSE W.ALL /= (4, 5) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT - 2");
- END IF;
-
- X := IDENT (Y);
- IF X.ALL /= (1, 2, 3) OR CREATE (2, 3, 4, X) . ALL /= (4, 5) THEN
- FAILED ("INCORRECT .ALL (VALUE)");
- END IF;
-
- X.ALL := (10, 11, 12);
- IF X /= Y OR Y.ALL /= (10, 11, 12) THEN
- FAILED ("INCORRECT .ALL (ASSIGNMENT)");
- END IF;
-
- Y.ALL := (1, 2, 3);
- BEGIN
- CREATE (2, 3, 4, X) . ALL := (10, 11);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
- END;
-
-
- X := IDENT (Y);
- IF X (IDENT_INT (5)) /= 1 OR
- CREATE (2, 3, 4, X) (3) /= 5 THEN
- FAILED ("INCORRECT INDEX (VALUE)");
- END IF;
-
- Y.ALL := (1, 2, 3);
- X := IDENT (Y);
- BEGIN
- CREATE (2, 3, 4, X) (2) := 10;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)");
- END;
-
- IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR
- CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN
- FAILED ("INCORRECT SLICE (VALUE)");
- END IF;
-
- Y.ALL := (1, 2, 3);
- X := IDENT (Y);
- BEGIN
- CREATE (1, 4, 4, X) (2 .. 4) := (10, 11, 12);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR SLICE (ASSIGNMENT)");
- END;
-
- IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
- X = CREATE (2, 3, 4, X) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= Y OR NOT (X /= NULL) OR NOT (X /= CREATE (2, 3, 4, X)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR CREATE (2, 3, 4, X) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (CREATE (2, 3, 4, X) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- RESULT;
-END C34007V;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34008a.ada b/gcc/testsuite/ada/acats/tests/c3/c34008a.ada
deleted file mode 100644
index 5af4e3a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34008a.ada
+++ /dev/null
@@ -1,226 +0,0 @@
--- C34008A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED TASK TYPES.
-
--- HISTORY:
--- JRK 08/27/87 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--- DTN 11/30/95 REMOVED ATTIBUTES OF NON-OBJECTS.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34008A IS
-
- PACKAGE PKG IS
-
- TASK TYPE PARENT IS
- ENTRY E (I : IN OUT INTEGER);
- ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER);
- ENTRY G;
- ENTRY H (1 .. 3);
- ENTRY R (I : OUT INTEGER);
- ENTRY W (I : INTEGER);
- END PARENT;
-
- FUNCTION ID (X : PARENT) RETURN INTEGER;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT;
-
- TASK TYPE AUX;
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
- I : INTEGER := 0;
- J : INTEGER := 0;
- A1, A2 : AUX;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- FUNCTION V RETURN T IS
- BEGIN
- RETURN X;
- END V;
-
- PACKAGE BODY PKG IS
-
- TASK BODY PARENT IS
- N : INTEGER := 1;
- BEGIN
- LOOP
- SELECT
- ACCEPT E (I : IN OUT INTEGER) DO
- I := I + N;
- END E;
- OR
- ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO
- J := I + N;
- END F;
- OR
- ACCEPT G DO
- WHILE H(2)'COUNT < 2 LOOP
- DELAY 5.0;
- END LOOP;
- ACCEPT H (2) DO
- IF E'COUNT /= 0 OR
- F(1)'COUNT /= 0 OR
- F(2)'COUNT /= 0 OR
- F(3)'COUNT /= 0 OR
- G'COUNT /= 0 OR
- H(1)'COUNT /= 0 OR
- H(2)'COUNT /= 1 OR
- H(3)'COUNT /= 0 OR
- R'COUNT /= 0 OR
- W'COUNT /= 0 THEN
- FAILED ("INCORRECT 'COUNT");
- END IF;
- END H;
- ACCEPT H (2);
- END G;
- OR
- ACCEPT R (I : OUT INTEGER) DO
- I := N;
- END R;
- OR
- ACCEPT W (I : INTEGER) DO
- N := I;
- END W;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END PARENT;
-
- FUNCTION ID (X : PARENT) RETURN INTEGER IS
- I : INTEGER;
- BEGIN
- X.R (I);
- RETURN I;
- END ID;
-
- END PKG;
-
- TASK BODY AUX IS
- BEGIN
- X.H (2);
- END AUX;
-
-BEGIN
- TEST ("C34008A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED TASK " &
- "TYPES");
-
- X.W (IDENT_INT (2));
- IF ID (X) /= 2 THEN
- FAILED ("INCORRECT INITIALIZATION");
- END IF;
-
- IF ID (T'(X)) /= 2 THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF ID (T (X)) /= 2 THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- W.W (IDENT_INT (3));
- IF ID (T (W)) /= 3 THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF ID (PARENT (X)) /= 2 THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- I := 5;
- X.E (I);
- IF I /= 7 THEN
- FAILED ("INCORRECT SELECTION (ENTRY)");
- END IF;
-
- I := 5;
- X.F (IDENT_INT (2)) (I, J);
- IF J /= 7 THEN
- FAILED ("INCORRECT SELECTION (FAMILY)");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT OBJECT'ADDRESS");
- END IF;
-
- IF NOT X'CALLABLE THEN
- FAILED ("INCORRECT OBJECT'CALLABLE");
- END IF;
-
- IF NOT V'CALLABLE THEN
- FAILED ("INCORRECT VALUE'CALLABLE");
- END IF;
-
- X.G;
-
- IF X'SIZE < T'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- IF T'STORAGE_SIZE < 0 THEN
- FAILED ("INCORRECT TYPE'STORAGE_SIZE");
- END IF;
-
- IF X'STORAGE_SIZE < 0 THEN
- FAILED ("INCORRECT OBJECT'STORAGE_SIZE");
- END IF;
-
- IF X'TERMINATED THEN
- FAILED ("INCORRECT OBJECT'TERMINATED");
- END IF;
-
- IF V'TERMINATED THEN
- FAILED ("INCORRECT VALUE'TERMINATED");
- END IF;
-
- RESULT;
-END C34008A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009a.ada b/gcc/testsuite/ada/acats/tests/c3/c34009a.ada
deleted file mode 100644
index 6cda327..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- C34009A.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITHOUT
--- DISCRIMINANTS.
-
--- HISTORY:
--- JRK 08/28/87 CREATED ORIGINAL TEST.
--- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009A IS
-
- PACKAGE PKG IS
-
- TYPE PARENT IS PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN PARENT;
-
- FUNCTION CON (X : INTEGER) RETURN PARENT;
-
- PRIVATE
-
- TYPE PARENT IS NEW INTEGER;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT;
-
- X : T;
- K : INTEGER := X'SIZE;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE (X : INTEGER) RETURN PARENT IS
- BEGIN
- RETURN PARENT (IDENT_INT (X));
- END CREATE;
-
- FUNCTION CON (X : INTEGER) RETURN PARENT IS
- BEGIN
- RETURN PARENT (X);
- END CON;
-
- END PKG;
-
-BEGIN
- TEST ("C34009A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "NON-LIMITED PRIVATE TYPES WITHOUT " &
- "DISCRIMINANTS");
-
- X := CREATE (30);
- IF X /= CON (30) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= CON (30) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= CON (30) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- W := CREATE (-30);
- IF T (W) /= CON (-30) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= CON (30) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF X = CON (0) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= CON (30) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- RESULT;
-END C34009A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009d.ada b/gcc/testsuite/ada/acats/tests/c3/c34009d.ada
deleted file mode 100644
index c65441f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009d.ada
+++ /dev/null
@@ -1,226 +0,0 @@
--- C34009D.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITH
--- DISCRIMINANTS.
-
--- HISTORY:
--- JRK 08/31/87 CREATED ORIGINAL TEST.
--- WMC 03/13/92 REVISED TYPE'SIZE CHECKS.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009D IS
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- PRIVATE
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- J : INTEGER;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, J);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (TRUE, L, I, S, J);
- END CON;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (FALSE, L, I, F);
- END CON;
-
- END PKG;
-
-BEGIN
- TEST ("C34009D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
-
- X := CON (TRUE, 3, 2, "AAA", 2);
- W := CON (TRUE, 3, 2, "AAA", 2);
-
- IF EQUAL (3, 3) THEN
- X := CON (TRUE, 3, 1, "ABC", 4);
- END IF;
- IF X /= CON (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT :=");
- END IF;
-
- IF T'(X) /= CON (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF T (X) /= CON (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- W := CON (TRUE, 3, 1, "ABC", 4);
- END IF;
- IF T (W) /= CON (TRUE, 3, 1, "ABC", 4) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF PARENT (X) /= CON (TRUE, 3, 1, "ABC", 4) OR
- PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /=
- CON (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
-
- IF X = CON (TRUE, 3, 1, "ABC", 5) OR
- X = CON (FALSE, 2, 3, 6.0) THEN
- FAILED ("INCORRECT =");
- END IF;
-
- IF X /= CON (TRUE, 3, 1, "ABC", 4) OR
- NOT (X /= CON (FALSE, 2, 3, 6.0)) THEN
- FAILED ("INCORRECT /=");
- END IF;
-
- IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF NOT X'CONSTRAINED THEN
- FAILED ("INCORRECT OBJECT'CONSTRAINED");
- END IF;
-
- IF T'SIZE <= 0 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < T'SIZE OR
- X.B'SIZE < BOOLEAN'SIZE OR
- X.L'SIZE < LENGTH'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34009D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009f.ada b/gcc/testsuite/ada/acats/tests/c3/c34009f.ada
deleted file mode 100644
index 63716c5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009f.ada
+++ /dev/null
@@ -1,256 +0,0 @@
--- C34009F.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:
--- FOR DERIVED NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
--- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
--- IS CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
--- ALSO IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 08/31/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009F IS
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- PRIVATE
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
- RECORD
- I : INTEGER;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L);
- J : INTEGER;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, J);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (TRUE, L, I, S, J);
- END CON;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (FALSE, L, I, F);
- END CON;
-
- END PKG;
-
-BEGIN
- TEST ("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
-
- X := CON (TRUE, 3, 2, "AAA", 2);
- Y := CON (TRUE, 3, 2, "AAA", 2);
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /=
- CON (FALSE, 2, 3, 6.0) OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /=
- CON (FALSE, 2, 3, 6.0) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- BEGIN
- X := CON (TRUE, 3, 1, "ABC", 4);
- Y := CON (TRUE, 3, 1, "ABC", 4);
- IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
- END;
-
- BEGIN
- X := CON (FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := CON (FALSE, 3, 2, 6.0)");
- IF X = CON (FALSE, 3, 2, 6.0) THEN -- USE X.
- COMMENT ("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := CON (FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- X := CON (TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- IF X = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- BEGIN
- Y := CON (FALSE, 3, 2, 6.0);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := CON (FALSE, 3, 2, 6.0)");
- IF Y = CON (FALSE, 3, 2, 6.0) THEN -- USE Y.
- COMMENT ("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := CON (FALSE, 3, 2, 6.0)");
- END;
-
- BEGIN
- Y := CON (TRUE, 4, 2, "ZZZZ", 6);
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- IF Y = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
- END;
-
- RESULT;
-END C34009F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009g.ada b/gcc/testsuite/ada/acats/tests/c3/c34009g.ada
deleted file mode 100644
index a225347..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009g.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- C34009G.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITHOUT
--- DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/01/87 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009G IS
-
- PACKAGE PKG IS
-
- TYPE PARENT IS LIMITED PRIVATE;
-
- FUNCTION CREATE (X : INTEGER) RETURN PARENT;
-
- FUNCTION CON (X : INTEGER) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
-
- PRIVATE
-
- TYPE PARENT IS NEW INTEGER;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT;
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE (X : INTEGER) RETURN PARENT IS
- BEGIN
- RETURN PARENT (IDENT_INT (X));
- END CREATE;
-
- FUNCTION CON (X : INTEGER) RETURN PARENT IS
- BEGIN
- RETURN PARENT (X);
- END CON;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG;
-
-BEGIN
- TEST ("C34009G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS");
-
- ASSIGN (X, CREATE (30));
- IF NOT EQUAL (T'(X), CON (30)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T (X), CON (30)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- ASSIGN (W, CREATE (-30));
- IF NOT EQUAL (T (W), CON (-30)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF NOT EQUAL (PARENT (X), CON (30)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF NOT (X IN T) THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
- IF X'SIZE < T'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34009G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009j.ada b/gcc/testsuite/ada/acats/tests/c3/c34009j.ada
deleted file mode 100644
index f095fad..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009j.ada
+++ /dev/null
@@ -1,225 +0,0 @@
--- C34009J.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 REQUIRED PREDEFINED OPERATIONS ARE DECLARED
--- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITH
--- DISCRIMINANTS.
-
--- HISTORY:
--- JRK 09/01/87 CREATED ORIGINAL TEST.
--- WMC 03/13/92 REVISED TYPE'SIZE CHECKS.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009J IS
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- LIMITED PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
-
- PRIVATE
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- J : INTEGER := 2;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- X : T;
- W : PARENT;
- B : BOOLEAN := FALSE;
-
- PROCEDURE A (X : ADDRESS) IS
- BEGIN
- B := IDENT_BOOL (TRUE);
- END A;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, J);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (TRUE, L, I, S, J);
- END CON;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (FALSE, L, I, F);
- END CON;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG;
-
-BEGIN
- TEST ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
- "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
- "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
-
- IF EQUAL (3, 3) THEN
- ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
- END IF;
- IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN
- FAILED ("INCORRECT QUALIFICATION");
- END IF;
-
- IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN
- FAILED ("INCORRECT SELF CONVERSION");
- END IF;
-
- IF EQUAL (3, 3) THEN
- ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4));
- END IF;
- IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN
- FAILED ("INCORRECT CONVERSION FROM PARENT");
- END IF;
-
- IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR
- NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)),
- CON (FALSE, 2, 3, 6.0)) THEN
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
-
- IF X.B /= TRUE OR X.L /= 3 OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
- CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
- FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
- END IF;
-
- IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN
- FAILED ("INCORRECT ""NOT IN""");
- END IF;
-
- B := FALSE;
- A (X'ADDRESS);
- IF NOT B THEN
- FAILED ("INCORRECT 'ADDRESS");
- END IF;
-
-
- IF NOT X'CONSTRAINED THEN
- FAILED ("INCORRECT OBJECT'CONSTRAINED");
- END IF;
-
- IF T'SIZE <= 0 THEN
- FAILED ("INCORRECT TYPE'SIZE");
- END IF;
-
- IF X'SIZE < T'SIZE OR
- X.B'SIZE < BOOLEAN'SIZE OR
- X.L'SIZE < LENGTH'SIZE THEN
- FAILED ("INCORRECT OBJECT'SIZE");
- END IF;
-
- RESULT;
-END C34009J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34009l.ada b/gcc/testsuite/ada/acats/tests/c3/c34009l.ada
deleted file mode 100644
index 71a02f2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34009l.ada
+++ /dev/null
@@ -1,270 +0,0 @@
--- C34009L.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:
--- FOR DERIVED LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
-
--- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
--- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
--- IS CONSTRAINED.
-
--- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
--- ALSO IMPOSED ON THE DERIVED SUBTYPE.
-
--- HISTORY:
--- JRK 09/01/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34009L IS
-
- PACKAGE PKG IS
-
- MAX_LEN : CONSTANT := 10;
-
- SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- LIMITED PRIVATE;
-
- FUNCTION CREATE ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT -- TO RESOLVE OVERLOADING.
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT;
-
- FUNCTION CON ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
-
- PRIVATE
-
- TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
- RECORD
- I : INTEGER := 2;
- CASE B IS
- WHEN TRUE =>
- S : STRING (1 .. L) := (1 .. L => 'A');
- J : INTEGER := 2;
- WHEN FALSE =>
- F : FLOAT := 5.0;
- END CASE;
- END RECORD;
-
- END PKG;
-
- USE PKG;
-
- TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
-
- SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
-
- TYPE S IS NEW SUBPARENT;
-
- X : T;
- Y : S;
-
- PACKAGE BODY PKG IS
-
- FUNCTION CREATE
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER;
- F : FLOAT;
- X : PARENT
- ) RETURN PARENT
- IS
- BEGIN
- CASE B IS
- WHEN TRUE =>
- RETURN (TRUE, L, I, S, J);
- WHEN FALSE =>
- RETURN (FALSE, L, I, F);
- END CASE;
- END CREATE;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- S : STRING;
- J : INTEGER
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (TRUE, L, I, S, J);
- END CON;
-
- FUNCTION CON
- ( B : BOOLEAN;
- L : LENGTH;
- I : INTEGER;
- F : FLOAT
- ) RETURN PARENT
- IS
- BEGIN
- RETURN (FALSE, L, I, F);
- END CON;
-
- FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END EQUAL;
-
- PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
- BEGIN
- X := Y;
- END ASSIGN;
-
- END PKG;
-
-BEGIN
- TEST ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
- "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
- "WHEN THE DERIVED TYPE DEFINITION IS " &
- "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
- "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
- "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
- "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
-
- -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
-
- IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X),
- CON (FALSE, 2, 3, 6.0)) OR
- NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y),
- CON (FALSE, 2, 3, 6.0)) THEN
- FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
- END IF;
-
- IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
- CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
- FAILED ("INCORRECT ""IN""");
- END IF;
-
- -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
-
- IF X.B /= TRUE OR X.L /= 3 OR
- Y.B /= TRUE OR Y.L /= 3 THEN
- FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
- END IF;
-
- IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
- FAILED ("INCORRECT 'CONSTRAINED");
- END IF;
-
- BEGIN
- ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
- ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4));
- IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y.
- FAILED ("INCORRECT CONVERSION TO PARENT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL");
- END;
-
- BEGIN
- ASSIGN (X, CON (FALSE, 3, 2, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
- IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CON (FALSE, 3, 2, 6.0))");
- END;
-
- BEGIN
- ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE X.
- COMMENT ("X ALTERED -- " &
- "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- END;
-
- BEGIN
- ASSIGN (Y, CON (FALSE, 3, 2, 6.0));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
- IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))");
- END;
-
- BEGIN
- ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
- "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE Y.
- COMMENT ("Y ALTERED -- " &
- "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -- " &
- "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))");
- END;
-
- RESULT;
-END C34009L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34011b.ada b/gcc/testsuite/ada/acats/tests/c3/c34011b.ada
deleted file mode 100644
index 47e2600..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34011b.ada
+++ /dev/null
@@ -1,343 +0,0 @@
--- C34011B.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 DERIVED TYPE DECLARATION IS NOT CONSIDERED EXACTLY
--- EQUIVALENT TO AN ANONYMOUS DECLARATION OF THE DERIVED TYPE
--- FOLLOWED BY A SUBTYPE DECLARATION OF THE DERIVED SUBTYPE. IN
--- PARTICULAR, CHECK THAT CONSTRAINT_ERROR CAN BE RAISED WHEN THE
--- SUBTYPE INDICATION OF THE DERIVED TYPE DECLARATION IS ELABORATED
--- (EVEN THOUGH THE CONSTRAINT WOULD SATISFY THE DERIVED (BASE)
--- TYPE).
-
--- HISTORY:
--- JRK 09/04/87 CREATED ORIGINAL TEST.
--- EDS 07/29/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34011B IS
-
- SUBTYPE BOOL IS BOOLEAN RANGE FALSE .. FALSE;
-
- SUBTYPE FLT IS FLOAT RANGE -10.0 .. 10.0;
-
- SUBTYPE DUR IS DURATION RANGE 0.0 .. 10.0;
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
-
- TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
-
- TYPE REC (D : INT := 0) IS
- RECORD
- I : INTEGER;
- END RECORD;
-
- PACKAGE PT IS
- TYPE PRIV (D : POSITIVE := 1) IS PRIVATE;
- PRIVATE
- TYPE PRIV (D : POSITIVE := 1) IS
- RECORD
- I : INTEGER;
- END RECORD;
- END PT;
-
- USE PT;
-
- TYPE ACC_ARR IS ACCESS ARR;
-
- TYPE ACC_REC IS ACCESS REC;
-
-BEGIN
- TEST ("C34011B", "CHECK THAT CONSTRAINT_ERROR CAN BE RAISED " &
- "WHEN THE SUBTYPE INDICATION OF A DERIVED TYPE " &
- "DECLARATION IS ELABORATED");
-
- BEGIN
- DECLARE
- TYPE T IS NEW BOOL RANGE FALSE .. BOOL(IDENT_BOOL(TRUE));
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T := T(IDENT_BOOL(TRUE));
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
- " AT PROPER PLACE - BOOL " &
- T'IMAGE(T1) ); --USE T1);
- END;
-
- FAILED ("EXCEPTION NOT RAISED - BOOL");
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - BOOL");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - BOOL");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW POSITIVE RANGE IDENT_INT (0) .. 10;
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T := T(IDENT_INT(1));
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR - POSITIVE " &
- T'IMAGE(T1)); --USE T1
- END;
- FAILED ("EXCEPTION NOT RAISED - POSITIVE" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - POSITIVE");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - POSITIVE");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW FLT RANGE 0.0 .. FLT(IDENT_INT(20));
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T := T(IDENT_INT(0));
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
- " AT PROPER PLACE " &
- T'IMAGE(T1) ); --USE T1
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
- " AT PROPER PLACE ");
- END;
- FAILED ("EXCEPTION NOT RAISED - FLT" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - FLT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLT");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW DUR RANGE DUR(IDENT_INT(-1)) .. 5.0;
-
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T := T(IDENT_INT(2));
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR" &
- " AT PROPER PLACE " &
- T'IMAGE(T1) ); -- USE T1
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- END;
- FAILED ("EXCEPTION NOT RAISED - DUR " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - DUR");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - DUR");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW ARR (IDENT_INT (-1) .. 10);
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T := (OTHERS => IDENT_INT(3));
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
- "AT PROPER PLACE " &
- INTEGER'IMAGE(T1(1)) ); --USE T1
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- END;
- FAILED ("EXCEPTION NOT RAISED - ARR " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - ARR");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - ARR");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW REC (IDENT_INT (11));
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T;
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
- "AT PROPER PLACE " &
- INTEGER'IMAGE(T1.D) ); --USE T1
- END;
- FAILED ("EXCEPTION NOT RAISED - REC " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - REC");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - REC");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW PRIV (IDENT_INT (0)); --RAISES C_E
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T;
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
- "AT PROPER PLACE " &
- INTEGER'IMAGE(T1.D) ); --USE T1
- END;
- FAILED ("EXCEPTION NOT RAISED - PRIV " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - PRIV");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PRIV");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW ACC_ARR (0 .. IDENT_INT (11)); --RAISES C_E
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T;
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
- "AT PROPER PLACE " &
- INTEGER'IMAGE(T1(1)) ); --USE T1
- END;
- FAILED ("EXCEPTION NOT RAISED - ACC_ARR " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - ACC_ARR");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - ACC_ARR");
- END;
-
- BEGIN
- DECLARE
- TYPE T IS NEW ACC_REC (IDENT_INT (-1)); --RAISES C_E
-
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION
- T1 : T;
- BEGIN
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR " &
- "AT PROPER PLACE " &
- INTEGER'IMAGE(T1.D) ); --USE T1
- END;
- FAILED ("EXCEPTION NOT RAISED - ACC_REC " );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER ENTERED - ACC_REC");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - ACC_REC");
- END;
-
- RESULT;
-END C34011B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34012a.ada b/gcc/testsuite/ada/acats/tests/c3/c34012a.ada
deleted file mode 100644
index 020b79b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34012a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C34012A.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 DEFAULT EXPRESSIONS IN DERIVED RECORD TYPES AND
--- DERIVED SUBPROGRAMS ARE EVALUATED USING THE ENTITIES DENOTED BY
--- THE EXPRESSIONS IN THE PARENT TYPE.
-
--- HISTORY:
--- RJW 06/19/86 CREATED ORIGINAL TEST.
--- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED
--- PACKAGE B SO WOULD HAVE ONE CASE WHERE DEFAULT IS
--- DECLARED BEFORE THE DERIVED TYPE DECLARATION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34012A IS
-
-BEGIN
- TEST ("C34012A", "CHECK THAT DEFAULT EXPRESSIONS IN DERIVED " &
- "RECORD TYPES AND DERIVED SUBPROGRAMS ARE " &
- "EVALUATED USING THE ENTITIES DENOTED BY THE " &
- "EXPRESSIONS IN THE PARENT TYPE" );
-
- DECLARE
- PACKAGE P IS
- X : INTEGER := 5;
- TYPE REC IS
- RECORD
- C : INTEGER := X;
- END RECORD;
- END P;
-
- PACKAGE Q IS
- X : INTEGER := 6;
- TYPE NEW_REC IS NEW P.REC;
- QVAR : NEW_REC;
- END Q;
-
- PACKAGE R IS
- X : INTEGER := 7;
- TYPE BRAND_NEW_REC IS NEW Q.NEW_REC;
- RVAR : BRAND_NEW_REC;
- END R;
-
- USE Q;
- USE R;
- BEGIN
- IF QVAR.C = 5 THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VALUE FOR QVAR" );
- END IF;
-
- IF RVAR.C = 5 THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VALUE FOR RVAR" );
- END IF;
- END;
-
- DECLARE
- PACKAGE A IS
- TYPE T IS RANGE 1 .. 10;
- DEFAULT : T := 5;
- FUNCTION F (X : T := DEFAULT) RETURN T;
- END A;
-
- PACKAGE BODY A IS
- FUNCTION F (X : T := DEFAULT) RETURN T IS
- BEGIN
- RETURN X;
- END F;
- END A;
-
- PACKAGE B IS
- DEFAULT : A.T:= 6;
- TYPE NEW_T IS NEW A.T;
- BVAR : NEW_T := F;
- END B;
-
- PACKAGE C IS
- TYPE BRAND_NEW_T IS NEW B.NEW_T;
- DEFAULT : BRAND_NEW_T := 7;
- CVAR : BRAND_NEW_T :=F;
- END C;
-
- USE B;
- USE C;
- BEGIN
- IF BVAR = 5 THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VALUE FOR BVAR" );
- END IF;
-
- IF CVAR = 5 THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VALUE FOR CVAR" );
- END IF;
-
- DECLARE
- VAR : BRAND_NEW_T := F;
- BEGIN
- IF VAR = 5 THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VALUE FOR VAR" );
- END IF;
- END;
- END;
-
- RESULT;
-END C34012A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014a.ada b/gcc/testsuite/ada/acats/tests/c3/c34014a.ada
deleted file mode 100644
index e2a917e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014a.ada
+++ /dev/null
@@ -1,256 +0,0 @@
--- C34014A.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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER
--- DECLARED EXPLICITLY IN THE SAME VISIBLE PART.
-
--- HISTORY:
--- JRK 09/08/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014A IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION F RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (1));
- END F;
- END P;
-
-BEGIN
- TEST ("C34014A", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " &
- "THE SAME VISIBLE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- FUNCTION F RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- PRIVATE
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION F RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END F;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- FUNCTION G RETURN QT;
- FUNCTION F RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- PRIVATE
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G RETURN T;
-
- FUNCTION G RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- FUNCTION F IS NEW G (QT);
- W : QT := F;
- PRIVATE
- TYPE QS IS NEW QT;
- Z : QS := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014c.ada b/gcc/testsuite/ada/acats/tests/c3/c34014c.ada
deleted file mode 100644
index 9dd17e2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014c.ada
+++ /dev/null
@@ -1,259 +0,0 @@
--- C34014C.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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER
--- DECLARED EXPLICITLY IN THE PRIVATE PART.
-
--- HISTORY:
--- JRK 09/11/87 CREATED ORIGINAL TEST.
--- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES.
--- PWN 10/24/96 RESTORED CHECK WITH NEW ADA 95 RESULTS EXPECTED.
--- PWB.CTA 02/20/97 Made failure messages unique.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014C IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION F RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (1));
- END F;
- END P;
-
-BEGIN
- TEST ("C34014C", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " &
- "THE PRIVATE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- PRIVATE
- FUNCTION F RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION F RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END F;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- PRIVATE
- FUNCTION G RETURN QT;
- FUNCTION F RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G RETURN T;
-
- FUNCTION G RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- PRIVATE
- FUNCTION F IS NEW G (QT);
- W : QT := F;
- TYPE QS IS NEW QT;
- Z : QS := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014e.ada b/gcc/testsuite/ada/acats/tests/c3/c34014e.ada
deleted file mode 100644
index 0c7fea2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014e.ada
+++ /dev/null
@@ -1,257 +0,0 @@
--- C34014E.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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER
--- DECLARED EXPLICITLY IN THE PACKAGE BODY.
-
--- HISTORY:
--- JRK 09/15/87 CREATED ORIGINAL TEST.
--- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES.
--- PWN 04/11/96 Restored subtests in Ada95 legal format.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014E IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION F RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (1));
- END F;
- END P;
-
-BEGIN
- TEST ("C34014E", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " &
- "THE PACKAGE BODY");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION F RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
-
- FUNCTION F RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END F;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G RETURN QT;
- FUNCTION F RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
-
- FUNCTION G RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G RETURN T;
-
- FUNCTION G RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION F IS NEW G (QT);
- W : QT := F;
- TYPE QS IS NEW QT;
- Z : QS := F;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014g.ada b/gcc/testsuite/ada/acats/tests/c3/c34014g.ada
deleted file mode 100644
index 5be7f50..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014g.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C34014G.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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC SUBPROGRAM IS LATER
--- DECLARED EXPLICITLY.
-
--- HISTORY:
--- JRK 09/16/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014G IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION F RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (1));
- END F;
- END P;
-
-BEGIN
- TEST ("C34014G", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " &
- "SUBPROGRAM IS LATER DECLARED EXPLICITLY");
-
- -----------------------------------------------------------------
-
- COMMENT ("NO NEW SUBPROGRAM DECLARED EXPLICITLY");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := F;
- PRIVATE
- TYPE QS IS NEW QT;
- Z : QS := F;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - 1");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT VISIBLE - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD SUBPROGRAM NOT DERIVED - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014h.ada b/gcc/testsuite/ada/acats/tests/c3/c34014h.ada
deleted file mode 100644
index b1bf56c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014h.ada
+++ /dev/null
@@ -1,208 +0,0 @@
--- C34014H.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 DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE
--- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A
--- HOMOGRAPHIC SUBPROGRAM IN THE VISIBLE PART.
-
--- HISTORY:
--- JRK 09/16/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014H IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION F RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN T IS
- BEGIN
- RETURN T (IDENT_INT (1));
- END F;
- END P;
-
-BEGIN
- TEST ("C34014H", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " &
- "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " &
- "DECLARATION OF A HOMOGRAPHIC SUBPROGRAM IN " &
- "THE VISIBLE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS PRIVATE;
- C2 : CONSTANT QT;
- FUNCTION F RETURN QT;
- TYPE QR1 IS
- RECORD
- C : QT := F;
- END RECORD;
- PRIVATE
- TYPE QT IS NEW T;
- C2 : CONSTANT QT := 2;
- TYPE QR2 IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION F RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END F;
-
- PACKAGE R IS
- X : QR1;
- Y : QR2;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " &
- "DECL - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= C2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 3");
- END IF;
-
- IF Z /= RT (C2) THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS PRIVATE;
- C2 : CONSTANT QT;
- FUNCTION G RETURN QT;
- FUNCTION F RETURN QT RENAMES G;
- TYPE QR1 IS
- RECORD
- C : QT := F;
- END RECORD;
- PRIVATE
- TYPE QT IS NEW T;
- C2 : CONSTANT QT := 2;
- TYPE QR2 IS
- RECORD
- C : QT := F;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G RETURN QT IS
- BEGIN
- RETURN QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- X : QR1;
- Y : QR2;
- Z : QS := F;
- END R;
- USE R;
- BEGIN
- IF X.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " &
- "2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := F;
- TYPE RT IS NEW QT;
- Z : RT := F;
- END R;
- USE R;
-
- BEGIN
- IF Y /= C2 THEN
- FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 3");
- END IF;
-
- IF Z /= RT (C2) THEN
- FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014n.ada b/gcc/testsuite/ada/acats/tests/c3/c34014n.ada
deleted file mode 100644
index 321a784..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014n.ada
+++ /dev/null
@@ -1,256 +0,0 @@
--- C34014N.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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER
--- DECLARED EXPLICITLY IN THE SAME VISIBLE PART.
-
--- HISTORY:
--- JRK 09/21/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014N IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION "+" (X : T) RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X : T) RETURN T IS
- BEGIN
- RETURN X + T (IDENT_INT (1));
- END "+";
- END P;
-
-BEGIN
- TEST ("C34014N", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "OPERATOR IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "OPERATOR IS LATER DECLARED EXPLICITLY IN " &
- "THE SAME VISIBLE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- FUNCTION "+" (Y : QT) RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- PRIVATE
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION "+" (Y : QT) RETURN QT IS
- BEGIN
- RETURN Y + QT (IDENT_INT (2));
- END "+";
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- FUNCTION G (X : QT) RETURN QT;
- FUNCTION "+" (Y : QT) RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- PRIVATE
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G (X : QT) RETURN QT IS
- BEGIN
- RETURN X + QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G (Y : T) RETURN T;
-
- FUNCTION G (Y : T) RETURN T IS
- BEGIN
- RETURN Y + T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- FUNCTION "+" IS NEW G (QT);
- W : QT := +0;
- PRIVATE
- TYPE QS IS NEW QT;
- Z : QS := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014N;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014p.ada b/gcc/testsuite/ada/acats/tests/c3/c34014p.ada
deleted file mode 100644
index 161fbbb..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014p.ada
+++ /dev/null
@@ -1,258 +0,0 @@
--- C34014P.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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER
--- DECLARED EXPLICITLY IN THE PRIVATE PART.
-
--- HISTORY:
--- JRK 09/22/87 CREATED ORIGINAL TEST.
--- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES.
--- PWN 04/11/96 Restored subtests in Ada95 legal format.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014P IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION "+" (X : T) RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X : T) RETURN T IS
- BEGIN
- RETURN X + T (IDENT_INT (1));
- END "+";
- END P;
-
-BEGIN
- TEST ("C34014P", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "OPERATOR IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "OPERATOR IS LATER DECLARED EXPLICITLY IN " &
- "THE PRIVATE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- PRIVATE
- FUNCTION "+" (Y : QT) RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION "+" (Y : QT) RETURN QT IS
- BEGIN
- RETURN Y + QT (IDENT_INT (2));
- END "+";
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- PRIVATE
- FUNCTION G (X : QT) RETURN QT;
- FUNCTION "+" (Y : QT) RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G (X : QT) RETURN QT IS
- BEGIN
- RETURN X + QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G (Y : T) RETURN T;
-
- FUNCTION G (Y : T) RETURN T IS
- BEGIN
- RETURN Y + T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- PRIVATE
- FUNCTION "+" IS NEW G (QT);
- W : QT := +0;
- TYPE QS IS NEW QT;
- Z : QS := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014r.ada b/gcc/testsuite/ada/acats/tests/c3/c34014r.ada
deleted file mode 100644
index ab21b48..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014r.ada
+++ /dev/null
@@ -1,257 +0,0 @@
--- C34014R.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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER
--- DECLARED EXPLICITLY IN THE PACKAGE BODY.
-
--- HISTORY:
--- JRK 09/22/87 CREATED ORIGINAL TEST.
--- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES.
--- PWN 04/11/96 Restored subtests in Ada95 legal format.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014R IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION "+" (X : T) RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X : T) RETURN T IS
- BEGIN
- RETURN X + T (IDENT_INT (1));
- END "+";
- END P;
-
-BEGIN
- TEST ("C34014R", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "OPERATOR IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
- "OPERATOR IS LATER DECLARED EXPLICITLY IN " &
- "THE PACKAGE BODY");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION "+" (Y : QT) RETURN QT;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
-
- FUNCTION "+" (Y : QT) RETURN QT IS
- BEGIN
- RETURN Y + QT (IDENT_INT (2));
- END "+";
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G (X : QT) RETURN QT;
- FUNCTION "+" (Y : QT) RETURN QT RENAMES G;
- TYPE QR IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
-
- FUNCTION G (X : QT) RETURN QT IS
- BEGIN
- RETURN X + QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- Y : QR;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION");
-
- DECLARE
-
- GENERIC
- TYPE T IS RANGE <>;
- FUNCTION G (Y : T) RETURN T;
-
- FUNCTION G (Y : T) RETURN T IS
- BEGIN
- RETURN Y + T (IDENT_INT (2));
- END G;
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION "+" IS NEW G (QT);
- W : QT := +0;
- TYPE QS IS NEW QT;
- Z : QS := +0;
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - " &
- "INSTANTIATION - 1");
- END IF;
-
- IF W /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - " &
- "INSTANTIATION");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - " &
- "INSTANTIATION - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " &
- "2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " &
- "2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014R;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014t.ada b/gcc/testsuite/ada/acats/tests/c3/c34014t.ada
deleted file mode 100644
index ddf22c6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014t.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C34014T.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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
--- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC OPERATOR IS LATER
--- DECLARED EXPLICITLY.
-
--- HISTORY:
--- JRK 09/22/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014T IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION "+" (X : T) RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X : T) RETURN T IS
- BEGIN
- RETURN X + T (IDENT_INT (1));
- END "+";
- END P;
-
-BEGIN
- TEST ("C34014T", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "OPERATOR IS IMPLICITLY DECLARED IN THE " &
- "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " &
- "OPERATOR IS LATER DECLARED EXPLICITLY");
-
- -----------------------------------------------------------------
-
- COMMENT ("NO NEW OPERATOR DECLARED EXPLICITLY");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS NEW T;
- X : QT := +0;
- PRIVATE
- TYPE QS IS NEW QT;
- Z : QS := +0;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - 1");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +0;
- TYPE RT IS NEW QT;
- Z : RT := +0;
- END R;
- USE R;
-
- BEGIN
- IF Y /= 1 THEN
- FAILED ("OLD OPERATOR NOT VISIBLE - 2");
- END IF;
-
- IF Z /= 1 THEN
- FAILED ("OLD OPERATOR NOT DERIVED - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014T;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34014u.ada b/gcc/testsuite/ada/acats/tests/c3/c34014u.ada
deleted file mode 100644
index 209b06d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34014u.ada
+++ /dev/null
@@ -1,212 +0,0 @@
--- C34014U.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 DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
--- UNDER APPROPRIATE CIRCUMSTANCES.
-
--- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
--- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A
--- HOMOGRAPHIC OPERATOR IN THE VISIBLE PART.
-
--- HISTORY:
--- JRK 09/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C34014U IS
-
- PACKAGE P IS
- TYPE T IS RANGE -100 .. 100;
- FUNCTION "+" (X : T) RETURN T;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X : T) RETURN T IS
- BEGIN
- RETURN X + T (IDENT_INT (1));
- END "+";
- END P;
-
-BEGIN
- TEST ("C34014U", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
- "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
- "CIRCUMSTANCES. CHECK WHEN THE DERIVED " &
- "OPERATOR IS IMPLICITLY DECLARED IN THE " &
- "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " &
- "DECLARATION OF A HOMOGRAPHIC OPERATOR IN " &
- "THE VISIBLE PART");
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS PRIVATE;
- C0 : CONSTANT QT;
- C2 : CONSTANT QT;
- FUNCTION "+" (Y : QT) RETURN QT;
- TYPE QR1 IS
- RECORD
- C : QT := +C0;
- END RECORD;
- PRIVATE
- TYPE QT IS NEW T;
- C0 : CONSTANT QT := 0;
- C2 : CONSTANT QT := 2;
- TYPE QR2 IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION "+" (Y : QT) RETURN QT IS
- BEGIN
- RETURN Y + QT (IDENT_INT (2));
- END "+";
-
- PACKAGE R IS
- X : QR1;
- Y : QR2;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL - 1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
- "DECL - 2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " &
- "DECL - 1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +C0;
- TYPE RT IS NEW QT;
- Z : RT := +RT(C0);
- END R;
- USE R;
-
- BEGIN
- IF Y /= C2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 3");
- END IF;
-
- IF Z /= RT (C2) THEN
- FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- COMMENT ("NEW OPERATOR DECLARED BY RENAMING");
-
- DECLARE
-
- PACKAGE Q IS
- TYPE QT IS PRIVATE;
- C0 : CONSTANT QT;
- C2 : CONSTANT QT;
- FUNCTION G (X : QT) RETURN QT;
- FUNCTION "+" (Y : QT) RETURN QT RENAMES G;
- TYPE QR1 IS
- RECORD
- C : QT := +C0;
- END RECORD;
- PRIVATE
- TYPE QT IS NEW T;
- C0 : CONSTANT QT := 0;
- C2 : CONSTANT QT := 2;
- TYPE QR2 IS
- RECORD
- C : QT := +0;
- END RECORD;
- TYPE QS IS NEW QT;
- END Q;
- USE Q;
-
- PACKAGE BODY Q IS
- FUNCTION G (X : QT) RETURN QT IS
- BEGIN
- RETURN X + QT (IDENT_INT (2));
- END G;
-
- PACKAGE R IS
- X : QR1;
- Y : QR2;
- Z : QS := +0;
- END R;
- USE R;
- BEGIN
- IF X.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " &
- "1");
- END IF;
-
- IF Y.C /= 2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " &
- "2");
- END IF;
-
- IF Z /= 2 THEN
- FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " &
- "1");
- END IF;
- END Q;
-
- PACKAGE R IS
- Y : QT := +C0;
- TYPE RT IS NEW QT;
- Z : RT := +RT(C0);
- END R;
- USE R;
-
- BEGIN
- IF Y /= C2 THEN
- FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 3");
- END IF;
-
- IF Z /= RT (C2) THEN
- FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2");
- END IF;
- END;
-
- -----------------------------------------------------------------
-
- RESULT;
-END C34014U;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c34018a.ada b/gcc/testsuite/ada/acats/tests/c3/c34018a.ada
deleted file mode 100644
index d039337..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c34018a.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- C34018A.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 OF DERIVED SUBPROGRAMS CHECK CONSTRAINTS OF THE
--- PARENT SUBPROGRAM, NOT THE CONSTRAINTS OF THE DERIVED SUBTYPE.
-
--- JBG 11/15/85
--- JRK 2/12/86 CORRECTED ERROR: RESOLVED AMBIGUOUS CALL G(41) TO
--- TYPE NEW_INT.
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C34018A IS
-
- PACKAGE P IS
- TYPE INT IS RANGE 1..100;
- SUBTYPE INT_50 IS INT RANGE 1..50;
- SUBTYPE INT_51 IS INT RANGE 51..100;
-
- FUNCTION "+" (L, R : INT) RETURN INT;
- FUNCTION G (X : INT_50) RETURN INT_51;
-
- TYPE STR IS ARRAY (1..10) OF CHARACTER;
- FUNCTION F (X : STR) RETURN STR;
- END P;
-
- USE P;
-
- TYPE NEW_STR IS NEW P.STR;
- TYPE NEW_INT IS NEW P.INT RANGE 51..90;
-
- PACKAGE BODY P IS
-
- FUNCTION "+" (L, R : INT) RETURN INT IS
- BEGIN
- RETURN INT(INTEGER(L) + INTEGER(R));
- END "+";
-
- FUNCTION G (X : INT_50) RETURN INT_51 IS
- BEGIN
- RETURN X + 10;
- END G;
-
- FUNCTION F (X : STR) RETURN STR IS
- BEGIN
- RETURN X;
- END F;
-
- END P;
-
-BEGIN
-
- TEST ("C34018A", "CHECK CONSTRAINTS PROCESSED CORRECTLY FOR " &
- "CALLS OF DERIVED SUBPROGRAMS");
-
- DECLARE
-
- Y : NEW_STR := F("1234567890"); -- UNAMBIGUOUS.
-
- BEGIN
- IF Y /= "1234567890" THEN
- FAILED ("DERIVED F");
- END IF;
- END;
-
- DECLARE
-
- A : INT := 51;
- B : NEW_INT := NEW_INT(IDENT_INT(90));
-
- BEGIN
-
- BEGIN
- A := A + 0;
- FAILED ("NO EXCEPTION - A + 0 = " & INT'IMAGE(A) ); --Use A
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- IF B + 2 /= 92 THEN -- 92 IN INT.
- FAILED ("WRONG RESULT - B + 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("WRONG CONSTRAINT FOR DERIVED ""+""");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 2");
- END;
-
- BEGIN
- IF B + 14 > 90 THEN -- 104 NOT IN INT.
- FAILED ("NO EXCEPTION RAISED FOR DERIVED ""+""");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 3");
- END;
-
-
- BEGIN
- IF G(B) > 90 THEN -- 90 NOT IN INT_50.
- FAILED ("NO EXCEPTION RAISED FOR DERIVED G");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 4");
- END;
-
- BEGIN
- IF C34018A.G(41) /= 51 THEN -- 41 CONVERTED TO
- -- NEW_INT'BASE.
- -- 41 IN INT_50.
- -- 51 IN INT_51.
- FAILED ("WRONG RESULT - G(41)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("C_E RAISED FOR LITERAL ARGUMENT");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 5");
- END;
- END;
-
- RESULT;
-END C34018A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a01.a b/gcc/testsuite/ada/acats/tests/c3/c340a01.a
deleted file mode 100644
index 108a30b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340a01.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C340A01.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 tagged type declared in a package specification
--- may be passed as a generic formal (tagged) private type to a generic
--- package declaration. Check that the formal type may be extended with
--- a record extension in the generic package.
---
--- Check that, in the instance, the record extension inherits the
--- user-defined primitive subprograms of the tagged actual.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a generic package
--- which takes a tagged type as a formal parameter, and then extends
--- it with a record extension (foundation code).
---
--- Instantiate the generic package with the tagged type from the first
--- package (the "generic" extension should now have inherited
--- the primitive subprogram of the tagged type from the first
--- package).
---
--- In the main program, call the primitive subprogram inherited by the
--- "generic" extension, and verify the correctness of the components.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F340A000.A
--- F340A001.A
--- => C340A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous
--- comments.
---
---!
-
-with F340A001; -- Book definitions.
-package C340A01_0 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
-end C340A01_0;
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is tagged record.
-
-with F340A001; -- Book definitions.
-with F340A000; -- Singly-linked list abstraction.
-package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with F340A001; -- Book definitions.
-with C340A01_0; -- Raw book data.
-with C340A01_1; -- Instance.
-
-use F340A001; -- Primitive operations of Book_Type directly visible.
-use C340A01_1; -- Operations inherited by Node_Type directly visible.
-
-procedure C340A01 is
-
-
- List_Of_Books : Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C340A01_0.Data_List;
- Head : in out Node_Ptr) is
-
- Book : Node_Type; -- Object of extended type.
- Book_Ptr : Node_Ptr;
-
- begin
- for I in C340A01_0.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call inherited
- -- operation.
- Book_Ptr := new Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- begin
- return (List_Of_Books.Title.all /= "Ulysses" or
- List_Of_Books.Author.all /= "Joyce, James" or
- List_Of_Books.Next.Title.all /= "Heart of Darkness" or
- List_Of_Books.Next.Author.all /= "Conrad, Joseph" or
- List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or
- List_Of_Books.Next.Next.Author.all /= "Bronte, Emily");
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C340A01", "Inheritance of primitive operations: record " &
- "extension of formal tagged private type; actual is " &
- "an ultimate ancestor type");
-
- -- Create linked list using inherited operation:
- Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operation");
- end if;
-
- Report.Result;
-
-end C340A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a02.a b/gcc/testsuite/ada/acats/tests/c3/c340a02.a
deleted file mode 100644
index 2dd8f17..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340a02.a
+++ /dev/null
@@ -1,221 +0,0 @@
--- C340A02.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 record extension (declared in a package specification) of
--- a tagged type (declared in a different package specification) may be
--- passed as a generic formal (tagged) private type to a generic package
--- declaration. Check that the formal type may be further extended with a
--- record extension in the generic package.
---
--- Check that, in the instance, the record extension inherits the
--- user-defined primitive subprograms of the tagged actual, including
--- those inherited by the actual from its parent.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a record extension
--- of the tagged type and an associated primitive subprogram in a second
--- package specification. Declare a generic package which takes a tagged
--- type as a formal parameter, and then extends it with a record
--- extension (foundation code).
---
--- Instantiate the generic package with the record extension from the
--- second package (the "generic" extension should now have inherited
--- the primitive subprograms of the record extension from the second
--- package).
---
--- In the main program, call the primitive subprograms inherited by the
--- "generic" extension. There are two: (1) Create_Book, declared for
--- the root tagged type in the first package (inherited by the record
--- extension of the second package, and then in turn by the "generic"
--- extension), and (2) Update_Pages, declared for the record extension
--- in the second package. Verify the correctness of the components.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F340A000.A
--- F340A001.A
--- => C340A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous
--- comments.
---
---!
-
-with F340A001; -- Book definitions.
-package C340A02_0 is -- Extended book abstraction.
-
-
- type Detailed_Book_Type is new F340A001.Book_Type with record
- Pages : Natural; -- Record ext.
- end record; -- of root tagged
- -- type.
-
- -- Inherits Create_Book from Book_Type.
-
- procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op.
- Pages : in Natural); -- of extension.
-
-
-end C340A02_0;
-
-
- --==================================================================--
-
-
-package body C340A02_0 is
-
-
- procedure Update_Pages (Book : in out Detailed_Book_Type;
- Pages : in Natural) is
- begin
- Book.Pages := Pages;
- end Update_Pages;
-
-
-end C340A02_0;
-
-
- --==================================================================--
-
-
-with F340A001; -- Book definitions.
-package C340A02_1 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr;
- type Page_Counts is array (Number_Of_Books) of Natural;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
- Page_List : Page_Counts := (237, 215, 456);
-
-end C340A02_1;
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is record extension.
-
-with C340A02_0; -- Extended book abstraction.
-with F340A000; -- Singly-linked list abstraction.
-package C340A02_2 is new F340A000
- (Parent_Type => C340A02_0.Detailed_Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with C340A02_0; -- Extended book abstraction.
-with C340A02_1; -- Raw book data.
-with C340A02_2; -- Instance.
-
-use C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
-use C340A02_2; -- Operations inherited by Node_Type directly visible.
-
-procedure C340A02 is
-
-
- List_Of_Books : Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C340A02_1.Data_List;
- Pages : in C340A02_1.Page_Counts;
- Head : in out Node_Ptr) is
-
- Book : Node_Type; -- Object of extended type.
- Book_Ptr : Node_Ptr;
-
- begin
- for I in C340A02_1.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call twice-inherited
- -- operation.
- Update_Pages (Book, Pages (I)); -- Call inherited op.
- Book_Ptr := new Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- begin
- return (List_Of_Books.Title.all /= "Ulysses" or
- List_Of_Books.Author.all /= "Joyce, James" or
- List_Of_Books.Pages /= 456 or
- List_Of_Books.Next.Title.all /= "Heart of Darkness" or
- List_Of_Books.Next.Author.all /= "Conrad, Joseph" or
- List_Of_Books.Next.Pages /= 215 or
- List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or
- List_Of_Books.Next.Next.Author.all /= "Bronte, Emily" or
- List_Of_Books.Next.Next.Pages /= 237);
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C340A02", "Inheritance of primitive operations: record " &
- "extension of formal tagged private type; actual is " &
- "a record extension");
-
- -- Create linked list using inherited operation:
- Create_List (C340A02_1.Title_List, C340A02_1.Author_List,
- C340A02_1.Page_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operations");
- end if;
-
- Report.Result;
-
-end C340A02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a01.a b/gcc/testsuite/ada/acats/tests/c3/c341a01.a
deleted file mode 100644
index 34a1eee..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a01.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- C341A01.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 formal parameters of a class-wide type can be passed
--- values of any specific type within the class.
---
--- TEST DESCRIPTION:
--- Define an object of a root tagged type and of various types derived
--- from the root. Define objects of the root class, and initialize them
--- by parameter association of objects of the specific types (root and
--- extended types) within the class.
---
--- The particular root and extended types used in this abstraction are
--- defined in foundation code (F341A00.A), and are graphically displayed
--- as follows:
---
--- package Bank
--- type Account
--- |
--- |
--- |
--- package Checking
--- type Account
--- |
--- |
--- |
--- package Interest_Checking
--- type Account
---
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F341A00.A
---
--- The following files comprise this test:
---
--- => C341A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-with F341A00_2; -- package Interest_Checking
-with Report;
-
-procedure C341A01 is
-
- package Bank renames F341A00_0;
- use type Bank.Dollar_Amount;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Initialize objects of specific tagged types.
- B_Acct : Bank.Account := (Current_Balance => 10.00);
- C_Acct : Checking.Account := (100.00, 10.00);
- IC_Acct : Interest_Checking.Account := (1000.00, 10.00, 0.030);
-
- -- Define and initialize (by parameter association) objects of class-wide
- -- type originating from the root type (Bank.Account).
-
- -- Define an account auditing procedure with a class-wide
- -- variable that can hold a value of any object within the class.
- procedure Audit (Next_Account : Bank.Account'Class) is
- begin
- Bank_Balance := Bank_Balance + Next_Account.Current_Balance;
- end Audit;
-
-
-begin -- C341A01
-
- Report.Test ("C341A01", "Check that objects of a class-wide type can " &
- "be initialized, by direct assignment, to a " &
- "value of any specific type within the class" );
-
- -- Perform nightly audit of total funds on deposit in bank.
- Audit (B_Acct);
- Audit (C_Acct);
- Audit (IC_Acct);
-
- if Bank_Balance /= 1110.00 then
- Report.Failed ("Class-wide object processing failed");
- end if;
-
- Report.Result;
-
-end C341A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a02.a b/gcc/testsuite/ada/acats/tests/c3/c341a02.a
deleted file mode 100644
index 4fa9842..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a02.a
+++ /dev/null
@@ -1,145 +0,0 @@
--- C341A02.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 class-wide objects can be reassigned with objects from
- -- the same specific type used to initialize them.
- --
- -- TEST DESCRIPTION:
- -- Define new objects of specific types from within a class. Reassign
- -- previously declared class-wide objects with the new specific type
- -- objects. Check that new assignments were performed.
- --
- -- The particular root and extended types used in this abstraction are
- -- defined in foundation code (F341A00.A), and are graphically displayed
- -- as follows:
- --
- -- package Bank
- -- type Account
- -- |
- -- |
- -- |
- -- package Checking
- -- type Account
- -- |
- -- |
- -- |
- -- package Interest_Checking
- -- type Account
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F341A00.A
- --
- -- The following files comprise this test:
- --
- -- => C341A02.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F341A00_0; -- package Bank
- with F341A00_1; -- package Checking
- with F341A00_2; -- package Interest_Checking
- with Report;
-
- procedure C341A02 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Define and initialize objects of specific types.
- B_Acct : aliased Bank.Account := (Current_Balance => 10.00);
- C_Acct : aliased Checking.Account := (100.00, 10.00);
- IC_Acct : aliased Interest_Checking.Account := (1000.00, 10.00, 0.030);
- New_B_Acct : aliased Bank.Account := (Current_Balance => 20.00);
- New_C_Acct : aliased Checking.Account := (200.00, 20.00);
- New_IC_Acct : aliased Interest_Checking.Account := (2000.00, 20.00, 0.060);
-
-
- -- Define and initialize (by direct assignment) objects of a class-wide
- -- type originating from the root type (Bank.Account).
-
- type ATM_Card is access all Bank.Account'Class;
-
- Accounts : array (1 .. Max_Accts) of ATM_Card :=
- (1 => B_Acct'Access, 2 => C_Acct'Access, 3 => IC_Acct'Access);
-
- New_Accounts : array (1 .. Max_Accts) of ATM_Card :=
- (1 => New_B_Acct'Access,
- 2 => New_C_Acct'Access,
- 3 => New_IC_Acct'Access);
-
- -- Define an account auditing procedure with a class-wide
- -- variable that can hold a value of any object within the class,
- -- and once initialized, can hold other values of the same specific type.
-
- procedure Audit (Num : in integer;
- Amt : out Bank.Dollar_Amount) is
- Account_Being_Audited : Bank.Account'Class := Accounts(Num).all;
- use type Bank.Dollar_Amount;
- begin
- Amt := Account_Being_Audited.Current_Balance;
- -- Reassign class-wide variable to another object of the type used to
- -- initialize it.
- Account_Being_Audited := New_Accounts(Num).all;
- Amt := Amt + Account_Being_Audited.Current_Balance; -- Reading OUT
- end Audit; -- parameter.
-
-
- begin
-
- Report.Test ("C341A02", "Check that class-wide objects can be " &
- "reassigned with objects from the same " &
- "specific type used to initialize them" );
- Night_Audit:
- declare
- use type Bank.Dollar_Amount;
- Acct_Value : Bank.Dollar_Amount := 0.00;
- begin
- -- Perform nightly audit of total funds on deposit in bank.
- for i in 1 .. Max_Accts loop
- Audit (i, Acct_Value);
- Bank_Balance := Bank_Balance + Acct_Value;
- end loop;
-
- if Bank_Balance /= 3330.00 then
- Report.Failed ("Class-wide object processing failed");
- end if;
-
- end Night_Audit;
-
- Report.Result;
-
- end C341A02;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a03.a b/gcc/testsuite/ada/acats/tests/c3/c341a03.a
deleted file mode 100644
index 0911e63..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a03.a
+++ /dev/null
@@ -1,140 +0,0 @@
--- C341A03.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 object of one class-wide type can initialize a
--- class-wide object of a different type when the operation is embedded
--- in a generic unit.
---
--- TEST DESCRIPTION:
--- Declare specific-type objects of an extended type. Declare an array
--- of access values designating class-wide objects, initialized to point
--- to the objects of the specific type. Define a generic subprogram
--- having a generic formal derived type parameter. Within the generic,
--- declare a class-wide variable of the formal parameter type. Verify
--- that the variable can be initialized with the value of an object
--- of another class-wide type within the class.
---
--- The particular root and extended types used in this abstraction are
--- defined in foundation code (F341A00.A), and are graphically displayed
--- as follows:
---
--- package Bank
--- type Account
--- |
--- |
--- |
--- package Checking
--- type Account
--- |
--- |
--- |
--- package Interest_Checking
--- type Account
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F341A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Changed level of 'Class for ATM_Card
---
---!
-
-with F341A00_0; -- package Bank
-generic
- type Account_Type is new F341A00_0.Account with private; -- new Bank.Account
-function C341A03_0 (The_Account : Account_Type'Class) -- function Audit
- return F341A00_0.Dollar_Amount;
-
-function C341A03_0 (The_Account : Account_Type'Class)
- return F341A00_0.Dollar_Amount is
- Acct : Account_Type'Class := The_Account; -- Init. of class-wide with
-begin -- another class-wide object.
- return Acct.Current_Balance;
-end C341A03_0;
-
-
- --=================================================================--
-
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-with C341A03_0; -- generic function Audit
-with Report;
-
-procedure C341A03 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
-
- Current_Checking_Accounts : constant := 3;
-
- Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00,
- Overdraft_Fee => 5.00);
- Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00,
- Overdraft_Fee => 5.00);
- Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00,
- Overdraft_Fee => 5.00);
-
- type ATM_Card is access all Checking.Account'Class;
-
- -- Declare array of accesses to class-wide objects.
- Account_Array : array (1 .. Current_Checking_Accounts) of
- ATM_Card := (Checking_Acct1'Access,
- Checking_Acct2'Access,
- Checking_Acct3'Access);
-begin -- C341A03
-
- Report.Test ("C341A03", "Check that an object of one class-wide type " &
- "can initialize a class-wide object of a " &
- "different type when the operation is embedded " &
- "in a generic unit" );
-
- Audit_Checking_Accounts:
- declare
- Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00;
- -- Instantiate with a specific extended type.
- function Checking_Audit is new C341A03_0 (Checking.Account);
- use type Bank.Dollar_Amount;
- begin
-
- for I in 1 .. Current_Checking_Accounts loop
- Balance_In_Checking_Accounts := Balance_In_Checking_Accounts +
- Checking_Audit (Account_Array (I).all);
- end loop;
-
- if Balance_In_Checking_Accounts /= 60.00 then
- Report.Failed ("Incorrect initialization of class-wide object");
- end if;
-
- end Audit_Checking_Accounts;
-
- Report.Result;
-
-end C341A03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a04.a b/gcc/testsuite/ada/acats/tests/c3/c341a04.a
deleted file mode 100644
index d739256..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a04.a
+++ /dev/null
@@ -1,141 +0,0 @@
--- C341A04.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 class-wide objects can be initialized using allocation.
- --
- -- TEST DESCRIPTION:
- -- Declare access types that refer to class-wide types, one with basis
- -- of the root type, another with basis of a type extended from the root.
- -- Declare objects of these access types, and allocate class-wide
- -- objects, initialized to values of specific types within the particular
- -- classes.
- --
- -- The particular root and extended types used in this abstraction are
- -- defined in foundation code (F341A00.A), and are graphically displayed
- -- as follows:
- --
- -- package Bank
- -- type Account
- -- |
- -- |
- -- |
- -- package Checking
- -- type Account
- -- |
- -- |
- -- |
- -- package Interest_Checking
- -- type Account
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F341A00.A
- --
- -- The following files comprise this test:
- --
- -- => C341A04.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F341A00_0; -- package Bank
- with F341A00_1; -- package Checking
- with F341A00_2; -- package Interest_Checking
- with Report;
-
- procedure C341A04 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- use type Bank.Dollar_Amount;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Define access types referring to class of types rooted at
- -- Bank.Account (root).
-
- type Bank_Account_Pointer is access Bank.Account'Class;
-
- --
- -- Define class-wide objects, initializing them through allocation.
- --
-
- -- Initialized to specific type that is basis of class.
- Bank_Acct : Bank_Account_Pointer :=
- new Bank.Account'(Current_Balance => 10.00);
-
- -- Initialized to specific type that has been extended from the basis
- -- of the class.
- Checking_Acct : Bank_Account_Pointer :=
- new Checking.Account'(Current_Balance => 100.00,
- Overdraft_Fee => 10.00);
-
- -- Initialized to specific type that has been twice extended from the
- -- basis of the class.
- IC_Acct : Bank_Account_Pointer :=
- new Interest_Checking.Account'(Current_Balance => 1000.00,
- Overdraft_Fee => 10.00,
- Rate => 0.030);
-
- -- Declare and initialize array of pointers to objects of
- -- Bank.Account'Class.
-
- Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer :=
- (Bank_Acct, Checking_Acct, IC_Acct);
-
-
- -- Audit will process any account object within Bank.Account'Class.
-
- function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is
- begin
- return (Ptr.Current_Balance);
- end Audit;
-
-
- begin -- C341A04
-
- Report.Test ("C341A04", "Check that class-wide objects were " &
- "successfully initialized using allocation" );
-
- for i in 1 .. Max_Accts loop
- Bank_Balance := Bank_Balance + Audit (Accounts(i));
- end loop;
-
- if Bank_Balance /= 1110.00 then
- Report.Failed ("Failed class-wide object allocation");
- end if;
-
- Report.Result;
-
- end C341A04;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35003a.ada b/gcc/testsuite/ada/acats/tests/c3/c35003a.ada
deleted file mode 100644
index c384683..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35003a.ada
+++ /dev/null
@@ -1,234 +0,0 @@
--- C35003A.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 CONSTRAINT_ERROR IS RAISED FOR AN INTEGER OR
--- ENUMERATION SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND
--- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK.
-
--- HISTORY:
--- JET 01/25/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35003A IS
-
- TYPE ENUM IS (ZERO, ONE, TWO, THREE);
- SUBTYPE SUBENUM IS ENUM RANGE ONE..TWO;
- TYPE INT IS RANGE 1..10;
- SUBTYPE SUBINT IS INTEGER RANGE -10..10;
- TYPE A1 IS ARRAY (0..11) OF INTEGER;
- TYPE A2 IS ARRAY (INTEGER RANGE -11..10) OF INTEGER;
-
-BEGIN
- TEST ("C35003A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR AN " &
- "INTEGER OR ENUMERATION SUBTYPE INDICATION " &
- "WHEN THE LOWER OR UPPER BOUND OF A NON-NULL " &
- "RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK");
- BEGIN
- DECLARE
- SUBTYPE SUBSUBENUM IS SUBENUM RANGE ZERO..TWO;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (E1)");
- DECLARE
- Z : SUBSUBENUM := ONE;
- BEGIN
- IF NOT EQUAL(SUBSUBENUM'POS(Z),SUBSUBENUM'POS(Z))
- THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (E1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (E1)");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (SUBENUM RANGE ONE..THREE) OF INTEGER;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (E2)");
- DECLARE
- Z : A := (OTHERS => 0);
- BEGIN
- IF NOT EQUAL(Z(ONE),Z(ONE)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (E2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (E2)");
- END;
-
- BEGIN
- DECLARE
- TYPE I IS ACCESS INT RANGE INT(IDENT_INT(0))..10;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (I1)");
- DECLARE
- Z : I := NEW INT'(1);
- BEGIN
- IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (I1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (I1)");
- END;
-
- BEGIN
- DECLARE
- TYPE I IS NEW INT RANGE 1..INT'SUCC(10);
- BEGIN
- FAILED ("NO EXCEPTION RAISED (I2)");
- DECLARE
- Z : I := 1;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (I2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (I2)");
- END;
-
- BEGIN
- DECLARE
- TYPE R IS RECORD
- A : SUBINT RANGE IDENT_INT(-11)..0;
- END RECORD;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (S1)");
- DECLARE
- Z : R := (A => 1);
- BEGIN
- IF NOT EQUAL(INTEGER(Z.A),INTEGER(Z.A)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (S1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (S1)");
- END;
-
- BEGIN
- DECLARE
- Z : SUBINT RANGE 0..IDENT_INT(11) := 0;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (S2)");
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (S2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (S2)");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE I IS SUBINT RANGE A1'RANGE;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (R1)");
- DECLARE
- Z : I := 1;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (R1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (R1)");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE I IS SUBINT RANGE A2'RANGE;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (R2)");
- DECLARE
- Z : I := 1;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (R2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (R2)");
- END;
-
- RESULT;
-
-END C35003A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35003b.ada b/gcc/testsuite/ada/acats/tests/c3/c35003b.ada
deleted file mode 100644
index 3eebde4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35003b.ada
+++ /dev/null
@@ -1,217 +0,0 @@
--- C35003B.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 CONSTRAINT_ERROR IS RAISED FOR A SUBTYPE INDICATION
--- OF A DISCRETE GENERIC FORMAL TYPE WHEN THE LOWER OR UPPER BOUND
--- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK.
-
--- HISTORY:
--- JET 07/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35003B IS
-
- TYPE ENUM IS (WE, LOVE, WRITING, TESTS);
- TYPE INT IS RANGE -10..10;
-
- GENERIC
- TYPE GEN_ENUM IS (<>);
- TYPE GEN_INT IS RANGE <>;
- PACKAGE GEN_PACK IS
- SUBTYPE SUBENUM IS GEN_ENUM RANGE
- GEN_ENUM'SUCC(GEN_ENUM'FIRST) ..
- GEN_ENUM'PRED(GEN_ENUM'LAST);
- SUBTYPE SUBINT IS GEN_INT RANGE
- GEN_INT'SUCC(GEN_INT'FIRST) ..
- GEN_INT'PRED(GEN_INT'LAST);
- TYPE A1 IS ARRAY (0..GEN_INT'LAST) OF INTEGER;
- TYPE A2 IS ARRAY (GEN_INT RANGE GEN_INT'FIRST..0) OF INTEGER;
- END GEN_PACK;
-
- PACKAGE BODY GEN_PACK IS
- BEGIN
- TEST ("C35003B", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "FOR A SUBTYPE INDICATION OF A DISCRETE " &
- "GENERIC FORMAL TYPE WHEN THE LOWER OR " &
- "UPPER BOUND OF A NON-NULL RANGE LIES " &
- "OUTSIDE THE RANGE OF THE TYPE MARK");
- BEGIN
- DECLARE
- SUBTYPE SUBSUBENUM IS SUBENUM RANGE
- GEN_ENUM'FIRST..SUBENUM'LAST;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (E1)");
- DECLARE
- Z : SUBSUBENUM := SUBENUM'FIRST;
- BEGIN
- IF NOT EQUAL(SUBSUBENUM'POS(Z),
- SUBSUBENUM'POS(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG " &
- "PLACE (E1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (E1)");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (SUBENUM RANGE SUBENUM'FIRST ..
- GEN_ENUM'LAST) OF INTEGER;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (E2)");
- DECLARE
- Z : A := (OTHERS => 0);
- BEGIN
- IF NOT EQUAL(Z(SUBENUM'FIRST),
- Z(SUBENUM'FIRST)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE " &
- "(E2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (E2)");
- END;
-
- BEGIN
- DECLARE
- TYPE I IS ACCESS SUBINT RANGE
- GEN_INT'FIRST..SUBINT'LAST;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (I1)");
- DECLARE
- Z : I := NEW SUBINT'(SUBINT'FIRST);
- BEGIN
- IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL))
- THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE " &
- "(I1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (I1)");
- END;
-
- BEGIN
- DECLARE
- TYPE I IS NEW
- SUBINT RANGE SUBINT'FIRST..GEN_INT'LAST;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (I2)");
- DECLARE
- Z : I := I'FIRST;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE " &
- "(I2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (I2)");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE I IS SUBINT RANGE A1'RANGE;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (R1)");
- DECLARE
- Z : I := SUBINT'FIRST;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE " &
- "(R1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (R1)");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE I IS SUBINT RANGE A2'RANGE;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (R2)");
- DECLARE
- Z : I := 1;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE " &
- "(R2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (R2)");
- END;
- END GEN_PACK;
-
- PACKAGE ENUM_PACK IS NEW GEN_PACK(ENUM, INT);
-
-BEGIN
- RESULT;
-END C35003B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35003d.ada b/gcc/testsuite/ada/acats/tests/c3/c35003d.ada
deleted file mode 100644
index c5241ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35003d.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C35003D.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 CONSTRAINT_ERROR IS RAISED FOR A FLOATING-POINT
--- SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND OF A NON-NULL
--- RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35003D IS
-
- SUBTYPE FLT1 IS FLOAT RANGE -100.0 .. 100.0;
-
-BEGIN
- TEST ("C35003D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " &
- "FLOATING-POINT SUBTYPE INDICATION WHEN THE " &
- "LOWER OR UPPER BOUND OF A NON-NULL RANGE LIES " &
- "OUTSIDE THE RANGE OF THE TYPE MARK");
- BEGIN
- DECLARE
- SUBTYPE F IS FLT1 RANGE 0.0..101.0+FLT1(IDENT_INT(0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED (F1)");
- DECLARE
- Z : F := 1.0;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (F1)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (F1)");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE F IS FLT1 RANGE -101.0..0.0;
- BEGIN
- FAILED ("NO EXCEPTION RAISED (F2)");
- DECLARE
- Z : F := -1.0;
- BEGIN
- IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN
- COMMENT ("DON'T OPTIMIZE Z");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN WRONG PLACE (F2)");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED (F2)");
- END;
-
- RESULT;
-
-END C35003D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35102a.ada b/gcc/testsuite/ada/acats/tests/c3/c35102a.ada
deleted file mode 100644
index a5ca875..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35102a.ada
+++ /dev/null
@@ -1,364 +0,0 @@
--- C35102A.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 ENUMERATION LITERAL BELONGING TO ONE ENUMERATION TYPE
--- MAY BE DECLARED IN ANOTHER ENUMERATION TYPE DEFINITION IN THE SAME
--- DECLARATIVE REGION.
-
--- R.WILLIAMS 8/20/86
--- GMT 6/30/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY
--- CREATED PACKAGE NAMED SHOW_TEST_HEADER.
--- ADDED CODE FOR MY_PACK AND MY_FTN.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35102A IS
-
- TYPE E1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE E2 IS ('A', 'C', RED, BLUE);
-
- PACKAGE SHOW_TEST_HEADER IS
- -- PURPOSE OF THIS PACKAGE:
- -- WE WANT THE TEST HEADER INFORMATION TO BE
- -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES.
- END SHOW_TEST_HEADER;
-
- PACKAGE BODY SHOW_TEST_HEADER IS
- BEGIN
- TEST ( "C35102A",
- "CHECK THAT AN ENUMERATION LITERAL BELONGING " &
- "TO ONE ENUMERATION TYPE MAY BE DECLARED IN " &
- "ANOTHER ENUMERATION TYPE DEFINITION IN THE " &
- "SAME DECLARATIVE REGION" );
- END SHOW_TEST_HEADER;
-
- FUNCTION MY_FTN ( E : E1 ) RETURN E2 IS
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN MY_FTN - 1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN MY_FTN - 1" );
- END IF;
-
- RETURN E2'VAL ( IDENT_INT ( E1'POS(E) ) );
- END MY_FTN;
-
-
- PACKAGE MY_PACK IS
- END MY_PACK;
-
- PACKAGE BODY MY_PACK IS
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
- BEGIN -- MY_PACK
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN MY_PACK - 1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN MY_PACK - 1" );
- END IF;
- END MY_PACK;
-
- PACKAGE PKG IS
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN PKG - 1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN PKG - 1" );
- END IF;
- END PKG;
-
- PACKAGE PRIV IS
- TYPE ENUM1 IS PRIVATE;
- TYPE ENUM2 IS PRIVATE;
-
- FUNCTION FE1 (E : E1) RETURN ENUM1;
-
- FUNCTION FE2 (E : E2) RETURN ENUM2;
-
- PRIVATE
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- END PRIV;
-
- PACKAGE BODY PRIV IS
- FUNCTION FE1 (E : E1) RETURN ENUM1 IS
- BEGIN
- RETURN ENUM1'VAL (IDENT_INT (E1'POS (E)));
- END FE1;
-
- FUNCTION FE2 (E : E2) RETURN ENUM2 IS
- BEGIN
- RETURN ENUM2'VAL (IDENT_INT (E2'POS (E)));
- END FE2;
-
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN PRIV - 1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN PRIV - 1" );
- END IF;
- END PRIV;
-
- PACKAGE LPRIV IS
- TYPE ENUM1 IS LIMITED PRIVATE;
- TYPE ENUM2 IS LIMITED PRIVATE;
-
- FUNCTION FE1 (E : E1) RETURN ENUM1;
-
- FUNCTION FE2 (E : E2) RETURN ENUM2;
-
- FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN;
-
- FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN;
-
- PRIVATE
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- END LPRIV;
-
- PACKAGE BODY LPRIV IS
- FUNCTION FE1 (E : E1) RETURN ENUM1 IS
- BEGIN
- RETURN ENUM1'VAL (IDENT_INT (E1'POS (E)));
- END FE1;
-
- FUNCTION FE2 (E : E2) RETURN ENUM2 IS
- BEGIN
- RETURN ENUM2'VAL (IDENT_INT (E2'POS (E)));
- END FE2;
-
- FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN IS
- BEGIN
- IF A = B THEN
- RETURN TRUE;
- ELSE
- RETURN FALSE;
- END IF;
- END EQUALS;
-
- FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN IS
- BEGIN
- IF A = B THEN
- RETURN TRUE;
- ELSE
- RETURN FALSE;
- END IF;
- END EQUALS;
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN LPRIV - 1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN LPRIV - 2" );
- END IF;
- END LPRIV;
-
- TASK T1;
-
- TASK BODY T1 IS
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN T1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN T1" );
- END IF;
- END T1;
-
- TASK T2 IS
- ENTRY E;
- END T2;
-
- TASK BODY T2 IS
- BEGIN
- ACCEPT E DO
- DECLARE
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN T2.E" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN " &
- "ENUM1 IN T2.E" );
- END IF;
- END;
- END E;
- END T2;
-
- GENERIC
- PROCEDURE GP1;
-
- PROCEDURE GP1 IS
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN GP1" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN GP1" );
- END IF;
- END GP1;
-
- GENERIC
- TYPE E1 IS (<>);
- TYPE E2 IS (<>);
- PROCEDURE GP2;
-
- PROCEDURE GP2 IS
- BEGIN
- IF E2'SUCC (E2'VALUE ("'A'")) /= E2'VALUE ("'C'") THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN E2 " &
- "IN GP2" );
- END IF;
-
- IF E1'POS (E1'VALUE ("RED")) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN E1 " &
- "IN GP2" );
- END IF;
- END GP2;
-
- PROCEDURE NEWGP1 IS NEW GP1;
- PROCEDURE NEWGP2 IS NEW GP2 (E1, E2);
-
-BEGIN
-
- DECLARE
- TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE);
- TYPE ENUM2 IS ('A', 'C', RED, BLUE);
-
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN BLOCK" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN BLOCK" );
- END IF;
- END;
-
- DECLARE
- USE PKG;
- BEGIN
- IF ENUM2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN PKG - 2" );
- END IF;
-
- IF ENUM1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN PKG - 2" );
- END IF;
- END;
-
- DECLARE
- USE PRIV;
- BEGIN
- IF FE2 (E2'SUCC('A')) /= FE2 ('C') THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN PRIV - 2" );
- END IF;
-
- IF FE1 (RED) /= FE1 (E1'VAL (3)) THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN PRIV - 2" );
- END IF;
- END;
-
- DECLARE
- USE LPRIV;
- BEGIN
- IF NOT EQUALS (FE2 (E2'SUCC('A')), FE2 ('C')) THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " &
- "IN LPRIV - 2" );
- END IF;
-
- IF NOT EQUALS (FE1 (RED), FE1 (E1'VAL (3))) THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " &
- "IN LPRIV - 2" );
- END IF;
- END;
-
- BEGIN
- IF E2'SUCC ('A') /= 'C' THEN
- FAILED ( "'A' NOT DECLARED CORRECTLY IN E2" );
- END IF;
-
- IF E1'POS (RED) /= 3 THEN
- FAILED ( "RED NOT DECLARED CORRECTLY IN E1" );
- END IF;
- END;
-
- NEWGP1;
- NEWGP2;
- T2.E;
-
- RESULT;
-END C35102A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c352001.a b/gcc/testsuite/ada/acats/tests/c3/c352001.a
deleted file mode 100644
index 04b094f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c352001.a
+++ /dev/null
@@ -1,270 +0,0 @@
---
--- C352001.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 predefined Character type comprises 256 positions.
--- Check that the names of the non-graphic characters are usable with
--- the attributes (Wide_)Image and (Wide_)Value, and that these
--- attributes produce the correct result.
---
--- TEST DESCRIPTION:
--- Build two tables of nongraphic characters from positions of Row 00
--- (0000-001F and 007F-009F) of the ISO 10646 Basic Multilingual Plane.
--- Fill the first table with compiler created strings. Fill the second
--- table with strings defined by the language. Compare the two tables.
--- Check 256 positions of the predefined character type. Use attributes
--- (Wide_)Image and (Wide_)Value to check the values of the non-graphic
--- characters and the last 2 characters.
---
---
--- CHANGE HISTORY:
--- 20 Jun 95 SAIC Initial prerelease version.
--- 27 Jan 96 SAIC Revised for 2.1. Hid values, added "del" case.
---
---!
-
-with Ada.Characters.Handling;
-with Report;
-procedure C352001 is
-
- Lower_Bound : Integer := 0;
- Middle_Bound : Integer := 31;
- Upper_Bound : Integer := 159;
- Half_Bound : Integer := 127;
- Max_Bound : Integer := 255;
-
- type Dyn_String is access String;
- type Value_Result is array (Character) of Dyn_String;
-
- Table_Of_Character : Value_Result;
- TC_Table : Value_Result;
-
- function CVII(K : Natural) return Character is
- begin
- return Character'Val( Report.Ident_Int(K) );
- end CVII;
-
- function "=" (L, R : String) return Boolean is
- UCL : String (L'First .. L'Last);
- UCR : String (R'First .. R'last);
- begin
- UCL := Ada.Characters.Handling.To_Upper (L);
- UCR := Ada.Characters.Handling.To_Upper (R);
- if UCL'Last /= UCR'Last then
- return False;
- else
- for I in UCL'First .. UCR'Last loop
- if UCL (I) /= UCR (I) then
- return False;
- end if;
- end loop;
- return True;
- end if;
- end "=";
-
-begin
-
- Report.Test ("C352001", "Check that, the predefined Character type " &
- "comprises 256 positions. Check that the names of the " &
- "non-graphic characters are usable with the attributes " &
- "(Wide_)Image and (Wide_)Value, and that these attributes " &
- "produce the correct result");
-
- -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
- -- 10646 Basic Multilingual Plane created by the compiler.
-
- for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
- Table_Of_Character (I) := new String'(Character'Image(I));
- end loop;
-
- -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
- -- 10646 Basic Multilingual Plane created by the compiler.
-
- for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
- Table_Of_Character (I) := new String'(Character'Image(I));
- end loop;
-
- -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
- -- 10646 Basic Multilingual Plane defined by the language.
-
- TC_Table (CVII(0)) := new String'("nul");
- TC_Table (CVII(1)) := new String'("soh");
- TC_Table (CVII(2)) := new String'("stx");
- TC_Table (CVII(3)) := new String'("etx");
- TC_Table (CVII(4)) := new String'("eot");
- TC_Table (CVII(5)) := new String'("enq");
- TC_Table (CVII(6)) := new String'("ack");
- TC_Table (CVII(7)) := new String'("bel");
- TC_Table (CVII(8)) := new String'("bs");
- TC_Table (CVII(9)) := new String'("ht");
- TC_Table (CVII(10)) := new String'("lf");
- TC_Table (CVII(11)) := new String'("vt");
- TC_Table (CVII(12)) := new String'("ff");
- TC_Table (CVII(13)) := new String'("cr");
- TC_Table (CVII(14)) := new String'("so");
- TC_Table (CVII(15)) := new String'("si");
- TC_Table (CVII(16)) := new String'("dle");
- TC_Table (CVII(17)) := new String'("dc1");
- TC_Table (CVII(18)) := new String'("dc2");
- TC_Table (CVII(19)) := new String'("dc3");
- TC_Table (CVII(20)) := new String'("dc4");
- TC_Table (CVII(21)) := new String'("nak");
- TC_Table (CVII(22)) := new String'("syn");
- TC_Table (CVII(23)) := new String'("etb");
- TC_Table (CVII(24)) := new String'("can");
- TC_Table (CVII(25)) := new String'("em");
- TC_Table (CVII(26)) := new String'("sub");
- TC_Table (CVII(27)) := new String'("esc");
- TC_Table (CVII(28)) := new String'("fs");
- TC_Table (CVII(29)) := new String'("gs");
- TC_Table (CVII(30)) := new String'("rs");
- TC_Table (CVII(31)) := new String'("us");
- TC_Table (CVII(127)) := new String'("del");
-
- -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
- -- 10646 Basic Multilingual Plane defined by the language.
-
- TC_Table (CVII(128)) := new String'("reserved_128");
- TC_Table (CVII(129)) := new String'("reserved_129");
- TC_Table (CVII(130)) := new String'("bph");
- TC_Table (CVII(131)) := new String'("nbh");
- TC_Table (CVII(132)) := new String'("reserved_132");
- TC_Table (CVII(133)) := new String'("nel");
- TC_Table (CVII(134)) := new String'("ssa");
- TC_Table (CVII(135)) := new String'("esa");
- TC_Table (CVII(136)) := new String'("hts");
- TC_Table (CVII(137)) := new String'("htj");
- TC_Table (CVII(138)) := new String'("vts");
- TC_Table (CVII(139)) := new String'("pld");
- TC_Table (CVII(140)) := new String'("plu");
- TC_Table (CVII(141)) := new String'("ri");
- TC_Table (CVII(142)) := new String'("ss2");
- TC_Table (CVII(143)) := new String'("ss3");
- TC_Table (CVII(144)) := new String'("dcs");
- TC_Table (CVII(145)) := new String'("pu1");
- TC_Table (CVII(146)) := new String'("pu2");
- TC_Table (CVII(147)) := new String'("sts");
- TC_Table (CVII(148)) := new String'("cch");
- TC_Table (CVII(149)) := new String'("mw");
- TC_Table (CVII(150)) := new String'("spa");
- TC_Table (CVII(151)) := new String'("epa");
- TC_Table (CVII(152)) := new String'("sos");
- TC_Table (CVII(153)) := new String'("reserved_153");
- TC_Table (CVII(154)) := new String'("sci");
- TC_Table (CVII(155)) := new String'("csi");
- TC_Table (CVII(156)) := new String'("st");
- TC_Table (CVII(157)) := new String'("osc");
- TC_Table (CVII(158)) := new String'("pm");
- TC_Table (CVII(159)) := new String'("apc");
-
-
- -- Compare the first half of two tables.
- for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
- if TC_Table(I).all /= Table_Of_Character(I).all then
- Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
- " is not the same in the first half of the table");
- end if;
- end loop;
-
-
- -- Compare the second half of two tables.
- for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
- if TC_Table(I).all /= Table_Of_Character(I).all then
- Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
- " is not the same in the second half of the table");
- end if;
- end loop;
-
-
- -- Check the first character.
- if Character'Image( Character'First ) /= "NUL" then
- Report.Failed("Value of character#" &
- Integer'Image(Character'Pos (Character'First)) &
- " is not NUL");
- end if;
-
-
- -- Check that the names of the non-graphic characters are usable with
- -- Image and Value attributes.
- if Character'Value( Character'Image( CVII(153) )) /=
- CVII( 153 ) then
- Report.Failed ("Value of character#" &
- Integer'Image( Character'Pos(CVII(153)) ) &
- " is not reserved_153");
- end if;
-
-
- for I in CVII(Lower_Bound) .. CVII(Max_Bound) loop
- if Character'Value(
- Report.Ident_Str(
- Character'Image(CVII(Character'Pos(I)))))
- /= CVII( Character'Pos(I)) then
- Report.Failed ("Value of character#" &
- Integer'Image( Character'Pos(I) ) &
- " is not the same as the predefined character type");
- end if;
- end loop;
-
-
- -- Check Wide_Character attributes.
- for I in Wide_Character'Val(Lower_Bound) .. Wide_Character'Val(Max_Bound)
- loop
- if Wide_Character'Wide_Value(
- Report.Ident_Wide_Str(
- Wide_Character'Wide_Image(
- Wide_Character'Val(Wide_Character'Pos(I)))))
- /= Wide_Character'Val(Wide_Character'Pos(I))
- then
- Report.Failed ("Value of the predefined Wide_Character type " &
- "is not correct");
- end if;
- end loop;
-
-
- if Wide_Character'Value( Wide_Character'Image(Wide_Character'Val(132)) )
- /= Wide_Character'Val( Report.Ident_Int(132) ) then
- Report.Failed ("Wide_Character at 132 is not reserved_132");
- end if;
-
-
- if Wide_Character'Image( Wide_Character'First ) /= "NUL" then
- Report.Failed ("Wide_Character'First is not NUL");
- end if;
-
-
- if Wide_Character'Image
- (Wide_Character'Pred (Wide_Character'Last) ) /= "FFFE" then
- Report.Failed ("Wide_Character at 65534 is not FFFE");
- end if;
-
-
- if Wide_Character'Image(Wide_Character'Last) /= "FFFF" then
- Report.Failed ("Wide_Character'Last is not FFFF");
- end if;
-
- Report.Result;
-
-end C352001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c354002.a b/gcc/testsuite/ada/acats/tests/c3/c354002.a
deleted file mode 100644
index 3129182..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c354002.a
+++ /dev/null
@@ -1,335 +0,0 @@
---
--- C354002.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 attributes of modular types yield
--- correct values/results. The attributes checked are:
---
--- First, Last, Range, Base, Min, Max, Succ, Pred,
--- Image, Width, Value, Pos, and Val
---
--- TEST DESCRIPTION:
--- This test defines several modular types. One type defined at
--- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus,
--- a power of two half that of System.Max_Binary_Modulus, one less
--- than that power of two; one more than that power of two, two
--- less than a (large) power of two. For each of these types,
--- determine the correct operation of the following attributes:
---
--- First, Last, Range, Base, Min, Max, Succ, Pred, Image, Width,
--- Value, Pos, Val, and Modulus
---
--- The attributes Wide_Image and Wide_Value are deferred to C354003.
---
---
---
--- CHANGE HISTORY:
--- 08 SEP 94 SAIC Initial version
--- 17 NOV 94 SAIC Revised version
--- 13 DEC 94 SAIC split off Wide_String attributes into C354003
--- 06 JAN 95 SAIC Promoted to next release
--- 19 APR 95 SAIC Revised in accord with reviewer comments
--- 27 JAN 96 SAIC Eliminated 32/64 bit potential conflict for 2.1
---
---!
-
-with Report;
-with System;
-with TCTouch;
-procedure C354002 is
-
- function ID(Local_Value: Integer) return Integer renames Report.Ident_Int;
- function ID(Local_Value: String) return String renames Report.Ident_Str;
-
- Power_2_Bits : constant := System.Storage_Unit;
- Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2;
-
- type Max_Binary is mod System.Max_Binary_Modulus;
- type Max_NonBinary is mod System.Max_Nonbinary_Modulus;
- type Half_Max_Binary is mod Half_Max_Binary_Value;
-
- type Medium is mod 2048;
- type Medium_Plus is mod 2042;
- type Medium_Minus is mod 2111;
-
- type Small is mod 2;
- type Finger is mod 5;
-
- MBL : constant := Max_NonBinary'Last;
- MNBM : constant := Max_NonBinary'Modulus;
-
- Ones_Complement_Permission : constant Boolean := MBL = MNBM;
-
- type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie);
-
- subtype Midrange is Medium_Minus range 222 .. 1111;
-
--- a few numbers for testing purposes
- Max_Binary_Mod_Over_3 : constant := Max_Binary'Modulus / 3;
- Max_NonBinary_Mod_Over_4 : constant := Max_NonBinary'Modulus / 4;
- System_Max_Bin_Mod_Pred : constant := System.Max_Binary_Modulus - 1;
- System_Max_NonBin_Mod_Pred : constant := System.Max_Nonbinary_Modulus - 1;
- Half_Max_Bin_Value_Pred : constant := Half_Max_Binary_Value - 1;
-
- AMB, BMB : Max_Binary;
- AHMB, BHMB : Half_Max_Binary;
- AM, BM : Medium;
- AMP, BMP : Medium_Plus;
- AMM, BMM : Medium_Minus;
- AS, BS : Small;
- AF, BF : Finger;
-
- TC_Pass_Case : Boolean := True;
-
- procedure Value_Fault( S: String ) is
- -- check 'Value for failure modes
- begin
- -- the evaluation of the 'Value expression should raise C_E
- TCTouch.Assert_Not( Midrange'Value(S) = 0, "Value_Fault" );
- if Midrange'Value(S) not in Midrange'Base then
- Report.Failed("'Value(" & S & ") raised no exception");
- end if;
- exception
- when Constraint_Error => null; -- expected case
- when others =>
- Report.Failed("'Value(" & S & ") raised wrong exception");
- end Value_Fault;
-
-begin -- Main test procedure.
-
- Report.Test ("C354002", "Check attributes of modular types" );
-
--- Base
- TCTouch.Assert( Midrange'Base'First = 0, "Midrange'Base'First" );
- TCTouch.Assert( Midrange'Base'Last = Medium_Minus'Last,
- "Midrange'Base'Last" );
-
--- First
- TCTouch.Assert( Max_Binary'First = 0, "Max_Binary'First" );
- TCTouch.Assert( Max_NonBinary'First = 0, "Max_NonBinary'First" );
- TCTouch.Assert( Half_Max_Binary'First = 0, "Half_Max_Binary'First" );
-
- TCTouch.Assert( Medium'First = Medium(ID(0)), "Medium'First" );
- TCTouch.Assert( Medium_Plus'First = Medium_Plus(ID(0)),
- "Medium_Plus'First" );
- TCTouch.Assert( Medium_Minus'First = Medium_Minus(ID(0)),
- "Medium_Minus'First" );
-
- TCTouch.Assert( Small'First = Small(ID(0)), "Small'First" );
- TCTouch.Assert( Finger'First = Finger(ID(0)), "Finger'First" );
- TCTouch.Assert( Midrange'First = Midrange(ID(222)),
- "Midrange'First" );
-
--- Image
- TCTouch.Assert( Half_Max_Binary'Image(255) = " 255",
- "Half_Max_Binary'Image" );
- TCTouch.Assert( Medium'Image(0) = ID(" 0"), "Medium'Image" );
- TCTouch.Assert( Medium_Plus'Image(Medium_Plus'Last) = " 2041",
- "Medium_Plus'Image" );
- TCTouch.Assert( Medium_Minus'Image(Medium_Minus(ID(1024))) = " 1024",
- "Medium_Minus'Image" );
- TCTouch.Assert( Small'Image(Small(ID(1))) = " 1", "Small'Image" );
- TCTouch.Assert( Midrange'Image(Midrange(ID(333))) = " 333",
- "Midrange'Image" );
-
--- Last
- TCTouch.Assert( Max_Binary'Last = System_Max_Bin_Mod_Pred,
- "Max_Binary'Last");
- if Ones_Complement_Permission then
- TCTouch.Assert( Max_NonBinary'Last >= System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Last (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Last = System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Last");
- end if;
- TCTouch.Assert( Half_Max_Binary'Last = Half_Max_Bin_Value_Pred,
- "Half_Max_Binary'Last");
-
- TCTouch.Assert( Medium'Last = Medium(ID(2047)), "Medium'Last");
- TCTouch.Assert( Medium_Plus'Last = Medium_Plus(ID(2041)),
- "Medium_Plus'Last");
- TCTouch.Assert( Medium_Minus'Last = Medium_Minus(ID(2110)),
- "Medium_Minus'Last");
- TCTouch.Assert( Small'Last = Small(ID(1)), "Small'Last");
- TCTouch.Assert( Finger'Last = Finger(ID(4)), "Finger'Last");
- TCTouch.Assert( Midrange'Last = Midrange(ID(1111)), "Midrange'Last");
-
--- Max
- TCTouch.Assert( Max_Binary'Max(Power_2_Bits, Max_Binary'Last)
- = Max_Binary'Last, "Max_Binary'Max");
- TCTouch.Assert( Max_NonBinary'Max(100,2000) = 2000, "Max_NonBinary'Max");
- TCTouch.Assert( Half_Max_Binary'Max(123,456) = 456,
- "Half_Max_Binary'Max");
-
- TCTouch.Assert( Medium'Max(0,2040) = 2040, "Medium'Max");
- TCTouch.Assert( Medium_Plus'Max(0,1) = 1, "Medium_Plus'Max");
- TCTouch.Assert( Medium_Minus'Max(2001,1995) = 2001, "Medium_Minus'Max");
- TCTouch.Assert( Small'Max(1,0) = 1, "Small'Max");
- TCTouch.Assert( Finger'Max(Finger'Last+1,4) = 4, "Finger'Max");
- TCTouch.Assert( Midrange'Max(Midrange'First+1,222) = Midrange'First+1,
- "Midrange'Max");
-
--- Min
- TCTouch.Assert( Max_Binary'Min(Power_2_Bits, Max_Binary'Last)
- = Power_2_Bits, "Max_Binary'Min");
- TCTouch.Assert( Max_NonBinary'Min(100,2000) = 100, "Max_NonBinary'Min");
- TCTouch.Assert( Half_Max_Binary'Min(123,456) = 123,
- "Half_Max_Binary'Min");
-
- TCTouch.Assert( Medium'Min(0,Medium(ID(2040))) = 0, "Medium'Min");
- TCTouch.Assert( Medium_Plus'Min(0,1) = 0, "Medium_Plus'Min");
- TCTouch.Assert( Medium_Minus'Min(2001,1995) = 1995, "Medium_Minus'Min");
- TCTouch.Assert( Small'Min(1,0) = 0, "Small'Min");
- TCTouch.Assert( Finger'Min(Finger'Last+1,4) /= 4, "Finger'Min");
- TCTouch.Assert( Midrange'Min(Midrange'First+1,222) = 222,
- "Midrange'Min");
--- Modulus
- TCTouch.Assert( Max_Binary'Modulus = System.Max_Binary_Modulus,
- "Max_Binary'Modulus");
- TCTouch.Assert( Max_NonBinary'Modulus = System.Max_Nonbinary_Modulus,
- "Max_NonBinary'Modulus");
- TCTouch.Assert( Half_Max_Binary'Modulus = Half_Max_Binary_Value,
- "Half_Max_Binary'Modulus");
-
- TCTouch.Assert( Medium'Modulus = 2048, "Medium'Modulus");
- TCTouch.Assert( Medium_Plus'Modulus = 2042, "Medium_Plus'Modulus");
- TCTouch.Assert( Medium_Minus'Modulus = 2111, "Medium_Minus'Modulus");
- TCTouch.Assert( Small'Modulus = 2, "Small'Modulus");
- TCTouch.Assert( Finger'Modulus = 5, "Finger'Modulus");
- TCTouch.Assert( Midrange'Modulus = ID(2111), "Midrange'Modulus");
-
--- Pos
- declare
- Int : Natural := 222;
- begin
- for I in Midrange loop
- TC_Pass_Case := TC_Pass_Case and Midrange'Pos(I) = Int;
-
- Int := Int +1;
- end loop;
- end;
-
- TCTouch.Assert( TC_Pass_Case, "Midrange'Pos");
-
--- Pred
- TCTouch.Assert( Max_Binary'Pred(0) = System_Max_Bin_Mod_Pred,
- "Max_Binary'Pred(0)");
- if Ones_Complement_Permission then
- TCTouch.Assert( Max_NonBinary'Pred(0) >= System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Pred(0) (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Pred(0) = System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Pred(0)");
- end if;
- TCTouch.Assert( Half_Max_Binary'Pred(0) = Half_Max_Bin_Value_Pred,
- "Half_Max_Binary'Pred(0)");
-
- TCTouch.Assert( Medium'Pred(Medium(ID(0))) = 2047, "Medium'Pred(0)");
- TCTouch.Assert( Medium_Plus'Pred(0) = 2041, "Medium_Plus'Pred(0)");
- TCTouch.Assert( Medium_Minus'Pred(0) = 2110, "Medium_Minus'Pred(0)");
- TCTouch.Assert( Small'Pred(0) = 1, "Small'Pred(0)");
- TCTouch.Assert( Finger'Pred(Finger(ID(0))) = 4, "Finger'Pred(0)");
- TCTouch.Assert( Midrange'Pred(222) = 221, "Midrange'Pred('First)");
-
--- Range
- for I in Midrange'Range loop
- if I not in Midrange then
- Report.Failed("Midrange loop test");
- end if;
- end loop;
- for I in Medium'Range loop
- if I not in Medium then
- Report.Failed("Medium loop test");
- end if;
- end loop;
- for I in Medium_Minus'Range loop
- if I not in 0..2110 then
- Report.Failed("Medium loop test");
- end if;
- end loop;
-
--- Succ
- TCTouch.Assert( Max_Binary'Succ(System_Max_Bin_Mod_Pred) = 0,
- "Max_Binary'Succ('Last)");
- if Ones_Complement_Permission then
- TCTouch.Assert( (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0)
- or (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred)
- = Max_NonBinary'Last),
- "Max_NonBinary'Succ('Last) (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0,
- "Max_NonBinary'Succ('Last)");
- end if;
- TCTouch.Assert( Half_Max_Binary'Succ(Half_Max_Bin_Value_Pred) = 0,
- "Half_Max_Binary'Succ('Last)");
-
- TCTouch.Assert( Medium'Succ(2047) = 0, "Medium'Succ('Last)");
- TCTouch.Assert( Medium_Plus'Succ(2041) = 0, "Medium_Plus'Succ('Last)");
- TCTouch.Assert( Medium_Minus'Succ(2110) = 0, "Medium_Minus'Succ('Last)");
- TCTouch.Assert( Small'Succ(1) = 0, "Small'Succ('Last)");
- TCTouch.Assert( Finger'Succ(4) = 0, "Finger'Succ('Last)");
- TCTouch.Assert( Midrange'Succ(Midrange(ID(1111))) = 1112,
- "Midrange'Succ('Last)");
-
--- Val
- for I in Natural range ID(222)..ID(1111) loop
- TCTouch.Assert( Midrange'Val(I) = Medium_Minus(I), "Midrange'Val");
- end loop;
-
--- Value
-
- TCTouch.Assert( Half_Max_Binary'Value("255") = 255,
- "Half_Max_Binary'Value" );
-
- TCTouch.Assert( Medium'Value(" 1e2") = 100, "Medium'Value(""1e2"")" );
- TCTouch.Assert( Medium'Value(" 0 ") = 0, "Medium'Value" );
- TCTouch.Assert( Medium_Plus'Value(ID("2041")) = 2041,
- "Medium_Plus'Value" );
- TCTouch.Assert( Medium_Minus'Value(ID("+10_24")) = 1024,
- "Medium_Minus'Value" );
-
- TCTouch.Assert( Small'Value("+1") = 1, "Small'Value" );
- TCTouch.Assert( Midrange'Value(ID("333")) = 333, "Midrange'Value" );
- TCTouch.Assert( Midrange'Value("1E3") = 1000,
- "Midrange'Value(""1E3"")" );
-
- Value_Fault( "bad input" );
- Value_Fault( "-333" );
- Value_Fault( "9999" );
- Value_Fault( ".1" );
- Value_Fault( "1e-1" );
-
--- Width
- TCTouch.Assert( Medium'Width = 5, "Medium'Width");
- TCTouch.Assert( Medium_Plus'Width = 5, "Medium_Plus'Width");
- TCTouch.Assert( Medium_Minus'Width = 5, "Medium_Minus'Width");
- TCTouch.Assert( Small'Width = 2, "Small'Width");
- TCTouch.Assert( Finger'Width = 2, "Finger'Width");
- TCTouch.Assert( Midrange'Width = 5, "Midrange'Width");
-
- Report.Result;
-
-end C354002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c354003.a b/gcc/testsuite/ada/acats/tests/c3/c354003.a
deleted file mode 100644
index 1f607a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c354003.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- C354003.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 Wide_String attributes of modular types yield
--- correct values/results. The attributes checked are:
---
--- Wide_Image
--- Wide_Value
---
--- TEST DESCRIPTION:
--- This test is split from C354002. It tests only the attributes:
---
--- Wide_Image, Wide_Value
---
--- This test defines several modular types. One type defined at
--- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus,
--- a power of two half that of System.Max_Binary_Modulus, one less
--- than that power of two; one more than that power of two, two
--- less than a (large) power of two. For each of these types,
--- determine the correct operation of the Wide_String attributes.
---
---
--- CHANGE HISTORY:
--- 13 DEC 94 SAIC Initial version
--- 06 JAN 94 SAIC Promoted to future release
--- 19 APR 95 SAIC Revised in accord with reviewer comments
--- 01 DEC 95 SAIC Corrected for 2.0.1
--- 27 JAN 96 SAIC Eliminated potential 32/64 bit conflict for 2.1
--- 24 FEB 97 PWB.CTA Corrected out-of-range value
---!
-
-with Report;
-with System;
-with TCTouch;
-with Ada.Characters.Handling;
-procedure C354003 is
-
- function ID(Local_Value: Integer) return Integer renames Report.Ident_Int;
- function ID(Local_Value: String) return String renames Report.Ident_Str;
-
- function ID(Local_Value: String) return Wide_String is
- begin
- return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) );
- end ID;
-
- Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2;
-
- type Max_Binary is mod System.Max_Binary_Modulus;
- type Max_NonBinary is mod System.Max_Nonbinary_Modulus;
- type Half_Max_Binary is mod Half_Max_Binary_Value;
-
- type Medium is mod 2048;
- type Medium_Plus is mod 2042;
- type Medium_Minus is mod 2111;
-
- type Small is mod 2;
- type Finger is mod 5;
-
- type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie);
-
- subtype Midrange is Medium_Minus range 222 .. 1111;
-
- AMB, BMB : Max_Binary;
- AHMB, BHMB : Half_Max_Binary;
- AM, BM : Medium;
- AMP, BMP : Medium_Plus;
- AMM, BMM : Medium_Minus;
- AS, BS : Small;
- AF, BF : Finger;
-
- procedure Wide_Value_Fault( S: Wide_String ) is
- -- check 'Wide_Value for failure modes
- begin
- -- the evaluation of the 'Wide_Value expression should raise C_E
- TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" );
- if Midrange'Wide_Value(S) not in Midrange'Base then
- Report.Failed("'Wide_Value raised no exception");
- end if;
- exception
- when Constraint_Error => null; -- expected case
- when others =>
- Report.Failed("'Wide_Value raised wrong exception");
- end Wide_Value_Fault;
-
-
- The_Cap, The_Toe : Natural;
-
- procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is
- subtype Non_Static is Medium range Lower_Bound..Upper_Bound;
- begin
- -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val
-
- TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" );
- TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap),
- "Non_Static'Last" );
- TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range,
- "Non_Static'Range" );
- TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)),
- Medium(Report.Ident_Int(200))) = 100,
- "Non_Static'Min" );
- TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)),
- Medium(Report.Ident_Int(200))) = 200,
- "Non_Static'Max" );
- TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap))
- = Medium'Succ(Upper_Bound),
- "Non_Static'Succ" );
- TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap)))
- = Non_Static(Report.Ident_Int(The_Cap-1)),
- "Non_Static'Pred" );
- TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap),
- "Non_Static'Pos" );
- TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound,
- "Non_Static'Val" );
-
- end Check_Non_Static_Cases;
-
-
-begin -- Main test procedure.
-
- Report.Test ("C354003", "Check Wide_String attributes of modular types" );
-
- Wide_Strings_Needed: declare
-
- Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3;
- Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4;
-
- begin
-
--- Wide_Image
-
- TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255",
- "Half_Max_Binary'Wide_Image" );
-
- TCTouch.Assert( Medium'Wide_Image(0) = " 0", "Medium'Wide_Image" );
-
- TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041",
- "Medium_Plus'Wide_Image" );
-
- TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024",
- "Medium_Minus'Wide_Image" );
-
- TCTouch.Assert( Small'Wide_Image(1) = " 1", "Small'Wide_Image" );
-
- TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333",
- "Midrange'Wide_Image" );
-
--- Wide_Value
-
- TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255,
- "Half_Max_Binary'Wide_Value" );
-
- TCTouch.Assert( Medium'Wide_Value(" 0 ") = 0, "Medium'Wide_Value" );
-
- TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last,
- "Medium_Plus'Wide_Value" );
-
- TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14,
- "Medium_Minus'Wide_Value" );
-
- TCTouch.Assert( Small'Wide_Value("+1") = 1, "Small'Wide_Value" );
-
- TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333,
- "Midrange'Wide_Value" );
-
- TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000,
- "Midrange'Wide_Value(""1E3"")" );
-
- Wide_Value_Fault( "bad input" );
- Wide_Value_Fault( "-333" );
- Wide_Value_Fault( "9999" );
- Wide_Value_Fault( ".1" );
- Wide_Value_Fault( "1e-1" );
-
- end Wide_Strings_Needed;
-
- The_Toe := Report.Ident_Int(25);
- The_Cap := Report.Ident_Int(256);
- Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
- Medium(Report.Ident_Int(The_Cap)) );
-
- The_Toe := Report.Ident_Int(40);
- The_Cap := Report.Ident_Int(2047);
- Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
- Medium(Report.Ident_Int(The_Cap)) );
-
- Report.Result;
-
-end C354003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502a.ada b/gcc/testsuite/ada/acats/tests/c3/c35502a.ada
deleted file mode 100644
index ffb8190..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502a.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C35502A.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS
--- WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR
--- A CHARACTER TYPE.
-
--- RJW 5/05/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502A IS
-
-BEGIN
-
- TEST( "C35502A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX " &
- "IS AN ENUMERATION TYPE OTHER THAN " &
- "A BOOLEAN OR A CHARACTER TYPE" );
-
- DECLARE
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
-
- SUBTYPE SUBENUM IS ENUM RANGE A .. ABC;
- SUBTYPE NOENUM IS ENUM RANGE ABC .. A;
-
- TYPE NEWENUM IS NEW ENUM;
-
- BEGIN
-
- IF ENUM'WIDTH /= IDENT_INT(5) THEN
- FAILED( "INCORRECT WIDTH FOR ENUM" );
- END IF;
-
- IF NEWENUM'WIDTH /= IDENT_INT(5) THEN
- FAILED( "INCORRECT WIDTH FOR NEWENUM" );
- END IF;
-
- IF SUBENUM'WIDTH /= IDENT_INT(3) THEN
- FAILED( "INCORRECT WIDTH FOR SUBENUM" );
- END IF;
-
- IF NOENUM'WIDTH /= IDENT_INT(0) THEN
- FAILED( "INCORRECT WIDTH FOR NOENUM" );
- END IF;
-
- END;
-
- RESULT;
-END C35502A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502b.ada b/gcc/testsuite/ada/acats/tests/c3/c35502b.ada
deleted file mode 100644
index aff8135..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502b.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C35502B.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS
--- WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR CHARACTER
--- TYPE.
-
--- RJW 5/05/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502B IS
-
-BEGIN
-
- TEST( "C35502B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX " &
- "IS A GENERIC FORMAL DISCRETE TYPE " &
- "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " &
- "TYPE" );
-
- DECLARE
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- SUBTYPE SUBENUM IS ENUM RANGE A .. ABC;
- SUBTYPE NOENUM IS ENUM RANGE ABC .. A;
-
- TYPE NEWENUM IS NEW ENUM;
-
- GENERIC
- TYPE E IS (<>);
- W : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE NOENUM IS E RANGE
- E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1));
- BEGIN
- IF E'WIDTH /= IDENT_INT(W) THEN
- FAILED ( "INCORRECT E'WIDTH FOR " & STR );
- END IF;
- IF NOENUM'WIDTH /= IDENT_INT(0) THEN
- FAILED ( "INCORRECT NOENUM'WIDTH FOR " & STR );
- END IF;
- END P;
-
- PROCEDURE PROC1 IS NEW P (ENUM, 5);
- PROCEDURE PROC2 IS NEW P (SUBENUM, 3);
- PROCEDURE PROC3 IS NEW P (NEWENUM, 5);
- PROCEDURE PROC4 IS NEW P (NOENUM, 0);
-
- BEGIN
- PROC1 ( "ENUM" );
- PROC2 ( "SUBENUM" );
- PROC3 ( "NEWENUM" );
- PROC4 ( "NOENUM" );
- END;
-
- RESULT;
-END C35502B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502c.ada b/gcc/testsuite/ada/acats/tests/c3/c35502c.ada
deleted file mode 100644
index a635e68..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502c.ada
+++ /dev/null
@@ -1,318 +0,0 @@
--- C35502C.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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN
--- OR A CHARACTER TYPE.
--- SUBTESTS ARE:
--- PART (A). TESTS FOR IMAGE.
--- PART (B). TESTS FOR VALUE.
-
--- RJW 5/07/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502C IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, abcd);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
-
- FUNCTION IDENT (X : ENUM) RETURN ENUM IS
- BEGIN
- IF EQUAL (ENUM'POS (X), ENUM'POS(X)) THEN
- RETURN X;
- END IF;
- RETURN ENUM'FIRST;
- END IDENT;
-
-BEGIN
-
- TEST( "C35502C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS " &
- "WHEN THE PREFIX IS AN ENUMERATION TYPE " &
- "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" );
-
--- PART (A).
-
- BEGIN
-
- IF ENUM'IMAGE ( IDENT(ABC) ) /= "ABC" THEN
- FAILED ( "INCORRECT ENUM'IMAGE FOR ABC" );
- END IF;
- IF ENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR ABC IN ENUM" );
- END IF;
-
- IF ENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN
- FAILED ( "INCORRECT ENUM'IMAGE FOR A_B_C" );
- END IF;
- IF ENUM'IMAGE ( IDENT(A_B_C) )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR A_B_C IN ENUM" );
- END IF;
-
- IF SUBENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN
- FAILED ( "INCORRECT SUBENUM'IMAGE FOR A_B_C" );
- END IF;
- IF SUBENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR ABC " &
- "IN SUBENUM" );
- END IF;
-
- IF NEWENUM'IMAGE ( ABC ) /= IDENT_STR("ABC") THEN
- FAILED ( "INCORRECT NEWENUM'IMAGE FOR ABC" );
- END IF;
- IF NEWENUM'IMAGE ( ABC )'FIRST /= IDENT_INT(1) THEN
- FAILED ( "INCORRECT LOWER BOUND FOR ABC" &
- "IN NEWENUM" );
- END IF;
-
- IF ENUM'IMAGE ( IDENT(abcd) ) /= "ABCD" THEN
- FAILED ( "INCORRECT ENUM'IMAGE FOR abcd" );
- END IF;
- IF ENUM'IMAGE ( IDENT(abcd) )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR abcd IN ENUM" );
- END IF;
-
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("ABC")) /= ABC THEN
- FAILED ( "INCORRECT VALUE FOR ""ABC""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABC""" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("abc")) /= abc THEN
- FAILED ( "INCORRECT VALUE FOR ""abc""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""abc""" );
- END;
-
- BEGIN
- IF ENUM'VALUE ("ABC") /= ABC THEN
- FAILED ( "INCORRECT VALUE FOR ABC" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ABC" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE (IDENT_STR("abcd")) /= abcd THEN
- FAILED ( "INCORRECT VALUE FOR ""abcd""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""abcd""" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE (IDENT_STR("ABCD")) /= abcd THEN
- FAILED ( "INCORRECT VALUE FOR ""ABCD""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABCD""" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE ("abcd") /= abcd THEN
- FAILED ( "INCORRECT VALUE FOR abcd" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR abcd" );
- END;
-
- BEGIN
- IF SUBENUM'VALUE (IDENT_STR("A_B_C")) /= A_B_C THEN
- FAILED ( "INCORRECT VALUE FOR ""A_B_C""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""A_B_C""" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("ABC ")) /= ABC THEN
- FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE WITH " &
- "TRAILING BLANKS" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE (IDENT_STR(" A_B_C")) /= A_B_C THEN
- FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE WITH LEADING " &
- "BLANKS" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("A_BC")) /= ABC THEN
- FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""A_BC""" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("A BC")) /= ABC THEN
- FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""A BC""" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("A&BC")) /= ABC THEN
- FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""A&BC""" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_CHAR(ASCII.HT) & "BC") /= BC THEN
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE ("A" & (IDENT_CHAR(ASCII.HT))) /= A THEN
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" );
- END;
-
- BEGIN
- IF ENUM'VALUE (IDENT_STR("B__C")) /= BC THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "CONSECUTIVE UNDERSCORES - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "CONSECUTIVE UNDERSCORES - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "CONSECUTIVE UNDERSCORES" );
- END;
-
- BEGIN
- IF NEWENUM'VALUE (IDENT_STR("BC_")) /= BC THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "TRAILING UNDERSCORE - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "TRAILING UNDERSCORE - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "TRAILING UNDERSCORE" );
- END;
-
- BEGIN
- IF SUBENUM'VALUE (IDENT_STR("_BC")) /= BC THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "LEADING UNDERSCORE - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "LEADING UNDERSCORE - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "LEADING UNDERSCORE" );
- END;
-
- BEGIN
- IF SUBENUM'VALUE (IDENT_STR("0BC")) /= BC THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "FIRST CHARACTER IS A DIGIT - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "FIRST CHARACTER IS A DIGIT - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "FIRST CHARACTER IS A DIGIT" );
- END;
-
- RESULT;
-END C35502C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502d.tst b/gcc/testsuite/ada/acats/tests/c3/c35502d.tst
deleted file mode 100644
index 7da9881..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502d.tst
+++ /dev/null
@@ -1,84 +0,0 @@
--- C35502D.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 THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE
--- LONGEST POSSIBLE ENUMERATION LITERAL.
-
--- RJW 2/21/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502D IS
-
-BEGIN
- TEST ("C35502D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " &
- "CORRECT RESULTS FOR THE LONGEST POSSIBLE " &
- "ENUMERATION LITERAL");
-
- -- BIG_ID1 IS A MAXIMUM LENGTH IDENTIFIER. BIG_STRING1 AND
- -- BIG_STRING2 ARE TWO STRING LITERALS WHICH WHEN CONCATENATED
- -- FORM THE IMAGE OF BIG_ID1;
-
-
- DECLARE
- TYPE ENUM IS (
-$BIG_ID1
- );
-
- BEGIN
- BEGIN
- IF ENUM'VALUE (
-$BIG_STRING1
-&
-$BIG_STRING2
-) /=
-$BIG_ID1
- THEN
- FAILED ( "INCORRECT RESULTS FOR 'VALUE'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR 'VALUE'" );
- END;
- BEGIN
- IF ENUM'IMAGE(
-$BIG_ID1
-) /=
-(
-$BIG_STRING1
-&
-$BIG_STRING2
-) THEN
- FAILED ( "INCORRECT RESULTS FOR 'IMAGE'" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR 'IMAGE'" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR 'IMAGE'" );
- END;
- END;
-
- RESULT;
-END C35502D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502e.ada b/gcc/testsuite/ada/acats/tests/c3/c35502e.ada
deleted file mode 100644
index 16e3cf0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502e.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- C35502E.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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A
--- CHARACTER TYPE.
--- SUBTESTS ARE:
--- PART (A). TESTS FOR IMAGE.
--- PART (B). TESTS FOR VALUE.
-
--- RJW 5/13/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502E IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, abcd);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
-
-BEGIN
-
- TEST( "C35502E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS AN ENUMERATION TYPE " &
- "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" );
-
--- PART (A).
- DECLARE
- GENERIC
- TYPE E IS (<>);
- STR1 : STRING;
- PROCEDURE P ( E1 : E; STR2 : STRING );
-
- PROCEDURE P ( E1 : E; STR2 : STRING ) IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- BEGIN
- IF SE'IMAGE ( E1 ) /= STR2 THEN
- FAILED ( "INCORRECT SE'IMAGE FOR " & STR2 & " IN "
- & STR1 );
- END IF;
- IF SE'IMAGE ( E1 )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR " & STR2
- & " IN " & STR1 );
- END IF;
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM , "ENUM" );
- PROCEDURE PS IS NEW P ( SUBENUM, "SUBENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
-
- BEGIN
- PE ( ABC, "ABC" );
- PE ( A_B_C, "A_B_C" );
- PS ( BC, "BC" );
- PN ( ABC, "ABC" );
- PE ( abcd, "ABCD" );
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- DECLARE
- GENERIC
- TYPE E IS (<>);
- STR1 : STRING;
- PROCEDURE P ( STR2 : STRING ; E1 : E );
-
- PROCEDURE P ( STR2 : STRING ; E1 : E ) IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- BEGIN
- IF E'VALUE ( STR2 ) /= E1 THEN
- FAILED ( "INCORRECT " & STR1 & "'VALUE FOR """ &
- STR2 & """" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - " & STR1 & "'VALUE " &
- "FOR """ & STR2 & """" );
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM , "ENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
-
- BEGIN
- PN ("abcd", abcd);
- PN ("A_B_C", A_B_C);
- PE ("ABC ", ABC);
- PE (" A_B_C", A_B_C);
- END;
-
-
- DECLARE
- GENERIC
- TYPE E IS (<>);
- PROCEDURE P ( STR : STRING );
-
- PROCEDURE P ( STR : STRING ) IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- BEGIN
- IF SE'VALUE (STR) = SE'VAL (0) THEN
- FAILED ( "NO EXCEPTION RAISED - " & STR & " - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " & STR & " - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " & STR );
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM );
- PROCEDURE PS IS NEW P ( SUBENUM );
- PROCEDURE PN IS NEW P ( NEWENUM );
-
- BEGIN
- PS ("A BC");
- PN ("A&BC");
- PE (ASCII.HT & "BC");
- PE ("A" & ASCII.HT);
- PS ("_BC");
- PN ("BC_");
- PE ("B__C");
- PE ("0BC");
-
- END;
-
- RESULT;
-END C35502E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502f.tst b/gcc/testsuite/ada/acats/tests/c3/c35502f.tst
deleted file mode 100644
index 30be23e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502f.tst
+++ /dev/null
@@ -1,89 +0,0 @@
--- C35502F.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 THAT IMAGE AND VALUE ATTRIBUTES ARE CORRECT FOR A FORMAL
--- DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN ENUMERATED TYPE
--- WITH THE LONGEST POSSIBLE IDENTIFIER AS ONE CONSTANT.
-
--- PWB 03/05/86
--- DWC 07/22/87 -- ADDED THE CONSTANT STRING 'STR'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502F IS
-
- -- BIG_ID1 IS AN IDENTIFIER OF MAXIMUM LENGTH.
- TYPE ENUM IS ( EVAL1,
-$BIG_ID1
- );
-
- -- BIG_STRING1 & BIG_STRING2 YIELDS BIG_ID.
- STR1 : CONSTANT STRING :=
-$BIG_STRING1;
- STR2 : CONSTANT STRING :=
-$BIG_STRING2;
- STR : CONSTANT STRING := STR1 & STR2;
-
- GENERIC
- TYPE FORMAL IS (<>);
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- VALUE_CHECK:
- BEGIN
- IF FORMAL'VALUE (STR) /= FORMAL'LAST THEN
- FAILED ("VALUE OF LONG STRING NOT LONG IDENTIFIER");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CHECKING " &
- "VALUE ATTRIBUTE");
- END VALUE_CHECK;
-
- IMAGE_CHECK:
- BEGIN
- IF FORMAL'IMAGE (FORMAL'LAST) /= STR
- THEN
- FAILED ("IMAGE OF LONG IDENTIFIER NOT LONG STRING");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CHECKING " &
- "IMAGE ATTRIBUTE");
- END IMAGE_CHECK;
-
- END GEN_PROC;
-
- PROCEDURE TEST_PROC IS NEW GEN_PROC (ENUM);
-
-BEGIN -- C35502F
-
- TEST ("C35502F", "IMAGE AND VALUE ATTRIBUTES FOR A FORMAL " &
- "DISCRETE TYPE WITH ONE ACTUAL VALUE HAVING " &
- "LONGEST POSSIBLE IDENTIFIER");
- TEST_PROC;
- RESULT;
-
-END C35502F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502g.ada b/gcc/testsuite/ada/acats/tests/c3/c35502g.ada
deleted file mode 100644
index aff9fb3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502g.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C35502G.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A
--- CHARACTER TYPE.
-
--- RJW 5/27/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502G IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "ENUMERATION TYPE OTHER THAN A CHARACTER " &
- "OR A BOOLEAN TYPE" );
-
- BEGIN
- FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP
- IF SUBENUM'PRED (I) /=
- ENUM'VAL (ENUM'POS (I) - 1) THEN
- FAILED ("INCORRECT SUBENUM'PRED(" &
- ENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP
- IF SUBENUM'SUCC (I) /=
- ENUM'VAL (ENUM'POS (I) + 1) THEN
- FAILED ("INCORRECT SUBENUM'SUCC(" &
- ENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
- END;
-
- BEGIN
- FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP
- IF SUBNEW'PRED (I) /=
- NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN
- FAILED ("INCORRECT SUBNEW'PRED(" &
- NEWENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP
- IF SUBNEW'SUCC (I) /=
- NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN
- FAILED ("INCORRECT SUBNEW'SUCC(" &
- NEWENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
- END;
-
- RESULT;
-END C35502G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502h.ada b/gcc/testsuite/ada/acats/tests/c3/c35502h.ada
deleted file mode 100644
index 640e2e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502h.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C35502H.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS
--- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE.
-
--- RJW 5/27/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502H IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
-
- TYPE NEWENUM IS NEW ENUM;
-
-BEGIN
- TEST ("C35502H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "ARGUMENT IS AN ENUMERATION TYPE OTHER THAN " &
- "A CHARACTER OR A BOOLEAN TYPE" );
-
- DECLARE
- GENERIC
- TYPE E IS (<>);
- STR : STRING;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- BEGIN
- FOR I IN E'VAL (1) .. E'VAL (4) LOOP
- IF SE'PRED (I) /=
- E'VAL (E'POS (I) - 1) THEN
- FAILED ("INCORRECT " & STR & "'PRED(" &
- E'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN E'VAL (0) .. E'VAL (3) LOOP
- IF SE'SUCC (I) /=
- E'VAL (E'POS (I) + 1) THEN
- FAILED ("INCORRECT " & STR & "'SUCC(" &
- E'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM, "ENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
-
- BEGIN
- PE;
- PN;
- END;
-
- RESULT;
-END C35502H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502i.ada b/gcc/testsuite/ada/acats/tests/c3/c35502i.ada
deleted file mode 100644
index a9116d6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502i.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- C35502I.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A
--- CHARACTER TYPE, WITH A REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 05/27/86 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502I IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- FOR ENUM USE (A => 2, BC => 4, ABC => 6,
- A_B_C => 8, ABCD => 10);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502I", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "ENUMERATION TYPE, OTHER THAN A CHARACTER " &
- "OR A BOOLEAN TYPE, WITH A REPRESENTATION " &
- "CLAUSE" );
-
- BEGIN
- FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP
- IF SUBENUM'PRED (I) /=
- ENUM'VAL (ENUM'POS (I) - 1) THEN
- FAILED ("INCORRECT SUBENUM'PRED(" &
- ENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP
- IF SUBENUM'SUCC (I) /=
- ENUM'VAL (ENUM'POS (I) + 1) THEN
- FAILED ("INCORRECT SUBENUM'SUCC(" &
- ENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
- END;
-
- BEGIN
- FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP
- IF SUBNEW'PRED (I) /=
- NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN
- FAILED ("INCORRECT SUBNEW'PRED(" &
- NEWENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP
- IF SUBNEW'SUCC (I) /=
- NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN
- FAILED ("INCORRECT SUBNEW'SUCC(" &
- NEWENUM'IMAGE (I) & ")" );
- END IF;
- END LOOP;
- END;
-
- RESULT;
-END C35502I;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502j.ada b/gcc/testsuite/ada/acats/tests/c3/c35502j.ada
deleted file mode 100644
index 37d17b2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502j.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C35502J.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS
--- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE,
--- WITH AN ENUMERATION REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 05/27/86 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502J IS
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- FOR ENUM USE (A => 2, BC => 4, ABC => 6,
- A_B_C => 8, ABCD => 10);
-
- TYPE NEWENUM IS NEW ENUM;
-
-BEGIN
- TEST ("C35502J", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS " &
- "A FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "ARGUMENT IS AN ENUMERATION TYPE, OTHER THAN " &
- "A CHARACTER OR A BOOLEAN TYPE, WITH AN " &
- "ENUMERATION REPRESENTATION CLAUSE" );
-
- DECLARE
- GENERIC
- TYPE E IS (<>);
- STR : STRING;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
-
- BEGIN
- FOR I IN E'VAL (1) .. E'VAL (4)
- LOOP
- IF SE'PRED (I) /=
- E'VAL (E'POS (I) - 1) THEN
- FAILED ("INCORRECT " & STR & "'PRED(" &
- E'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- FOR I IN E'VAL (0) .. E'VAL (3)
- LOOP
- IF SE'SUCC (I) /=
- E'VAL (E'POS (I) + 1) THEN
- FAILED ("INCORRECT " & STR & "'SUCC(" &
- E'IMAGE (I) & ")" );
- END IF;
- END LOOP;
-
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM, "ENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
-
- BEGIN
- PE;
- PN;
- END;
-
- RESULT;
-END C35502J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502k.ada b/gcc/testsuite/ada/acats/tests/c3/c35502k.ada
deleted file mode 100644
index 716521ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502k.ada
+++ /dev/null
@@ -1,174 +0,0 @@
--- C35502K.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A
--- CHARACTER TYPE.
-
--- RJW 5/27/86
--- GMT 7/02/87 ADDED ENUM'VAL(3) CHECK NEAR END OF 2ND BLOCK STATEMENT.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502K IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "ENUMERATION TYPE OTHER THAN A CHARACTER " &
- "OR A BOOLEAN TYPE" );
-
- DECLARE
- POSITION : INTEGER;
- BEGIN
- POSITION := 0;
-
- FOR E IN ENUM LOOP
- IF SUBENUM'POS (E) /= POSITION THEN
- FAILED ( "INCORRECT SUBENUM'POS (" &
- ENUM'IMAGE (E) & ")" );
- END IF;
-
- IF SUBENUM'VAL (POSITION) /= E THEN
- FAILED ( "INCORRECT SUBENUM'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- POSITION := 0;
- FOR E IN NEWENUM LOOP
- IF SUBNEW'POS (E) /= POSITION THEN
- FAILED ( "INCORRECT SUBNEW'POS (" &
- NEWENUM'IMAGE (E) & ")" );
- END IF;
-
- IF SUBNEW'VAL (POSITION) /= E THEN
- FAILED ( "INCORRECT SUBNEW'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
- END;
-
- DECLARE
- FUNCTION A_B_C RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (IDENT_INT (0));
- END A_B_C;
-
- BEGIN
- IF ENUM'VAL (0) /= A_B_C THEN
- FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " &
- "BY FUNCTION - 1" );
- END IF;
-
- IF ENUM'VAL (0) = C35502K.A_B_C THEN
- FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " &
- "BY FUNCTION - 2" );
- END IF;
-
- IF ENUM'VAL (3) /= C35502K.A_B_C THEN
- FAILED ( "WRONG ENUM'VAL (3) WHEN HIDDEN " &
- "BY FUNCTION - 3" );
- END IF;
- END;
-
- BEGIN
- IF ENUM'VAL (IDENT_INT (-1)) = A THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (-1))" );
- END;
-
- BEGIN
- IF NEWENUM'VAL (IDENT_INT (-1)) = A THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1))" );
- END;
-
- BEGIN
- IF ENUM'VAL (IDENT_INT (5)) = A THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (5)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (5)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR ENUM'VAL (IDENT_INT (5))" );
- END;
-
- BEGIN
- IF NEWENUM'VAL (IDENT_INT (5)) = A THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5))" );
- END;
-
- RESULT;
-END C35502K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502l.ada b/gcc/testsuite/ada/acats/tests/c3/c35502l.ada
deleted file mode 100644
index 768c143..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502l.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C35502L.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS
--- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE.
-
--- RJW 5/27/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502L IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " &
- "IS AN ENUMERATION TYPE OTHER THAN A " &
- "CHARACTER OR A BOOLEAN TYPE" );
-
- DECLARE
-
- GENERIC
- TYPE E IS (<>);
- STR : STRING;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- POSITION : INTEGER;
- BEGIN
-
- POSITION := 0;
-
- FOR E1 IN E
- LOOP
- IF SE'POS (E1) /= POSITION THEN
- FAILED ( "INCORRECT SE'POS (" &
- E'IMAGE (E1) & ")" );
- END IF;
-
- IF SE'VAL (POSITION) /= E1 THEN
- FAILED ( "INCORRECT " & STR & "'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- BEGIN
- IF E'VAL (-1) = E'VAL (1) THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (-1) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (-1) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'VAL (-1)" );
- END;
-
- BEGIN
- IF E'VAL (5) = E'VAL (4) THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (5) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (5) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'VAL (5)" );
- END;
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM, "ENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
- BEGIN
- PE;
- PN;
- END;
-
- DECLARE
- GENERIC
- TYPE E IS (<>);
- FUNCTION F (E1 : E) RETURN BOOLEAN;
-
- FUNCTION F (E1 : E) RETURN BOOLEAN IS
- BEGIN
- RETURN E'VAL (0) = E1;
- END F;
-
- FUNCTION FE IS NEW F (ENUM);
-
- BEGIN
-
- DECLARE
- FUNCTION A_B_C RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (IDENT_INT (0));
- END A_B_C;
- BEGIN
- IF FE (A_B_C) THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " &
- "BY A FUNCTION" );
- END IF;
-
- IF FE (C35502L.A_B_C) THEN
- FAILED ( "INCORRECT VAL FOR C35502L.A_B_C" );
- END IF;
- END;
- END;
-
- RESULT;
-END C35502L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502m.ada b/gcc/testsuite/ada/acats/tests/c3/c35502m.ada
deleted file mode 100644
index 754ecc5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502m.ada
+++ /dev/null
@@ -1,177 +0,0 @@
--- C35502M.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A
--- CHARACTER TYPE, WITH AN ENUMERATION REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 05/27/86 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502M IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- FOR ENUM USE (A => 2, BC => 4, ABC => 6,
- A_B_C => 8, ABCD => 10);
-
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502M", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "ENUMERATION TYPE, OTHER THAN A CHARACTER " &
- "OR A BOOLEAN TYPE, WITH AN ENUMERATION " &
- "REPRESENTATION CLAUSE" );
-
- DECLARE
- POSITION : INTEGER;
- BEGIN
- POSITION := 0;
-
- FOR E IN ENUM
- LOOP
- IF SUBENUM'POS (E) /= POSITION THEN
- FAILED ( "INCORRECT SUBENUM'POS (" &
- ENUM'IMAGE (E) & ")" );
- END IF;
-
- IF SUBENUM'VAL (POSITION) /= E THEN
- FAILED ( "INCORRECT SUBENUM'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- POSITION := 0;
- FOR E IN NEWENUM
- LOOP
- IF SUBNEW'POS (E) /= POSITION THEN
- FAILED ( "INCORRECT SUBNEW'POS (" &
- NEWENUM'IMAGE (E) & ")" );
- END IF;
-
- IF SUBNEW'VAL (POSITION) /= E THEN
- FAILED ( "INCORRECT SUBNEW'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
- END;
-
- DECLARE
- FUNCTION A_B_C RETURN ENUM IS
- BEGIN
- RETURN A;
- END A_B_C;
-
- BEGIN
- IF ENUM'VAL (0) /= A_B_C THEN
- FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " &
- "BY FUNCTION - 1" );
- END IF;
-
- IF ENUM'VAL (0) = C35502M.A_B_C THEN
- FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " &
- "BY FUNCTION - 2" );
- END IF;
- END;
-
- BEGIN
- IF ENUM'VAL (IDENT_INT (-1)) = ENUM'FIRST THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (-1))" );
- END;
-
- BEGIN
- IF NEWENUM'VAL (IDENT_INT (-1)) = NEWENUM'LAST THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (-1))" );
- END;
-
- BEGIN
- IF ENUM'VAL (IDENT_INT (5)) = ENUM'LAST THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (5)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (5)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "ENUM'VAL (IDENT_INT (5))" );
- END;
-
- BEGIN
- IF NEWENUM'VAL (IDENT_INT (5)) = NEWENUM'LAST THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWENUM'VAL (IDENT_INT (5))" );
- END;
-
- RESULT;
-END C35502M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502n.ada b/gcc/testsuite/ada/acats/tests/c3/c35502n.ada
deleted file mode 100644
index 780120d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502n.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C35502N.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS
--- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE,
--- WITH AN ENUMERATION REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 05/27/86
--- DWC 07/22/87 ADDED THE PARAMETER 'N' TO FUNCTION F.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502N IS
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- FOR ENUM USE (A => 1, BC => 4, ABC => 5, A_B_C => 6,
- ABCD => 8);
-
- SUBTYPE SUBENUM IS ENUM RANGE A .. BC;
-
- TYPE NEWENUM IS NEW ENUM;
- SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC;
-
-BEGIN
- TEST ("C35502N", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " &
- "IS AN ENUMERATION TYPE, OTHER THAN A " &
- "CHARACTER OR A BOOLEAN TYPE, WITH AN " &
- "ENUMERATION REPRESENTATION CLAUSE" );
-
- DECLARE
-
- GENERIC
- TYPE E IS (<>);
- STR : STRING;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1);
- POSITION : INTEGER;
- BEGIN
-
- POSITION := 0;
-
- FOR E1 IN E LOOP
- IF SE'POS (E1) /= POSITION THEN
- FAILED ( "INCORRECT " & STR & "'POS (" &
- E'IMAGE (E1) & ")" );
- END IF;
-
- IF SE'VAL (POSITION) /= E1 THEN
- FAILED ( "INCORRECT " & STR & "'VAL (" &
- INTEGER'IMAGE (POSITION) &
- ")" );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- BEGIN
- IF E'VAL (-1) = E'VAL (1) THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (-1) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (-1) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'VAL (-1)" );
- END;
-
- BEGIN
- IF E'VAL (5) = E'VAL (4) THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (5) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'VAL (5) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'VAL (5)" );
- END;
- END P;
-
- PROCEDURE PE IS NEW P ( ENUM, "ENUM" );
- PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" );
- BEGIN
- PE;
- PN;
- END;
-
- DECLARE
- FUNCTION A_B_C RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (IDENT_INT (0));
- END A_B_C;
-
- GENERIC
- TYPE E IS (<>);
- FUNCTION F (N : INTEGER;
- E1 : E) RETURN BOOLEAN;
-
- FUNCTION F (N : INTEGER;
- E1 : E) RETURN BOOLEAN IS
- BEGIN
- RETURN E'VAL (N) = E1;
- END F;
-
- FUNCTION FE IS NEW F (ENUM);
-
- BEGIN
-
- IF NOT FE (0, A_B_C) THEN
- FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " &
- "BY A FUNCTION" );
- END IF;
-
- IF NOT FE (3, C35502N.A_B_C) THEN
- FAILED ( "INCORRECT VAL FOR C35502N.A_B_C" );
- END IF;
- END;
-
- RESULT;
-END C35502N;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502o.ada b/gcc/testsuite/ada/acats/tests/c3/c35502o.ada
deleted file mode 100644
index 561e1e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502o.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- C35502O.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 AND 'LAST GIVE CORRECT RESULTS FOR TYPES
--- AND SUBTYPES.
-
--- DAT 3/17/81
--- R. WILLIAMS 11/11/86 RENAMED FROM C35104A.ADA.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35502O IS
-
- TYPE E IS (E1, E2, E3, E4, E5);
-
- SUBTYPE S IS E RANGE E2 .. E4;
-
-BEGIN
- TEST ("C35502O", "CHECK THAT 'FIRST AND 'LAST WORK FOR"
- & " ENUMERATION TYPES AND SUBTYPES");
-
- IF E'FIRST /= E1 OR E'LAST /= E5
- OR E'BASE'FIRST /= E1 OR E'BASE'LAST /= E5
- OR S'BASE'FIRST /= E1 OR S'BASE'LAST /= E5
- OR S'FIRST /= E2 OR S'LAST /= E4
- OR BOOLEAN'FIRST /= FALSE OR BOOLEAN'LAST /= TRUE
- THEN
- FAILED ("'FIRST OR 'LAST GIVES WRONG RESULTS");
- END IF;
-
- RESULT;
-END C35502O;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35502p.ada b/gcc/testsuite/ada/acats/tests/c3/c35502p.ada
deleted file mode 100644
index 1dfef9a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35502p.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- C35502P.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:
--- FOR AN ENUMERATION TYPE OTHER THAN BOOLEAN OR CHARACTER TYPE,
--- CHECK THAT THE RESULTS AND TYPE PRODUCED BY THE ATTRIBUTES
--- ARE CORRECT.
-
--- CHECK THAT 'FIRST AND 'LAST YIELD CORRECT RESULTS WHEN THE
--- PREFIX DENOTES A NULL SUBTYPE.
-
--- HISTORY:
--- RJW 05/05/86 CREATED ORIGINAL TEST.
--- CJJ 06/09/87 CHANGED "=" COMPARISONS IN GENERIC
--- PROCEDURE Q TO "/=".
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35502P IS
-
-BEGIN
-
- TEST( "C35502P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " &
- "'LAST' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " &
- "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " &
- "TYPE OTHER THAN A CHARACTER OR A BOOLEAN " &
- "TYPE" );
-
- DECLARE
- -- FOR THESE DECLARATIONS, 'FIRST AND 'LAST REFER TO THE
- -- SUBTYPE VALUES, BUT 'VAL AND 'POS ARE INHERITED FROM THE
- -- BASE TYPE.
-
- TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD);
- SUBTYPE SUBENUM IS ENUM RANGE A .. ABC;
-
- TYPE NEWENUM IS NEW ENUM RANGE BC .. A_B_C;
- TYPE NONEWENUM IS NEW ENUM RANGE ABCD .. A;
- GENERIC
- TYPE E IS (<>);
- F, L : E;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE NOENUM IS E RANGE
- E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1));
- BEGIN
- IF E'FIRST /= F THEN
- FAILED ( "INCORRECT E'FIRST FOR " & STR );
- END IF;
- IF NOENUM'FIRST /= E'VAL (2) THEN
- FAILED ( "INCORRECT NOENUM'FIRST FOR " & STR );
- END IF;
-
- IF E'LAST /= L THEN
- FAILED ( "INCORRECT E'LAST FOR " & STR );
- END IF;
- IF NOENUM'LAST /= E'VAL (1) THEN
- FAILED ( "INCORRECT NOENUM'LAST FOR " & STR );
- END IF;
- END P;
-
- GENERIC
- TYPE E IS (<>);
- PROCEDURE Q;
-
- PROCEDURE Q IS
- SUBTYPE NOENUM IS E RANGE
- E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1));
- BEGIN
- IF E'FIRST /= E'VAL (IDENT_INT(4)) THEN
- FAILED ( "INCORRECT E'FIRST FOR NONEWENUM" );
- END IF;
- IF NOENUM'FIRST /= E'VAL (2) THEN
- FAILED ( "INCORRECT NOENUM'FIRST FOR NONEWENUM");
- END IF;
-
- IF E'LAST /= E'VAL (IDENT_INT(0)) THEN
- FAILED ( "INCORRECT E'LAST FOR NONEWENUM");
- END IF;
- IF NOENUM'LAST /= E'VAL (1) THEN
- FAILED ( "INCORRECT NOENUM'LAST FOR NONEWENUM");
- END IF;
- END Q;
-
- PROCEDURE PROC1 IS NEW P (ENUM, A, ABCD);
- PROCEDURE PROC2 IS NEW P (SUBENUM, A, ABC);
- PROCEDURE PROC3 IS NEW P (NEWENUM, BC, A_B_C);
- PROCEDURE PROC4 IS NEW Q (NONEWENUM);
-
- BEGIN
- PROC1 ( "ENUM" );
- PROC2 ( "SUBENUM" );
- PROC3 ( "NEWENUM" );
- PROC4;
- END;
-
- RESULT;
-END C35502P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503a.ada b/gcc/testsuite/ada/acats/tests/c3/c35503a.ada
deleted file mode 100644
index b9daf25..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C35503A.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 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS AN
--- INTEGER TYPE.
-
--- RJW 3/12/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503A IS
-
-BEGIN
- TEST ("C35503A", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " &
- "RESULT WHEN THE PREFIX IS AN INTEGER TYPE" );
-
- DECLARE
- SUBTYPE SINTEGER IS INTEGER;
-
- TYPE INT IS RANGE -1000 .. 1000;
- TYPE INT2 IS NEW INT RANGE 1E2 .. 1E2;
-
- SUBTYPE SINT1 IS INT RANGE 00000 .. 100;
- SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#;
- SUBTYPE SINT3 IS INT RANGE -100 .. 9;
- SUBTYPE NOINT IS INT RANGE 1 .. -1;
-
- BEGIN
- IF IDENT_INT(SINTEGER'WIDTH) /= INTEGER'WIDTH THEN
- FAILED ( "WRONG WIDTH FOR 'SINTEGER'" );
- END IF;
-
- IF IDENT_INT(INT'WIDTH) /= 5 THEN
- FAILED ( "WRONG WIDTH FOR 'INT'" );
- END IF;
-
- IF IDENT_INT(INT2'WIDTH) /= 4 THEN
- FAILED ( "WRONG WIDTH FOR 'INT2'");
- END IF;
-
- IF IDENT_INT(SINT1'WIDTH) /= 4 THEN
- FAILED ( "WRONG WIDTH FOR 'SINT1'" );
- END IF;
-
- IF IDENT_INT(SINT2'WIDTH) /= 4 THEN
- FAILED ( "WRONG WIDTH FOR 'SINT2'" );
- END IF;
-
- IF IDENT_INT(SINT3'WIDTH) /= 4 THEN
- FAILED ( "WRONG WIDTH FOR 'SINT3'" );
- END IF;
-
- IF IDENT_INT(NOINT'WIDTH) /= 0 THEN
- FAILED ( "WRONG WIDTH FOR 'NOINT'" );
- END IF;
- END;
-
- RESULT;
-END C35503A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503b.ada b/gcc/testsuite/ada/acats/tests/c3/c35503b.ada
deleted file mode 100644
index f1bb5af..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503b.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C35503B.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 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS A
--- GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN INTEGER
--- TYPE.
-
--- RJW 3/17/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503B IS
-
-BEGIN
- TEST ("C35503B", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " &
- "RESULT WHEN THE PREFIX IS A GENERIC FORMAL " &
- "DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN " &
- "INTEGER TYPE" );
-
- DECLARE
-
- TYPE INT IS RANGE -1000 .. 1000;
- TYPE INT2 IS NEW INT RANGE 0E8 .. 1E3;
- SUBTYPE SINT1 IS INT RANGE 00000 .. 300;
- SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#;
-
- GENERIC
- TYPE I IS (<>);
- W : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE SUBI IS I
- RANGE I'VAL (IDENT_INT(224)) .. I'VAL (255);
- SUBTYPE NORANGE IS I
- RANGE I'VAL (255) .. I'VAL (IDENT_INT(224));
- BEGIN
- IF IDENT_INT(I'WIDTH) /= W THEN
- FAILED ( "INCORRECT I'WIDTH FOR " & STR );
- END IF;
-
- IF IDENT_INT(SUBI'WIDTH) /= 4 THEN
- FAILED ( "INCORRECT SUBI'WIDTH FOR " & STR );
- END IF;
-
- IF IDENT_INT(NORANGE'WIDTH) /= 0 THEN
- FAILED ( "INCORRECT NORANGE'WIDTH FOR " & STR );
- END IF;
- END P;
-
- PROCEDURE P_INTEGER IS NEW P (INTEGER, INTEGER'WIDTH);
- PROCEDURE P_INT IS NEW P (INT, 5);
- PROCEDURE P_INT2 IS NEW P (INT2, 5);
- PROCEDURE P_SINT1 IS NEW P (SINT1, 4);
- PROCEDURE P_SINT2 IS NEW P (SINT2, 4);
-
- BEGIN
- P_INTEGER ("'INTEGER'");
- P_INT ("'INT'");
- P_INT2 ("'INT2'");
- P_SINT1 ("'SINT1'");
- P_SINT2 ("'SINT2'");
- END;
-
- RESULT;
-END C35503B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503c.ada b/gcc/testsuite/ada/acats/tests/c3/c35503c.ada
deleted file mode 100644
index 331c76c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503c.ada
+++ /dev/null
@@ -1,543 +0,0 @@
--- C35503C.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 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS AN INTEGER TYPE.
--- SUBTESTS ARE :
--- PART (A). TESTS FOR 'IMAGE'.
--- PART (B). TESTS FOR 'VALUE'.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- VCL 10/23/87 MODIFIED THIS HEADER, ADDED A CHECK THAT
--- CONSTRAINT_ERROR IS RAISED FOR THE ATTRIBUTE
--- 'VALUE' IF THE FINAL SHARP OR COLON IS MISSING
--- FROM A BASED LITERAL.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35503C IS
- TYPE NEWINT IS NEW INTEGER;
- TYPE INT IS RANGE -1000 .. 1000;
-
- FUNCTION IDENT (X : INT) RETURN INT IS
- BEGIN
- IF EQUAL (INT'POS (X), INT'POS(X)) THEN
- RETURN X;
- END IF;
- RETURN INT'FIRST;
- END IDENT;
-
-BEGIN
- TEST ("C35503C", "THE ATTIBUTES 'IMAGE' AND 'VALUE' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "INTEGER TYPE" );
--- PART (A).
-
- BEGIN
- IF INTEGER'IMAGE (-500) /= "-500" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-500'" );
- END IF;
- IF INTEGER'IMAGE (-500)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-500'" );
- END IF;
-
- IF NEWINT'IMAGE (2 ** 6) /= " 64" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '2 ** 6'" );
- END IF;
- IF NEWINT'IMAGE (2 ** 6)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '2 ** 6'" );
- END IF;
-
- IF NATURAL'IMAGE (-1E2) /= "-100" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-1E2'" );
- END IF;
- IF NATURAL'IMAGE (-1E2)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-1E2'" );
- END IF;
-
- IF NEWINT'IMAGE (3_45) /= " 345" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '3_45'" );
- END IF;
- IF NEWINT'IMAGE (3_45)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '3_45'" );
- END IF;
-
- IF INTEGER'IMAGE (-2#1111_1111#) /= "-255" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-2#1111_1111#'" );
- END IF;
- IF INTEGER'IMAGE (-2#1111_1111#)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-2#1111_1111#'" );
- END IF;
-
- IF NEWINT'IMAGE (16#FF#) /= " 255" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '16#FF#'" );
- END IF;
- IF NEWINT'IMAGE (16#FF#)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '16#FF#'" );
- END IF;
-
- IF INTEGER'IMAGE (-016#0FF#) /= "-255" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-016#0FF#'" );
- END IF;
- IF INTEGER'IMAGE (-016#0FF#)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-016#0FF#'" );
- END IF;
-
- IF NEWINT'IMAGE (2#1110_0000#) /= " 224" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '2#1110_0000#'" );
- END IF;
- IF NEWINT'IMAGE (2#1110_0000#)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '2#1110_0000#'" );
- END IF;
-
- IF POSITIVE'IMAGE (-16#E#E1) /= "-224" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-16#E#E1'" );
- END IF;
- IF POSITIVE'IMAGE (-16#E#E1)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-16#E#E1'" );
- END IF;
-
- IF INT'IMAGE (IDENT(-1000)) /= "-1000" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-1000'" );
- END IF;
- IF INT'IMAGE (IDENT(-1000))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-1000'" );
- END IF;
-
- IF INT'IMAGE (IDENT(-999)) /= "-999" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-999'" );
- END IF;
- IF INT'IMAGE (IDENT(-999))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-999'" );
- END IF;
-
- IF INT'IMAGE (IDENT(-10)) /= "-10" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-1000'" );
- END IF;
- IF INT'IMAGE (IDENT(-10))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-10'" );
- END IF;
-
- IF INT'IMAGE (IDENT(-9)) /= "-9" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-9'" );
- END IF;
- IF INT'IMAGE (IDENT(-9))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-9'" );
- END IF;
-
- IF INT'IMAGE (IDENT(-1)) /= "-1" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '-1'" );
- END IF;
- IF INT'IMAGE (IDENT(-1))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '-1'" );
- END IF;
-
- IF INT'IMAGE (IDENT(0)) /= " 0" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '0'" );
- END IF;
- IF INT'IMAGE (IDENT(0))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '0'" );
- END IF;
-
- IF INT'IMAGE (IDENT(1)) /= " 1" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '1'" );
- END IF;
- IF INT'IMAGE (IDENT(1))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '1'" );
- END IF;
-
- IF INT'IMAGE (IDENT(9)) /= " 9" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '9'" );
- END IF;
- IF INT'IMAGE (IDENT(9))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '9'" );
- END IF;
-
- IF INT'IMAGE (IDENT(10)) /= " 10" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '10'" );
- END IF;
- IF INT'IMAGE (IDENT(10))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '10'" );
- END IF;
-
- IF INT'IMAGE (IDENT(999)) /= " 999" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '999'" );
- END IF;
- IF INT'IMAGE (IDENT(999))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '999'" );
- END IF;
-
- IF INT'IMAGE (IDENT(1000)) /= " 1000" THEN
- FAILED ( "INCORRECT 'IMAGE' OF '1000'" );
- END IF;
- IF INT'IMAGE (IDENT(1000))'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR '1000'" );
- END IF;
-
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- BEGIN
- IF POSITIVE'VALUE (IDENT_STR("-500")) /= -500 THEN
- FAILED ( "INCORRECT 'VALUE' OF ""-500""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""-500""" );
- END;
-
- BEGIN
- IF NEWINT'VALUE (" -001E2") /= -100 THEN
- FAILED ( "INCORRECT 'VALUE' OF "" -001E2""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF "" -001E2""" );
- END;
-
- BEGIN
- IF INTEGER'VALUE ("03_45") /= 345 THEN
- FAILED ( "INCORRECT 'VALUE' OF ""03_45""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""03_45""" );
- END;
-
- BEGIN
- IF NEWINT'VALUE ("-2#1111_1111#") /= -255 THEN
- FAILED ( "INCORRECT 'VALUE' OF ""-2#1111_1111#""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF "&
- """-2#1111_1111#""" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("16#FF#")) /= 255 THEN
- FAILED ( "INCORRECT 'VALUE' OF ""16#FF#""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""16#FF#""" );
- END;
-
- BEGIN
- IF NATURAL'VALUE (IDENT_STR("-016#0FF#")) /= -255 THEN
- FAILED ( "INCORRECT 'VALUE' OF ""-016#0FF#""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
- """-016#0FF#""" );
- END;
-
- BEGIN
- IF INTEGER'VALUE ("2#1110_0000# ") /= 224 THEN
- FAILED ( "INCORRECT 'VALUE' OF " &
- """2#1110_0000# """ );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
- """2#1110_0000# """ );
- END;
-
- BEGIN
- IF NEWINT'VALUE (" -16#E#E1") /= -224 THEN
- FAILED ( "INCORRECT 'VALUE' OF "" -16#E#E1""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
- """ -16#E#E1""" );
- END;
-
- BEGIN
- IF INTEGER'VALUE ("5/0") = 0 THEN
- FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""5/0""" );
- END;
-
- DECLARE
- SUBTYPE SUBINT IS INTEGER RANGE 0 .. 10;
- BEGIN
- IF SUBINT'VALUE (IDENT_STR("-500")) /= -500 THEN
- FAILED ( "INCORRECT VALUE WITH ""-500"" AND SUBINT" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - SUBINT" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("1.0")) = 1 THEN
- FAILED ( "NO EXCEPTION RAISED - "" 1.0"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""1.0"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""1.0"" " );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_CHAR(ASCII.HT) & "244") /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE ("244" & (IDENT_CHAR(ASCII.HT))) /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("2__44")) /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "WITH CONSECUTIVE '_'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("_244")) /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - LEADING '_'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("244_")) /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - TRAILING '_'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("244_E1")) /= 2440 THEN
- FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'E'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("244E_1")) /= 2440 THEN
- FAILED ( "NO EXCEPTION RAISED - '_' " &
- "FOLLOWING 'E' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - '_' FOLLOWING 'E' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "- '_' FOLLOWING 'E'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("244_e1")) /= 2440 THEN
- FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'e'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("16#_FF#")) /= 255 THEN
- FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " &
- "LITERAL - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " &
- "LITERAL - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "- LEADING '_' IN BASED LITERAL" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("1E-0")) /= 1 THEN
- FAILED ( "NO EXCEPTION RAISED - NEGATIVE " &
- "EXPONENT - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - NEGATIVE EXPONENT - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "- NEGATIVE EXPONENT" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("244.")) /= 244 THEN
- FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - TRAILING '.'" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("8#811#")) /= 0 THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "DIGITS NOT IN CORRECT RANGE - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "DIGITS NOT IN CORRECT RANGE - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "DIGITS NOT IN CORRECT RANGE" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("1#000#")) /= 0 THEN
- FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "- BASE LESS THAN 2" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("17#0#")) /= 0 THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "- BASE GREATER THAN 16 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "- BASE GREATER THAN 16 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "- BASE GREATER THAN 16" );
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("8#666")) /= 438 THEN
- FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 1");
- ELSE
- FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL SHARP");
- END;
-
- BEGIN
- IF INTEGER'VALUE (IDENT_STR("16:FF")) /= 255 THEN
- FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 1");
- ELSE
- FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL COLON");
- END;
-
- RESULT;
-END C35503C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503d.tst b/gcc/testsuite/ada/acats/tests/c3/c35503d.tst
deleted file mode 100644
index b15e1ab..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503d.tst
+++ /dev/null
@@ -1,97 +0,0 @@
--- C35503D.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.
---*
--- OBJECTIVE:
--- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE
--- LARGEST/SMALLEST INTEGER LITERAL FOR THE LONGEST INTEGER TYPE.
-
--- HISTORY:
--- RJW 02/26/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503D IS
-
- TYPE INT IS RANGE MIN_INT .. MAX_INT;
-
- FUNCTION IDENT (X:INT) RETURN INT IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN X;
- END IF;
- RETURN 0;
- END IDENT;
-
-BEGIN
- TEST ("C35503D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " &
- "CORRECT RESULTS FOR THE LARGEST/SMALLEST "&
- "INTEGER LITERAL FOR THE LARGEST INTEGER TYPE");
-
- -- MIN_INT IS THE DECIMAL LITERAL FOR SYSTEM.MIN_INT.
- -- MAX_INT IS THE DECIMAL LITERAL FOR SYSTEM.MAX_INT.
-
- BEGIN
- IF INT'VALUE (IDENT_STR("$MIN_INT")) /= MIN_INT THEN
- FAILED("INCORRECT RESULTS FOR 'VALUE' - MIN_INT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MIN_INT");
- WHEN OTHERS =>
- FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MIN_INT");
- END;
-
- BEGIN
- IF INT'IMAGE (IDENT(MIN_INT)) /= "$MIN_INT" THEN
- FAILED("INCORRECT RESULTS FOR 'IMAGE' - MIN_INT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED FOR 'IMAGE' - MIN_INT");
- END;
-
- BEGIN
- IF INT'VALUE (IDENT_STR("$MAX_INT")) /= MAX_INT THEN
- FAILED("INCORRECT RESULTS FOR 'VALUE' - MAX_INT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MAX_INT");
- WHEN OTHERS =>
- FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MAX_INT");
- END;
-
- BEGIN
- IF INT'IMAGE (IDENT(MAX_INT)) /= ' ' & "$MAX_INT" THEN
- FAILED("INCORRECT RESULTS FOR 'IMAGE' - MAXINT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED FOR 'IMAGE' - MAXINT");
- END;
-
- RESULT;
-END C35503D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503e.ada b/gcc/testsuite/ada/acats/tests/c3/c35503e.ada
deleted file mode 100644
index 0f326e1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503e.ada
+++ /dev/null
@@ -1,212 +0,0 @@
--- C35503E.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 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN
--- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS AN INTEGER TYPE.
--- SUBTESTS ARE :
--- PART (A). TESTS FOR 'IMAGE'.
--- PART (B). TESTS FOR 'VALUE'.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503E IS
-
-BEGIN
- TEST ("C35503E", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "PARAMETER IS AN INTEGER TYPE" );
--- PART (A).
-
- DECLARE
- TYPE NEWINT IS NEW INTEGER RANGE -2000 .. 2000;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P (I1 : INT; STR : STRING );
-
- PROCEDURE P (I1 : INT; STR : STRING) IS
- SUBTYPE SUBINT IS INT
- RANGE INT'VAL (IDENT_INT(-1000)) ..
- INT'VAL (IDENT_INT(1000));
- BEGIN
-
- IF INT'IMAGE (I1) /= STR THEN
- FAILED ( "INCORRECT INT'IMAGE OF " & STR );
- END IF;
- IF INT'IMAGE (I1)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR INT'IMAGE OF " &
- STR );
- END IF;
-
- IF SUBINT'IMAGE (I1) /= STR THEN
- FAILED ( "INCORRECT SUBINT'IMAGE OF " & STR );
- END IF;
- IF SUBINT'IMAGE (I1)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR SUBINT'IMAGE " &
- "OF " & STR );
- END IF;
-
- END P;
-
- PROCEDURE PROC1 IS NEW P (INTEGER);
- PROCEDURE PROC2 IS NEW P (NEWINT);
-
- BEGIN
- PROC1 (-500, "-500");
- PROC2 (0, " 0");
- PROC2 (99," 99");
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- DECLARE
- TYPE NEWINT IS NEW INTEGER;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P (STR : STRING; I1 : INT );
-
- PROCEDURE P (STR : STRING; I1 : INT) IS
- SUBTYPE SUBINT IS INT
- RANGE INT'VAL (IDENT_INT(0)) ..
- INT'VAL (IDENT_INT(10));
-
- BEGIN
- BEGIN
- IF INT'VALUE (STR) /= I1 THEN
- FAILED ( "INCORRECT INT'VALUE OF """ &
- STR & """");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INT'VALUE OF """ &
- STR & """");
- END;
- BEGIN
- IF SUBINT'VALUE (STR) /= I1 THEN
- FAILED ( "INCORRECT SUBINT'VALUE OF """ &
- STR & """");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED SUBINT'VALUE " &
- "OF """ & STR & """");
- END;
- END P;
-
- PROCEDURE PROC1 IS NEW P (INTEGER);
- PROCEDURE PROC2 IS NEW P (NEWINT);
-
- BEGIN
- PROC1 ("-500" , -500);
- PROC2 (" -001E2 " , -100);
- PROC1 ("3_45" , 345);
- PROC2 ("-2#1111_1111#" , -255);
- PROC1 ("16#FF#" , 255);
- PROC2 ("-016#0FF#" , -255);
- PROC1 ("2#1110_0000# " , 224);
- PROC2 ("-16#E#E1" , -224);
-
- END;
-
- DECLARE
- TYPE NEWINT IS NEW INTEGER;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING);
-
- PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING) IS
- SUBTYPE SUBINT IS INT
- RANGE INT'VAL (IDENT_INT(0)) ..
- INT'VAL (IDENT_INT(10));
-
- BEGIN
- BEGIN
- IF INT'VALUE (STR1) = I1 THEN
- FAILED ( "NO EXCEPTION RAISED - INT'VALUE " &
- "WITH " & STR2 & " - EQUAL");
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "- INT'VALUE WITH " &
- STR2 & " - NOT EQUAL" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "INT'VALUE WITH " & STR2 );
- END;
- BEGIN
- IF SUBINT'VALUE (STR1) = I1 THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "SUBINT'VALUE WITH " & STR2
- & " - EQUAL" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "SUBINT'VALUE WITH " &
- STR2 & " - NOT EQUAL" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "SUBINT'VALUE WITH " & STR2 );
- END;
- END P;
-
- PROCEDURE PROC1 IS NEW P (INTEGER);
- PROCEDURE PROC2 IS NEW P (NEWINT);
-
- BEGIN
- PROC1 ("1.0" , 1, "DECIMAL POINT");
- PROC1 (ASCII.HT & "244", 244, "LEADING 'HT'" );
- PROC2 ("244" & ASCII.HT, 244, "TRAILING 'HT'" );
- PROC1 ("2__44" , 244, "CONSECUTIVE '_'" );
- PROC2 ("_244" , 244, "LEADING '_'" );
- PROC1 ("244_" , 244, "TRAILING '_'" );
- PROC2 ("244_E1" , 2440, "'_' BEFORE 'E'" );
- PROC1 ("244E_1" , 2440, "'_' FOLLOWING 'E'" );
- PROC2 ("244_e1" , 2440, "'_' BEFORE 'e'" );
- PROC1 ("16#_FF#" , 255, "'_' IN BASED LITERAL" );
- PROC2 ("1E-0" , 0, "NEGATIVE EXPONENT" );
- PROC1 ("244." , 244, "TRAILING '.'" );
- PROC2 ("8#811#" , 0, "DIGITS OUTSIDE OF RANGE" );
- PROC1 ("1#000#" , 0, "BASE LESS THAN 2" );
- PROC2 ("17#0#" , 0, "BASE GREATER THAN 16" );
- END;
-
- RESULT;
-END C35503E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503f.tst b/gcc/testsuite/ada/acats/tests/c3/c35503f.tst
deleted file mode 100644
index f68669a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503f.tst
+++ /dev/null
@@ -1,132 +0,0 @@
--- C35503F.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.
---*
--- OBJECTIVE:
--- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE
--- LARGEST/SMALLEST INTEGER LITERAL AND A FORMAL DISCRETE TYPE WHOSE
--- ACTUAL PARAMETER IS AN INTEGER TYPE.
-
--- HISTORY
--- RJW 05/12/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503F IS
-
-TYPE LONGEST_INT IS RANGE MIN_INT .. MAX_INT;
-
-BEGIN
- TEST ("C35503F", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " &
- "CORRECT RESULTS FOR THE LARGEST/SMALLEST "&
- "INTEGER LITERAL AND A FORMAL DISCRETE TYPE " &
- "WHOSE ACTUAL PARAMETER IS AN INTEGER TYPE");
-
- -- INTEGER_FIRST IS THE DECIMAL LITERAL IMAGE OF INTEGER'FIRST.
- -- INTEGER_LAST IS THE DECIMAL LITERAL IMAGE OF INTEGER'LAST.
- -- MIN_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MIN_INT.
- -- MAX_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MAX_INT.
-
- DECLARE
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P ( FS, LS : STRING; FI, LI : INT );
-
- PROCEDURE P ( FS, LS : STRING; FI, LI : INT ) IS
- BEGIN
- BEGIN
- IF INT'VALUE (FS) /= FI THEN
- FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " &
- FS );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
- "'VALUE' OF " & FS );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR " &
- "'VALUE' OF " & FS );
- END;
-
- BEGIN
- IF INT'VALUE (LS) /= LI THEN
- FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " &
- LS );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
- "'VALUE' OF " & LS );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR " &
- "'VALUE' OF " & LS );
- END;
- END P;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE Q ( FS, LS : STRING; FI, LI : INT );
-
- PROCEDURE Q ( FS, LS : STRING; FI, LI : INT ) IS
- BEGIN
- BEGIN
- IF INT'IMAGE(FI) /= FS THEN
- FAILED ( "INCORRECT RESULTS FOR " &
- "'IMAGE' WITH " & FS );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " &
- "WITH " & FS );
- END;
-
- BEGIN
- IF INT'IMAGE(LI) /= LS THEN
- FAILED ( "INCORRECT RESULTS FOR " &
- "'IMAGE' WITH " & LS );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " &
- "WITH " & LS );
- END;
- END Q;
-
- PROCEDURE P1 IS NEW P ( INTEGER );
- PROCEDURE Q1 IS NEW Q ( INTEGER );
- PROCEDURE P2 IS NEW P ( LONGEST_INT );
- PROCEDURE Q2 IS NEW Q ( LONGEST_INT );
- BEGIN
- P1 ("$INTEGER_FIRST", "$INTEGER_LAST", INTEGER'FIRST,
- INTEGER'LAST);
- P2 ("$MIN_INT", "$MAX_INT", MIN_INT, MAX_INT);
- Q1 ("$INTEGER_FIRST"," $INTEGER_LAST", INTEGER'FIRST,
- INTEGER'LAST);
- Q2 ("$MIN_INT", " $MAX_INT", MIN_INT, MAX_INT);
-
- END;
-
- RESULT;
-END C35503F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503g.ada b/gcc/testsuite/ada/acats/tests/c3/c35503g.ada
deleted file mode 100644
index 2004e45..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503g.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- C35503G.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE
--- PREFIX IS AN INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503G IS
-
-BEGIN
- TEST ("C35503G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULT WHEN THE PREFIX IS AN " &
- "INTEGER TYPE" );
-
- DECLARE
- TYPE INT IS RANGE -6 .. 6;
- SUBTYPE SINT IS INT RANGE -4 .. 4;
-
- BEGIN
-
- FOR I IN INT'FIRST + 1 .. INT'LAST LOOP
- BEGIN
- IF SINT'PRED (I) /= I - 1 THEN
- FAILED ( "WRONG SINT'PRED FOR " &
- INT'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- "SINT'PRED OF " &
- INT'IMAGE (I));
- END;
- END LOOP;
-
- FOR I IN INT'FIRST .. INT'LAST - 1 LOOP
- BEGIN
- IF SINT'SUCC (I) /= I + 1 THEN
- FAILED ( "WRONG SINT'SUCC FOR " &
- INT'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- "SINT'SUCC OF " &
- INT'IMAGE (I));
- END;
- END LOOP;
-
- END;
-
- DECLARE
- SUBTYPE INTRANGE IS INTEGER RANGE IDENT_INT(-6) ..
- IDENT_INT(6);
- SUBTYPE SINTEGER IS INTEGER RANGE IDENT_INT(-4) ..
- IDENT_INT(4);
-
- BEGIN
- FOR I IN INTRANGE LOOP
- BEGIN
- IF SINTEGER'PRED (I) /= I - IDENT_INT(1) THEN
- FAILED ( "WRONG SINTEGER'PRED FOR " &
- INTEGER'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- "SINTEGER'PRED OF " &
- INTEGER'IMAGE (I));
- END;
- BEGIN
- IF SINTEGER'SUCC (I) /= I + IDENT_INT(1) THEN
- FAILED ( "WRONG SINTEGER'SUCC FOR " &
- INTEGER'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- "SINTEGER'SUCC OF " &
- INTEGER'IMAGE (I));
- END;
- END LOOP;
-
- END;
-
- RESULT;
-END C35503G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503h.ada b/gcc/testsuite/ada/acats/tests/c3/c35503h.ada
deleted file mode 100644
index e141067..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503h.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C35503H.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE
--- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER
--- IS AN INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503H IS
-
-BEGIN
- TEST ("C35503H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULT WHEN THE PREFIX IS A GENERIC " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " &
- "IS AN INTEGER TYPE" );
-
- DECLARE
- TYPE INTRANGE IS RANGE -6 .. 6;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE SINT IS INT
- RANGE INT'VAL (IDENT_INT(-4)) ..
- INT'VAL (IDENT_INT(4));
- BEGIN
- FOR I IN INT'VAL (IDENT_INT(-6)) ..
- INT'VAL (IDENT_INT(6))
- LOOP
- BEGIN
- IF SINT'PRED (I) /=
- SINT'VAL (SINT'POS (I) - 1) THEN
- FAILED ( "WRONG " & STR & "'PRED " &
- "FOR " & INT'IMAGE (I) );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- STR & "'PRED OF " &
- INT'IMAGE (I));
- END;
- BEGIN
- IF SINT'SUCC (I) /=
- SINT'VAL (SINT'POS (I) + 1) THEN
- FAILED ( "WRONG " & STR & "'SUCC " &
- "FOR " & INT'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- STR & "'SUCC OF " &
- INT'IMAGE (I));
- END;
- END LOOP;
- END P;
-
- PROCEDURE PROC1 IS NEW P (INTRANGE);
- PROCEDURE PROC2 IS NEW P (INTEGER);
- BEGIN
- PROC1 ("INTRANGE");
- PROC2 ("INTEGER");
- END;
-
- RESULT;
-END C35503H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503k.ada b/gcc/testsuite/ada/acats/tests/c3/c35503k.ada
deleted file mode 100644
index e05021c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503k.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C35503K.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS AN INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- PWN 11/30/94 REMOVED ATTRIBUTE TESTS ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503K IS
-
-BEGIN
- TEST ("C35503K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "INTEGER TYPE" );
-
- DECLARE
- TYPE INT IS RANGE -6 .. 6;
- SUBTYPE SINT IS INT RANGE -4 .. 4;
-
- PROCEDURE P (I : INTEGER; STR : STRING) IS
- BEGIN
- BEGIN
- IF INTEGER'POS (I) /= I THEN
- FAILED ( "WRONG POS FOR " & STR);
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR POS OF " &
- STR);
- END;
- BEGIN
- IF INTEGER'VAL (I) /= I THEN
- FAILED ( "WRONG VAL FOR " & STR);
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR VAL OF " &
- STR);
- END;
- END P;
-
- BEGIN
- P ( INTEGER'FIRST, "INTEGER'FIRST");
- P ( INTEGER'LAST, "INTEGER'LAST");
- P ( 0, "'0'");
-
- FOR I IN INT'FIRST .. INT'LAST LOOP
- BEGIN
- IF SINT'POS (I) /= I THEN
- FAILED ( "WRONG POS FOR "
- & INT'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR POS OF "
- & INT'IMAGE (I));
- END;
- BEGIN
- IF SINT'VAL (I) /= I THEN
- FAILED ( "WRONG VAL FOR "
- & INT'IMAGE (I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR VAL OF "
- & INT'IMAGE (I));
- END;
- END LOOP;
-
- BEGIN
- IF INT'VAL (INTEGER'(0)) /= 0 THEN
- FAILED ( "WRONG VAL FOR INT WITH INTEGER" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR VAL OF " &
- "INT WITH INTEGER" );
- END;
-
- BEGIN
- IF INTEGER'VAL (INT'(0)) /= 0 THEN
- FAILED ( "WRONG VAL FOR INTEGER WITH INT" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR VAL OF " &
- "INTEGER WITH INT" );
- END;
- END;
-
- RESULT;
-END C35503K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503l.ada b/gcc/testsuite/ada/acats/tests/c3/c35503l.ada
deleted file mode 100644
index 33d571d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503l.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C35503L.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER
--- IS AN INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503L IS
-
-BEGIN
- TEST ("C35503L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "GENERIC FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS AN INTEGER TYPE" );
-
- DECLARE
- TYPE INTRANGE IS RANGE -6 .. 6;
-
- GENERIC
- TYPE INT IS (<>);
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE SINT IS INT RANGE
- INT'VAL (IDENT_INT(-4)) .. INT'VAL (IDENT_INT(4));
- I :INTEGER;
- BEGIN
- I := IDENT_INT(-6);
- FOR S IN INT'VAL (IDENT_INT(-6)) ..
- INT'VAL (IDENT_INT(6))
- LOOP
- BEGIN
- IF SINT'POS (S) /= I THEN
- FAILED ( "WRONG VALUE FOR " &
- STR & "'POS OF "
- & INT'IMAGE (S) );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- STR & "'POS "
- & "OF " & INT'IMAGE (S) );
- END;
- BEGIN
- IF SINT'VAL (I) /= S THEN
- FAILED ( "WRONG VALUE FOR " &
- STR & "'VAL "
- & "OF " & INT'IMAGE (S) );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR " &
- STR & "'VAL "
- & "OF " & INT'IMAGE (S) );
- END;
- I := I + 1;
- END LOOP;
- END P;
-
- PROCEDURE P1 IS NEW P (INTRANGE);
- PROCEDURE P2 IS NEW P (INTEGER);
-
- BEGIN
- P1 ("INTRANGE");
- P2 ("INTEGER");
- END;
-
- RESULT;
-
-END C35503L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503o.ada b/gcc/testsuite/ada/acats/tests/c3/c35503o.ada
deleted file mode 100644
index 57d288f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503o.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C35503O.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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS AN INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/17/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503O IS
-
-BEGIN
- TEST ("C35503O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS AN " &
- "INTEGER TYPE" );
-
- DECLARE
- SUBTYPE SINTEGER IS INTEGER;
- SUBTYPE SMALL IS INTEGER RANGE IDENT_INT(-10) ..
- IDENT_INT(10);
- SUBTYPE NOINTEGER IS INTEGER
- RANGE IDENT_INT(5) .. IDENT_INT(-7);
-
- TYPE INT IS RANGE -6 .. 6;
- SUBTYPE SINT IS INT
- RANGE INT(IDENT_INT(-4)) .. INT(IDENT_INT(4));
- SUBTYPE NOINT IS INT
- RANGE INT(IDENT_INT(1)) .. INT(IDENT_INT(-1));
- TYPE NEWINT IS NEW INTEGER RANGE IDENT_INT(-9) ..
- IDENT_INT(-2);
- SUBTYPE SNEWINT IS NEWINT RANGE -7 .. -5;
- SUBTYPE NONEWINT IS NEWINT RANGE 3 .. -15;
-
- BEGIN
- IF SINTEGER'FIRST /= INTEGER'FIRST THEN
- FAILED ( "WRONG VALUE FOR SINTEGER'FIRST" );
- END IF;
- IF SINTEGER'LAST /= INTEGER'LAST THEN
- FAILED ( "WRONG VALUE FOR SINTEGER'LAST" );
- END IF;
-
- IF SMALL'FIRST /= -10 THEN
- FAILED ( "WRONG VALUE FOR SMALL'FIRST" );
- END IF;
- IF SMALL'LAST /= 10 THEN
- FAILED ( "WRONG VALUE FOR SMALL'LAST" );
- END IF;
-
- IF NOINTEGER'FIRST /= 5 THEN
- FAILED ( "WRONG VALUE FOR NOINTEGER'FIRST" );
- END IF;
- IF NOINTEGER'LAST /= -7 THEN
- FAILED ( "WRONG VALUE FOR NOINTEGER'LAST" );
- END IF;
-
- IF INT'FIRST /= -6 THEN
- FAILED ( "WRONG VALUE FOR INT'FIRST" );
- END IF;
- IF INT'LAST /= 6 THEN
- FAILED ( "WRONG VALUE FOR INT'LAST" );
- END IF;
-
- IF SINT'FIRST /= -4 THEN
- FAILED ( "WRONG VALUE FOR SINT'FIRST" );
- END IF;
- IF SINT'LAST /= 4 THEN
- FAILED ( "WRONG VALUE FOR SINT'LAST" );
- END IF;
-
- IF NOINT'FIRST /= 1 THEN
- FAILED ( "WRONG VALUE FOR NOINT'FIRST" );
- END IF;
- IF NOINT'LAST /= -1 THEN
- FAILED ( "WRONG VALUE FOR NOINT'LAST" );
- END IF;
-
- IF NEWINT'FIRST /= -9 THEN
- FAILED ( "WRONG VALUE FOR NEWINT'FIRST" );
- END IF;
- IF NEWINT'LAST /= -2 THEN
- FAILED ( "WRONG VALUE FOR NEWINT'LAST" );
- END IF;
-
- IF SNEWINT'FIRST /= -7 THEN
- FAILED ( "WRONG VALUE FOR SNEWINT'FIRST" );
- END IF;
- IF SNEWINT'LAST /= -5 THEN
- FAILED ( "WRONG VALUE FOR SNEWINT'LAST" );
- END IF;
-
- IF NONEWINT'FIRST /= 3 THEN
- FAILED ( "WRONG VALUE FOR NONEWINT'FIRST" );
- END IF;
- IF NONEWINT'LAST /= -15 THEN
- FAILED ( "WRONG VALUE FOR NONEWINT'LAST" );
- END IF;
- END;
-
- RESULT;
-END C35503O;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35503p.ada b/gcc/testsuite/ada/acats/tests/c3/c35503p.ada
deleted file mode 100644
index 28ecac3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35503p.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- C35503P.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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT IS AN
--- INTEGER TYPE.
-
--- HISTORY:
--- RJW 03/24/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35503P IS
-
-BEGIN
- TEST ("C35503P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT " &
- "IS AN INTEGER TYPE" );
-
-
- DECLARE
-
- TYPE INT IS RANGE -6 .. 6;
- SUBTYPE SINT IS INT RANGE INT(IDENT_INT(-4)) ..
- INT(IDENT_INT(4));
- SUBTYPE NOINT IS INT RANGE INT(IDENT_INT(1)) ..
- INT(IDENT_INT(-1));
-
- GENERIC
- TYPE I IS (<>);
- F, L : I;
- PROCEDURE P ( STR : STRING );
-
- PROCEDURE P ( STR : STRING ) IS
- BEGIN
- IF I'FIRST /= F THEN
- FAILED ( "INCORRECT 'FIRST' FOR " & STR );
- END IF;
- IF I'LAST /= L THEN
- FAILED ( "INCORRECT 'LAST' FOR " & STR );
- END IF;
- END P;
-
- GENERIC
- TYPE I IS (<>);
- F, L : I;
- PROCEDURE Q;
-
- PROCEDURE Q IS
- SUBTYPE SI IS I;
- BEGIN
- IF SI'FIRST /= F THEN
- FAILED ( "INCORRECT VALUE FOR INTEGER'FIRST" );
- END IF;
- IF SI'LAST /= L THEN
- FAILED ( "INCORRECT VALUE FOR INTEGER'LAST" );
- END IF;
- END Q;
-
- GENERIC
- TYPE I IS (<>);
- PROCEDURE R;
-
- PROCEDURE R IS
- SUBTYPE SI IS I;
- BEGIN
- IF SI'FIRST /= SI'VAL (IDENT_INT(1)) THEN
- FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" );
- END IF;
- IF SI'LAST /= SI'VAL (IDENT_INT(-1)) THEN
- FAILED ( "INCORRECT VALUE FOR NOINT'LAST" );
- END IF;
- END R;
-
- PROCEDURE P1 IS NEW P ( I => INT, F => -6, L => 6 );
- PROCEDURE P2 IS NEW P ( I => SINT, F => -4, L => 4 );
- PROCEDURE Q1 IS NEW Q
- ( I => INTEGER, F => INTEGER'FIRST, L => INTEGER'LAST );
- PROCEDURE R1 IS NEW R ( I => NOINT);
-
- BEGIN
- P1 ( "INT" );
- P2 ( "SINT" );
- Q1;
- R1;
- END;
-
- RESULT;
-END C35503P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35504a.ada b/gcc/testsuite/ada/acats/tests/c3/c35504a.ada
deleted file mode 100644
index 6c2c59a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35504a.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C35504A.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 THE USER-DEFINED
--- ENUMERATION ARGUMENT TO 'SUCC, 'PRED, 'POS, 'VAL, 'IMAGE, AND 'VALUE
--- IS NOT IN THE ATTRIBUTED SUBTYPE'S RANGE CONSTRAINT.
-
--- DAT 3/18/81
--- SPS 01/13/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35504A IS
-
- TYPE E IS (A, 'A', B, 'B', C, 'C', D, 'D', XYZ);
-
- SUBTYPE S IS E RANGE B .. C;
-
-BEGIN
- TEST ("C35504A", "CONSTRAINT_ERROR IS NOT RAISED IN T'SUCC(X),"
- & " T'PRED(X), T'POS(X), T'VAL(X), T'IMAGE(X), AND"
- & " T'VALUE(X) WHEN THE VALUES ARE NOT WITHIN T'S"
- & " RANGE CONSTRAINT, FOR USER-DEFINED ENUMERATION TYPES");
-
- BEGIN
- FOR X IN E LOOP
- IF (X /= A AND THEN S'SUCC(S'PRED(X)) /= X)
- OR (X /= XYZ AND THEN S'PRED(S'SUCC(X)) /= X)
- OR S'VAL(S'POS(X)) /= X
- OR S'VALUE(S'IMAGE(X)) /= X
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE");
- END IF;
- END LOOP;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR RAISED"
- & " WHEN IT SHOULDN'T HAVE BEEN");
- WHEN OTHERS => FAILED ("INCORRECT EXCEPTION RAISED");
- END;
-
- RESULT;
-END C35504A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35504b.ada b/gcc/testsuite/ada/acats/tests/c3/c35504b.ada
deleted file mode 100644
index 644b1d6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35504b.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- C35504B.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 I'SUCC, I'PRED,
--- I'POS, I'VAL, I'IMAGE, AND I'VALUE FOR INTEGER ARGUMENTS
--- OUTSIDE THE RANGE OF I.
-
--- DAT 3/30/81
--- SPS 01/13/83
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE C35504B IS
-
- SUBTYPE I IS INTEGER RANGE 0 .. 0;
-
-BEGIN
- TEST ("C35504B", "CONSTRAINT_ERROR IS NOT RAISED FOR"
- & " INTEGER SUBTYPE ATTRIBUTES 'SUCC, 'PRED, 'POS, 'VAL,"
- & " 'IMAGE, AND 'VALUE WHOSE ARGUMENTS ARE OUTSIDE THE"
- & " SUBTYPE");
-
- BEGIN
- IF I'SUCC(-1) /= I'PRED(1)
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 1");
- END IF;
-
- IF I'SUCC (100) /= 101
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 2");
- END IF;
-
- IF I'PRED (100) /= 99
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 3");
- END IF;
-
- IF I'POS (-100) /= -100
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 4");
- END IF;
-
- IF I'VAL(-100) /= -100
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 5");
- END IF;
-
- IF I'IMAGE(1234) /= " 1234"
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 6");
- END IF;
-
- IF I'VALUE("999") /= 999
- THEN
- FAILED ("WRONG ATTRIBUTE VALUE - 7");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-END C35504B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35505c.ada b/gcc/testsuite/ada/acats/tests/c3/c35505c.ada
deleted file mode 100644
index 52bf7f2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35505c.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C35505C.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 CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED',
--- IF THE RETURNED VALUES WOULD BE OUTSIDE OF THE BASE TYPE,
--- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT
--- IS A USER-DEFINED ENUMERATION TYPE.
-
--- HISTORY:
--- RJW 06/05/86 CREATED ORIGINAL TEST.
--- VCL 08/19/87 REMOVED THE FUNCTION 'IDENT' IN THE GENERIC
--- PROCEDURE 'P' AND REPLACED ALL CALLS TO 'IDENT'
--- WITH "T'VAL(IDENT_INT(T'POS(...)))".
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35505C IS
-
- TYPE B IS ('Z', 'X', Z, X);
-
- SUBTYPE C IS B RANGE 'X' .. Z;
-
-BEGIN
- TEST ( "C35505C", "CHECK THAT 'SUCC' AND 'PRED' RAISE " &
- "CONSTRAINT_ERROR APPROPRIATELY WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ARGUMENT IS A USER-DEFINED ENUMERATION TYPE" );
-
- DECLARE
- GENERIC
- TYPE T IS (<>);
- STR : STRING;
- PROCEDURE P;
-
- PROCEDURE P IS
-
- BEGIN
- BEGIN
- IF T'PRED (T'VAL (IDENT_INT (T'POS
- (T'BASE'FIRST)))) = T'FIRST THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'PRED - 1" );
- ELSE
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'PRED - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'PRED - 1" );
- END;
-
- BEGIN
- IF T'SUCC (T'VAL (IDENT_INT (T'POS
- (T'BASE'LAST)))) = T'LAST THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'SUCC - 1" );
- ELSE
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'SUCC - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'SUCC - 1" );
- END;
- END P;
-
- PROCEDURE PB IS NEW P (B, "B");
- PROCEDURE PC IS NEW P (C, "C");
- BEGIN
- PB;
- PC;
- END;
-RESULT;
-END C35505C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35505e.ada b/gcc/testsuite/ada/acats/tests/c3/c35505e.ada
deleted file mode 100644
index 0da82da..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35505e.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- C35505E.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 CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED',
--- IF THE RESULT WOULD BE OUTSIDE THE RANGE OF THE BASE TYPE,
--- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT
--- IS TYPE CHARACTER OR A SUBTYPE OF TYPE CHARACTER.
-
--- HISTORY:
--- DWC 07/01/87
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35505E IS
-
- TYPE CHAR IS ('A', B, C);
- SUBTYPE NEWCHAR IS CHAR;
-
-BEGIN
- TEST ( "C35505E", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "'SUCC' AND 'PRED', IF THE RESULT WOULD BE " &
- "OUTSIDE THE RANGE OF THE BASE TYPE, WHEN " &
- "THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL ARGUMENT IS A CHARACTER TYPE ");
-
- DECLARE
- GENERIC
- TYPE SUBCH IS (<>);
- STR : STRING;
- I1, I2 : INTEGER;
- PROCEDURE P;
-
- PROCEDURE P IS
-
- FUNCTION IDENT (C : SUBCH) RETURN SUBCH IS
- BEGIN
- RETURN SUBCH'VAL (IDENT_INT (SUBCH'POS (C)));
- END IDENT;
-
- BEGIN
- BEGIN
- IF SUBCH'PRED (SUBCH'BASE'FIRST) = SUBCH'VAL (0)
- THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'PRED - 1" );
- ELSE
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'PRED - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'PRED - 1" );
- END;
-
- BEGIN
- IF SUBCH'SUCC (SUBCH'BASE'LAST) = SUBCH'VAL (0) THEN
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'SUCC - 1" );
- ELSE
- FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " &
- STR & "'SUCC - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'SUCC - 1" );
- END;
-
- BEGIN
- IF SUBCH'PRED (IDENT (SUBCH'BASE'FIRST)) =
- SUBCH'VAL (I1) THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'PRED " &
- "(IDENT (SUBCH'BASE'FIRST)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'PRED " &
- "(IDENT (SUBCH'BASE'FIRST)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR " & STR & "'PRED " &
- "(IDENT (SUBCH'BASE'FIRST))" );
- END;
-
- BEGIN
- IF SUBCH'SUCC (IDENT(SUBCH'BASE'LAST)) =
- SUBCH'VAL (I2) THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'SUCC " &
- "(IDENT (SUBCH'BASE'LAST)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'SUCC " &
- "(IDENT (SUBCH'BASE'LAST)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR " & STR & "'SUCC " &
- "(IDENT (SUBCH'BASE'LAST))" );
- END;
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1);
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1);
- BEGIN
- PCHAR;
- PNCHAR;
- END;
-RESULT;
-END C35505E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35505f.ada b/gcc/testsuite/ada/acats/tests/c3/c35505f.ada
deleted file mode 100644
index b8d4acc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35505f.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C35505F.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 CONSTRAINT ERROR IS RAISED BY THE ATTRIBUTES
--- 'PRED' AND 'SUCC' WHEN THE PREFIX IS A CHARACTER TYPE
--- AND THE RESULT IS OUTSIDE OF THE BASE TYPE.
-
--- HISTORY:
--- JET 08/18/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35505F IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
- END;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
- END;
-
-BEGIN
-
- TEST( "C35505F" , "CHECK THAT CONSTRAINT ERROR IS RAISED BY " &
- "THE ATTRIBUTES 'PRED' AND 'SUCC' WHEN THE " &
- "PREFIX IS A CHARACTER TYPE AND THE RESULT " &
- "IS OUTSIDE OF THE BASE TYPE" );
-
- BEGIN
- IF CHAR'PRED (IDENT ('A')) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'PRED (IDENT ('A')) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'PRED (IDENT ('A')) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHAR'PRED (IDENT ('A'))" );
- END;
-
- BEGIN
- IF CHAR'SUCC (IDENT (B)) = B THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'SUCC (IDENT (B)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'SUCC (IDENT (B)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHAR'SUCC (IDENT (B))" );
- END;
-
- BEGIN
- IF NEWCHAR'PRED (IDENT ('A')) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'PRED (IDENT ('A')) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'PRED (IDENT ('A')) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR NEWCHAR'PRED (IDENT ('A'))" );
- END;
-
- BEGIN
- IF NEWCHAR'SUCC (IDENT (B)) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'SUCC (IDENT (B)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'SUCC (IDENT (B)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR NEWCHAR'SUCC (IDENT (B))" );
- END;
-
- BEGIN
- IF CHARACTER'PRED (IDENT_CHAR (CHARACTER'BASE'FIRST)) = 'A'
- THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'PRED " &
- "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'PRED " &
- "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'PRED " &
- "(IDENT_CHAR (CHARACTER'BASE'FIRST))" );
- END;
-
- BEGIN
- IF CHARACTER'SUCC (IDENT_CHAR (CHARACTER'BASE'LAST)) = 'Z'
- THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'SUCC " &
- "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'SUCC " &
- "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'SUCC " &
- "(IDENT_CHAR (CHARACTER'BASE'LAST))" );
- END;
-
- RESULT;
-
-END C35505F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507a.ada b/gcc/testsuite/ada/acats/tests/c3/c35507a.ada
deleted file mode 100644
index 0a67765..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507a.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- C35507A.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS
--- WHEN THE PREFIX IS A CHARACTER TYPE.
-
--- RJW 5/29/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507A IS
-
-BEGIN
-
- TEST( "C35507A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX " &
- "IS A CHARACTER TYPE" );
-
- DECLARE
- TYPE CHAR1 IS (A, 'A');
-
- SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z';
-
- SUBTYPE NOCHAR IS CHARACTER RANGE 'Z' .. 'A';
-
- TYPE NEWCHAR IS NEW CHARACTER
- RANGE 'A' .. 'Z';
-
- BEGIN
- IF CHAR1'WIDTH /= 3 THEN
- FAILED( "INCORRECT WIDTH FOR CHAR1" );
- END IF;
-
- IF CHAR2'WIDTH /= 3 THEN
- FAILED( "INCORRECT WIDTH FOR CHAR2" );
- END IF;
-
- IF NEWCHAR'WIDTH /= 3 THEN
- FAILED( "INCORRECT WIDTH FOR NEWCHAR" );
- END IF;
-
- IF NOCHAR'WIDTH /= 0 THEN
- FAILED( "INCORRECT WIDTH FOR NOCHAR" );
- END IF;
- END;
-
- DECLARE
- SUBTYPE NONGRAPH IS CHARACTER
- RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31);
-
- MAX : INTEGER := 0;
-
- BEGIN
- FOR CH IN NONGRAPH
- LOOP
- IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN
- MAX := CHARACTER'IMAGE (CH)'LENGTH;
- END IF;
- END LOOP;
-
- IF NONGRAPH'WIDTH /= MAX THEN
- FAILED ( "INCORRECT WIDTH FOR NONGRAPH" );
- END IF;
- END;
-
- RESULT;
-END C35507A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507b.ada b/gcc/testsuite/ada/acats/tests/c3/c35507b.ada
deleted file mode 100644
index b50c4c0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507b.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C35507B.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS
--- WHEN THE PREFIX IS FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS
--- A CHARACTER TYPE.
-
--- RJW 5/29/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507B IS
-
- GENERIC
- TYPE CH IS (<>);
- PROCEDURE P ( STR : STRING; W : INTEGER );
-
- PROCEDURE P ( STR : STRING; W : INTEGER ) IS
-
- SUBTYPE NOCHAR IS CH RANGE CH'VAL (1) .. CH'VAL(0);
- BEGIN
- IF CH'WIDTH /= W THEN
- FAILED( "INCORRECT WIDTH FOR " & STR );
- END IF;
-
- IF NOCHAR'WIDTH /= 0 THEN
- FAILED( "INCORRECT WIDTH FOR NOCHAR WITH " & STR );
- END IF;
- END P;
-
-
-BEGIN
-
- TEST( "C35507B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX " &
- "IS A FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "PARAMETER IS A CHARACTER TYPE" );
-
- DECLARE
- TYPE CHAR1 IS (A, 'A');
-
- SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z';
-
- TYPE NEWCHAR IS NEW CHARACTER
- RANGE 'A' .. 'Z';
-
- PROCEDURE P1 IS NEW P (CHAR1);
- PROCEDURE P2 IS NEW P (CHAR2);
- PROCEDURE P3 IS NEW P (NEWCHAR);
- BEGIN
- P1 ("CHAR1", 3);
- P2 ("CHAR2", 3);
- P3 ("NEWCHAR", 3);
- END;
-
- DECLARE
- SUBTYPE NONGRAPH IS CHARACTER
- RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31);
-
- MAX : INTEGER := 0;
-
- PROCEDURE PN IS NEW P (NONGRAPH);
- BEGIN
- FOR CH IN NONGRAPH
- LOOP
- IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN
- MAX := CHARACTER'IMAGE (CH)'LENGTH;
- END IF;
- END LOOP;
-
- PN ("NONGRAPH", MAX);
- END;
-
- RESULT;
-END C35507B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507c.ada b/gcc/testsuite/ada/acats/tests/c3/c35507c.ada
deleted file mode 100644
index 386e5a3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507c.ada
+++ /dev/null
@@ -1,360 +0,0 @@
--- C35507C.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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE.
--- SUBTESTS ARE:
--- (A). TESTS FOR IMAGE.
--- (B). TESTS FOR VALUE.
-
--- HISTORY:
--- RJW 05/29/86 CREATED ORIGINAL TEST.
--- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT.
--- CORRECTED ERROR MESSAGES AND ADDED CALLS TO
--- IDENT_STR.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507C IS
-
- TYPE CHAR IS ('A', 'a');
-
- TYPE NEWCHAR IS NEW CHAR;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
- END IDENT;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
- END IDENT;
-
- PROCEDURE CHECK_BOUND (STR1, STR2 : STRING) IS
- BEGIN
- IF STR1'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 &
- "'IMAGE ('" & STR1 & "')" );
- END IF;
- END CHECK_BOUND;
-
-BEGIN
-
- TEST( "C35507C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE" );
-
- BEGIN -- (A).
- IF CHAR'IMAGE ('A') /= "'A'" THEN
- FAILED ( "INCORRECT IMAGE FOR CHAR'('A')" );
- END IF;
-
- CHECK_BOUND (CHAR'IMAGE ('A'), "CHAR");
-
- IF CHAR'IMAGE ('a') /= "'a'" THEN
- FAILED ( "INCORRECT IMAGE FOR CHAR'('a')" );
- END IF;
-
- CHECK_BOUND (CHAR'IMAGE ('a'), "CHAR");
-
- IF NEWCHAR'IMAGE ('A') /= "'A'" THEN
- FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('A')" );
- END IF;
-
- CHECK_BOUND (NEWCHAR'IMAGE ('A'), "NEWCHAR");
-
- IF NEWCHAR'IMAGE ('a') /= "'a'" THEN
- FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('a')" );
- END IF;
-
- CHECK_BOUND (NEWCHAR'IMAGE ('a'), "NEWCHAR");
-
- IF CHAR'IMAGE (IDENT ('A')) /= "'A'" THEN
- FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('A'))" );
- END IF;
-
- CHECK_BOUND (CHAR'IMAGE (IDENT ('A')), "IDENT OF CHAR");
-
- IF CHAR'IMAGE (IDENT ('a')) /= "'a'" THEN
- FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('a'))" );
- END IF;
-
- CHECK_BOUND (CHAR'IMAGE (IDENT ('a')), "IDENT OF CHAR");
-
- IF NEWCHAR'IMAGE (IDENT ('A')) /= "'A'" THEN
- FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('A'))" );
- END IF;
-
- CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('A')), "IDENT OF NEWCHAR");
-
- IF NEWCHAR'IMAGE (IDENT ('a')) /= "'a'" THEN
- FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('a'))" );
- END IF;
-
- CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('a')), "IDENT OF NEWCHAR");
-
- FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP
- IF CHARACTER'IMAGE (CH) /= ("'" & CH) & "'" THEN
- FAILED ( "INCORRECT IMAGE FOR CHARACTER'(" &
- CH & ")" );
- END IF;
-
- CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER");
-
- END LOOP;
-
- FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
- CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER");
- END LOOP;
-
- CHECK_BOUND (CHARACTER'IMAGE (CHARACTER'VAL (127)),
- "CHARACTER");
-
- END;
-
- ---------------------------------------------------------------
-
- DECLARE -- (B).
-
- SUBTYPE SUBCHAR IS CHARACTER
- RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127);
- BEGIN
- FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP
- IF SUBCHAR'VALUE (("'" & CH) & "'") /= CH THEN
- FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & CH );
- END IF;
- END LOOP;
-
- FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
- IF SUBCHAR'VALUE (CHARACTER'IMAGE (CH)) /= CH THEN
- FAILED ( "INCORRECT SUBCHAR'VALUE FOR " &
- CHARACTER'IMAGE (CH) );
- END IF;
- END LOOP;
-
- IF SUBCHAR'VALUE (CHARACTER'IMAGE (CHARACTER'VAL (127))) /=
- CHARACTER'VAL (127) THEN
- FAILED ( "INCORRECT SUBCHAR'VALUE FOR " &
- "CHARACTER'VAL (127)" );
- END IF;
- END;
-
- BEGIN
- IF CHAR'VALUE ("'A'") /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'(""'A'"")" );
- END IF;
-
- IF CHAR'VALUE ("'a'") /= 'a' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'(""'a'"")" );
- END IF;
-
- IF NEWCHAR'VALUE ("'A'") /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'A'"")" );
- END IF;
-
- IF NEWCHAR'VALUE ("'a'") /= 'a' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'a'"")" );
- END IF;
- END;
-
- BEGIN
- IF CHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" &
- "(""'A'""))" );
- END IF;
-
- IF CHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" &
- "(""'a'""))" );
- END IF;
-
- IF NEWCHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" &
- "(""'A'""))" );
- END IF;
-
- IF NEWCHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" &
- "(""'a'""))" );
- END IF;
- END;
-
- BEGIN
- IF CHAR'VALUE (IDENT_STR ("'B'")) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHAR'VALUE (IDENT_STR (""'B'""))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_CHAR (ASCII.HT) & "'A'") = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE " &
- "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE " &
- "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE " &
- "(IDENT_CHAR (ASCII.HT) & ""'A'"")" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE ("'B'" & IDENT_CHAR (ASCII.HT)) = 'B' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (""'B'"" & " &
- "IDENT_CHAR (ASCII.HT)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (""'B'"" & " &
- "IDENT_CHAR (ASCII.HT)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE (""'B'"" & " &
- "IDENT_CHAR (ASCII.HT)) " );
- END;
-
- BEGIN
- IF CHARACTER'VALUE ("'C'" & IDENT_CHAR (ASCII.BEL)) = 'C'
- THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (""'C'"" & " &
- "IDENT_CHAR (ASCII.BEL)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (""'C'"" & " &
- "IDENT_CHAR (ASCII.BEL)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE (""'C'"" & " &
- "IDENT_CHAR (ASCII.BEL))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_STR ("'")) = ''' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE (IDENT_STR (""'""))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_STR ("''")) = ''' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""''"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""''"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE (IDENT_STR (""''""))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_STR ("'A")) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'A"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'A"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE IDENT_STR (""'A""))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_STR ("A'")) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""A'"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""A'"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE (IDENT_STR (""A'""))" );
- END;
-
- BEGIN
- IF CHARACTER'VALUE (IDENT_STR ("'AB'")) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VALUE IDENT_STR (""'AB'""))" );
- END;
-
- RESULT;
-END C35507C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507e.ada b/gcc/testsuite/ada/acats/tests/c3/c35507e.ada
deleted file mode 100644
index 9397990..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507e.ada
+++ /dev/null
@@ -1,194 +0,0 @@
--- C35507E.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 ATTRIBUTES 'IMAGE' AND 'VALUE YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE.
--- SUBTESTS ARE:
--- (A). TESTS FOR IMAGE.
--- (B). TESTS FOR VALUE.
-
--- HISTORY:
--- RJW 05/29/86 CREATED ORIGINAL TEST.
--- VCL 10/23/87 MODIFIED THIS HEADER, CHANGED THE CALLS TO
--- PROCEDURE 'PCH', IN THE SECOND PART OF SUBTEST B,
--- TO INCLUDE ANOTHER CALL TO PROCEDURE 'PCHAR' AND
--- CALLS TO PROCEDURE 'PNCHAR'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35507E IS
-
- TYPE CHAR IS ('A', 'a');
-
- TYPE NEWCHAR IS NEW CHAR;
-
- PROCEDURE CHECK_LOWER_BOUND (STR1, STR2 : STRING) IS
- BEGIN
- IF STR1'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & "'(" &
- STR1 & ")" );
- END IF;
- END CHECK_LOWER_BOUND;
-
-BEGIN
-
- TEST( "C35507E" , "THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE" );
-
- DECLARE -- (A).
- GENERIC
- TYPE CHTYPE IS (<>);
- STR1 : STRING;
- PROCEDURE P (CH : CHTYPE; STR2 : STRING);
-
- PROCEDURE P (CH : CHTYPE; STR2 : STRING) IS
- SUBTYPE SUBCH IS CHTYPE;
- BEGIN
- IF SUBCH'IMAGE (CH) /= STR2 THEN
- FAILED ( "INCORRECT IMAGE FOR " & STR1 & "'(" &
- STR2 & ")" );
- END IF;
-
- CHECK_LOWER_BOUND (SUBCH'IMAGE (CH), STR1);
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR");
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER");
-
- BEGIN
- PCHAR ('A', "'A'");
- PCHAR ('a', "'a'");
- PNCHAR ('A', "'A'");
- PNCHAR ('a', "'a'");
-
- FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP
- PCH (CH, ("'" & CH) & "'" );
- END LOOP;
- END;
-
- DECLARE
-
- GENERIC
- TYPE CHTYPE IS (<>);
- PROCEDURE P (CH : CHTYPE; STR : STRING);
-
- PROCEDURE P (CH : CHTYPE; STR : STRING) IS
- SUBTYPE SUBCH IS CHTYPE;
- BEGIN
- CHECK_LOWER_BOUND (CHTYPE'IMAGE (CH), "CHARACTER");
- END P;
-
- PROCEDURE PN IS NEW P (CHARACTER);
-
- BEGIN
-
- FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
- PN (CH, CHARACTER'IMAGE (CH));
- END LOOP;
-
- PN (ASCII.DEL, CHARACTER'IMAGE (ASCII.DEL));
- END;
-
- ---------------------------------------------------------------
-
- DECLARE -- (B).
-
- GENERIC
- TYPE CHTYPE IS (<>);
- STR1 : STRING;
- PROCEDURE P (STR2 : STRING; CH : CHTYPE);
-
- PROCEDURE P (STR2 : STRING; CH : CHTYPE) IS
- SUBTYPE SUBCH IS CHTYPE;
- BEGIN
- IF SUBCH'VALUE (STR2) /= CH THEN
- FAILED ( "INCORRECT " & STR1 & "'VALUE FOR " &
- STR2 );
- END IF;
- END P;
-
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER");
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR");
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");
-
- BEGIN
- FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP
- PCH (CHARACTER'IMAGE (CH), CH );
- END LOOP;
-
- PCH (CHARACTER'IMAGE (CHARACTER'VAL (127)),
- CHARACTER'VAL (127));
-
- PCHAR ("'A'", 'A');
- PCHAR ("'a'", 'a' );
- PNCHAR ("'A'", 'A');
- PNCHAR ("'a'", 'a');
- END;
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR1 : STRING;
- PROCEDURE P (STR2 : STRING);
-
- PROCEDURE P (STR2 : STRING) IS
- SUBTYPE SUBCH IS CHTYPE;
- BEGIN
- IF SUBCH'VALUE (STR2) = SUBCH'VAL (0) THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR1 & "'VALUE (" & STR2 & ") - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR1 & "'VALUE (" & STR2 & ") - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR " & STR1 & "'VALUE (" & STR2 & ")" );
- END P;
-
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER");
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR");
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR");
-
- BEGIN
- PCHAR ("'B'");
- PCH (ASCII.HT & "'A'");
- PCH ("'B'" & ASCII.HT);
- PCH ("'C'" & ASCII.BEL);
- PCH ("'");
- PNCHAR ("''");
- PCHAR ("'A");
- PNCHAR ("A'");
- PCH ("'AB'");
- END;
-
- RESULT;
-END C35507E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507g.ada b/gcc/testsuite/ada/acats/tests/c3/c35507g.ada
deleted file mode 100644
index a1d8ece..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507g.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C35507G.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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST.
--- JET 08/13/87 REMOVED TESTS INTENDED FOR C35505F.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507G IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
- END;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
- END;
-
-BEGIN
-
- TEST( "C35507G" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " &
- "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE" );
-
- BEGIN
- IF CHAR'SUCC ('A') /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" );
- END IF;
-
- IF CHAR'PRED (IDENT (B)) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" );
- END IF;
- END;
-
- BEGIN
- IF NEWCHAR'SUCC (IDENT ('A')) /= B THEN
- FAILED ( "INCORRECT VALUE FOR " &
- "IDENT (NEWCHAR'SUCC('A'))" );
- END IF;
-
- IF NEWCHAR'PRED (B) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" );
- END IF;
- END;
-
- FOR CH IN CHARACTER'VAL (1) .. CHARACTER'VAL (127) LOOP
- IF CHARACTER'PRED (CH) /=
- CHARACTER'VAL (CHARACTER'POS (CH) - 1) THEN
- FAILED ( "INCORRECT VALUE FOR CHARACTER'PRED OF " &
- CHARACTER'IMAGE (CH) );
- END IF;
- END LOOP;
-
- FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (126) LOOP
- IF CHARACTER'SUCC (CH) /=
- CHARACTER'VAL (CHARACTER'POS (CH) + 1) THEN
- FAILED ( "INCORRECT VALUE FOR CHARACTER'SUCC OF " &
- CHARACTER'IMAGE (CH) );
- END IF;
- END LOOP;
-
- RESULT;
-
-END C35507G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507h.ada b/gcc/testsuite/ada/acats/tests/c3/c35507h.ada
deleted file mode 100644
index 053b20c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507h.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- C35507H.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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE.
-
--- RJW 6/03/86
--- DWC 7/01/87 -- ADDED THIRD VALUE TO CHAR TYPE.
- -- REMOVED SECTION OF CODE AND PLACED INTO
- -- C35505E.ADA.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507H IS
-
- TYPE CHAR IS ('A', B, C);
-
- TYPE NEWCHAR IS NEW CHAR;
-
-BEGIN
-
- TEST( "C35507H" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " &
- "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE" );
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR : STRING;
- I1, I2 : INTEGER;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SUBCH IS CHTYPE
- RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2);
-
- BEGIN
- FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP
- IF SUBCH'PRED (CH) /=
- SUBCH'VAL (SUBCH'POS (CH) - 1) THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'PRED OF " & SUBCH'IMAGE (CH) );
- END IF;
- END LOOP;
-
- FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP
- IF SUBCH'SUCC (CH) /=
- SUBCH'VAL (SUBCH'POS (CH) + 1) THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'SUCC OF " & SUBCH'IMAGE (CH) );
- END IF;
- END LOOP;
-
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1);
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1);
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 0, 127);
- BEGIN
- PCHAR;
- PNCHAR;
- PCH;
- END;
-
- RESULT;
-END C35507H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507i.ada b/gcc/testsuite/ada/acats/tests/c3/c35507i.ada
deleted file mode 100644
index e2318d7..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507i.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C35507I.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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION
--- REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- DTN 11/26/91 DELETED CONSTRAINT_ERROR FOR ATTRIBUTES PRED AND
--- SUCC SUBTESTS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507I IS
-
- TYPE CHAR IS ('A', B);
- FOR CHAR USE ('A' => 2, B => 5);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
- END;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
- END;
-
-BEGIN
-
- TEST( "C35507I" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " &
- "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE WITH AN " &
- "ENUMERATION REPRESENTATION CLAUSE" );
-
- BEGIN
- IF CHAR'SUCC ('A') /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" );
- END IF;
-
- IF CHAR'PRED (IDENT (B)) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" );
- END IF;
- END;
-
- BEGIN
- IF IDENT (NEWCHAR'SUCC ('A')) /= B THEN
- FAILED ( "INCORRECT VALUE FOR " &
- "IDENT (NEWCHAR'SUCC('A'))" );
- END IF;
-
- IF NEWCHAR'PRED (B) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" );
- END IF;
- END;
-
- RESULT;
-END C35507I;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507j.ada b/gcc/testsuite/ada/acats/tests/c3/c35507j.ada
deleted file mode 100644
index 9e9e898..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507j.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- C35507J.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 ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION
--- CLAUSE.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST.
--- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507J IS
-
- TYPE CHAR IS ('A', B);
- FOR CHAR USE ('A' => 4, B => 5);
-
- TYPE NEWCHAR IS NEW CHAR;
-
-BEGIN
-
- TEST( "C35507J" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " &
- "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE WITH " &
- "WITH AN ENUMERATION REPRESENTATION CLAUSE" );
-
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR : STRING;
- I1, I2 : INTEGER;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SUBCH IS CHTYPE
- RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2);
- BEGIN
- FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP
- IF SUBCH'PRED (CH) /=
- SUBCH'VAL (SUBCH'POS (CH) - 1) THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'PRED OF " & SUBCH'IMAGE (CH) );
- END IF;
- END LOOP;
-
- FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP
- IF SUBCH'SUCC (CH) /=
- SUBCH'VAL (SUBCH'POS (CH) + 1) THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'SUCC OF " & SUBCH'IMAGE (CH) );
- END IF;
- END LOOP;
-
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1);
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1);
-
- BEGIN
- PCHAR;
- PNCHAR;
-
- END;
-
- RESULT;
-END C35507J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507k.ada b/gcc/testsuite/ada/acats/tests/c3/c35507k.ada
deleted file mode 100644
index b263992..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507k.ada
+++ /dev/null
@@ -1,224 +0,0 @@
--- C35507K.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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE.
-
--- HISTORY:
--- RJW 06/03/86
--- JLH 07/28/87 MODIFIED FUNCTION IDENT.
--- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507K IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- SUBTYPE SCHAR IS CHARACTER
- RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127);
-
- BLANK : CONSTANT CHARACTER := ' ';
-
- POSITION : INTEGER;
-
- NONGRAPH : ARRAY (0 .. 31) OF CHARACTER :=
- (ASCII.NUL, ASCII.SOH, ASCII.STX, ASCII.ETX,
- ASCII.EOT, ASCII.ENQ, ASCII.ACK, ASCII.BEL,
- ASCII.BS, ASCII.HT, ASCII.LF, ASCII.VT,
- ASCII.FF, ASCII.CR, ASCII.SO, ASCII.SI,
- ASCII.DLE, ASCII.DC1, ASCII.DC2, ASCII.DC3,
- ASCII.DC4, ASCII.NAK, ASCII.SYN, ASCII.ETB,
- ASCII.CAN, ASCII.EM, ASCII.SUB, ASCII.ESC,
- ASCII.FS, ASCII.GS, ASCII.RS, ASCII.US);
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- IF EQUAL (CHAR'POS (CH), CHAR'POS (CH)) THEN
- RETURN CH;
- END IF;
- RETURN CHAR'FIRST;
- END IDENT;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- IF EQUAL (NEWCHAR'POS (CH), NEWCHAR'POS (CH)) THEN
- RETURN CH;
- END IF;
- RETURN NEWCHAR'FIRST;
- END IDENT;
-
-BEGIN
-
- TEST( "C35507K" , "CHECK THAT THE ATTRIBUTES 'POS' AND " &
- "'VAL' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE" );
-
- BEGIN
- IF CHAR'POS ('A') /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') - 1" );
- END IF;
-
- IF CHAR'POS (B) /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'POS(B) - 1" );
- END IF;
-
- IF CHAR'VAL (0) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" );
- END IF;
-
- IF CHAR'VAL (1) /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" );
- END IF;
-
- IF CHAR'POS (IDENT ('A')) /= 0 THEN
- FAILED ( "INCORRECT VALUE " &
- "FOR CHAR'POS (IDENT ('A')) - 2" );
- END IF;
-
- IF CHAR'POS (IDENT (B)) /= 1 THEN
- FAILED ( "INCORRECT VALUE " &
- "FOR CHAR'POS (IDENT (B)) - 2" );
- END IF;
-
- END;
-
- BEGIN
- IF NEWCHAR'POS ('A') /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" );
- END IF;
-
- IF NEWCHAR'POS (B) /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) - 1" );
- END IF;
-
- IF NEWCHAR'VAL (0) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) - 1" );
- END IF;
-
- IF NEWCHAR'VAL (1) /= B THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" );
- END IF;
-
- IF NEWCHAR'VAL (IDENT_INT (1)) /= B THEN
- FAILED ( "INCORRECT VALUE " &
- "FOR NEWCHAR'POS (IDENT (B)) - 2" );
- END IF;
-
- IF (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN
- FAILED ( "INCORRECT VALUE " &
- "FOR IDENT (NEWCHAR'VAL (0)) - 2" );
- END IF;
-
- END;
-
- BEGIN
- IF CHAR'VAL (IDENT_INT (2)) = B THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'VAL (IDENT_INT (2)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHAR'VAL (IDENT_INT (2)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHAR'VAL (IDENT_INT (2))" );
- END;
-
- BEGIN
- IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1))" );
- END;
-
- POSITION := 0;
-
- FOR CH IN CHARACTER LOOP
- IF SCHAR'POS (CH) /= POSITION THEN
- FAILED ( "INCORRECT VALUE FOR SCHAR'POS OF " &
- CHARACTER'IMAGE (CH) );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- FOR POSITION IN 0 .. 31 LOOP
- IF CHARACTER'VAL (POSITION) /= NONGRAPH (POSITION) THEN
- FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " &
- "NONGRAPHIC CHARACTER IN POSITION - " &
- INTEGER'IMAGE (POSITION) );
- END IF;
- END LOOP;
-
- POSITION := 32;
-
- FOR CH IN BLANK .. ASCII.TILDE LOOP
- IF SCHAR'VAL (POSITION) /= CH THEN
- FAILED ( "INCORRECT VALUE FOR SCHAR'VAL OF " &
- "GRAPHIC CHARACTER IN POSITION - " &
- INTEGER'IMAGE (POSITION) );
- END IF;
-
- POSITION := POSITION + 1;
- END LOOP;
-
- IF CHARACTER'VAL (127) /= ASCII.DEL THEN
- FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " &
- "NONGRAPHIC CHARACTER IN POSITION - 127" );
- END IF;
-
- BEGIN
- IF CHARACTER'VAL (IDENT_INT (-1)) = ASCII.NUL THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR CHARACTER'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR CHARACTER'VAL (IDENT_INT (-1))" );
- END;
-
- RESULT;
-END C35507K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507l.ada b/gcc/testsuite/ada/acats/tests/c3/c35507l.ada
deleted file mode 100644
index a259c74..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507l.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C35507L.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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE.
-
--- RJW 6/03/86
--- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507L IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
-BEGIN
-
- TEST( "C35507L" , "CHECK THAT THE ATTRIBUTES 'POS' AND " &
- "'VAL' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE" );
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR : STRING;
- I1 : INTEGER;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SUBCH IS CHTYPE;
- CH : CHTYPE;
- POSITION : INTEGER;
- BEGIN
- POSITION := 0;
- FOR CH IN CHTYPE LOOP
- IF SUBCH'POS (CH) /= POSITION THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'POS OF " & CHTYPE'IMAGE (CH) );
- END IF;
-
- IF SUBCH'VAL (POSITION) /= CH THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'VAL OF CHARACTER IN POSITION - " &
- INTEGER'IMAGE (POSITION) );
- END IF;
- POSITION := POSITION + 1;
- END LOOP;
-
- BEGIN
- IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1)" );
- END;
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1);
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1);
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127);
- BEGIN
- PCHAR;
- PNCHAR;
- PCH;
- END;
-
- RESULT;
-END C35507L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507m.ada b/gcc/testsuite/ada/acats/tests/c3/c35507m.ada
deleted file mode 100644
index e76178c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507m.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- C35507M.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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION
--- REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST
--- JLH 07/28/87 MODIFIED FUNCTION IDENT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507M IS
-
- TYPE CHAR IS ('A', B);
- FOR CHAR USE ('A' => 4, B => 5);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN CH;
- ELSE
- RETURN 'A';
- END IF;
- END IDENT;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN CH;
- ELSE
- RETURN 'A';
- END IF;
- END IDENT;
-
-BEGIN
-
- TEST( "C35507M" , "CHECK THAT THE ATTRIBUTES 'POS' AND " &
- "'VAL' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE WITH AN " &
- "ENUMERATION REPESENTATION CLAUSE" );
-
- BEGIN
- IF CHAR'POS ('A') /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'POS('A')" );
- END IF;
-
- IF CHAR'POS (B) /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'POS(B)" );
- END IF;
-
- IF CHAR'VAL (0) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" );
- END IF;
-
- IF CHAR'VAL (1) /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" );
- END IF;
- END;
-
- BEGIN
- IF NEWCHAR'POS ('A') /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" );
- END IF;
-
- IF NEWCHAR'POS (B) /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B)" );
- END IF;
-
- IF NEWCHAR'VAL (0) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0)" );
- END IF;
-
- IF NEWCHAR'VAL (1) /= B THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" );
- END IF;
- END;
-
- BEGIN
- IF CHAR'POS (IDENT ('A')) /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') WITH " &
- "IDENT" );
- END IF;
-
- IF NEWCHAR'POS (IDENT (B)) /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) WITH " &
- "IDENT" );
- END IF;
-
- IF IDENT (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) WITH " &
- "IDENT" );
- END IF;
-
- IF IDENT (CHAR'VAL (IDENT_INT(1))) /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1) WITH IDENT" );
- END IF;
- END;
-
- BEGIN
- IF CHAR'VAL (IDENT_INT(2)) = B THEN
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHAR'VAL (IDENT_INT(2)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "CHAR'VAL (IDENT_INT(2)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "CHAR'VAL (IDENT_INT(2))" );
- END;
-
- BEGIN
- IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR NEWCHAR'VAL (IDENT_INT (-1))" );
- END;
-
- RESULT;
-END C35507M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507n.ada b/gcc/testsuite/ada/acats/tests/c3/c35507n.ada
deleted file mode 100644
index 1e5e48a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507n.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- C35507N.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 ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION
--- CLAUSE.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST.
--- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507N IS
-
- TYPE CHAR IS ('A', B);
- FOR CHAR USE ('A' => 4, B => 5);
-
- TYPE NEWCHAR IS NEW CHAR;
-
-BEGIN
-
- TEST( "C35507N" , "CHECK THAT THE ATTRIBUTES 'POS' AND " &
- "'VAL' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE " &
- "WITH AN ENUMERATION REPRESENTATION CLAUSE" );
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR : STRING;
- I1 : INTEGER;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE SUBCH IS CHTYPE;
- CH : CHTYPE;
- POSITION : INTEGER;
- BEGIN
- POSITION := 0;
- FOR CH IN CHTYPE LOOP
- IF SUBCH'POS (CH) /= POSITION THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'POS OF " & CHTYPE'IMAGE (CH) );
- END IF;
-
- IF SUBCH'VAL (POSITION) /= CH THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'VAL OF CHARACTER IN POSITION - " &
- INTEGER'IMAGE (POSITION) );
- END IF;
- POSITION := POSITION + 1;
- END LOOP;
-
- BEGIN
- IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1) - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1) - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "FOR " & STR & "'VAL (-1)" );
- END;
- END P;
-
- PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1);
- PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1);
- PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127);
- BEGIN
- PCHAR;
- PNCHAR;
- PCH;
- END;
-
- RESULT;
-END C35507N;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507o.ada b/gcc/testsuite/ada/acats/tests/c3/c35507o.ada
deleted file mode 100644
index 723a5ea..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507o.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C35507O.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 ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE.
-
--- RJW 6/03/86
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
--- REMOVED PART OF TEST INVALID FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507O IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- SPACE : CONSTANT CHARACTER := CHARACTER'(' ');
-
- SUBTYPE NOCHAR IS CHARACTER RANGE CHARACTER'('Z') .. CHARACTER'('A');
- SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE;
- SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US;
-
- FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
- END IDENT;
-
- FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
- BEGIN
- RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
- END IDENT;
-
-BEGIN
-
- TEST( "C35507O" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " &
- "'LAST' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A CHARACTER TYPE" );
-
- BEGIN
- IF IDENT (CHAR'FIRST) /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'FIRST" );
- END IF;
-
- IF CHAR'LAST /= B THEN
- FAILED ( "INCORRECT VALUE FOR CHAR'LAST" );
- END IF;
- END;
-
- BEGIN
- IF NEWCHAR'FIRST /= 'A' THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'FIRST" );
- END IF;
-
- IF NEWCHAR'LAST /= IDENT (B) THEN
- FAILED ( "INCORRECT VALUE FOR NEWCHAR'LAST" );
- END IF;
- END;
-
- BEGIN
- IF NOCHAR'FIRST /= CHARACTER'('Z') THEN
- FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST" );
- END IF;
-
- IF NOCHAR'LAST /= CHARACTER'('A') THEN
- FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST" );
- END IF;
- END;
-
- BEGIN
- IF CHARACTER'FIRST /= ASCII.NUL THEN
- FAILED ( "INCORRECT VALUE FOR CHARACTER'FIRST" );
- END IF;
-
- END;
-
- BEGIN
- IF NONGRAPHIC'FIRST /= IDENT_CHAR (ASCII.NUL) THEN
- FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'FIRST" );
- END IF;
-
- IF NONGRAPHIC'LAST /= ASCII.US THEN
- FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'LAST" );
- END IF;
- END;
-
- BEGIN
- IF GRAPHIC'FIRST /= SPACE THEN
- FAILED ( "INCORRECT VALUE FOR GRAPHIC'FIRST" );
- END IF;
-
- IF GRAPHIC'LAST /= ASCII.TILDE THEN
- FAILED ( "INCORRECT VALUE FOR GRAPHIC'LAST" );
- END IF;
- END;
-
- RESULT;
-END C35507O;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35507p.ada b/gcc/testsuite/ada/acats/tests/c3/c35507p.ada
deleted file mode 100644
index 85c8c27..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35507p.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C35507P.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 ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A CHARACTER TYPE.
-
--- RJW 6/03/86
--- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35507P IS
-
- TYPE CHAR IS ('A', B);
-
- TYPE NEWCHAR IS NEW CHAR;
-
- SPACE : CONSTANT CHARACTER := ' ';
-
- SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE;
- SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US;
-BEGIN
-
- TEST( "C35507P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " &
- "'LAST' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " &
- "ACTUAL PARAMETER IS A CHARACTER TYPE" );
-
- DECLARE
- GENERIC
- TYPE CHTYPE IS (<>);
- STR : STRING;
- F, L : CHTYPE;
- PROCEDURE P;
-
- PROCEDURE P IS
- SUBTYPE NOCHAR IS CHTYPE RANGE L .. F;
- BEGIN
- IF CHTYPE'FIRST /= F THEN
- FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" );
- END IF;
-
- IF CHTYPE'LAST /= L THEN
- FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" );
- END IF;
-
- IF NOCHAR'FIRST /= L THEN
- FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST AS A " &
- "SUBTYPE OF " & STR );
- END IF;
-
- IF NOCHAR'LAST /= F THEN
- FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST AS A " &
- "SUBTYPE OF " & STR );
- END IF;
- END P;
-
- PROCEDURE P1 IS NEW P (CHAR, "CHAR", 'A', B);
- PROCEDURE P2 IS NEW P (NEWCHAR, "NEWCHAR", 'A', B);
- PROCEDURE P3 IS NEW P
- (GRAPHIC, "GRAPHIC", SPACE, ASCII.TILDE);
- PROCEDURE P4 IS NEW P
- (NONGRAPHIC, "NONGRAPHIC", ASCII.NUL, ASCII.US);
- BEGIN
- P1;
- P2;
- P3;
- P4;
- END;
-
- RESULT;
-END C35507P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508a.ada b/gcc/testsuite/ada/acats/tests/c3/c35508a.ada
deleted file mode 100644
index 5e4f72da..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508a.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C35508A.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN
--- THE PREFIX IS A BOOLEAN TYPE.
-
--- RJW 3/14/86 COMPLETELY REVISED.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508A IS
-
-BEGIN
-
- TEST( "C35508A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX IS A " &
- "BOOLEAN TYPE" );
-
- DECLARE
- TYPE NEWBOOL IS NEW BOOLEAN;
- SUBTYPE FRANGE IS BOOLEAN
- RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE);
- SUBTYPE TRANGE IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE);
- SUBTYPE NOBOOL IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE);
-
- BEGIN
-
- IF BOOLEAN'WIDTH /= 5 THEN
- FAILED( "INCORRECT WIDTH FOR BOOLEAN" );
- END IF;
-
- IF NEWBOOL'WIDTH /= 5 THEN
- FAILED( "INCORRECT WIDTH FOR NEWBOOL" );
- END IF;
-
- IF FRANGE'WIDTH /= 5 THEN
- FAILED( "INCORRECT WIDTH FOR FRANGE" );
- END IF;
-
- IF TRANGE'WIDTH /= 4 THEN
- FAILED( "INCORRECT WIDTH FOR TRANGE" );
- END IF;
-
- IF NOBOOL'WIDTH /= 0 THEN
- FAILED( "INCORRECT WIDTH FOR NOBOOL" );
- END IF;
-
- END;
-
- RESULT;
-END C35508A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508b.ada b/gcc/testsuite/ada/acats/tests/c3/c35508b.ada
deleted file mode 100644
index b0339fa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508b.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C35508B.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 ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN
--- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL
--- PARAMETER IS A BOOLEAN TYPE.
-
--- RJW 3/19/86 COMPLETELY REVISED.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508B IS
-
-BEGIN
-
- TEST( "C35508B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " &
- "THE CORRECT RESULTS WHEN THE PREFIX IS A " &
- "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "PARAMETER IS A BOOLEAN TYPE" );
-
- DECLARE
- SUBTYPE FRANGE IS BOOLEAN
- RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE);
- SUBTYPE TRANGE IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE);
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE B IS (<>);
- W : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE NOBOOL IS B RANGE
- B'VAL (IDENT_INT(1)) .. B'VAL (IDENT_INT(0));
- BEGIN
- IF B'WIDTH /= W THEN
- FAILED ( "INCORRECT B'WIDTH FOR " & STR );
- END IF;
- IF NOBOOL'WIDTH /= 0 THEN
- FAILED ( "INCORRECT NOBOOL'WIDTH FOR " & STR );
- END IF;
- END P;
-
- PROCEDURE PROC1 IS NEW P (BOOLEAN, 5);
- PROCEDURE PROC2 IS NEW P (FRANGE, 5);
- PROCEDURE PROC3 IS NEW P (TRANGE, 4);
- PROCEDURE PROC4 IS NEW P (NEWBOOL, 5);
-
- BEGIN
- PROC1 ( "BOOLEAN" );
- PROC2 ( "FRANGE" );
- PROC3 ( "TRANGE");
- PROC4 ( "NEWBOOL" );
- END;
-
- RESULT;
-END C35508B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508c.ada b/gcc/testsuite/ada/acats/tests/c3/c35508c.ada
deleted file mode 100644
index 88ca20a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508c.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C35508C.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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A BOOLEAN TYPE.
-
--- SUBTESTS ARE:
--- (A). TESTS FOR IMAGE.
--- (B). TESTS FOR VALUE.
-
--- RJW 3/19/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508C IS
-
- TYPE NEWBOOL IS NEW BOOLEAN;
-
-BEGIN
-
- TEST( "C35508C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A BOOLEAN TYPE" );
--- PART (A).
-
- DECLARE
-
- A5, B5 : INTEGER := IDENT_INT(5);
- C6 : INTEGER := IDENT_INT(6);
- BEGIN
-
- IF BOOLEAN'IMAGE ( A5 = B5 ) /= "TRUE" THEN
- FAILED ( "INCORRECT IMAGE FOR 'A5 = B5'" );
- END IF;
- IF BOOLEAN'IMAGE ( A5 = B5 )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR 'A5 = B5'" );
- END IF;
-
- IF BOOLEAN'IMAGE ( C6 = A5 ) /= "FALSE" THEN
- FAILED ( "INCORRECT IMAGE FOR 'C6 = A5'" );
- END IF;
- IF BOOLEAN'IMAGE ( C6 = A5 )'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR 'C6 = A5'" );
- END IF;
-
- IF BOOLEAN'IMAGE (TRUE) /= "TRUE" THEN
- FAILED ( "INCORRECT IMAGE FOR 'TRUE'" );
- END IF;
- IF BOOLEAN'IMAGE (TRUE)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR 'TRUE'" );
- END IF;
-
- IF NEWBOOL'IMAGE (FALSE) /= "FALSE" THEN
- FAILED ( "INCORRECT IMAGE FOR NEWBOOL'FALSE'" );
- END IF;
- IF NEWBOOL'IMAGE (FALSE)'FIRST /= 1 THEN
- FAILED ( "INCORRECT LOWER BOUND FOR NEWBOOL'FALSE'" );
- END IF;
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- BEGIN
- IF BOOLEAN'VALUE (IDENT_STR("TRUE")) /= TRUE THEN
- FAILED ( "INCORRECT VALUE FOR ""TRUE""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""TRUE""" );
- END;
-
- BEGIN
- IF NEWBOOL'VALUE (IDENT_STR("FALSE")) /= FALSE THEN
- FAILED ( "INCORRECT VALUE FOR ""FALSE""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""FALSE""" );
- END;
-
- BEGIN
- IF BOOLEAN'VALUE ("true") /= TRUE THEN
- FAILED ( "INCORRECT VALUE FOR ""true""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR ""true""" );
- END;
-
- BEGIN
- IF NEWBOOL'VALUE ("false") /= FALSE THEN
- FAILED ( "INCORRECT VALUE FOR ""false""" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE FOR " &
- """false""" );
- END;
-
- BEGIN
- IF BOOLEAN'VALUE (IDENT_STR("TRUE ")) /= TRUE THEN
- FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE - " &
- "TRAILING BLANKS" );
- END;
-
- BEGIN
- IF NEWBOOL'VALUE (" FALSE") /= FALSE THEN
- FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - VALUE - LEADING " &
- "BLANKS" );
- END;
-
- DECLARE
- SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE .. FALSE;
- BEGIN
- IF SUBBOOL'VALUE (IDENT_STR("TRUE")) /= TRUE THEN
- FAILED ( "INCORRECT VALUE - ""TRUE"" AND " &
- "SUBBOOL" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED - SUBBOOL" );
- END;
-
- BEGIN
- IF BOOLEAN'VALUE (IDENT_STR("MAYBE")) = TRUE THEN
- FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - ""MAYBE"" " );
- END;
-
- BEGIN
- IF BOOLEAN'VALUE (IDENT_CHAR(ASCII.HT) & "TRUE") = TRUE THEN
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" );
- END;
-
- BEGIN
- IF NEWBOOL'VALUE ("FALSE" & ASCII.HT) = FALSE THEN
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" );
- END;
-
- RESULT;
-END C35508C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508e.ada b/gcc/testsuite/ada/acats/tests/c3/c35508e.ada
deleted file mode 100644
index 584ccfe..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508e.ada
+++ /dev/null
@@ -1,192 +0,0 @@
--- C35508E.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 ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT
--- RESULTS WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE
--- ACTUAL ARGUMENT IS A BOOLEAN TYPE.
-
--- SUBTESTS ARE:
--- (A). TESTS FOR IMAGE.
--- (B). TESTS FOR VALUE.
-
--- HISTORY:
--- RJW 03/19/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508E IS
-
-BEGIN
-
- TEST( "C35508E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " &
- "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " &
- "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " &
- "WHOSE ACTUAL ARGUMENT IS A BOOLEAN TYPE" );
--- PART (A).
-
- DECLARE
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE P (B : BOOL; STR : STRING );
-
- PROCEDURE P (B : BOOL; STR : STRING) IS
- SUBTYPE SUBBOOL IS BOOL
- RANGE BOOL'VAL (IDENT_INT(0)) ..
- BOOL'VAL (IDENT_INT(0));
- BEGIN
-
- IF BOOL'IMAGE (B) /= STR THEN
- FAILED ( "INCORRECT BOOL'IMAGE OF " & STR );
- END IF;
- IF BOOL'IMAGE (B)'FIRST /= 1 THEN
- FAILED ( "INCORRECT BOOL'FIRST FOR " & STR );
- END IF;
-
- IF SUBBOOL'IMAGE (B) /= STR THEN
- FAILED ( "INCORRECT SUBBOOL'IMAGE OF " & STR );
- END IF;
- IF SUBBOOL'IMAGE (B)'FIRST /= 1 THEN
- FAILED ( "INCORRECT SUBBOOL'FIRST FOR " & STR );
- END IF;
- END P;
-
- PROCEDURE NP1 IS NEW P ( BOOLEAN );
- PROCEDURE NP2 IS NEW P ( NEWBOOL );
- BEGIN
- NP1 ( TRUE, "TRUE" );
- NP2 ( FALSE, "FALSE" );
-
- END;
-
------------------------------------------------------------------------
-
--- PART (B).
-
- DECLARE
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE P (STR : STRING; B : BOOL );
-
- PROCEDURE P (STR : STRING; B : BOOL) IS
- SUBTYPE SUBBOOL IS BOOL
- RANGE BOOL'VAL (IDENT_INT(0)) ..
- BOOL'VAL (IDENT_INT(0));
-
- BEGIN
- BEGIN
- IF BOOL'VALUE (STR) /= B THEN
- FAILED ( "INCORRECT BOOL'VALUE OF """ &
- STR & """" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BOOL'VALUE OF """ &
- STR & """" );
- END;
- BEGIN
- IF SUBBOOL'VALUE (STR) /= B THEN
- FAILED ( "INCORRECT SUBBOOL'VALUE OF """ &
- STR & """" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED SUBBOOL'VALUE " &
- "OF """ & STR & """" );
- END;
- END P;
-
- PROCEDURE NP1 IS NEW P ( BOOLEAN );
- PROCEDURE NP2 IS NEW P ( NEWBOOL );
-
- BEGIN
- NP1 ( "TRUE", TRUE );
- NP2 ( "FALSE", FALSE );
- NP2 ( "true", TRUE );
- NP1 ( "false", FALSE );
- NP1 ( " TRUE", TRUE );
- NP2 ( "FALSE ", FALSE );
- END;
-
- DECLARE
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING);
-
- PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING) IS
- SUBTYPE SUBBOOL IS BOOL
- RANGE BOOL'VAL (IDENT_INT(0)) ..
- BOOL'VAL (IDENT_INT(0));
-
- BEGIN
- BEGIN
- IF BOOL'VALUE (STR1) = B THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "BOOL'VALUE WITH " & STR2 &
- "- EQUAL " );
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "BOOL'VALUE WITH " & STR2 &
- " - NOT EQUAL" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "BOOL'VALUE WITH " & STR2 );
- END;
- BEGIN
- IF SUBBOOL'VALUE (STR1) /= B THEN
- FAILED ( "NO EXCEPTION RAISED - " &
- "SUBBOOL'VALUE WITH " &
- STR2 & " - EQUAL");
- ELSE
- FAILED ( "NO EXCEPTION RAISED - " &
- "SUBBOOL'VALUE WITH " &
- STR2 & " - NOT EQUAL");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - " &
- "SUBBOOL'VALUE WITH " & STR2 );
- END;
- END P;
-
- PROCEDURE NP IS NEW P ( BOOLEAN );
- BEGIN
- NP ( "MAYBE", TRUE, "NON-BOOLEAN VALUE");
- NP ( ASCII.HT & "TRUE", TRUE, "LEADING 'HT'" );
- NP ( "FALSE" & ASCII.HT , FALSE, "TRAILING 'HT'" );
- END;
-
- RESULT;
-END C35508E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508g.ada b/gcc/testsuite/ada/acats/tests/c3/c35508g.ada
deleted file mode 100644
index dd546d2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508g.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C35508G.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A BOOLEAN TYPE.
-
--- HISTORY:
--- RJW 03/19/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508G IS
-
-BEGIN
- TEST ("C35508G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "BOOLEAN TYPE" );
-
- BEGIN
- IF BOOLEAN'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN
- FAILED ( "INCORRECT VALUE FOR PRED OF TRUE" );
- END IF;
- IF BOOLEAN'SUCC (IDENT_BOOL(FALSE)) /= TRUE THEN
- FAILED ( "INCORRECT VALUE FOR SUCC OF FALSE" );
- END IF;
- END;
-
- DECLARE
- TYPE NEWBOOL IS NEW BOOLEAN;
- BEGIN
- IF NEWBOOL'PRED (TRUE) /= FALSE THEN
- FAILED ( "INCORRECT VALUE FOR NEWBOOL'PRED OF TRUE" );
- END IF;
- IF NEWBOOL'SUCC (FALSE) /= TRUE THEN
- FAILED ( "INCORRECT VALUE FOR NEWBOOL'SUCC OF FALSE" );
- END IF;
- END;
-
- DECLARE
-
- SUBTYPE SBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) ..
- IDENT_BOOL(TRUE);
-
- BEGIN
- BEGIN
- IF SBOOL'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN
- FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " &
- "OF TRUE" );
- END IF;
- END;
-
- BEGIN
- IF SBOOL'PRED (IDENT_BOOL(SBOOL'BASE'FIRST)) = TRUE THEN
- FAILED("'PRED('FIRST) WRAPPED AROUNT TO TRUE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "'PRED (SBOOL'BASE'FIRST)" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "'PRED (SBOOL'BASE'FIRST)" );
- END;
-
- BEGIN
- IF SBOOL'SUCC (IDENT_BOOL(SBOOL'BASE'LAST)) = FALSE THEN
- FAILED("'SUCC('LAST) WRAPPED AROUNT TO FALSE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "'SUCC (SBOOL'BASE'LAST)" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "'SUCC (SBOOL'BASE'LAST)" );
- END;
- END;
-
- RESULT;
-END C35508G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508h.ada b/gcc/testsuite/ada/acats/tests/c3/c35508h.ada
deleted file mode 100644
index 2b89a29..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508h.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C35508H.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 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A
--- BOOLEAN TYPE.
-
--- HISTORY:
--- RJW 03/24/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508H IS
-
-BEGIN
- TEST ("C35508H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " &
- "IS A BOOLEAN TYPE" );
-
- DECLARE
-
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE BOOL IS (<>);
- F, T : BOOL;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- SUBTYPE SBOOL IS BOOL RANGE T .. T;
- BEGIN
- BEGIN
- IF BOOL'PRED (T) /= F THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'PRED OF T" );
- END IF;
- IF BOOL'SUCC (F) /= T THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'SUCC OF F" );
- END IF;
- END;
-
- BEGIN
- IF SBOOL'PRED (T) /= F THEN
- FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " &
- "OF T FOR " & STR);
- END IF;
- END;
-
- BEGIN
- IF SBOOL'PRED (SBOOL'BASE'FIRST) = T THEN
- FAILED("'PRED('FIRST) WRAPPED AROUND " &
- "TO TRUE FOR " & STR);
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'PRED (SBOOL'BASE'FIRST)" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'PRED (SBOOL'BASE'FIRST)" );
- END;
-
- BEGIN
- IF SBOOL'SUCC (SBOOL'BASE'LAST) = F THEN
- FAILED("'SUCC('LAST) WRAPPED AROUND TO " &
- "FALSE FOR " & STR);
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR " & STR &
- "'SUCC (SBOOL'BASE'LAST)" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'SUCC (SBOOL'BASE'LAST)" );
- END;
- END P;
-
- PROCEDURE NP1 IS NEW P
- ( BOOL => BOOLEAN, F => FALSE, T => TRUE );
-
- PROCEDURE NP2 IS NEW P
- ( BOOL => NEWBOOL, F => FALSE, T => TRUE );
- BEGIN
- NP1 ("BOOLEAN");
- NP2 ("NEWBOOL");
- END;
-
- RESULT;
-END C35508H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508k.ada b/gcc/testsuite/ada/acats/tests/c3/c35508k.ada
deleted file mode 100644
index 338397a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508k.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C35508K.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A BOOLEAN TYPE.
-
--- RJW 3/19/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508K IS
-
- TYPE NEWBOOL IS NEW BOOLEAN;
-
-BEGIN
- TEST ("C35508K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "BOOLEAN TYPE" );
-
- BEGIN
- IF BOOLEAN'POS (IDENT_BOOL(FALSE)) /= 0 THEN
- FAILED ( "WRONG POS FOR 'FALSE'" );
- END IF;
- IF BOOLEAN'POS (IDENT_BOOL(TRUE)) /= 1 THEN
- FAILED ( "WRONG POS FOR 'TRUE'" );
- END IF;
-
- IF BOOLEAN'VAL (IDENT_INT(0)) /= FALSE THEN
- FAILED ( "WRONG VAL FOR '0'" );
- END IF;
- IF BOOLEAN'VAL (IDENT_INT(1)) /= TRUE THEN
- FAILED ( "WRONG VAL FOR '1'" );
- END IF;
- END;
-
- BEGIN
- IF BOOLEAN'VAL (IDENT_INT(-1)) = TRUE THEN
- FAILED("'VAL(-1) WRAPPED AROUND TO TRUE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR VAL OF '-1'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '-1'" );
- END;
-
- BEGIN
- IF BOOLEAN'VAL (IDENT_INT(2)) = FALSE THEN
- FAILED("BOOLEAN'VAL(2) WRAPPED AROUND TO FALSE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR VAL OF '2'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '2'" );
- END;
-
- BEGIN
- IF NEWBOOL'POS (FALSE) /= 0 THEN
- FAILED ( "WRONG POS FOR NEWBOOL'(FALSE)" );
- END IF;
- IF NEWBOOL'POS (TRUE) /= 1 THEN
- FAILED ( "WRONG POS FOR NEWBOOL'(TRUE)" );
- END IF;
-
- IF NEWBOOL'VAL (0) /= FALSE THEN
- FAILED ( "WRONG NEWBOOL'VAL FOR '0'" );
- END IF;
- IF NEWBOOL'VAL (1) /= TRUE THEN
- FAILED ( "WRONG NEWBOOL'VAL FOR '1'" );
- END IF;
- END;
-
- BEGIN
- IF NEWBOOL'VAL (IDENT_INT(-1)) = TRUE THEN
- FAILED("NEWBOOL'VAL(-1) WRAPPED AROUND TO TRUE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '-1'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWBOOL'VAL OF '-1'" );
- END;
-
- BEGIN
- IF NEWBOOL'VAL (IDENT_INT(2)) = FALSE THEN
- FAILED("NEWBOOL'VAL(2) WRAPPED AROUND TO FALSE");
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '2'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWBOOL'VAL OF '2'" );
- END;
-
- RESULT;
-END C35508K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508l.ada b/gcc/testsuite/ada/acats/tests/c3/c35508l.ada
deleted file mode 100644
index cba30e2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508l.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- C35508L.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A
--- BOOLEAN TYPE.
-
--- RJW 3/24/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508L IS
-
-BEGIN
- TEST ("C35508L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " &
- "IS A BOOLEAN TYPE" );
-
- DECLARE
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER);
-
- PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER) IS
- SUBTYPE SBOOL IS BOOL
- RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0));
- BEGIN
- IF BOOL'POS (B) /= I THEN
- FAILED ( "WRONG " & STR & "'POS FOR " &
- BOOL'IMAGE (B) & " - 1" );
- END IF;
- IF BOOL'VAL (I) /= B THEN
- FAILED ( "WRONG " & STR & "'VAL FOR " &
- INTEGER'IMAGE (I) & " - 1" );
- END IF;
-
- IF SBOOL'POS (B) /= I THEN
- FAILED ( "WRONG " & STR & "'POS FOR " &
- BOOL'IMAGE (B) & " - 2" );
- END IF;
-
- IF SBOOL'VAL (I) /= B THEN
- FAILED ( "WRONG " & STR & "'VAL FOR " &
- INTEGER'IMAGE (I) & " - 2" );
- END IF;
- END P;
-
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER);
-
- PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER) IS
- SUBTYPE SBOOL IS BOOL
- RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0));
- BEGIN
- BEGIN
- IF BOOL'VAL (I) = B THEN
- FAILED (STR & "'VAL OF " & INTEGER'IMAGE (I) &
- " = " & BOOL'IMAGE (B));
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR " & STR &
- "'VAL OF " & INTEGER'IMAGE (I) );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " & STR &
- "'VAL " & "OF " &
- INTEGER'IMAGE (I) );
- END;
-
- BEGIN
- IF SBOOL'VAL (I) = B THEN
- FAILED (STR & " SBOOL'VAL OF " &
- INTEGER'IMAGE(I) & " = " &
- BOOL'IMAGE (B) );
- END IF;
- FAILED( "NO EXCEPTION RAISED FOR VAL OF " &
- INTEGER'IMAGE (I) &
- "WITH SBOOL OF " & STR);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " & STR &
- "'VAL " & "OF " &
- INTEGER'IMAGE (I) &
- "WITH SBOOL " );
- END;
- END Q;
-
- PROCEDURE NP1 IS NEW P ( BOOL => BOOLEAN );
- PROCEDURE NP2 IS NEW P ( BOOL => NEWBOOL );
- PROCEDURE NQ1 IS NEW Q ( BOOL => BOOLEAN );
- PROCEDURE NQ2 IS NEW Q ( BOOL => NEWBOOL );
- BEGIN
- NP1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(0) );
- NP1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(1) );
- NP2 ( "NEWBOOL", FALSE , 0 );
- NP2 ( "NEWBOOL", TRUE , 1 );
- NQ1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(-1) );
- NQ1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(2) );
- NQ2 ( "NEWBOOL", FALSE , -1 );
- NQ2 ( "NEWBOOL", TRUE , 2 );
- END;
-
- RESULT;
-END C35508L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508o.ada b/gcc/testsuite/ada/acats/tests/c3/c35508o.ada
deleted file mode 100644
index ff1eb67..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508o.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C35508O.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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A BOOLEAN TYPE.
-
--- HISTORY:
--- RJW 03/19/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508O IS
-
-BEGIN
- TEST ("C35508O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "BOOLEAN TYPE" );
-
- DECLARE
- SUBTYPE TBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) ..
- IDENT_BOOL(TRUE);
- SUBTYPE FBOOL IS BOOLEAN
- RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE);
- SUBTYPE NOBOOL IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE);
- TYPE NEWBOOL IS NEW BOOLEAN;
- TYPE NIL IS NEW BOOLEAN RANGE IDENT_BOOL(TRUE) ..
- IDENT_BOOL(FALSE);
-
- BEGIN
- IF IDENT_BOOL(BOOLEAN'FIRST) /= FALSE THEN
- FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST" );
- END IF;
- IF IDENT_BOOL(BOOLEAN'LAST) /= TRUE THEN
- FAILED ( "WRONG VALUE FOR BOOLEAN'LAST" );
- END IF;
-
- IF TBOOL'FIRST /= TRUE THEN
- FAILED ( "WRONG VALUE FOR TBOOL'FIRST" );
- END IF;
- IF TBOOL'LAST /= TRUE THEN
- FAILED ( "WRONG VALUE FOR TBOOL'LAST" );
- END IF;
-
- IF FBOOL'FIRST /= FALSE THEN
- FAILED ( "WRONG VALUE FOR FBOOL'FIRST" );
- END IF;
- IF FBOOL'LAST /= FALSE THEN
- FAILED ( "WRONG VALUE FOR FBOOL'LAST" );
- END IF;
-
- IF NOBOOL'FIRST /= TRUE THEN
- FAILED ( "WRONG VALUE FOR NOBOOL'FIRST" );
- END IF;
- IF NOBOOL'LAST /= FALSE THEN
- FAILED ( "WRONG VALUE FOR NOBOOL'LAST" );
- END IF;
-
- IF NEWBOOL'FIRST /= FALSE THEN
- FAILED ( "WRONG VALUE FOR NEWBOOL'FIRST" );
- END IF;
- IF NEWBOOL'LAST /= TRUE THEN
- FAILED ( "WRONG VALUE FOR NEWBOOL'LAST" );
- END IF;
- IF NIL'FIRST /= TRUE THEN
- FAILED ( "WRONG VALUE FOR NIL'FIRST" );
- END IF;
- IF NIL'LAST /= FALSE THEN
- FAILED ( "WRONG VALUE FOR NIL'LAST" );
- END IF;
-
- END;
-
- RESULT;
-END C35508O;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35508p.ada b/gcc/testsuite/ada/acats/tests/c3/c35508p.ada
deleted file mode 100644
index 8ee3e88..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35508p.ada
+++ /dev/null
@@ -1,131 +0,0 @@
--- C35508P.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 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE
--- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER
--- IS A BOOLEAN TYPE.
-
--- HISTORY:
--- RJW 03/19/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35508P IS
-
-BEGIN
- TEST ("C35508P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " &
- "CORRECT RESULTS WHEN THE PREFIX IS A " &
- "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " &
- "PARAMETER IS A BOOLEAN TYPE" );
- DECLARE
- SUBTYPE TBOOL IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE);
- SUBTYPE FBOOL IS BOOLEAN
- RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE);
- SUBTYPE NOBOOL IS BOOLEAN
- RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE);
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- GENERIC
- TYPE BOOL IS (<>);
- F, L : BOOL;
- PROCEDURE P ( STR : STRING );
-
- PROCEDURE P ( STR : STRING ) IS
- BEGIN
- IF BOOL'FIRST /= F THEN
- FAILED ( "WRONG VALUE FOR " & STR & "'FIRST" );
- END IF;
- IF BOOL'LAST /= L THEN
- FAILED ( "WRONG VALUE FOR " & STR & "'LAST" );
- END IF;
- END P;
-
- GENERIC
- TYPE BOOL IS (<>);
- PROCEDURE Q;
-
- PROCEDURE Q IS
- BEGIN
- IF BOOL'FIRST /= BOOL'VAL (IDENT_INT(1)) THEN
- FAILED ( "WRONG 'FIRST FOR NOBOOL" );
- END IF;
- IF BOOL'LAST /= BOOL'VAL (IDENT_INT(0)) THEN
- FAILED ( "WRONG 'LAST FOR NOBOOL" );
- END IF;
- END Q;
-
- GENERIC
- TYPE BOOL IS (<>);
- F, L : BOOL;
- PROCEDURE R;
-
- PROCEDURE R IS
- SUBTYPE SBOOL IS BOOL
- RANGE BOOL'VAL (0) .. BOOL'VAL (1);
- BEGIN
- IF SBOOL'FIRST /= F THEN
- FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST AS " &
- "SUBTYPE " );
- END IF;
- IF SBOOL'LAST /= L THEN
- FAILED ( "WRONG VALUE FOR BOOLEAN'LAST AS " &
- "SUBTYPE" );
- END IF;
- END R;
-
- PROCEDURE P1 IS NEW P
- ( BOOL => BOOLEAN, F => IDENT_BOOL(FALSE),
- L => IDENT_BOOL(TRUE) );
-
- PROCEDURE P2 IS NEW P
- ( BOOL => TBOOL, F => IDENT_BOOL(TRUE),
- L => IDENT_BOOL(TRUE) );
-
- PROCEDURE P3 IS NEW P
- ( BOOL => FBOOL, F => IDENT_BOOL(FALSE),
- L => IDENT_BOOL(FALSE) );
-
- PROCEDURE P4 IS NEW P
- (BOOL => NEWBOOL, F => FALSE, L => TRUE );
-
- PROCEDURE Q1 IS NEW Q
- ( BOOL => NOBOOL );
-
- PROCEDURE R1 IS NEW R
- ( BOOL => BOOLEAN, F => FALSE, L => TRUE );
-
- BEGIN
- P1 ( "BOOLEAN" );
- P2 ( "TBOOL" );
- P3 ( "FBOOL" );
- P4 ( "NEWBOOL" );
- Q1;
- R1;
- END;
-
- RESULT;
-END C35508P;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35703a.ada b/gcc/testsuite/ada/acats/tests/c3/c35703a.ada
deleted file mode 100644
index 6980f3c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35703a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C35703A.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 AND 'LAST EXIST AND CAN BE ASSIGNED. CHECK THAT
--- 'FIRST IS LESS THAN OR EQUAL TO 'LAST.
-
--- BAW 5 SEPT 80
--- R.WILLIAMS 8/21/86 ADDED A TYPE DECLARED WITHOUT A RANGE
--- CONSTRAINT. RENAMED TO -B. ADDED EXCEPTION
--- HANDLERS.
--- GMT 6/29/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY
--- CREATED PACKAGE NAMED SHOW_TEST_HEADER.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35703A IS
-
- TYPE REAL1 IS DIGITS 2 RANGE 0.25..0.5;
- TYPE REAL2 IS DIGITS 3;
-
- PACKAGE SHOW_TEST_HEADER IS
- -- PURPOSE OF THIS PACKAGE:
- -- WE WANT THE TEST HEADER INFORMATION TO BE
- -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES.
- END SHOW_TEST_HEADER;
-
- PACKAGE BODY SHOW_TEST_HEADER IS
- BEGIN
- TEST( "C35703A",
- "CHECK THAT FIRST AND LAST CAN BE ASSIGNED " &
- "AND THAT FIRST <= LAST" );
- END SHOW_TEST_HEADER;
-
- PACKAGE XPKG IS
- X : REAL1;
- END XPKG;
-
- PACKAGE BODY XPKG IS
- BEGIN
- X := REAL1'FIRST;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " &
- "REAL1'FIRST" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " &
- "REAL1'FIRST" );
- END XPKG;
-
- PACKAGE YPKG IS
- Y : REAL1;
- END YPKG;
-
- PACKAGE BODY YPKG IS
- BEGIN
- Y := REAL1'LAST;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " &
- "REAL1'LAST" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " &
- "REAL1'LAST" );
- END YPKG;
-
- PACKAGE APKG IS
- A : REAL2;
- END APKG;
-
- PACKAGE BODY APKG IS
- BEGIN
- A := REAL2'FIRST;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " &
- "REAL2'FIRST" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " &
- "REAL2'FIRST" );
- END APKG;
-
- PACKAGE BPKG IS
- B : REAL2;
- END BPKG;
-
- PACKAGE BODY BPKG IS
- BEGIN
- B := REAL2'LAST;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " &
- "REAL2'LAST" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " &
- "REAL2'LAST" );
- END BPKG;
-
-
-BEGIN
-
- DECLARE
- USE XPKG;
- USE YPKG;
- BEGIN
- IF X > Y THEN
- FAILED ( "REAL1'FIRST IS GREATER THAN REAL1'LAST" );
- END IF;
- END;
-
- DECLARE
- USE APKG;
- USE BPKG;
- BEGIN
- IF A > B THEN
- FAILED ( "REAL2'FIRST IS GREATER THEN REAL2'LAST" );
- END IF;
- END;
-
- RESULT;
-
-END C35703A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35704a.ada b/gcc/testsuite/ada/acats/tests/c3/c35704a.ada
deleted file mode 100644
index e1e8532..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35704a.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C35704A.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 FIXED POINT VALUES CAN BE USED IN FLOATING POINT RANGE
--- CONSTRAINT IN TYPE DEFINITION.
-
--- BAW 9/5/80
--- JCR 4/7/82
-
-WITH REPORT;
-PROCEDURE C35704A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C35704A","CHECK THAT L AND R CAN BE FIXED POINT" &
- " IN A FLOATING POINT TYPE DEFINITION");
-
- DECLARE
-
-
- TYPE F IS DELTA 0.5 RANGE -5.0..5.0;
-
- F1 : CONSTANT F := -4.0;
- F2 : CONSTANT F := 4.0;
-
- TYPE G1 IS DIGITS 5 RANGE F1..F2;
- BEGIN
-
- IF (ABS(G1'FIRST)-4.0) /= 0.0 OR
- (ABS(G1'LAST)-4.0) /= 0.0
- THEN FAILED ("ERROR IN USING FIXED-POINT IN RANGE " &
- "CONSTRAINT");
- END IF;
-
- END;
- RESULT;
-
-END C35704A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35704b.ada b/gcc/testsuite/ada/acats/tests/c3/c35704b.ada
deleted file mode 100644
index 7efae77..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35704b.ada
+++ /dev/null
@@ -1,62 +0,0 @@
--- C35704B.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 DIFFERENT FLOATING POINT TYPES FROM SAME PARENT CAN BE
--- USED IN A FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION.
-
--- JCR 4/7/82
-
-WITH REPORT;
-PROCEDURE C35704B IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C35704B", "DIFFERENT FLOATING POINT TYPES " &
- "FROM THE SAME PARENT IN FLOATING POINT" &
- "TYPE DEFINITION'S RANGE CONSTRAINT");
-
- DECLARE
- TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0;
-
- TYPE F1 IS NEW F;
-
- TYPE G1 IS DIGITS 5 RANGE F1'FIRST..F'LAST;
- TYPE G2 IS DIGITS 5 RANGE F'FIRST..F1'LAST;
-
- BEGIN
-
- IF G1'FIRST /= G1(G2'FIRST) OR G1'LAST /= G1(G2'LAST) OR
- G2'FIRST /= G2(F'FIRST) OR G2'LAST /= G2(F'LAST)
- THEN
- FAILED ("USING DIFF FLOATING POINT TYPES " &
- "FROM SAME PARENT");
-
- END IF;
-
- END;
-
- RESULT;
-
-END C35704B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35704c.ada b/gcc/testsuite/ada/acats/tests/c3/c35704c.ada
deleted file mode 100644
index 2b0fe3b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35704c.ada
+++ /dev/null
@@ -1,62 +0,0 @@
--- C35704C.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 DIFFERENT FLOATING POINT TYPES FROM DIFFERENT PARENTS
--- CAN BE USE IN FLOATING POINT RANGE CONSTRAINTS IN TYPE DEFINITIONS.
-
--- JCR 4/7/82
-
-WITH REPORT;
-PROCEDURE C35704C IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C35704C", "DIFFERENT FLOATING POINT TYPES " &
- "FROM DIFFERENT PARENTS IN FLOATING POINT RANGE " &
- "CONSTRAINT IN TYPE DEFINITION");
-
- DECLARE
-
- TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0;
- TYPE F1 IS DIGITS 5 RANGE -5.0 .. 5.0;
-
- TYPE G1 IS DIGITS 5 RANGE F'FIRST..F1'LAST;
- TYPE G2 IS DIGITS 5 RANGE F1'FIRST..F'LAST;
-
- BEGIN
-
-
- IF G1'FIRST /= G1(F'FIRST) OR G1'FIRST /= G1(G2'FIRST) OR
- G1'FIRST /= G1(F1'FIRST) OR G1'LAST /= G1(F'LAST) OR
- G1'LAST /= G1(G2'LAST) OR G1'LAST /= G1(F1'LAST)
-
- THEN FAILED ("USING FLOAT FROM DIFF PARENTS");
-
- END IF;
- END;
-
- RESULT;
-
-END C35704C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35704d.ada b/gcc/testsuite/ada/acats/tests/c3/c35704d.ada
deleted file mode 100644
index 0afd81d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35704d.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C35704D.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 COMBINATION OF FIXED AND FLOAT CAN BE USED IN A
--- FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION.
-
--- JCR 4/7/82
-
-WITH REPORT;
-PROCEDURE C35704D IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C35704D","MIXED FIXED AND FLOAT IN FLOATING " &
- "POINT RANGE CONSTRAINT IN A TYPE DEFINITION");
-
- DECLARE
-
- TYPE F IS DIGITS 5;
- TYPE R IS DELTA 0.5 RANGE -5.0 .. 5.0;
-
- T1 : CONSTANT F := -4.0;
- T2 : CONSTANT F := 4.0;
-
- R1 : CONSTANT R := -4.0;
- R2 : CONSTANT R := 4.0;
-
- TYPE G1 IS DIGITS 5 RANGE T1..R2;
- TYPE G2 IS DIGITS 5 RANGE R1..T2;
-
- BEGIN
-
- IF (ABS(G1'FIRST)- 4.0) /= 0.0 OR
- (ABS(G1'LAST) - 4.0) /= 0.0 OR
- (ABS(G2'FIRST)- 4.0) /= 0.0 OR
- (ABS(G2'LAST) - 4.0) /= 0.0
-
- THEN FAILED ("MIXED FIXED AND FLOAT IN FLOAT RANGE " &
- "CONSTRAINT");
-
- END IF;
-
- END;
-
- RESULT;
-
-
-END C35704D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35801d.ada b/gcc/testsuite/ada/acats/tests/c3/c35801d.ada
deleted file mode 100644
index 5ee8259..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35801d.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C35801D.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 ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE
--- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A GENERIC FORMAL
--- SUBTYPE WHOSE ACTUAL ARGUMENT IS A FLOATING POINT TYPE.
-
--- R.WILLIAMS 8/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35801D IS
- TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0;
-
- TYPE NFLT IS NEW FLOAT;
-
- GENERIC
- TYPE F IS DIGITS <>;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- SUBTYPE SF IS F RANGE -1.0 .. 1.0;
- F1 : SF := 0.0;
- F2 : SF := 0.0;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- F1 := SF'FIRST;
- F2 := SF'LAST;
- END IF;
-
- IF F1 /= -1.0 OR F2 /= 1.0 THEN
- FAILED ( "WRONG RESULTS FROM " & STR & "'FIRST OR " &
- STR & "'LAST" );
- END IF;
- END P;
-
- PROCEDURE NP1 IS NEW P (FLOAT);
-
- PROCEDURE NP2 IS NEW P (NFLT);
-
- PROCEDURE NP3 IS NEW P (REAL);
-
-BEGIN
- TEST ( "C35801D", "CHECK THAT THE ATTRIBUTES FIRST AND " &
- "LAST RETURN VALUES HAVING THE SAME " &
- "BASE TYPE AS THE PREFIX WHEN THE " &
- "PREFIX IS A GENERIC FORMAL SUBTYPE " &
- "WHOSE ACTUAL ARGUMENT IS A FLOATING " &
- "POINT TYPE" );
-
-
- NP1 ("FLOAT");
- NP2 ("NFLT");
- NP3 ("REAL");
-
- RESULT;
-END C35801D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35902d.ada b/gcc/testsuite/ada/acats/tests/c3/c35902d.ada
deleted file mode 100644
index c09fe58..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35902d.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- C35902D.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 BINARY POINT IN THE MANTISSA OF A FIXED POINT NUMBER
--- CAN LIE OUTSIDE THE MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT).
-
--- WRG 7/18/86
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-PROCEDURE C35902D IS
-
-BEGIN
-
- TEST ("C35902D", "CHECK THAT THE BINARY POINT IN THE MANTISSA " &
- "OF A FIXED POINT NUMBER CAN LIE OUTSIDE THE " &
- "MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT)");
-
- COMMENT ("VALUE OF SYSTEM.MAX_MANTISSA IS" &
- POSITIVE'IMAGE(MAX_MANTISSA) );
-
- A: DECLARE
-
- RS : CONSTANT := 2.0;
-
- TYPE ONE_TO_THE_RIGHT IS
- DELTA RS
- RANGE -(2.0 ** (MAX_MANTISSA+1) ) ..
- 2.0 ** (MAX_MANTISSA+1);
- -- THE BINARY POINT IS ONE PLACE TO THE RIGHT OF THE
- -- LARGEST POSSIBLE MANTISSA.
-
- R1, R2 : ONE_TO_THE_RIGHT;
-
- BEGIN
-
- R1 := RS;
- FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP
- R1 := R1 * IDENT_INT (2);
- END LOOP;
- R2 := R1 - RS;
- R2 := R2 + R1;
- -- AT THIS POINT, R2 SHOULD EQUAL ONE_TO_THE_RIGHT'LARGE.
- R2 := -R2;
- R2 := R2 + (R1 - RS);
- FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP
- R2 := R2 / IDENT_INT (2);
- END LOOP;
- IF R2 /= -RS THEN
- FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - A");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - A");
-
- END A;
-
- B: DECLARE
-
- LS : CONSTANT := 2.0 ** (-(MAX_MANTISSA+1) );
-
- TYPE ONE_TO_THE_LEFT IS
- DELTA LS
- RANGE -(2.0 ** (-1) ) ..
- 2.0 ** (-1);
- -- THE BINARY POINT IS ONE PLACE TO THE LEFT OF THE
- -- LARGEST POSSIBLE MANTISSA.
-
- L1, L2 : ONE_TO_THE_LEFT;
-
- BEGIN
-
- L1 := LS;
- FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP
- L1 := L1 * IDENT_INT (2);
- END LOOP;
- L2 := L1 - LS;
- L2 := L2 + L1;
- -- AT THIS POINT, L2 SHOULD EQUAL ONE_TO_THE_LEFT'LARGE.
- L2 := -L2;
- L2 := L2 + (L1 - LS);
- FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP
- L2 := L2 / IDENT_INT (2);
- END LOOP;
- IF L2 /= -LS THEN
- FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - B");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - B");
-
- END B;
-
- RESULT;
-
-END C35902D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35904a.ada b/gcc/testsuite/ada/acats/tests/c3/c35904a.ada
deleted file mode 100644
index 8b3bfbb..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35904a.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- C35904A.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 INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE
--- APPROPRIATE EXCEPTIONS.
-
-
--- HISTORY:
--- RJK 05/17/83 CREATED ORIGINAL TEST.
--- PWB 02/03/86 CORRECTED TEST ERROR:
--- ADDED POSSIBLITY OF NUMERIC_ERROR
--- IN DECLARATIONS OF SFX3 AND SFX4.
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED RANGE
--- CONSTRAINTS OF SUBTYPE SFX1. CHANGED UPPER BOUND
--- OF THE CONSTRAINT OF SFX4. CHANGED RANGE
--- CONSTRAINTS OF FIX.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS.
--- EDS 07/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35904A IS
-
- TYPE FIX IS DELTA 0.5 RANGE -3.0 .. 3.0;
-
-BEGIN
-
- TEST ("C35904A", "CHECK THAT INCOMPATIBLE FIXED POINT " &
- "CONSTRAINTS RAISE APPROPRIATE EXCEPTION");
-
--- TEST FOR CORRECT SUBTYPE DEFINITION FOR COMPATIBILITY BETWEEN TYPE
--- AND SUBTYPE CONSTRAINTS.
-
- BEGIN
-
- DECLARE
-
- SUBTYPE SFX1 IS FIX DELTA 1.0 RANGE 0.0 .. 2.0; -- OK.
- SFX1_VAR : SFX1;
-
- BEGIN
- SFX1_VAR := 1.0;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("FIXED POINT CONSTRAINTS ARE NOT IN ERROR");
- WHEN OTHERS =>
- FAILED ("EXCEPTION SHOULD NOT BE RAISED WHILE " &
- "CHECKING DELTA CONSTRAINT");
- END;
-
--- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND
--- SUBTYPE DEFINITIONS.
-
- BEGIN
-
- DECLARE
-
- SUBTYPE SFX IS FIX DELTA 0.1; -- DELTA IS SMALLER FOR
- -- SUBTYPE THAN FOR TYPE.
- -- DEFINE AN OBJECT OF SUBTYPE SFX AND USE IT TO AVOID
- -- OPTIMIZATION OF SUBTYPE
- SFX_VAR : SFX := FIX(IDENT_INT(1));
-
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR INCOMPATABLE DELTA " &
- FIX'IMAGE(SFX_VAR) ); --USE SFX_VAR
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " &
- "DELTA CONSTRAINT");
- END;
-
- RESULT;
-
-END C35904A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35904b.ada b/gcc/testsuite/ada/acats/tests/c3/c35904b.ada
deleted file mode 100644
index cff7d2e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35904b.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C35904B.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 INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE
--- CONSTRAINT_ERROR FOR GENERIC FORMAL TYPES.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- RJW 6/20/86
--- DWC 07/24/87 -- ADDED NUMERIC_ERROR HANDLERS.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
--- EDS 07/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35904B IS
-
- GENERIC
- TYPE FIX IS DELTA <>;
- PROCEDURE PROC (STR : STRING);
-
- PROCEDURE PROC (STR : STRING) IS
- SUBTYPE SFIX IS FIX DELTA 0.1 RANGE -1.0 .. 1.0;
- -- DEFINE AN OBJECT OF SUBTYPE SFIX AND USE IT TO AVOID
- -- OPTIMIZATION OF SUBTYPE
- SFIX_VAR : SFIX := SFIX(IDENT_INT(0));
- BEGIN
- FAILED ("NO EXCEPTION RAISED FOR " & STR & " " &
- SFIX'IMAGE(SFIX_VAR) ); --USE SFIX_VAR
- END PROC;
-
-BEGIN
-
- TEST ( "C35904B", "CHECK THAT INCOMPATIBLE FIXED POINT " &
- "CONSTRAINTS RAISE CONSTRAINT_ERROR " &
- "FOR GENERIC FORMAL TYPES" );
-
--- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND
--- SUBTYPE DEFINITIONS.
-
- BEGIN
-
- DECLARE
-
- TYPE FIX1 IS DELTA 0.5 -- DELTA IS SMALLER FOR
- RANGE -2.0 .. 2.0; -- SUBTYPE THEN FOR
- -- TYPE.
-
- PROCEDURE NPROC IS NEW PROC (FIX1);
-
- BEGIN
- NPROC ( "INCOMPATIBLE DELTA" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " &
- "DELTA CONSTRAINT");
- END;
-
--- TEST THAT CONSTRAINT_ERROR IS RAISED
--- FOR A RANGE VIOLATION.
-
- BEGIN
-
- DECLARE
-
- TYPE FIX2 IS DELTA 0.1 RANGE 0.0 .. 2.0; -- LOWER
- -- BOUND.
-
- PROCEDURE NPROC IS NEW PROC (FIX2);
-
- BEGIN
- NPROC ("FIXED POINT LOWER BOUND CONSTRAINT VIOLATION");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR " &
- "LOWER BOUND VIOLATION");
- WHEN OTHERS =>
- FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " &
- "FIXED POINT LOWER BOUND CONSTRAINT");
- END;
-
--- TEST THAT CONSTRAINT_ERROR IS RAISED
--- FOR A RANGE VIOLATION.
-
- BEGIN
-
- DECLARE
-
- TYPE FIX3 IS DELTA 0.1 RANGE -2.0 .. 0.0; -- UPPER
- -- BOUND.
-
- PROCEDURE NPROC IS NEW PROC (FIX3);
- BEGIN
- NPROC ("FIXED POINT UPPER BOUND CONSTRAINT VIOLATION");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR " &
- "UPPER BOUND VIOLATION");
- WHEN OTHERS =>
- FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " &
- "FIXED POINT UPPER BOUND CONSTRAINT");
- END;
-
- RESULT;
-
-END C35904B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada b/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada
deleted file mode 100644
index 5ebee35..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C35A02A.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 T'DELTA YIELDS CORRECT VALUES FOR SUBTYPE T.
-
--- RJW 2/27/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35A02A IS
-
-BEGIN
-
- TEST ( "C35A02A", "CHECK THAT T'DELTA YIELDS CORRECT VALUES " &
- "FOR SUBTYPE T" );
-
- DECLARE
- D : CONSTANT := 0.125;
- SD : CONSTANT := 1.0;
-
- TYPE VOLT IS DELTA D RANGE 0.0 .. 255.0;
- SUBTYPE ROUGH_VOLTAGE IS VOLT DELTA SD;
-
- GENERIC
- TYPE FIXED IS DELTA <> ;
- FUNCTION F RETURN FIXED;
-
- FUNCTION F RETURN FIXED IS
- BEGIN
- RETURN FIXED'DELTA;
- END F;
-
- FUNCTION VF IS NEW F (VOLT);
- FUNCTION RF IS NEW F (ROUGH_VOLTAGE);
-
- BEGIN
- IF VOLT'DELTA /= D THEN
- FAILED ( "INCORRECT VALUE FOR VOLT'DELTA" );
- END IF;
- IF ROUGH_VOLTAGE'DELTA /= SD THEN
- FAILED ( "INCORRECT VALUE FOR ROUGH_VOLTAGE'DELTA" );
- END IF;
-
- IF VF /= D THEN
- FAILED ( "INCORRECT VALUE FOR VF" );
- END IF;
- IF RF /= SD THEN
- FAILED ( "INCORRECT VALUE FOR RF" );
- END IF;
- END;
-
- RESULT;
-
-END C35A02A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada b/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada
deleted file mode 100644
index c850249..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C35A05A.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 FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD
--- THE CORRECT VALUES.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- WRG 8/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35A05A IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5;
- TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0;
- TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0;
- TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0;
- TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0;
- TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5;
- TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0;
- TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0;
- TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
- TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0;
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
- TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0;
- TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0;
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15
- DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0;
- SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16
- DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0;
- SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23
- DELTA 0.5 RANGE -2.0 .. 2.0;
- SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23
- DELTA 0.5 RANGE 0.0 .. 2.5;
- SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18
- DELTA 10.0 RANGE -1000.0 .. 1000.0;
- SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4
- DELTA 100.0 RANGE -500.0 .. 500.0;
-
- -------------------------------------------------------------------
-
- PROCEDURE CHECK_FORE_AND_AFT
- (NAME : STRING;
- ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE;
- ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS
- BEGIN
- IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN
- FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) );
- END IF;
- IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN
- FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) );
- END IF;
- END CHECK_FORE_AND_AFT;
-
-BEGIN
-
- TEST ("C35A05A", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " &
- "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " &
- "BASIC TYPES");
-
- CHECK_FORE_AND_AFT ("LEFT_OUT_M1", LEFT_OUT_M1'FORE, 2,
- LEFT_OUT_M1'AFT, 1);
-
- CHECK_FORE_AND_AFT ("LEFT_EDGE_M1", LEFT_EDGE_M1'FORE, 2,
- LEFT_EDGE_M1'AFT, 1);
-
- CHECK_FORE_AND_AFT ("RIGHT_EDGE_M1", RIGHT_EDGE_M1'FORE, 2,
- RIGHT_EDGE_M1'AFT, 1);
-
- CHECK_FORE_AND_AFT ("RIGHT_OUT_M1", RIGHT_OUT_M1'FORE, 2,
- RIGHT_OUT_M1'AFT, 1);
-
- CHECK_FORE_AND_AFT ("MIDDLE_M2", MIDDLE_M2'FORE, 2,
- MIDDLE_M2'AFT, 1);
-
- CHECK_FORE_AND_AFT ("MIDDLE_M3", MIDDLE_M3'FORE, 2,
- MIDDLE_M3'AFT, 1);
-
- CHECK_FORE_AND_AFT ("MIDDLE_M15", MIDDLE_M15'FORE, 4,
- MIDDLE_M15'AFT, 2);
-
- CHECK_FORE_AND_AFT ("MIDDLE_M16", MIDDLE_M16'FORE, 5,
- MIDDLE_M16'AFT, 2);
-
- CHECK_FORE_AND_AFT ("LIKE_DURATION_M23", LIKE_DURATION_M23'FORE, 6,
- LIKE_DURATION_M23'AFT, 2);
-
- CHECK_FORE_AND_AFT ("DECIMAL_M18", DECIMAL_M18'FORE, 6,
- DECIMAL_M18'AFT, 1);
-
- IF DECIMAL_M4'FORE /= 5 AND DECIMAL_M4'FORE /= 4 THEN
- FAILED ("DECIMAL_M4'FORE =" &
- INTEGER'IMAGE(DECIMAL_M4'FORE) );
- END IF;
- IF DECIMAL_M4'AFT /= 1 THEN
- FAILED ("DECIMAL_M4'AFT =" &
- INTEGER'IMAGE(DECIMAL_M4'AFT) );
- END IF;
-
- CHECK_FORE_AND_AFT ("DECIMAL_M11", DECIMAL_M11'FORE, 4,
- DECIMAL_M11'AFT, 2);
-
- CHECK_FORE_AND_AFT ("DECIMAL2_M18", DECIMAL2_M18'FORE, 5,
- DECIMAL2_M18'AFT, 1);
-
- CHECK_FORE_AND_AFT ("ST_LEFT_EDGE_M6", ST_LEFT_EDGE_M6'FORE, 2,
- ST_LEFT_EDGE_M6'AFT, 2);
-
- CHECK_FORE_AND_AFT ("ST_MIDDLE_M14", ST_MIDDLE_M14'FORE, 4,
- ST_MIDDLE_M14'AFT, 2);
-
- CHECK_FORE_AND_AFT ("ST_MIDDLE_M2", ST_MIDDLE_M2'FORE, 2,
- ST_MIDDLE_M2'AFT, 1);
-
- CHECK_FORE_AND_AFT ("ST_MIDDLE_M3", ST_MIDDLE_M3'FORE, 2,
- ST_MIDDLE_M3'AFT, 1);
-
- CHECK_FORE_AND_AFT ("ST_DECIMAL_M7", ST_DECIMAL_M7'FORE, 5,
- ST_DECIMAL_M7'AFT, 1);
-
- CHECK_FORE_AND_AFT ("ST_DECIMAL_M3", ST_DECIMAL_M3'FORE, 4,
- ST_DECIMAL_M3'AFT, 1);
-
- RESULT;
-
-END C35A05A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada b/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada
deleted file mode 100644
index 9b07671..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C35A05D.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 FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD
--- THE CORRECT VALUES.
-
--- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC.
-
--- WRG 8/14/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35A05D IS
-
- PI : CONSTANT := 3.14159_26535_89793_23846;
- TWO_PI : CONSTANT := 2 * PI;
- HALF_PI : CONSTANT := PI / 2;
-
- MM : CONSTANT := 23;
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE MICRO_ANGLE_ERROR_M15 IS
- DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19;
- TYPE TRACK_RANGE_M15 IS
- DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12;
- TYPE SECONDS_MM IS
- DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8;
- TYPE RANGE_CELL_MM IS
- DELTA 2.0 ** (-5)
- RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5);
-
- TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0;
- TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0;
-
- TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0;
- TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0;
-
- TYPE SYMMETRIC_DEGREES_M7 IS
- DELTA 2.0 RANGE -180.0 .. 180.0;
- TYPE NATURAL_DEGREES_M15 IS
- DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0;
- TYPE SYMMETRIC_RADIANS_M16 IS
- DELTA PI * 2.0 ** (-15) RANGE -PI .. PI;
- TYPE NATURAL_RADIANS_M8 IS
- DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI;
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_MILES_M8 IS MILES_M16
- DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0;
- SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15
- DELTA 0.25 RANGE 0.0 .. 360.0;
- SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16
- DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI;
-
- -------------------------------------------------------------------
-
- PROCEDURE CHECK_FORE_AND_AFT
- (NAME : STRING;
- ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE;
- ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS
- BEGIN
- IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN
- FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) );
- END IF;
- IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN
- FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) );
- END IF;
- END CHECK_FORE_AND_AFT;
-
-BEGIN
-
- TEST ("C35A05D", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " &
- "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " &
- "TYPICAL TYPES");
-
- CHECK_FORE_AND_AFT ("MICRO_ANGLE_ERROR_M15",
- MICRO_ANGLE_ERROR_M15'FORE, 7,
- MICRO_ANGLE_ERROR_M15'AFT, 1);
-
- CHECK_FORE_AND_AFT ("TRACK_RANGE_M15", TRACK_RANGE_M15'FORE, 5,
- TRACK_RANGE_M15'AFT, 1);
-
- CHECK_FORE_AND_AFT ("SECONDS_MM", SECONDS_MM'FORE, 4,
- SECONDS_MM'AFT, 5);
-
- CHECK_FORE_AND_AFT ("RANGE_CELL_MM", RANGE_CELL_MM'FORE, 7,
- RANGE_CELL_MM'AFT, 2);
-
- CHECK_FORE_AND_AFT ("PIXEL_M10", PIXEL_M10'FORE, 2,
- PIXEL_M10'AFT, 4);
-
- CHECK_FORE_AND_AFT ("RULER_M8", RULER_M8'FORE, 3,
- RULER_M8'AFT, 2);
-
- CHECK_FORE_AND_AFT ("HOURS_M16", HOURS_M16'FORE, 3,
- HOURS_M16'AFT, 4);
-
- CHECK_FORE_AND_AFT ("MILES_M16", MILES_M16'FORE, 5,
- MILES_M16'AFT, 2);
-
- CHECK_FORE_AND_AFT ("SYMMETRIC_DEGREES_M7",
- SYMMETRIC_DEGREES_M7'FORE, 4,
- SYMMETRIC_DEGREES_M7'AFT, 1);
-
- CHECK_FORE_AND_AFT ("NATURAL_DEGREES_M15",
- NATURAL_DEGREES_M15'FORE, 4,
- NATURAL_DEGREES_M15'AFT, 2);
-
- CHECK_FORE_AND_AFT ("SYMMETRIC_RADIANS_M16",
- SYMMETRIC_RADIANS_M16'FORE, 2,
- SYMMETRIC_RADIANS_M16'AFT, 5);
-
- CHECK_FORE_AND_AFT ("NATURAL_RADIANS_M8",
- NATURAL_RADIANS_M8'FORE, 2,
- NATURAL_RADIANS_M8'AFT, 2);
-
- CHECK_FORE_AND_AFT ("ST_MILES_M8", ST_MILES_M8'FORE, 3,
- ST_MILES_M8'AFT, 2);
-
- CHECK_FORE_AND_AFT ("ST_NATURAL_DEGREES_M11",
- ST_NATURAL_DEGREES_M11'FORE, 4,
- ST_NATURAL_DEGREES_M11'AFT, 1);
-
- CHECK_FORE_AND_AFT ("ST_SYMMETRIC_RADIANS_M8",
- ST_SYMMETRIC_RADIANS_M8'FORE, 2,
- ST_SYMMETRIC_RADIANS_M8'AFT, 2);
-
- RESULT;
-
-END C35A05D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada b/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada
deleted file mode 100644
index 4c1102d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C35A05N.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 FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD
--- THE CORRECT VALUES.
-
--- CASE N: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE,
--- FOR GENERICS.
-
--- WRG 8/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35A05N IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5;
- TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0;
- TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0;
- TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0;
- TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0;
- TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5;
- TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0;
- TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0;
- TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
- TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0;
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
- TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0;
- TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0;
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15
- DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0;
- SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16
- DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0;
- SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23
- DELTA 0.5 RANGE -2.0 .. 2.0;
- SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23
- DELTA 0.5 RANGE 0.0 .. 2.5;
- SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18
- DELTA 10.0 RANGE -1000.0 .. 1000.0;
- SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4
- DELTA 100.0 RANGE -500.0 .. 500.0;
-
- -------------------------------------------------------------------
-
- TYPE FORE_AND_AFT IS
- RECORD
- FORE, AFT : INTEGER;
- END RECORD;
-
- GENERIC
- TYPE T IS DELTA <>;
- FUNCTION ATTRIBUTES RETURN FORE_AND_AFT;
-
- FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS
- BEGIN
- RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) );
- END ATTRIBUTES;
-
- -------------------------------------------------------------------
-
- PROCEDURE CHECK_ATTRIBUTES
- (NAME : STRING;
- ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS
- BEGIN
- IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN
- FAILED ("GENERIC 'FORE FOR " & NAME & " =" &
- INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) );
- END IF;
- IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN
- FAILED ("GENERIC 'AFT FOR " & NAME & " =" &
- INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) );
- END IF;
- END CHECK_ATTRIBUTES;
-
- -------------------------------------------------------------------
-
- FUNCTION FA_LEFT_OUT_M1 IS NEW ATTRIBUTES(LEFT_OUT_M1 );
- FUNCTION FA_LEFT_EDGE_M1 IS NEW ATTRIBUTES(LEFT_EDGE_M1 );
- FUNCTION FA_RIGHT_EDGE_M1 IS NEW ATTRIBUTES(RIGHT_EDGE_M1 );
- FUNCTION FA_RIGHT_OUT_M1 IS NEW ATTRIBUTES(RIGHT_OUT_M1 );
- FUNCTION FA_MIDDLE_M2 IS NEW ATTRIBUTES(MIDDLE_M2 );
- FUNCTION FA_MIDDLE_M3 IS NEW ATTRIBUTES(MIDDLE_M3 );
- FUNCTION FA_MIDDLE_M15 IS NEW ATTRIBUTES(MIDDLE_M15 );
- FUNCTION FA_MIDDLE_M16 IS NEW ATTRIBUTES(MIDDLE_M16 );
- FUNCTION FA_LIKE_DURATION_M23 IS NEW ATTRIBUTES(LIKE_DURATION_M23);
- FUNCTION FA_DECIMAL_M18 IS NEW ATTRIBUTES(DECIMAL_M18 );
- FUNCTION FA_DECIMAL_M4 IS NEW ATTRIBUTES(DECIMAL_M4 );
- FUNCTION FA_DECIMAL_M11 IS NEW ATTRIBUTES(DECIMAL_M11 );
- FUNCTION FA_DECIMAL2_M18 IS NEW ATTRIBUTES(DECIMAL2_M18 );
- FUNCTION FA_ST_LEFT_EDGE_M6 IS NEW ATTRIBUTES(ST_LEFT_EDGE_M6 );
- FUNCTION FA_ST_MIDDLE_M14 IS NEW ATTRIBUTES(ST_MIDDLE_M14 );
- FUNCTION FA_ST_MIDDLE_M2 IS NEW ATTRIBUTES(ST_MIDDLE_M2 );
- FUNCTION FA_ST_MIDDLE_M3 IS NEW ATTRIBUTES(ST_MIDDLE_M3 );
- FUNCTION FA_ST_DECIMAL_M7 IS NEW ATTRIBUTES(ST_DECIMAL_M7 );
- FUNCTION FA_ST_DECIMAL_M3 IS NEW ATTRIBUTES(ST_DECIMAL_M3 );
-
-BEGIN
-
- TEST ("C35A05N", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " &
- "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " &
- "BASIC TYPES, GENERICS");
-
- CHECK_ATTRIBUTES ("LEFT_OUT_M1", FA_LEFT_OUT_M1, (2, 1) );
- CHECK_ATTRIBUTES ("LEFT_EDGE_M1", FA_LEFT_EDGE_M1, (2, 1) );
- CHECK_ATTRIBUTES ("RIGHT_EDGE_M1", FA_RIGHT_EDGE_M1, (2, 1) );
- CHECK_ATTRIBUTES ("RIGHT_OUT_M1", FA_RIGHT_OUT_M1, (2, 1) );
- CHECK_ATTRIBUTES ("MIDDLE_M2", FA_MIDDLE_M2, (2, 1) );
- CHECK_ATTRIBUTES ("MIDDLE_M3", FA_MIDDLE_M3, (2, 1) );
- CHECK_ATTRIBUTES ("MIDDLE_M15", FA_MIDDLE_M15, (4, 2) );
- CHECK_ATTRIBUTES ("MIDDLE_M16", FA_MIDDLE_M16, (5, 2) );
- CHECK_ATTRIBUTES ("LIKE_DURATION_M23",
- FA_LIKE_DURATION_M23, (6, 2) );
- CHECK_ATTRIBUTES ("DECIMAL_M18", FA_DECIMAL_M18, (6, 1) );
-
- IF FA_DECIMAL_M4.FORE /= 5 AND FA_DECIMAL_M4.FORE /= 4 THEN
- FAILED ("GENERIC 'FORE FOR DECIMAL_M4 =" &
- INTEGER'IMAGE(FA_DECIMAL_M4.FORE) );
- END IF;
- IF FA_DECIMAL_M4.AFT /= 1 THEN
- FAILED ("GENERIC 'AFT FOR DECIMAL_M4 =" &
- INTEGER'IMAGE(FA_DECIMAL_M4.AFT) );
- END IF;
-
- CHECK_ATTRIBUTES ("DECIMAL_M11", FA_DECIMAL_M11, (4, 2) );
- CHECK_ATTRIBUTES ("DECIMAL2_M18", FA_DECIMAL2_M18, (5, 1) );
- CHECK_ATTRIBUTES ("ST_LEFT_EDGE_M6", FA_ST_LEFT_EDGE_M6, (2, 2) );
- CHECK_ATTRIBUTES ("ST_MIDDLE_M14", FA_ST_MIDDLE_M14, (4, 2) );
- CHECK_ATTRIBUTES ("ST_MIDDLE_M2", FA_ST_MIDDLE_M2, (2, 1) );
- CHECK_ATTRIBUTES ("ST_MIDDLE_M3", FA_ST_MIDDLE_M3, (2, 1) );
- CHECK_ATTRIBUTES ("ST_DECIMAL_M7", FA_ST_DECIMAL_M7, (5, 1) );
- CHECK_ATTRIBUTES ("ST_DECIMAL_M3", FA_ST_DECIMAL_M3, (4, 1) );
-
- RESULT;
-
-END C35A05N;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada b/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada
deleted file mode 100644
index 3a88ffb..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- C35A05Q.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 FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD
--- THE CORRECT VALUES.
-
--- CASE Q: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC,
--- FOR GENERICS.
-
--- WRG 8/20/86
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-PROCEDURE C35A05Q IS
-
- PI : CONSTANT := 3.14159_26535_89793_23846;
- TWO_PI : CONSTANT := 2 * PI;
- HALF_PI : CONSTANT := PI / 2;
-
- MM : CONSTANT := 23;
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE MICRO_ANGLE_ERROR_M15 IS
- DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19;
- TYPE TRACK_RANGE_M15 IS
- DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12;
- TYPE SECONDS_MM IS
- DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8;
- TYPE RANGE_CELL_MM IS
- DELTA 2.0 ** (-5)
- RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5);
-
- TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0;
- TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0;
-
- TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0;
- TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0;
-
- TYPE SYMMETRIC_DEGREES_M7 IS
- DELTA 2.0 RANGE -180.0 .. 180.0;
- TYPE NATURAL_DEGREES_M15 IS
- DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0;
- TYPE SYMMETRIC_RADIANS_M16 IS
- DELTA PI * 2.0 ** (-15) RANGE -PI .. PI;
- TYPE NATURAL_RADIANS_M8 IS
- DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI;
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_MILES_M8 IS MILES_M16
- DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0;
- SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15
- DELTA 0.25 RANGE 0.0 .. 360.0;
- SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16
- DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI;
-
- -------------------------------------------------------------------
-
- TYPE FORE_AND_AFT IS
- RECORD
- FORE, AFT : INTEGER;
- END RECORD;
-
- GENERIC
- TYPE T IS DELTA <>;
- FUNCTION ATTRIBUTES RETURN FORE_AND_AFT;
-
- FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS
- BEGIN
- RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) );
- END ATTRIBUTES;
-
- -------------------------------------------------------------------
-
- PROCEDURE CHECK_ATTRIBUTES
- (NAME : STRING;
- ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS
- BEGIN
- IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN
- FAILED ("GENERIC 'FORE FOR " & NAME & " =" &
- INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) );
- END IF;
- IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN
- FAILED ("GENERIC 'AFT FOR " & NAME & " =" &
- INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) );
- END IF;
- END CHECK_ATTRIBUTES;
-
- -------------------------------------------------------------------
-
- FUNCTION FA_MICRO_ANGLE_ERROR_M15
- IS NEW ATTRIBUTES(MICRO_ANGLE_ERROR_M15 );
- FUNCTION FA_TRACK_RANGE_M15
- IS NEW ATTRIBUTES(TRACK_RANGE_M15 );
- FUNCTION FA_SECONDS_MM IS NEW ATTRIBUTES(SECONDS_MM );
- FUNCTION FA_RANGE_CELL_MM
- IS NEW ATTRIBUTES(RANGE_CELL_MM );
- FUNCTION FA_PIXEL_M10 IS NEW ATTRIBUTES(PIXEL_M10 );
- FUNCTION FA_RULER_M8 IS NEW ATTRIBUTES(RULER_M8 );
- FUNCTION FA_HOURS_M16 IS NEW ATTRIBUTES(HOURS_M16 );
- FUNCTION FA_MILES_M16 IS NEW ATTRIBUTES(MILES_M16 );
- FUNCTION FA_SYMMETRIC_DEGREES_M7
- IS NEW ATTRIBUTES(SYMMETRIC_DEGREES_M7 );
- FUNCTION FA_NATURAL_DEGREES_M15
- IS NEW ATTRIBUTES(NATURAL_DEGREES_M15 );
- FUNCTION FA_SYMMETRIC_RADIANS_M16
- IS NEW ATTRIBUTES(SYMMETRIC_RADIANS_M16 );
- FUNCTION FA_NATURAL_RADIANS_M8
- IS NEW ATTRIBUTES(NATURAL_RADIANS_M8 );
- FUNCTION FA_ST_MILES_M8 IS NEW ATTRIBUTES(ST_MILES_M8 );
- FUNCTION FA_ST_NATURAL_DEGREES_M11
- IS NEW ATTRIBUTES(ST_NATURAL_DEGREES_M11 );
- FUNCTION FA_ST_SYMMETRIC_RADIANS_M8
- IS NEW ATTRIBUTES(ST_SYMMETRIC_RADIANS_M8);
-
-BEGIN
-
- TEST ("C35A05Q", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " &
- "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " &
- "TYPICAL TYPES, GENERICS");
-
- CHECK_ATTRIBUTES ("MICRO_ANGLE_ERROR_M15",
- FA_MICRO_ANGLE_ERROR_M15, (7, 1) );
-
- CHECK_ATTRIBUTES ("TRACK_RANGE_M15", FA_TRACK_RANGE_M15, (5, 1) );
-
- CHECK_ATTRIBUTES ("SECONDS_MM", FA_SECONDS_MM, (4, 5) );
-
- CHECK_ATTRIBUTES ("RANGE_CELL_MM", FA_RANGE_CELL_MM, (7, 2) );
-
- CHECK_ATTRIBUTES ("PIXEL_M10", FA_PIXEL_M10, (2, 4) );
-
- CHECK_ATTRIBUTES ("RULER_M8", FA_RULER_M8, (3, 2) );
-
- CHECK_ATTRIBUTES ("HOURS_M16", FA_HOURS_M16, (3, 4) );
-
- CHECK_ATTRIBUTES ("MILES_M16", FA_MILES_M16, (5, 2) );
-
- CHECK_ATTRIBUTES ("SYMMETRIC_DEGREES_M7",
- FA_SYMMETRIC_DEGREES_M7, (4, 1) );
-
- CHECK_ATTRIBUTES ("NATURAL_DEGREES_M15",
- FA_NATURAL_DEGREES_M15, (4, 2) );
-
- CHECK_ATTRIBUTES ("SYMMETRIC_RADIANS_M16",
- FA_SYMMETRIC_RADIANS_M16, (2, 5) );
-
- CHECK_ATTRIBUTES ("NATURAL_RADIANS_M8",
- FA_NATURAL_RADIANS_M8, (2, 2) );
-
- CHECK_ATTRIBUTES ("ST_MILES_M8", FA_ST_MILES_M8, (3, 2) );
-
- CHECK_ATTRIBUTES ("ST_NATURAL_DEGREES_M11",
- FA_ST_NATURAL_DEGREES_M11, (4, 1) );
-
- CHECK_ATTRIBUTES ("ST_SYMMETRIC_RADIANS_M8",
- FA_ST_SYMMETRIC_RADIANS_M8, (2, 2) );
-
- RESULT;
-
-END C35A05Q;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada b/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada
deleted file mode 100644
index ae7baf6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C35A07A.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 FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD
--- CORRECT VALUES.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- WRG 8/25/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C35A07A IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5;
- TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0;
- TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
- TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0;
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
- -- LARGEST MODEL NUMBER IS 960.0.
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15
- DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0;
- SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23
- DELTA 0.5 RANGE 0.0 .. 2.5;
- SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18
- DELTA 10.0 RANGE -1000.0 .. 1000.0;
- -- LARGEST MODEL NUMBER IS 1016.0.
- SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4
- DELTA 100.0 RANGE -500.0 .. 500.0;
- -- LARGEST MODEL NUMBER IS 448.0.
- SUBTYPE ST_MIDDLE_M15 IS MIDDLE_M15
- RANGE 6.0 .. 3.0;
-
-BEGIN
-
- TEST ("C35A07A", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " &
- "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " &
- "BASIC TYPES");
-
- -------------------------------------------------------------------
-
-
- IF MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("MIDDLE_M3'FIRST /= 0.0");
- END IF;
- IF MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN
- FAILED ("MIDDLE_M3'LAST /= 2.5");
- END IF;
-
- -------------------------------------------------------------------
-
-
- IF LIKE_DURATION_M23'FIRST /= IDENT_INT (1) * (-86_400.0) THEN
- FAILED ("LIKE_DURATION_M23'FIRST /= -86_400.0");
- END IF;
- IF LIKE_DURATION_M23'LAST /= IDENT_INT (1) * 86_400.0 THEN
- FAILED ("LIKE_DURATION_M23'LAST /= 86_400.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF DECIMAL_M18'FIRST /= IDENT_INT (1) * (-10_000.0) THEN
- FAILED ("DECIMAL_M18'FIRST /= -10_000.0");
- END IF;
- IF DECIMAL_M18'LAST /= IDENT_INT (1) * 10_000.0 THEN
- FAILED ("DECIMAL_M18'LAST /= 10_000.0");
- END IF;
-
- -------------------------------------------------------------------
-
-
- IF ST_MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("ST_MIDDLE_M3'FIRST /= 0.0");
- END IF;
- IF ST_MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN
- FAILED ("ST_MIDDLE_M3'LAST /= 2.5");
- END IF;
-
- -------------------------------------------------------------------
-
- IF ST_DECIMAL_M7'FIRST /= IDENT_INT (1) * (-1000.0) THEN
- FAILED ("ST_DECIMAL_M7'FIRST /= -1000.0");
- END IF;
- IF ST_DECIMAL_M7'LAST /= IDENT_INT (1) * 1000.0 THEN
- FAILED ("ST_DECIMAL_M7'LAST /= 1000.0");
- END IF;
-
- -------------------------------------------------------------------
-
-
- IF ST_MIDDLE_M15'FIRST /= IDENT_INT (1) * 6.0 THEN
- FAILED ("ST_MIDDLE_M15'FIRST /= 6.0");
- END IF;
- IF ST_MIDDLE_M15'LAST /= IDENT_INT (1) * 3.0 THEN
- FAILED ("ST_MIDDLE_M15'LAST /= 3.0");
- END IF;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C35A07A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada b/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada
deleted file mode 100644
index 1a293cc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C35A07D.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 FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD
--- CORRECT VALUES.
-
--- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC.
-
--- WRG 8/25/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-PROCEDURE C35A07D IS
-
- PI : CONSTANT := 3.14159_26535_89793_23846;
- TWO_PI : CONSTANT := 2 * PI;
- HALF_PI : CONSTANT := PI / 2;
-
- MM : CONSTANT := MAX_MANTISSA;
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0;
- TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0;
-
- TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0;
- TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0;
-
- TYPE SYMMETRIC_DEGREES_M7 IS
- DELTA 2.0 RANGE -180.0 .. 180.0;
- TYPE NATURAL_DEGREES_M15 IS
- DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0;
- TYPE SYMMETRIC_RADIANS_M16 IS
- DELTA PI * 2.0 ** (-15) RANGE -PI .. PI;
- -- 'SMALL = 2.0 ** (-14) = 0.00006_10351_5625.
- TYPE NATURAL_RADIANS_M8 IS
- DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI;
- -- 'SMALL = 2.0 ** ( -5) = 0.03125.
-
- -------------------------------------------------------------------
-
- SUBTYPE ST_MILES_M8 IS MILES_M16
- DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0;
- SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15
- DELTA 0.25 RANGE 0.0 .. 360.0;
- SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16
- DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI;
- -- 'SMALL = 2.0 ** ( -7) = 0.00781_25.
-
-BEGIN
-
- TEST ("C35A07D", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " &
- "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " &
- "TYPICAL TYPES");
-
- -------------------------------------------------------------------
-
-
- IF PIXEL_M10'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("PIXEL_M10'FIRST /= 0.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF RULER_M8'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("RULER_M8'FIRST /= 0.0");
- END IF;
- IF RULER_M8'LAST /= IDENT_INT (1) * 12.0 THEN
- FAILED ("RULER_M8'LAST /= 12.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF HOURS_M16'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("HOURS_M16'FIRST /= 0.0");
- END IF;
- IF HOURS_M16'LAST /= IDENT_INT (1) * 24.0 THEN
- FAILED ("HOURS_M16'LAST /= 24.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF MILES_M16'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("MILES_M16'FIRST /= 0.0");
- END IF;
- IF MILES_M16'LAST /= IDENT_INT (1) * 3000.0 THEN
- FAILED ("MILES_M16'LAST /= 3000.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF SYMMETRIC_DEGREES_M7'FIRST /= IDENT_INT (1) * (-180.0) THEN
- FAILED ("SYMMETRIC_DEGREES_M7'FIRST /= -180.0");
- END IF;
- IF SYMMETRIC_DEGREES_M7'LAST /= IDENT_INT (1) * 180.0 THEN
- FAILED ("SYMMETRIC_DEGREES_M7'LAST /= 180.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF NATURAL_DEGREES_M15'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("NATURAL_DEGREES_M15'FIRST /= 0.0");
- END IF;
- IF NATURAL_DEGREES_M15'LAST /= IDENT_INT (1) * 360.0 THEN
- FAILED ("NATURAL_DEGREES_M15'LAST /= 360.0");
- END IF;
-
- -------------------------------------------------------------------
-
- -- PI IS IN 3.0 + 2319 * 'SMALL .. 3.0 + 2320 * 'SMALL.
- IF SYMMETRIC_RADIANS_M16'FIRST NOT IN
- -3.14160_15625 .. -3.14154_05273_4375 THEN
- FAILED ("SYMMETRIC_RADIANS_M16'FIRST NOT IN " &
- "-3.14160_15625 .. -3.14154_05273_4375");
- END IF;
- IF SYMMETRIC_RADIANS_M16'LAST NOT IN
- 3.14154_05273_4375 .. 3.14160_15625 THEN
- FAILED ("SYMMETRIC_RADIANS_M16'LAST NOT IN " &
- "3.14154_05273_4375 .. 3.14160_15625");
- END IF;
-
- -------------------------------------------------------------------
-
- IF NATURAL_RADIANS_M8'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("NATURAL_RADIANS_M8'FIRST /= 0.0");
- END IF;
- -- TWO_PI IS IN 201 * 'SMALL .. 202 * 'SMALL.
- IF NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125 THEN
- FAILED ("NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125");
- END IF;
-
- -------------------------------------------------------------------
-
- IF ST_MILES_M8'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("ST_MILES_M8'FIRST /= 0.0");
- END IF;
- IF ST_MILES_M8'LAST /= IDENT_INT (1) * 10.0 THEN
- FAILED ("ST_MILES_M8'LAST /= 10.0");
- END IF;
-
- -------------------------------------------------------------------
-
- IF ST_NATURAL_DEGREES_M11'FIRST /= IDENT_INT (1) * 0.0 THEN
- FAILED ("ST_NATURAL_DEGREES_M11'FIRST /= 0.0");
- END IF;
- IF ST_NATURAL_DEGREES_M11'LAST /= IDENT_INT (1) * 360.0 THEN
- FAILED ("ST_NATURAL_DEGREES_M11'LAST /= 360.0");
- END IF;
-
- -------------------------------------------------------------------
-
- -- HALF_PI IS IN 201 * 'SMALL .. 202 * 'SMALL.
- IF ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN
- -1.57812_5 .. -1.57031_25 THEN
- FAILED ("ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN " &
- "-1.57812_5 .. -1.57031_25");
- END IF;
- IF ST_SYMMETRIC_RADIANS_M8'LAST NOT IN
- 1.57031_25 .. 1.57812_5 THEN
- FAILED ("ST_SYMMETRIC_RADIANS_M8'LAST NOT IN " &
- "1.57031_25 .. 1.57812_5");
- END IF;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C35A07D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada b/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada
deleted file mode 100644
index 1750bfa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- C35A08B.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 MULTIPLICATION AND DIVISION OPERATORS FOR TWO
--- FIXED POINT OPERANDS ARE DECLARED IN STANDARD AND ARE DIRECTLY
--- VISIBLE.
-
--- HISTORY:
--- BCB 01/21/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C35A08B IS
-
- PACKAGE P IS
- TYPE T1 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0;
- TYPE T2 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0;
- END P;
- USE P;
-
- X1 : P.T1 := 6.0;
- X2 : P.T1 := 2.0;
- X3 : P.T1;
- X4 : P.T1;
- X5 : P.T1;
- X6 : P.T1;
-
- X7 : P.T2 := 2.0;
-
- FUNCTION IDENT_FIXED(X : P.T1) RETURN P.T1 IS
- BEGIN
- RETURN X * IDENT_INT(1);
- END IDENT_FIXED;
-
-BEGIN
- TEST ("C35A08B", "CHECK THAT THE MULTIPLICATION AND DIVISION " &
- "OPERATORS FOR TWO FIXED POINT OPERANDS ARE " &
- "DECLARED IN STANDARD AND ARE DIRECTLY VISIBLE");
-
- X3 := P.T1 (X1 * X2);
- X4 := P.T1 (X1 / X2);
-
- X5 := P.T1 (STANDARD."*" (X1,X2));
- X6 := P.T1 (STANDARD."/" (X1,X2));
-
- IF X3 /= IDENT_FIXED (12.0) THEN
- FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 1");
- END IF;
-
- IF X4 /= IDENT_FIXED (3.0) THEN
- FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 1");
- END IF;
-
- X3 := P.T1 (X1 * X7);
- X4 := P.T1 (X1 / X7);
-
- X5 := P.T1 (STANDARD."*" (X1,X7));
- X6 := P.T1 (STANDARD."/" (X1,X7));
-
- IF X3 /= IDENT_FIXED (12.0) THEN
- FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 2");
- END IF;
-
- IF X4 /= IDENT_FIXED (3.0) THEN
- FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 2");
- END IF;
-
- RESULT;
-END C35A08B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c360002.a b/gcc/testsuite/ada/acats/tests/c3/c360002.a
deleted file mode 100644
index 95cb3ef..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c360002.a
+++ /dev/null
@@ -1,268 +0,0 @@
--- C360002.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 modular types may be used as array indices.
---
--- Check that if aliased appears in the component_definition of an
--- array_type that each component of the array is aliased.
---
--- Check that references to aliased array objects produce correct
--- results, and that out-of-bounds indexing correctly produces
--- Constraint_Error.
---
--- TEST DESCRIPTION:
--- This test defines several array types and subtypes indexed by modular
--- types; some aliased some not, some with aliased components, some not.
---
--- It then checks that assignments move the correct data.
---
---
--- CHANGE HISTORY:
--- 28 SEP 95 SAIC Initial version
--- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict
--- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code
---!
-
-------------------------------------------------------------------- C360002
-
-with Report;
-
-procedure C360002 is
-
- Verbose : Boolean := Report.Ident_Bool( False );
-
- type Mod_128 is mod 128;
-
- function Ident_128( I: Integer ) return Mod_128 is
- begin
- return Mod_128( Report.Ident_Int( I ) );
- end Ident_128;
-
- type Unconstrained_Array
- is array( Mod_128 range <> ) of Integer;
-
- type Unconstrained_Array_Aliased
- is array( Mod_128 range <> ) of aliased Integer;
-
- type Access_All_Unconstrained_Array
- is access all Unconstrained_Array;
-
- type Access_All_Unconstrained_Array_Aliased
- is access all Unconstrained_Array_Aliased;
-
- subtype Array_01_10
- is Unconstrained_Array(01..10);
-
- subtype Array_11_20
- is Unconstrained_Array(11..20);
-
- subtype Array_Aliased_01_10
- is Unconstrained_Array_Aliased(01..10);
-
- subtype Array_Aliased_11_20
- is Unconstrained_Array_Aliased(11..20);
-
- subtype Access_All_01_10_Array
- is Access_All_Unconstrained_Array(01..10);
-
- subtype Access_All_01_10_Array_Aliased
- is Access_All_Unconstrained_Array_Aliased(01..10);
-
- subtype Access_All_11_20_Array
- is Access_All_Unconstrained_Array(11..20);
-
- subtype Access_All_11_20_Array_Aliased
- is Access_All_Unconstrained_Array_Aliased(11..20);
-
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- -- these 'filler' functions create unique values for every element that
- -- is used and/or tested in this test.
-
- Well_Bottom : Integer := 0;
-
- function Filler( Size : Mod_128 ) return Unconstrained_Array is
- It : Unconstrained_Array( 0..Size-1 );
- begin
- for Eyes in It'Range loop
- It(Eyes) := Integer( Eyes ) + Well_Bottom;
- end loop;
- Well_Bottom := Well_Bottom + It'Length;
- return It;
- end Filler;
-
- function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is
- It : Unconstrained_Array_Aliased( 0..Size-1 );
- begin
- for Ayes in It'Range loop
- It(Ayes) := Integer( Ayes ) + Well_Bottom;
- end loop;
- Well_Bottom := Well_Bottom + It'Length;
- return It;
- end Filler;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- An_Integer : Integer;
-
- type AAI is access all Integer;
-
- An_Integer_Access : AAI;
-
- Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9
-
- Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding)
-
- Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29
-
- Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39
-
- Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49
-
- Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59
-
- Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10
- := Filler(10); -- 60..69
-
- Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20
- := Filler(10); -- 70..79
-
- Check_Item : Access_All_Unconstrained_Array;
-
- Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- procedure Fail( Message : String; CI, SB : Integer ) is
- begin
- Report.Failed("Wrong value passed " & Message);
- if Verbose then
- Report.Comment("got" & Integer'Image(CI) &
- " should be" & Integer'Image(SB) );
- end if;
- end Fail;
-
- procedure Check_Array_01_10( Checked_Item : Array_01_10;
- Low_SB : Integer ) is
- begin
- for Index in Checked_Item'Range loop
- if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then
- Fail("unaliased 1..10", Checked_Item(Index),
- (Low_SB +Integer(Index)-1));
- end if;
- end loop;
- end Check_Array_01_10;
-
- procedure Check_Array_11_20( Checked_Item : Array_11_20;
- Low_SB : Integer ) is
- begin
- for Index in Checked_Item'Range loop
- if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then
- Fail("unaliased 11..20", Checked_Item(Index),
- (Low_SB +Integer(Index)-11));
- end if;
- end loop;
- end Check_Array_11_20;
-
- procedure Check_Single_Integer( The_Integer, SB : Integer;
- Message : String ) is
- begin
- if The_Integer /= SB then
- Report.Failed("Wrong integer value for " & Message );
- end if;
- end Check_Single_Integer;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C360002", "Check that modular types may be used as array " &
- "indices. Check that if aliased appears in " &
- "the component_definition of an array_type that " &
- "each component of the array is aliased. Check " &
- "that references to aliased array objects " &
- "produce correct results, and that out of bound " &
- "references to aliased objects correctly " &
- "produce Constraint_Error" );
- -- start with checks that the Filler assignments produced the expected
- -- result. This is a "case 0" test to check that nothing REALLY surprising
- -- is happening
-
- Check_Array_01_10( Array_Item_01_10, 0 );
- Check_Array_11_20( Array_Item_11_20, 10 );
-
- -- check that having the variable aliased makes no difference
- Check_Array_01_10( Aliased_Array_Item_01_10, 40 );
- Check_Array_11_20( Aliased_Array_Item_11_20, 50 );
-
- -- now check that conversion between array types where the only
- -- difference in the definitions is that the components are aliased works
-
- Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 );
- Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 );
-
- -- check that conversion of an aliased object with aliased components
- -- also works
-
- Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ),
- 60 );
- Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
- 70 );
-
- -- check that the bounds will slide
-
- Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 );
- Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 );
-
- -- point at some of the components and check them
-
- An_Integer_Access := Array_Aliased_Item_01_10(5)'Access;
-
- Check_Single_Integer( An_Integer_Access.all, 24,
- "Aliased component 'Access");
-
- An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access;
-
- Check_Single_Integer( An_Integer_Access.all, 66,
- "Aliased Aliased component 'Access");
-
- -- check some assignments
-
- Array_Item_01_10 := Aliased_Array_Item_01_10;
- Check_Array_01_10( Array_Item_01_10, 40 );
-
- Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20);
- Check_Array_01_10( Aliased_Array_Item_01_10, 50 );
-
- Aliased_Array_Aliased_Item_11_20(11..20)
- := Aliased_Array_Aliased_Item_01_10;
- Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
- 60 );
-
- Report.Result;
-
-end C360002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36104a.ada b/gcc/testsuite/ada/acats/tests/c3/c36104a.ada
deleted file mode 100644
index 4cdaccd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36104a.ada
+++ /dev/null
@@ -1,359 +0,0 @@
--- C36104A.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 OR NOT, AS APPROPRIATE,
--- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS,
--- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES,
--- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS,
--- WHERE AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE.
--- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT
--- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES.
--- ONLY STATIC CASES ARE CHECKED HERE.
-
--- DAT 2/3/81
--- JRK 2/25/81
--- VKG 1/21/83
--- L.BROWN 7/15/86 1) ADDED ACCESS TYPES.
--- 2) DELETED "NULL INDEX RANGES, CONSTRAINT_ERROR
--- RAISED" SECTION.
--- 3) DELETED ANY MENTION OF CASE STATEMENT CHOICES
--- AND VARIANT CHOICES IN THE ABOVE COMMENT.
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C36104A IS
-
- USE REPORT;
-
- TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK;
- SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI;
- SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU;
-
- TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10;
- TYPE I_10 IS NEW INT_10;
- SUBTYPE I_5 IS I_10 RANGE -5 .. 5;
- TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5;
-
-BEGIN
- TEST ("C36104A", "CONSTRAINT_ERROR IS RAISED OR NOT IN STATIC "
- & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS");
-
- -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED.
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5;
- -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID
- -- OPTIMIZATION OF SUBTYPE
- A1 : A := (OTHERS => I_5(IDENT_INT(1)));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " &
- I_5'IMAGE(A1(1)) ); --USE A1
- END;
- EXCEPTION
- --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS
- --REPORT FAILED.
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 1");
- END;
-
- BEGIN
- FOR I IN MID_WEEK RANGE MON .. MON LOOP
- FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
- END LOOP;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE P IS ACCESS I_5_ARRAY (I_5 RANGE 0 .. 6);
- -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- TYPE PA IS NEW P;
- -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID
- -- OPTIMIZATION OF TYPE
- PA1 : PA := NEW I_5_ARRAY'(0 .. I_5(IDENT_INT(6)) =>
- I_5(IDENT_INT(1)));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " &
- I_5'IMAGE(PA1(1))); --USE PA1
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 4");
- END;
-
- DECLARE
- W : WEEK_ARRAY (MID_WEEK);
- BEGIN
- W := (MID_WEEK RANGE MON .. WED => WED);
- -- CONSTRAINT_ERROR RAISED.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " &
- MID_WEEK'IMAGE(W(WED))); --USE W
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 7");
- END;
-
- DECLARE
- W : WEEK_ARRAY (WORK_WEEK);
- BEGIN
- W := (W'RANGE => WED); -- OK.
- W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
- MID_WEEK'IMAGE(W(WED))); --USE W
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI);
- -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR.
- BEGIN
- W := (W'RANGE => WED); -- OK.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " &
- MID_WEEK'IMAGE(W(WED))); --USE W
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 9");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. TUE);
- -- RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- W1 : W := (OTHERS => WED);
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " &
- MID_WEEK'IMAGE(W1(WED))); --USE W1
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 10");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. WED);
- -- RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- W1 : W := (OTHERS => (WED));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
- MID_WEEK'IMAGE(W1(WED))); --USE W1
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 11");
- END;
-
- -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED.
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (I_5 RANGE -5 .. -6) OF I_5;
- A1 : A;
- BEGIN
- IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN
- FAILED ("'FIRST OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 1");
- END;
-
- BEGIN
- FOR I IN MID_WEEK RANGE SAT .. SUN LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN MID_WEEK RANGE FRI .. WED LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN MID_WEEK RANGE MON .. SUN LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN I_5 RANGE 10 .. -10 LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN I_5 RANGE 10 .. 9 LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN I_5 RANGE -10 .. -11 LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN I_5 RANGE -10 .. -20 LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- FOR I IN I_5 RANGE 6 .. 5 LOOP
- FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
- END LOOP;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE P IS ACCESS I_5_ARRAY (-5 .. -6);
- PA1 : P := NEW I_5_ARRAY (-5 .. -6);
- BEGIN
- IF PA1'LENGTH /= IDENT_INT(0) THEN
- FAILED ("'LENGTH OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 5");
- END;
-
- DECLARE
- TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- SUBTYPE SNARR IS INTEGER RANGE 1 .. 2;
- W : NARR(SNARR) := (1,2);
- BEGIN
- IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN
- FAILED("EVALUATION OF EXPRESSION IS INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 7");
- END;
-
- DECLARE
- W : WEEK_ARRAY (MID_WEEK);
- BEGIN
- W := (W'RANGE => WED); -- OK.
- W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN);
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN);
- BEGIN
- IF (W'FIRST /= MON) THEN
- FAILED ("'FIRST OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
- W1 : W;
- BEGIN
- IF (W1'FIRST /= TUE) THEN
- FAILED ("'FIRST OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
- W1 : W;
- BEGIN
- IF (W1'FIRST /= TUE) THEN
- FAILED ("'FIRST OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 12");
- END;
-
- -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED.
-
- BEGIN
- IF SUN IN SAT .. SUN
- OR SAT IN FRI .. WED
- OR WED IN THU .. TUE
- OR THU IN MON .. SUN
- OR FRI IN SAT .. FRI
- OR WED IN FRI .. MON
- THEN
- FAILED ("INCORRECT 'IN' EVALUATION 1");
- END IF;
-
- IF INTEGER'(0) IN 10 .. -10
- OR INTEGER'(0) IN 10 .. 9
- OR INTEGER'(0) IN -10 .. -11
- OR INTEGER'(0) IN -10 .. -20
- OR INTEGER'(0) IN 6 .. 5
- OR INTEGER'(0) IN 5 .. 3
- OR INTEGER'(0) IN 7 .. 3
- THEN
- FAILED ("INCORRECT 'IN' EVALUATION 2");
- END IF;
-
- IF WED NOT IN THU .. TUE
- AND INTEGER'(0) NOT IN 4 .. -4
- THEN NULL;
- ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 52");
- END;
-
-
- RESULT;
-END C36104A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36104b.ada b/gcc/testsuite/ada/acats/tests/c3/c36104b.ada
deleted file mode 100644
index 9c896b9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36104b.ada
+++ /dev/null
@@ -1,421 +0,0 @@
--- C36104B.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 OR NOT, AS APPROPRIATE,
--- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS,
--- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES,
--- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, WHERE
--- AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE.
--- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT
--- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES.
--- ONLY DYNAMIC CASES ARE CHECKED HERE.
-
--- DAT 2/3/81
--- JRK 2/25/81
--- L.BROWN 7/15/86 1) ADDED ACCESS TYPES.
--- 2) DELETED "NULL INDEX RANGE, CONSTRAINT_ERROR
--- RAISED" SECTION.
--- 3) MADE USE OF DYNAMIC-RESULT FUNCTIONS.
--- 4) DELETED ALL REFERENCES TO CASE STATEMENT CHOICES
--- AND VARIANT PART CHOICES IN THE ABOVE COMMENT.
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C36104B IS
-
- USE REPORT;
-
- TYPE WEEK IS (SSUN, SMON, STUE, SWED, STHU, SFRI, SSAT);
- SUN : WEEK := WEEK'VAL(IDENT_INT(0));
- MON : WEEK := WEEK'VAL(IDENT_INT(1));
- TUE : WEEK := WEEK'VAL(IDENT_INT(2));
- WED : WEEK := WEEK'VAL(IDENT_INT(3));
- THU : WEEK := WEEK'VAL(IDENT_INT(4));
- FRI : WEEK := WEEK'VAL(IDENT_INT(5));
- SAT : WEEK := WEEK'VAL(IDENT_INT(6));
- TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK;
- SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI;
- SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU;
-
- TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10;
- TYPE I_10 IS NEW INT_10;
- SUBTYPE I_5 IS I_10 RANGE I_10(IDENT_INT(-5)) ..
- I_10(IDENT_INT(5));
- TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5;
-
- FUNCTION F(DAY : WEEK) RETURN WEEK IS
- BEGIN
- RETURN DAY;
- END;
-
-BEGIN
- TEST ("C36104B", "CONSTRAINT_ERROR IS RAISED OR NOT IN DYNAMIC "
- & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS");
-
- -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED.
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5;
- -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID
- -- OPTIMIZATION OF SUBTYPE
- A1 : A := (A'RANGE => I_5(IDENT_INT(1)));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " &
- I_5'IMAGE(A1(1)) ); --USE A1
- END;
- EXCEPTION
- --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS
- --REPORT FAILED.
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 1");
- END;
-
- BEGIN
- FOR I IN MID_WEEK RANGE MON .. MON LOOP
-
- IF EQUAL(2,2) THEN
- SAT := SSAT;
- END IF;
-
- END LOOP;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE P IS ACCESS I_5_ARRAY (0 .. 6);
- -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- TYPE PA IS NEW P;
- -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID
- -- OPTIMIZATION OF TYPE
- PA1 : PA :=NEW I_5_ARRAY'(0.. I_5(IDENT_INT(6)) =>
- I_5(IDENT_INT(1)));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " &
- I_5'IMAGE(PA1(1))); --USE PA1
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 4");
- END;
-
- DECLARE
- W : WEEK_ARRAY (MID_WEEK);
- BEGIN
- W := (MID_WEEK RANGE MON .. WED => WED);
- -- CONSTRAINT_ERROR RAISED.
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " &
- MID_WEEK'IMAGE(W(WED))); --USE W
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 7");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 7");
- END;
-
- DECLARE
- W : WEEK_ARRAY (WORK_WEEK);
- BEGIN
- W := (W'RANGE => WED); -- OK.
- W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION.
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
- MID_WEEK'IMAGE(W(WED))); --USE W
- EXCEPTION
- WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI);
- -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR.
- BEGIN
- W(WED) := THU; -- OK.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " &
- WEEK'IMAGE(W(WED))); -- USE W
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. WED);
- -- RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- X : W; -- OK.
- BEGIN
- X(TUE) := THU; -- OK.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " &
- WEEK'IMAGE(X(TUE))); -- USE X
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. THU);
- -- RAISES CONSTRAINT_ERROR.
- BEGIN
- DECLARE
- T : W; -- OK.
- BEGIN
- T(TUE) := THU; -- OK.
- FAILED ("CONSTRAINT_ERROR NOT RAISED 11 " &
- WEEK'IMAGE(T(TUE)));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 11");
- END;
-
- -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED.
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (I_5 RANGE I_5(IDENT_INT(-5)) .. -6) OF I_5;
- A1 : A;
- BEGIN
- IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN
- FAILED ("'FIRST OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 1");
- END;
-
- BEGIN
- FOR I IN MID_WEEK RANGE SAT .. SUN LOOP
-
- IF EQUAL(2,2) THEN
- TUE := STUE;
- END IF;
-
- END LOOP;
- FOR I IN MID_WEEK RANGE FRI .. WED LOOP
-
- IF EQUAL(2,2) THEN
- MON := SMON;
- END IF;
-
- END LOOP;
- FOR I IN MID_WEEK RANGE MON .. SUN LOOP
-
- IF EQUAL(3,3) THEN
- WED := SWED;
- END IF;
-
- END LOOP;
- FOR I IN I_5 RANGE 10 .. -10 LOOP
-
- IF EQUAL(2,2) THEN
- TUE := STUE;
- END IF;
-
- END LOOP;
- FOR I IN I_5 RANGE 10 .. 9 LOOP
-
- IF EQUAL(2,2) THEN
- THU := STHU;
- END IF;
-
- END LOOP;
- FOR I IN I_5 RANGE -10 .. -11 LOOP
-
- IF EQUAL(2,2) THEN
- SAT := SSAT;
- END IF;
-
- END LOOP;
- FOR I IN I_5 RANGE -10 .. -20 LOOP
-
- IF EQUAL(2,2) THEN
- SUN := SSUN;
- END IF;
-
- END LOOP;
- FOR I IN I_5 RANGE 6 .. 5 LOOP
-
- IF EQUAL(2,2) THEN
- MON := SMON;
- END IF;
-
- END LOOP;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE P IS ACCESS I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6);
- PA1 : P := NEW I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6);
- BEGIN
- IF PA1'LENGTH /= IDENT_INT(0) THEN
- FAILED ("'LENGTH OF NULL ARRAY INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 5");
- END;
-
- DECLARE
- TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- SUBTYPE SNARR IS INTEGER RANGE 1 .. 2;
- W : NARR(SNARR) := (1,2);
- BEGIN
- IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN
- FAILED("EVALUATION OF EXPRESSION IS INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 7");
- END;
-
- DECLARE
- W : WEEK_ARRAY (MID_WEEK);
- BEGIN
- W := (W'RANGE => WED); -- OK.
- W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN);
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN);
- BEGIN
-
- IF EQUAL(W'LENGTH,0) THEN
- TUE := STUE;
- END IF;
-
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
- BEGIN
-
- IF EQUAL(W'LENGTH,0) THEN
- MON := SMON;
- END IF;
-
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
- BEGIN
-
- IF EQUAL(W'LENGTH,0) THEN
- WED := SWED;
- END IF;
-
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 12");
- END;
-
- -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED.
-
- BEGIN
- IF F(SUN) IN SAT .. SUN
- OR SAT IN FRI .. WED
- OR F(WED) IN THU .. TUE
- OR THU IN MON .. SUN
- OR F(FRI) IN SAT .. FRI
- OR WED IN FRI .. MON
- THEN
- FAILED ("INCORRECT 'IN' EVALUATION 1");
- END IF;
-
- IF IDENT_INT(0) IN 10 .. IDENT_INT(-10)
- OR 0 IN IDENT_INT(10) .. 9
- OR IDENT_INT(0) IN IDENT_INT(-10) .. -11
- OR 0 IN -10 .. IDENT_INT(-20)
- OR IDENT_INT(0) IN 6 .. IDENT_INT(5)
- OR 0 IN 5 .. IDENT_INT(3)
- OR IDENT_INT(0) IN 7 .. IDENT_INT(3)
- THEN
- FAILED ("INCORRECT 'IN' EVALUATION 2");
- END IF;
-
- IF F(WED) NOT IN THU .. TUE
- AND IDENT_INT(0) NOT IN IDENT_INT(4) .. -4
- THEN NULL;
- ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 52");
- END;
-
- RESULT;
-END C36104B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36172a.ada b/gcc/testsuite/ada/acats/tests/c3/c36172a.ada
deleted file mode 100644
index 9c9e6cf..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36172a.ada
+++ /dev/null
@@ -1,250 +0,0 @@
--- C36172A.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 APPROPRIATELY
--- ON DISCRETE_RANGES USED AS INDEX_CONSTRAINTS.
-
--- DAT 2/9/81
--- SPS 4/7/82
--- JBG 6/5/85
-
-WITH REPORT;
-PROCEDURE C36172A IS
-
- USE REPORT;
-
- SUBTYPE INT_10 IS INTEGER RANGE 1 .. 10;
- TYPE A IS ARRAY (INT_10 RANGE <> ) OF INTEGER;
-
- SUBTYPE INT_11 IS INTEGER RANGE 0 .. 11;
- SUBTYPE NULL_6_4 IS INTEGER RANGE 6 .. 4;
- SUBTYPE NULL_11_10 IS INTEGER RANGE 11 .. 10;
- SUBTYPE INT_9_11 IS INTEGER RANGE 9 .. 11;
-
- TYPE A_9_11 IS ARRAY (9..11) OF BOOLEAN;
- TYPE A_11_10 IS ARRAY (11 .. 10) OF INTEGER;
- SUBTYPE A_1_10 IS A(INT_10);
-
-BEGIN
- TEST ("C36172A", "CONSTRAINT_ERROR IS RAISED APPROPRIATELY" &
- " FOR INDEX_RANGES");
-
- BEGIN
- DECLARE
- V : A (9 .. 11);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("OUT-OF-BOUNDS INDEX_RANGE 1");
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION 1");
- END;
-
- BEGIN
- DECLARE
- V : A (11 .. 10);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 2");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 2");
- END;
-
- BEGIN
- DECLARE
- V : A (6 .. 4);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 3");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 3");
- END;
-
- BEGIN
- DECLARE
- V : A (INT_9_11);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("OUT-OF-BOUNDS INDEX RANGE 4");
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION 4");
- END;
-
- BEGIN
- DECLARE
- V : A (NULL_11_10);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 5");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 5");
- END;
-
- BEGIN
- DECLARE
- V : A (NULL_6_4);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 6");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 6");
- END;
-
- BEGIN
- DECLARE
- V : A (INT_9_11 RANGE 10 .. 11);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("BAD NON-NULL INDEX RANGE 7");
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION 7");
- END;
-
- BEGIN
- DECLARE
- V : A (NULL_11_10 RANGE 11 .. 10);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 8");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 8");
- END;
-
- BEGIN
- DECLARE
- V : A (NULL_6_4 RANGE 6 .. 4);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 9");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 9");
- END;
-
- BEGIN
- DECLARE
- V : A (A_9_11'RANGE);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("BAD INDEX RANGE 10");
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION 10");
- END;
-
- BEGIN
- DECLARE
- V : A (A_11_10'RANGE);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 11");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 11");
- END;
-
- BEGIN
- DECLARE
- V : A (6 .. 4);
- BEGIN
- IF EQUAL (V'FIRST, V'FIRST) THEN
- NULL;
- ELSE
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " &
- "RAISED INAPPROPRIATELY 12");
- WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " &
- "SHOULD BE 12");
- END;
-
- RESULT;
-END C36172A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36172b.ada b/gcc/testsuite/ada/acats/tests/c3/c36172b.ada
deleted file mode 100644
index bf689b4256..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36172b.ada
+++ /dev/null
@@ -1,161 +0,0 @@
--- C36172B.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 A MULTIDIMENSIONAL INDEX
--- CONSTRAINT IF ONE OF THE RANGES IS A NULL RANGE AND THE OTHER IS A
--- NON-NULL RANGE WITH A BOUND THAT LIES OUTSIDE THE INDEX SUBTYPE.
-
--- CHECK THAT NO EXCEPTION IS RAISED IF ALL DISCRETE RANGES ARE NULL.
-
--- JBG 6/5/85
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C36172B IS
- SUBTYPE INT_10 IS INTEGER RANGE 1..10;
- TYPE ARR2 IS ARRAY (INT_10 RANGE <>, INT_10 RANGE <>) OF INTEGER;
-BEGIN
- TEST ("C36172B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " &
- "NON-NULL DIMENSION OF A NULL MULTIDIMENSIONAL " &
- "INDEX CONSTRAINT IF A BOUND LIES OUTSIDE THE " &
- "INDEX SUBTYPE");
-
- BEGIN
- DECLARE
- V : ARR2 (6..4, 9..11);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (13) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 13");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (0..3, 8..7);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (14) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 14");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (6..4, IDENT_INT(0)..2);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (15) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 15");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (9..IDENT_INT(11), 6..4);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (16) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 16");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (6..IDENT_INT(4), 9..IDENT_INT(11));
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (17) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 17");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (IDENT_INT(-1)..2, IDENT_INT(6)..4);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " &
- "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " &
- "THE INDEX SUBTYPE (18) " & INTEGER'IMAGE(V'FIRST));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 18");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (6..-1, 11..9);
- BEGIN
- IF NOT EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 19");
- END;
-
- BEGIN
- DECLARE
- V : ARR2 (IDENT_INT(11)..9, 6..IDENT_INT(0));
- BEGIN
- IF NOT EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 20");
- END;
-
- RESULT;
-END C36172B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36172c.ada b/gcc/testsuite/ada/acats/tests/c3/c36172c.ada
deleted file mode 100644
index 4d97fa1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36172c.ada
+++ /dev/null
@@ -1,58 +0,0 @@
--- C36172C.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 EXCEPTION IS RAISED FOR A NULL ARRAY WHOSE DIFFERENCE
--- IN BOUNDS LIES OUTSIDE THE INDEX BASE TYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- JBG 6/5/85
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C36172C IS
-BEGIN
- TEST ("C36172C", "CHECK THAT NO EXCEPTION IS RAISED FOR A NULL " &
- "ARRAY WHOSE DIFFERENCE IN BOUNDS LIES OUTSIDE " &
- "THE INDEX BASE TYPE");
-
- BEGIN
- DECLARE
- V : STRING (INTEGER'LAST .. -2);
- BEGIN
- IF NOT EQUAL (V'FIRST, V'FIRST) THEN
- FAILED ("IMPOSSIBLE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END;
-
- RESULT;
-END C36172C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36174a.ada b/gcc/testsuite/ada/acats/tests/c3/c36174a.ada
deleted file mode 100644
index 667512a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36174a.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- C36174A.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 INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS.
-
--- DAT 2/9/81
--- JBG 12/8/83
-
-
-WITH REPORT;
-PROCEDURE C36174A IS
-
- USE REPORT;
-
- S0 : CONSTANT STRING := "";
- S1 : CONSTANT STRING := S0;
- S2 : CONSTANT STRING := (1 .. 0 => 'Z');
- S3 : CONSTANT STRING := ('A', 'B', 'C');
- S4 : CONSTANT STRING := S3 & "ABC" & S3 & S2 & "Z";
- S9 : CONSTANT STRING := S0 & S1 & S2 & S3(3..1);
-
- TYPE A4 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>,
- INTEGER RANGE <>, INTEGER RANGE <>) OF STRING (1 .. 0);
- C4 : CONSTANT A4 :=
- (-6 .. -4 =>
- (4 .. 5 =>
- (-4 .. -5 =>
- (1000 .. 2000 =>
- S9))));
- S10 : CONSTANT STRING := (10 .. 9 => 'Q');
-
- TYPE I_12 IS NEW INTEGER RANGE 10 .. 12;
- TYPE A_12 IS ARRAY (I_12 RANGE <>, I_12 RANGE <>) OF I_12;
- A12 : CONSTANT A_12 :=
- (11 .. 12 => (10 .. 10 => 10));
- B12 : CONSTANT A_12 :=
- (11 => (10 | 12 => 10, 11 => 11),
- 10 => (10 | 12 | 11 => 12));
-
- N6 : CONSTANT INTEGER := IDENT_INT (6);
- S6 : CONSTANT STRING := (N6 .. N6 + 6 => 'Z');
- S7 : CONSTANT STRING := S6 (N6 .. N6 + IDENT_INT (-1));
-
-BEGIN
- TEST ("C36174A", "INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS");
-
- IF S0'FIRST /= 1 OR S0'LAST /= 0
- OR S1'FIRST /= 1 OR S1'LAST /= 0
- OR S2'FIRST /= 1 OR S2'LAST /= 0
- OR S3'FIRST /= 1 OR S3'LAST /= 3
- THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 1");
- END IF;
-
- IF S4'FIRST /= 1 OR S4'LAST /= 10 THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 2");
- END IF;
-
- IF S9'FIRST /= 3 OR S9'LAST /= 1 THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 3");
- END IF;
-
- IF C4'FIRST(1) /= -6 OR C4'LAST(1) /= -4
- OR C4'FIRST(2) /= 4 OR C4'LAST(2) /= 5
- OR C4'FIRST(3) /= -4 OR C4'LAST(3) /= -5
- OR C4'FIRST(4) /= 1000 OR C4'LAST(4) /= 2000
- THEN
- FAILED ("INVALID ARRAY CONSTANT BOUNDS");
- END IF;
-
- IF S10'FIRST /= 10 OR S10'LAST /= 9
- THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 10");
- END IF;
-
- IF A12'FIRST /= 11 OR A12'LAST /= 12
- OR A12'FIRST(2) /= 10 OR A12'LAST(2) /= 10
- THEN FAILED ("INVALID ARRAY CONSTANT BOUNDS 2");
- END IF;
-
- IF B12'FIRST /= 10 OR B12'LAST /= 11
- OR B12'FIRST(2) /= 10 OR B12'LAST(2) /= 12
- THEN
- FAILED ("INVALID ARRAY CONSTANT BOUNDS 3");
- END IF;
-
- IF S6'FIRST /= 6 OR S6'LAST /= 12 OR S6'LENGTH /= 7
- THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 12");
- END IF;
-
- IF S7'FIRST /= 6 OR S7'LAST /= 5 THEN
- FAILED ("INVALID STRING CONSTANT BOUNDS 13");
- END IF;
-
- RESULT;
-END C36174A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36180a.ada b/gcc/testsuite/ada/acats/tests/c3/c36180a.ada
deleted file mode 100644
index 5538096..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36180a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C36180A.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 INDEX CONSTRAINT CAN HAVE THE FORM A'RANGE,
--- WHERE A IS A PREVIOUSLY DECLARED ARRAY OBJECT OR CONSTRAINED
--- ARRAY SUBTYPE.
-
--- HISTORY:
--- BCB 01/21/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C36180A IS
-
- TYPE J IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE K IS ARRAY (1..10) OF INTEGER;
-
- SUBTYPE A IS J (0 .. 50);
-
- SUBTYPE W IS J (A'RANGE);
-
- SUBTYPE X IS J (K'RANGE);
-
- TYPE Y IS ACCESS J;
-
- TYPE Z IS ACCESS J;
-
- TYPE F IS NEW J (A'RANGE);
-
- TYPE G IS NEW J (K'RANGE);
-
- B : ARRAY (A'RANGE) OF INTEGER;
-
- C : ARRAY (K'RANGE) OF INTEGER;
-
- D : ARRAY (1 .. 10) OF INTEGER;
-
- E : ARRAY (D'RANGE) OF INTEGER;
-
- H : J (A'RANGE);
-
- I : J (K'RANGE);
-
- L : J (D'RANGE);
-
- V1 : W;
-
- V2 : X;
-
- V3 : Y := NEW J (A'RANGE);
-
- V4 : Z := NEW J (K'RANGE);
-
- V5 : F;
-
- V6 : G;
-
-BEGIN
- TEST ("C36180A", "CHECK THAT AN INDEX CONSTRAINT CAN HAVE THE " &
- "FORM A'RANGE, WHERE A IS A PREVIOUSLY " &
- "DECLARED ARRAY OBJECT OR CONSTRAINED ARRAY " &
- "SUBTYPE");
-
- IF B'FIRST /= IDENT_INT (0) OR B'LAST /= IDENT_INT (50)
- THEN FAILED ("IMPROPER VALUE FOR B'FIRST OR B'LAST");
- END IF;
-
- IF C'FIRST /= IDENT_INT (1) OR C'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR C'FIRST OR C'LAST");
- END IF;
-
- IF E'FIRST /= IDENT_INT (1) OR E'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR E'FIRST OR E'LAST");
- END IF;
-
- IF H'FIRST /= IDENT_INT (0) OR H'LAST /= IDENT_INT (50)
- THEN FAILED ("IMPROPER VALUE FOR H'FIRST OR H'LAST");
- END IF;
-
- IF I'FIRST /= IDENT_INT (1) OR I'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR I'FIRST OR I'LAST");
- END IF;
-
- IF L'FIRST /= IDENT_INT (1) OR L'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR L'FIRST OR L'LAST");
- END IF;
-
- IF V1'FIRST /= IDENT_INT (0) OR V1'LAST /= IDENT_INT (50)
- THEN FAILED ("IMPROPER VALUE FOR V1'FIRST OR V1'LAST");
- END IF;
-
- IF V2'FIRST /= IDENT_INT (1) OR V2'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR V2'FIRST OR V2'LAST");
- END IF;
-
- IF V3.ALL'FIRST /= IDENT_INT (0) OR V3.ALL'LAST /= IDENT_INT (50)
- THEN FAILED ("IMPROPER VALUE FOR V3'FIRST OR V3'LAST");
- END IF;
-
- IF V4.ALL'FIRST /= IDENT_INT (1) OR V4.ALL'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR V4'FIRST OR V4'LAST");
- END IF;
-
- IF V5'FIRST /= IDENT_INT (0) OR V5'LAST /= IDENT_INT (50)
- THEN FAILED ("IMPROPER VALUE FOR V5'FIRST OR V5'LAST");
- END IF;
-
- IF V6'FIRST /= IDENT_INT (1) OR V6'LAST /= IDENT_INT (10)
- THEN FAILED ("IMPROPER VALUE FOR V6'FIRST OR V6'LAST");
- END IF;
-
- RESULT;
-END C36180A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36202c.ada b/gcc/testsuite/ada/acats/tests/c3/c36202c.ada
deleted file mode 100644
index 03ca89e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36202c.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C36202C.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 'LENGTH DOES NOT RAISE AN EXCEPTION
--- WHEN APPLIED TO A NULL ARRAY A, EVEN IF A'LAST - A'FIRST
--- WOULD RAISE CONSTRAINT_ERROR.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- L.BROWN 07/29/86
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE C36202C IS
-
- TYPE LRG_INT IS RANGE MIN_INT .. MAX_INT;
-
- BEGIN
- TEST("C36202C", "NO EXCEPTION IS RAISED FOR 'LENGTH "&
- "WHEN APPLIED TO A NULL ARRAY");
-
- DECLARE
- TYPE LRG_ARR IS ARRAY
- (LRG_INT RANGE MAX_INT .. MIN_INT)
- OF INTEGER;
- LRG_OBJ : LRG_ARR;
-
- BEGIN
- IF LRG_OBJ'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR ONE-DIM NULL ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR WAS RAISED " &
- "FOR ONE-DIM NULL ARRAY");
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED FOR ONE-DIM " &
- "NULL ARRAY");
- END;
-
- DECLARE
- TYPE LRG2_ARR IS ARRAY (LRG_INT RANGE 1 .. 3 ,
- LRG_INT RANGE MAX_INT .. MIN_INT)
- OF INTEGER;
- BEGIN
- IF LRG2_ARR'LENGTH(2) /= 0 THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR TWO-DIM NULL ARRAY");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR WAS RAISED " &
- "FOR TWO-DIM NULL ARRAY");
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED FOR TWO-DIM " &
- "NULL ARRAY");
- END;
-
- RESULT;
-
- END C36202C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36203a.ada b/gcc/testsuite/ada/acats/tests/c3/c36203a.ada
deleted file mode 100644
index f3f7e2b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36203a.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- C36203A.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 'LENGTH YIELDS A RESULT OF TYPE UNIVERSAL INTEGER.
-
--- L.BROWN 07/31/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C36203A IS
-
- TYPE NINT IS NEW INTEGER RANGE 1 .. 5;
-
- TYPE INT_ARR IS ARRAY(INTEGER RANGE 1 .. 3) OF INTEGER;
- TYPE INT2_ARR IS ARRAY(INTEGER RANGE 1 .. 3,
- INTEGER RANGE 1 .. 2) OF INTEGER;
-
- OBJA : INTEGER := 3;
- OBJB : NINT := 3;
-
-BEGIN
- TEST("C36203A", "'LENGTH YIELDS A RESULT OF TYPE " &
- "UNIVERSAL INTEGER");
- IF (OBJA + INT_ARR'LENGTH) /= IDENT_INT(6) THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR ONE-DIM ARRAY TYPE 1");
- END IF;
-
- IF (OBJB + INT_ARR'LENGTH) /= 6 THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR ONE-DIM ARRAY TYPE 2");
- END IF;
-
- IF (OBJA + INT2_ARR'LENGTH(1)) /= IDENT_INT(6) THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 1");
- END IF;
-
- IF (OBJB + INT2_ARR'LENGTH(1)) /= 6 THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 2");
- END IF;
-
- IF (OBJA + INT2_ARR'LENGTH(2)) /= IDENT_INT(5) THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 1");
- END IF;
-
- IF (OBJB + INT2_ARR'LENGTH(2)) /= 5 THEN
- FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " &
- "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 2");
- END IF;
-
- RESULT;
-
-END C36203A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36204a.ada b/gcc/testsuite/ada/acats/tests/c3/c36204a.ada
deleted file mode 100644
index 4a4c374..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36204a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C36204A.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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES.
--- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED.
-
--- DAT 2/12/81
--- SPS 11/1/82
--- WMC 03/16/92 CREATED TYPE RANGE CHECK FOR AE_TYPE.
-
-WITH REPORT;
-PROCEDURE C36204A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C36204A", "ARRAY ATTRIBUTES RETURN CORRECT VALUES");
-
- DECLARE
- A1 : ARRAY (BOOLEAN,
- INTEGER RANGE IDENT_INT(1)..IDENT_INT(10))
- OF STRING(IDENT_INT(5)..IDENT_INT(7));
- TYPE NI IS RANGE -3 .. 3;
- N : NI := NI(IDENT_INT(2));
- SUBTYPE SNI IS NI RANGE -N .. N;
- TYPE AA IS ARRAY (NI, SNI, BOOLEAN)
- OF NI;
- A1_1_1 : BOOLEAN := A1'FIRST;
- A1_1_2 : BOOLEAN := A1'LAST(1);
- A1_2_1 : INTEGER RANGE A1'RANGE(2) := A1'FIRST(2); -- 1
- A1_2_2 : INTEGER RANGE A1'RANGE(2) := A1'LAST(2); -- 10
- SUBTYPE AE_TYPE IS INTEGER RANGE A1(TRUE,5)'RANGE; -- RANGE 5..7
- A2 : AA;
- A4 : ARRAY (A1_1_1 .. A1_1_2, A1_2_1 .. A1_2_2) OF
- STRING (IDENT_INT(1)..IDENT_INT(3));
-
- I : INTEGER;
- B : BOOLEAN;
- BEGIN
- IF A4'FIRST /= IDENT_BOOL(FALSE)
- OR A4'LAST /= IDENT_BOOL(TRUE)
- OR A4'FIRST(2) /= INTEGER'(1)
- OR A4'LAST(2) /= INTEGER'(10)
- THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST - 1");
- END IF;
-
- IF A4'LENGTH /= INTEGER'(2)
- OR A4'LENGTH /= NI'(2)
- OR A4'LENGTH(1) /= N
- OR A4'LENGTH(2) /= A4'LAST(2)
- THEN
- FAILED ("INCORRECT 'LENGTH - 1");
- END IF;
-
- A4 := (BOOLEAN => (1 .. 10 => "XYZ"));
- FOR L1 IN A1'RANGE(1) LOOP
- FOR L2 IN A4'RANGE(2) LOOP
- A1(L1,L2) := A4(L1,L2);
- END LOOP;
- END LOOP;
-
- IF AA'FIRST(1) /= NI'(-3)
- OR AA'LAST(1) /= N + 1
- OR AA'FIRST(2) /= -N
- OR AA'LAST(2) /= N
- OR AA'FIRST(3) /= IDENT_BOOL(FALSE)
- OR AA'LAST(3) /= IDENT_BOOL(TRUE)
- THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST - 2");
- END IF;
-
- IF N NOT IN AA'RANGE(2)
- OR IDENT_BOOL(FALSE) NOT IN AA'RANGE(3)
- OR N + 1 NOT IN AA'RANGE
- OR N + 1 IN AA'RANGE(2)
- THEN
- FAILED ("INCORRECT 'RANGE - 1");
- END IF;
-
- IF AA'LENGTH /= INTEGER'(7)
- OR AA'LENGTH(2) - 3 /= N
- OR AA'LENGTH(3) /= 2
- THEN
- FAILED ("INCORRECT 'LENGTH - 2");
- END IF;
-
- IF A2'FIRST(1) /= NI'(-3)
- OR A2'LAST(1) /= N + 1
- OR A2'FIRST(2) /= -N
- OR A2'LAST(2) /= N
- OR A2'FIRST(3) /= IDENT_BOOL(FALSE)
- OR A2'LAST(3) /= IDENT_BOOL(TRUE)
- THEN
- FAILED ("INCORRECT 'FIRST OR 'LAST - 3");
- END IF;
-
- IF N NOT IN A2'RANGE(2)
- OR IDENT_BOOL(FALSE) NOT IN A2'RANGE(3)
- OR N + 1 NOT IN A2'RANGE
- OR N + 1 IN A2'RANGE(2)
- THEN
- FAILED ("INCORRECT 'RANGE - 2");
- END IF;
-
- IF A2'LENGTH /= INTEGER'(7)
- OR A2'LENGTH(2) - 3 /= INTEGER(N)
- OR A2'LENGTH(3) /= 2
- THEN
- FAILED ("INCORRECT 'LENGTH - 3");
- END IF;
-
- IF (AE_TYPE'FIRST /= 5) OR (AE_TYPE'LAST /= 7) THEN
- FAILED ("INCORRECT TYPE RANGE DEFINED FOR AE_TYPE");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED ?");
- END;
-
- RESULT;
-END C36204A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36204b.ada b/gcc/testsuite/ada/acats/tests/c3/c36204b.ada
deleted file mode 100644
index 82f6b93..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36204b.ada
+++ /dev/null
@@ -1,229 +0,0 @@
--- C36204B.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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES WITH
--- ACCESS VALUES AND FUNCTION CALLS AS THE PREFIXES.
-
--- HISTORY:
--- L.BROWN 08/05/86
--- DWC 07/24/87 DELETED BLANK AT END OF TEST DESCRIPTION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C36204B IS
-
- BEGIN
- TEST("C36204B", "ARRAY ATTRIBUTES RETURN CORRECT VALUES " &
- "FOR ACCESS VALUES AND FUNCTION CALLS AS " &
- "PREFIXES");
- DECLARE
- TYPE ARR1 IS ARRAY (INTEGER RANGE IDENT_INT(1) ..
- IDENT_INT(10)) OF INTEGER ;
- TYPE ARR2 IS ARRAY (BOOLEAN,
- INTEGER RANGE IDENT_INT(1) ..
- IDENT_INT(3)) OF INTEGER ;
-
- TYPE PTR1 IS ACCESS ARR1;
- TYPE PTR2 IS ACCESS ARR2;
-
- PT1 : PTR1 := NEW ARR1'(ARR1'RANGE => 0);
- PT2 : PTR2 := NEW ARR2'(ARR2'RANGE(1) =>
- (ARR2'RANGE(2) => 0));
- SUBTYPE ARR1_RANGE IS INTEGER RANGE PT1'RANGE;
- BEGIN
- IF PT1'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 1");
- END IF;
-
- IF PT2'FIRST(2) /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 1");
- END IF;
-
- IF ARR1_RANGE'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 2");
- END IF;
-
- IF PT1'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 3");
- END IF;
-
- IF PT2'LAST(2) /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 2");
- END IF;
-
- IF ARR1_RANGE'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 4");
- END IF;
-
- IF PT1'LENGTH /= IDENT_INT(10) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 5");
- END IF;
-
- IF PT2'LENGTH(2) /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING ACCESS TYPES AS PREFIXES 3");
- END IF;
-
- END;
-
- DECLARE
-
- TYPE UNCON IS ARRAY (INTEGER RANGE <>) OF INTEGER ;
- TYPE UNCON2 IS ARRAY (INTEGER RANGE <>,
- INTEGER RANGE <>) OF INTEGER ;
-
- ARY1 : STRING(IDENT_INT(5) .. IDENT_INT(8));
- F : INTEGER := IDENT_INT(1);
- L : INTEGER := IDENT_INT(3);
-
- FUNCTION FUN( LO,HI : INTEGER ) RETURN UNCON IS
- ARR : UNCON(IDENT_INT(LO) .. IDENT_INT(HI));
- BEGIN
- ARR := (ARR'RANGE => 0);
- RETURN ARR;
- END FUN;
-
- FUNCTION FUN2( LO,HI : INTEGER ) RETURN UNCON2 IS
- AR2 : UNCON2(IDENT_INT(LO) .. IDENT_INT(HI),
- IDENT_INT(LO) .. IDENT_INT(HI));
- BEGIN
- AR2 := (AR2'RANGE(1) =>(AR2'RANGE(2) => 0));
- RETURN AR2;
- END FUN2;
- BEGIN
-
- ARY1 := (ARY1'RANGE => 'A');
-
- IF FUN(F,L)'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 1");
- END IF;
-
- IF FUN2(F,L)'FIRST(2) /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 1");
- END IF;
-
- IF "&"(ARY1,"XX")'FIRST /= IDENT_INT(5) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 2");
- END IF;
-
- IF FUN(F,L)'LAST /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 3");
- END IF;
-
- IF FUN2(F,L)'LAST(2) /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 2");
- END IF;
-
- IF "&"(ARY1,"YY")'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 4");
- END IF;
-
- IF FUN(F,L)'LENGTH /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 5");
- END IF;
-
- IF FUN2(F,L)'LENGTH(2) /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 3");
- END IF;
-
- IF "&"(ARY1,"XX")'LENGTH /= IDENT_INT(6) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " &
- "ARRAY USING FUNCTION RESULTS AS " &
- "PREFIXES 6");
- END IF;
-
- DECLARE
-
- SUBTYPE SMIN IS INTEGER RANGE FUN(F,L)'RANGE;
- SUBTYPE SMIN2 IS INTEGER RANGE FUN2(F,L)'RANGE(2);
- SUBTYPE SMIN3 IS INTEGER RANGE "&"(ARY1,"YY")'RANGE;
-
- BEGIN
- IF SMIN'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "ONE-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 7");
- END IF;
-
- IF SMIN2'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "TWO-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 4");
- END IF;
-
- IF SMIN3'FIRST /= IDENT_INT(5) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "ONE-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 8");
- END IF;
-
- IF SMIN'LAST /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "ONE-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 9");
- END IF;
-
- IF SMIN2'LAST /= IDENT_INT(3) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "TWO-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 5");
- END IF;
-
- IF SMIN3'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT ATTRIBUTE VALUE FOR " &
- "ONE-DIM ARRAY USING FUNCTION " &
- "RESULTS AS PREFIXES 10");
- END IF;
-
- END;
-
- END;
-
- RESULT;
-
- END C36204B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36204c.ada b/gcc/testsuite/ada/acats/tests/c3/c36204c.ada
deleted file mode 100644
index 1713695..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36204c.ada
+++ /dev/null
@@ -1,221 +0,0 @@
--- C36204C.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 'RANGE ATTRIBUTE CAN BE USED TO DECLARE OBJECTS
--- AND IN A SUBTYPE AND TYPE DECLARATION.
-
--- HISTORY:
--- LB 08/13/86 CREATED ORIGINAL TEST.
--- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT.
--- REARRANGED STATEMENTS SO TEST IS CALLED FIRST.
--- ELIMINATED DEAD VARIABLE OPTIMIZATION. CHECKED
--- RANGE VALUES FOR A SMALL INTEGER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C36204C IS
-
-BEGIN
- TEST("C36204C","USING 'RANGE TO DECLARE OBJECTS AND " &
- "IN A SUBTYPE AND TYPE DECLARATION " &
- "RETURNS THE CORRECT VALUES.");
-
- DECLARE
-
- ARR : ARRAY(IDENT_INT(4) .. IDENT_INT(10)) OF INTEGER;
- OBJ1 : ARRAY(ARR'RANGE) OF BOOLEAN;
-
- SUBTYPE SMALL_INT IS INTEGER RANGE ARR'RANGE ;
- SML : SMALL_INT;
-
- TYPE OTHER_ARR IS ARRAY(ARR'RANGE) OF CHARACTER;
- OBJ2 : OTHER_ARR;
-
- TYPE ARR_TYPE IS ARRAY(INTEGER RANGE IDENT_INT(1) ..
- IDENT_INT(10)) OF INTEGER;
- TYPE ARR_PTR IS ACCESS ARR_TYPE;
- PTR : ARR_PTR := NEW ARR_TYPE'(ARR_TYPE'RANGE => 0);
-
- FUNCTION F RETURN ARR_TYPE IS
- AR : ARR_TYPE := (ARR_TYPE'RANGE => 0);
- BEGIN
- RETURN AR;
- END F;
-
- BEGIN
- BEGIN
- IF OBJ1'FIRST /= IDENT_INT(4) THEN
- FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " &
- "DECLARATION 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING " &
- "OBJECT DECLARATION 1");
- END;
-
- BEGIN
- IF OBJ1'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " &
- "DECLARATION 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING " &
- "OBJECT DECLARATION 2");
- END;
-
- BEGIN
- IF SMALL_INT'FIRST /= 4 THEN
- FAILED("INCORRECT RANGE VALUE FOR A SMALL " &
- "INTEGER DECLARATION 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" &
- " INTEGER DECLARATION 1");
- END;
-
- BEGIN
- IF SMALL_INT'LAST /= 10 THEN
- FAILED("INCORRECT RANGE VALUE FOR A SMALL " &
- "INTEGER DECLARATION 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" &
- " INTEGER DECLARATION 2");
- END;
-
- BEGIN
- SML := IDENT_INT(3) ;
- IF SML = 3 THEN
- COMMENT("VARIABLE SML OPTIMIZED VALUE 1");
- END IF;
- FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " &
- "VALUE 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " &
- "RANGE VALUE 1");
- END;
-
- BEGIN
- SML := IDENT_INT(11) ;
- IF SML = 11 THEN
- COMMENT("VARIABLE SML OPTIMIZED VALUE 2");
- END IF;
- FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " &
- "VALUE 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " &
- "RANGE VALUE 2");
- END;
-
- BEGIN
- IF OBJ2'FIRST /= IDENT_INT(4) THEN
- FAILED("INCORRECT RANGE VALUE FOR A TYPE " &
- "DECLARATION 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING A " &
- "TYPE DECLARATION 1");
- END;
-
- BEGIN
- IF OBJ2'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT RANGE VALUE FOR A TYPE " &
- "DECLARATION 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING A " &
- "TYPE DECLARATION 2");
- END;
-
- BEGIN
- IF PTR'FIRST /= IDENT_INT(1) THEN
- FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " &
- "TYPE DECLARATION 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING AN " &
- "ACCESS TYPE DECLARATION 1");
- END;
-
- BEGIN
- IF PTR'LAST /= IDENT_INT(10) THEN
- FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " &
- "TYPE DECLARATION 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHEN CHECKING AN " &
- "ACCESS TYPE DECLARATION 2");
- END;
-
- DECLARE
- OBJ_F1 : INTEGER RANGE F'RANGE ;
- BEGIN
- OBJ_F1 := IDENT_INT(0) ;
- IF OBJ_F1 = 0 THEN
- COMMENT("VARIABLE OBJ_F1 OPTIMIZED VALUE 1");
- END IF;
- FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " &
- "VALUE 3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " &
- "RANGE VALUE 3");
- END;
-
- DECLARE
- OBJ_F2 : INTEGER RANGE F'RANGE ;
- BEGIN
- OBJ_F2 := IDENT_INT(11) ;
- IF OBJ_F2 = 11 THEN
- COMMENT("VARIABLE OBJ_F2 OPTIMIZED VALUE 1");
- END IF;
- FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " &
- "VALUE 4");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " &
- "RANGE VALUE 4");
- END;
- END;
- RESULT;
-
-END C36204C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36204d.ada b/gcc/testsuite/ada/acats/tests/c3/c36204d.ada
deleted file mode 100644
index afdadbf..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36204d.ada
+++ /dev/null
@@ -1,598 +0,0 @@
--- C36204D.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 EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES.
--- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. THIS TEST CHECKS
--- THE ABOVE FOR ARRAYS WITHIN GENERIC PROGRAM UNITS.
-
--- HISTROY
--- EDWARD V. BERARD, 9 AUGUST 1990
-
-WITH REPORT ;
-WITH SYSTEM ;
-
-PROCEDURE C36204D IS
-
- SHORT_START : CONSTANT := -10 ;
- SHORT_END : CONSTANT := 10 ;
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
- SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- SUBTYPE MID_YEAR IS MONTH_TYPE RANGE MAY .. AUG ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 10,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (DAY => 6,
- MONTH => JUN,
- YEAR => 1967) ;
-
- FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ;
- RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN
- RENAMES SYSTEM."=" ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- FIRST_INDEX_LENGTH : IN NATURAL ;
- FIRST_TEST_VALUE : IN FIRST_INDEX ;
- TYPE SECOND_INDEX IS (<>) ;
- SECOND_INDEX_LENGTH : IN NATURAL ;
- SECOND_TEST_VALUE : IN SECOND_INDEX ;
- TYPE THIRD_INDEX IS (<>) ;
- THIRD_INDEX_LENGTH : IN NATURAL ;
- THIRD_TEST_VALUE : IN THIRD_INDEX ;
- TYPE FIRST_COMPONENT_TYPE IS PRIVATE ;
- FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- TYPE SECOND_COMPONENT_TYPE IS PRIVATE ;
- THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
- FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
-
- PACKAGE ARRAY_ATTRIBUTE_TEST IS
-
- TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX)
- OF FIRST_COMPONENT_TYPE ;
-
- TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX)
- OF SECOND_COMPONENT_TYPE ;
-
- END ARRAY_ATTRIBUTE_TEST ;
-
- PACKAGE BODY ARRAY_ATTRIBUTE_TEST IS
-
- FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- FIRST_DEFAULT_VALUE)) ;
-
- SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- THIRD_DEFAULT_VALUE))) ;
-
- THIRD_ARRAY : CONSTANT MATRIX
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- SECOND_DEFAULT_VALUE)) ;
-
- FOURTH_ARRAY : CONSTANT CUBE
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- FOURTH_DEFAULT_VALUE))) ;
-
- FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ;
- FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ;
- FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ;
- FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ;
-
- SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ;
- SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ;
- SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ;
- SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ;
- SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ;
- SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ;
-
- FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ;
- FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ;
-
- SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ;
- SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ;
- SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ;
-
- MATRIX_SIZE : NATURAL := MATRIX'SIZE ;
- CUBE_SIZE : NATURAL := CUBE'SIZE ;
-
- FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ;
- SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ;
- TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ;
- FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ;
-
- BEGIN -- ARRAY_ATTRIBUTE_TEST
-
- IF (FA1 /= FIRST_INDEX'FIRST) OR
- (FA3 /= SECOND_INDEX'FIRST) OR
- (SA1 /= FIRST_INDEX'FIRST) OR
- (SA3 /= SECOND_INDEX'FIRST) OR
- (SA5 /= THIRD_INDEX'FIRST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST - PACKAGE") ;
- END IF ;
-
- IF (FA2 /= FIRST_INDEX'LAST) OR
- (FA4 /= SECOND_INDEX'LAST) OR
- (SA2 /= FIRST_INDEX'LAST) OR
- (SA4 /= SECOND_INDEX'LAST) OR
- (SA6 /= THIRD_INDEX'LAST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST - PACKAGE") ;
- END IF ;
-
- IF (FAL1 /= FIRST_INDEX_LENGTH) OR
- (FAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL1 /= FIRST_INDEX_LENGTH) OR
- (SAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL3 /= THIRD_INDEX_LENGTH) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH - PACKAGE") ;
- END IF ;
-
- FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP
- FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP
- FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) :=
- SECOND_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
-
- IF FIRST_ARRAY /= THIRD_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 2-DIMENSIONAL ARRAY. - PACKAGE") ;
- END IF ;
-
- FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP
- FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP
- FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP
- SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX)
- := FOURTH_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
- END LOOP ;
-
- IF SECOND_ARRAY /= FOURTH_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 3-DIMENSIONAL ARRAY. - PACKAGE") ;
- END IF ;
-
- IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR
- (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR
- (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR
- (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR
- (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "- PACKAGE") ;
- END IF ;
-
- IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " &
- "- PACKAGE") ;
- END IF ;
-
- IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA)
- OR (SAA = TAA) OR (TAA = FRAA) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " &
- "- PACKAGE") ;
- END IF ;
-
- END ARRAY_ATTRIBUTE_TEST ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- FIRST_INDEX_LENGTH : IN NATURAL ;
- FIRST_TEST_VALUE : IN FIRST_INDEX ;
- TYPE SECOND_INDEX IS (<>) ;
- SECOND_INDEX_LENGTH : IN NATURAL ;
- SECOND_TEST_VALUE : IN SECOND_INDEX ;
- TYPE THIRD_INDEX IS (<>) ;
- THIRD_INDEX_LENGTH : IN NATURAL ;
- THIRD_TEST_VALUE : IN THIRD_INDEX ;
- TYPE FIRST_COMPONENT_TYPE IS PRIVATE ;
- FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- TYPE SECOND_COMPONENT_TYPE IS PRIVATE ;
- THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
- FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
-
- PROCEDURE PROC_ARRAY_ATT_TEST ;
-
- PROCEDURE PROC_ARRAY_ATT_TEST IS
-
- TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX)
- OF FIRST_COMPONENT_TYPE ;
-
- TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX)
- OF SECOND_COMPONENT_TYPE ;
-
- FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- FIRST_DEFAULT_VALUE)) ;
-
- SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- THIRD_DEFAULT_VALUE))) ;
-
- THIRD_ARRAY : CONSTANT MATRIX
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- SECOND_DEFAULT_VALUE)) ;
-
- FOURTH_ARRAY : CONSTANT CUBE
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- FOURTH_DEFAULT_VALUE))) ;
-
- FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ;
- FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ;
- FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ;
- FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ;
-
- SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ;
- SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ;
- SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ;
- SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ;
- SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ;
- SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ;
-
- FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ;
- FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ;
-
- SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ;
- SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ;
- SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ;
-
- MATRIX_SIZE : NATURAL := MATRIX'SIZE ;
- CUBE_SIZE : NATURAL := CUBE'SIZE ;
-
- FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ;
- SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ;
- TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ;
- FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ;
-
- BEGIN -- PROC_ARRAY_ATT_TEST
-
- IF (FA1 /= FIRST_INDEX'FIRST) OR
- (FA3 /= SECOND_INDEX'FIRST) OR
- (SA1 /= FIRST_INDEX'FIRST) OR
- (SA3 /= SECOND_INDEX'FIRST) OR
- (SA5 /= THIRD_INDEX'FIRST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " &
- "- PROCEDURE") ;
- END IF ;
-
- IF (FA2 /= FIRST_INDEX'LAST) OR
- (FA4 /= SECOND_INDEX'LAST) OR
- (SA2 /= FIRST_INDEX'LAST) OR
- (SA4 /= SECOND_INDEX'LAST) OR
- (SA6 /= THIRD_INDEX'LAST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " &
- "- PROCEDURE") ;
- END IF ;
-
- IF (FAL1 /= FIRST_INDEX_LENGTH) OR
- (FAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL1 /= FIRST_INDEX_LENGTH) OR
- (SAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL3 /= THIRD_INDEX_LENGTH) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " &
- "- PROCEDURE") ;
- END IF ;
-
- FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP
- FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP
- FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) :=
- SECOND_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
-
- IF FIRST_ARRAY /= THIRD_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 2-DIMENSIONAL ARRAY. - PROCEDURE") ;
- END IF ;
-
- FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP
- FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP
- FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP
- SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX)
- := FOURTH_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
- END LOOP ;
-
- IF SECOND_ARRAY /= FOURTH_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 3-DIMENSIONAL ARRAY. - PROCEDURE") ;
- END IF ;
-
- IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR
- (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR
- (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR
- (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR
- (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "- PROCEDURE") ;
- END IF ;
-
- IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " &
- "- PROCEDURE") ;
- END IF ;
-
- IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA)
- OR (SAA = TAA) OR (TAA = FRAA) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " &
- "- PROCEDURE") ;
- END IF ;
-
- END PROC_ARRAY_ATT_TEST ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- FIRST_INDEX_LENGTH : IN NATURAL ;
- FIRST_TEST_VALUE : IN FIRST_INDEX ;
- TYPE SECOND_INDEX IS (<>) ;
- SECOND_INDEX_LENGTH : IN NATURAL ;
- SECOND_TEST_VALUE : IN SECOND_INDEX ;
- TYPE THIRD_INDEX IS (<>) ;
- THIRD_INDEX_LENGTH : IN NATURAL ;
- THIRD_TEST_VALUE : IN THIRD_INDEX ;
- TYPE FIRST_COMPONENT_TYPE IS PRIVATE ;
- FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ;
- TYPE SECOND_COMPONENT_TYPE IS PRIVATE ;
- THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
- FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ;
-
- FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN ;
-
- FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN IS
-
- TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX)
- OF FIRST_COMPONENT_TYPE ;
-
- TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX)
- OF SECOND_COMPONENT_TYPE ;
-
- FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- FIRST_DEFAULT_VALUE)) ;
-
- SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- THIRD_DEFAULT_VALUE))) ;
-
- THIRD_ARRAY : CONSTANT MATRIX
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- SECOND_DEFAULT_VALUE)) ;
-
- FOURTH_ARRAY : CONSTANT CUBE
- := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST =>
- (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST =>
- (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST =>
- FOURTH_DEFAULT_VALUE))) ;
-
- FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ;
- FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ;
- FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ;
- FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ;
-
- SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ;
- SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ;
- SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ;
- SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ;
- SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ;
- SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ;
-
- FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ;
- FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ;
-
- SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ;
- SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ;
- SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ;
-
- MATRIX_SIZE : NATURAL := MATRIX'SIZE ;
- CUBE_SIZE : NATURAL := CUBE'SIZE ;
-
- FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ;
- SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ;
- TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ;
- FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ;
-
- BEGIN -- FUNC_ARRAY_ATT_TEST
-
- IF (FA1 /= FIRST_INDEX'FIRST) OR
- (FA3 /= SECOND_INDEX'FIRST) OR
- (SA1 /= FIRST_INDEX'FIRST) OR
- (SA3 /= SECOND_INDEX'FIRST) OR
- (SA5 /= THIRD_INDEX'FIRST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " &
- "- FUNCTION") ;
- END IF ;
-
- IF (FA2 /= FIRST_INDEX'LAST) OR
- (FA4 /= SECOND_INDEX'LAST) OR
- (SA2 /= FIRST_INDEX'LAST) OR
- (SA4 /= SECOND_INDEX'LAST) OR
- (SA6 /= THIRD_INDEX'LAST) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " &
- "- FUNCTION") ;
- END IF ;
-
- IF (FAL1 /= FIRST_INDEX_LENGTH) OR
- (FAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL1 /= FIRST_INDEX_LENGTH) OR
- (SAL2 /= SECOND_INDEX_LENGTH) OR
- (SAL3 /= THIRD_INDEX_LENGTH) THEN
- REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " &
- "- FUNCTION") ;
- END IF ;
-
- FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP
- FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP
- FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) :=
- SECOND_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
-
- IF FIRST_ARRAY /= THIRD_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 2-DIMENSIONAL ARRAY. - FUNCTION") ;
- END IF ;
-
- FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP
- FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP
- FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP
- SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX)
- := FOURTH_DEFAULT_VALUE ;
- END LOOP ;
- END LOOP ;
- END LOOP ;
-
- IF SECOND_ARRAY /= FOURTH_ARRAY THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "FOR 3-DIMENSIONAL ARRAY. - FUNCTION") ;
- END IF ;
-
- IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR
- (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR
- (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR
- (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR
- (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " &
- "- FUNCTION") ;
- END IF ;
-
- IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " &
- "- FUNCTION") ;
- END IF ;
-
- IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA)
- OR (SAA = TAA) OR (TAA = FRAA) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " &
- "- FUNCTION") ;
- END IF ;
-
- RETURN TRUE ;
-
- END FUNC_ARRAY_ATT_TEST ;
-
-
-BEGIN -- C36204D
-
- REPORT.TEST ("C36204D", "ARRAY ATTRIBUTES RETURN CORRECT " &
- "VALUES WITHIN GENERIC PROGRAM UNITS.") ;
-
- LOCAL_BLOCK:
-
- DECLARE
-
- DUMMY : BOOLEAN := FALSE ;
-
- PACKAGE NEW_ARRAY_ATTRIBUTE_TEST IS NEW ARRAY_ATTRIBUTE_TEST (
- FIRST_INDEX => SHORT_RANGE,
- FIRST_INDEX_LENGTH => SHORT_LENGTH,
- FIRST_TEST_VALUE => -7,
- SECOND_INDEX => MONTH_TYPE,
- SECOND_INDEX_LENGTH => 12,
- SECOND_TEST_VALUE => AUG,
- THIRD_INDEX => BOOLEAN,
- THIRD_INDEX_LENGTH => 2,
- THIRD_TEST_VALUE => FALSE,
- FIRST_COMPONENT_TYPE => MONTH_TYPE,
- FIRST_DEFAULT_VALUE => JAN,
- SECOND_DEFAULT_VALUE => DEC,
- SECOND_COMPONENT_TYPE => DATE,
- THIRD_DEFAULT_VALUE => TODAY,
- FOURTH_DEFAULT_VALUE => FIRST_DATE) ;
-
- PROCEDURE NEW_PROC_ARRAY_ATT_TEST IS NEW PROC_ARRAY_ATT_TEST (
- FIRST_INDEX => MONTH_TYPE,
- FIRST_INDEX_LENGTH => 12,
- FIRST_TEST_VALUE => AUG,
- SECOND_INDEX => SHORT_RANGE,
- SECOND_INDEX_LENGTH => SHORT_LENGTH,
- SECOND_TEST_VALUE => -7,
- THIRD_INDEX => BOOLEAN,
- THIRD_INDEX_LENGTH => 2,
- THIRD_TEST_VALUE => FALSE,
- FIRST_COMPONENT_TYPE => DATE,
- FIRST_DEFAULT_VALUE => TODAY,
- SECOND_DEFAULT_VALUE => FIRST_DATE,
- SECOND_COMPONENT_TYPE => MONTH_TYPE,
- THIRD_DEFAULT_VALUE => JAN,
- FOURTH_DEFAULT_VALUE => DEC) ;
-
- FUNCTION NEW_FUNC_ARRAY_ATT_TEST IS NEW FUNC_ARRAY_ATT_TEST (
- FIRST_INDEX => DAY_TYPE,
- FIRST_INDEX_LENGTH => 31,
- FIRST_TEST_VALUE => 25,
- SECOND_INDEX => SHORT_RANGE,
- SECOND_INDEX_LENGTH => SHORT_LENGTH,
- SECOND_TEST_VALUE => -7,
- THIRD_INDEX => MID_YEAR,
- THIRD_INDEX_LENGTH => 4,
- THIRD_TEST_VALUE => JUL,
- FIRST_COMPONENT_TYPE => DATE,
- FIRST_DEFAULT_VALUE => TODAY,
- SECOND_DEFAULT_VALUE => FIRST_DATE,
- SECOND_COMPONENT_TYPE => MONTH_TYPE,
- THIRD_DEFAULT_VALUE => JAN,
- FOURTH_DEFAULT_VALUE => DEC) ;
-
- BEGIN -- LOCAL_BLOCK
-
- NEW_PROC_ARRAY_ATT_TEST ;
-
- DUMMY := NEW_FUNC_ARRAY_ATT_TEST ;
- IF NOT DUMMY THEN
- REPORT.FAILED ("WRONG VALUE RETURNED BY FUNCTION.") ;
- END IF ;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT ;
-
-END C36204D ;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205a.ada b/gcc/testsuite/ada/acats/tests/c3/c36205a.ada
deleted file mode 100644
index 8c1f683..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205a.ada
+++ /dev/null
@@ -1,212 +0,0 @@
--- C36205A.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS
--- PARAMETERS
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205A IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205A", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - BASIC CHECKS");
-
- IF A10'FIRST /= 1
- OR A2_10'FIRST(1) /= 1
- OR A2_10'FIRST(2) /= IDENT_INT(13)
- OR A2_20'FIRST /= 11
- OR A2_20'FIRST(2) /= 21
- THEN
- FAILED ("'FIRST FOR OBJECTS IS WRONG");
- END IF;
-
-
- IF A10'LAST(1) /= 10
- OR A2_10'LAST /= 10
- OR A2_10'LAST(2) /= 20
- OR A2_20'LAST(1) /= 30
- OR A2_20'LAST(2) /= IDENT_INT(20)
- THEN
- FAILED ("'LAST FOR OBJECTS IS WRONG");
- END IF;
- IF A10'LENGTH /= IDENT_INT(10)
- OR A2_10'LENGTH(1) /= 10
- OR A2_10'LENGTH(2) /= IDENT_INT(8)
- OR A2_20'LENGTH /= 20
- OR A2_20'LENGTH(2) /= IDENT_INT(0)
- THEN
- FAILED ("'LENGTH FOR OBJECTS IS WRONG");
- END IF;
-
- IF 0 IN A10'RANGE
- OR IDENT_INT(11) IN A10'RANGE(1)
- OR IDENT_INT(0) IN A2_10'RANGE(1)
- OR 11 IN A2_10'RANGE
- OR 12 IN A2_10'RANGE(2)
- OR IDENT_INT(21) IN A2_10'RANGE(2)
- OR 10 IN A2_20'RANGE
- OR IDENT_INT(31) IN A2_20'RANGE(1)
- OR IDENT_INT(20) IN A2_20'RANGE(2)
- OR 0 IN A2_20'RANGE(2)
- THEN
- FAILED ("'RANGE FOR OBJECTS IS WRONG");
- END IF;
-
- P1 (A10, 1, 10, "P1 1");
- P1 (A20, 18, 20, "P1 A20");
- P2(A2_10, 1, 10, 13, 20, "P2 1");
- P2 (A2_20, 11, 30, 21, 20, "P2 2");
- S1 (ALF, 1, 5, "X0");
- S1 (ARF, 5, 9, "ARF1");
-
- RESULT;
-
-END C36205A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205b.ada b/gcc/testsuite/ada/acats/tests/c3/c36205b.ada
deleted file mode 100644
index b29816c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205b.ada
+++ /dev/null
@@ -1,169 +0,0 @@
--- C36205B.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF NON-NULL STATIC SLICES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205B IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205B", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - NON-NULL STATIC SLICES");
-
- P1 (A10(1 .. 10), 1, 10, "P1 2");
- P1 (A10(1..9), 1, 9, "P1 3");
- P1 (A10(2..10), 2, 10, "P1 4");
- P1 (A10 (2..9), 2, 9, "P1 5");
- P1 (A10 (4 .. 5), 4, 5, "P1 6");
- P1 (A10 (5 .. 5), 5, 5, "P1 7");
-
- RESULT;
-END C36205B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205c.ada b/gcc/testsuite/ada/acats/tests/c3/c36205c.ada
deleted file mode 100644
index b11363ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205c.ada
+++ /dev/null
@@ -1,165 +0,0 @@
--- C36205C.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF NON-NULL DYNAMIC SLICES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205C IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205C", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - NON-NULL DYNAMIC SLICES");
-
- P1 (A10 (I10..I10), 10, 10, "P1 8");
- P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9");
-
- RESULT;
-END C36205C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205d.ada b/gcc/testsuite/ada/acats/tests/c3/c36205d.ada
deleted file mode 100644
index f03f75d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205d.ada
+++ /dev/null
@@ -1,180 +0,0 @@
--- C36205D.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF NULL STATIC SLICES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205D IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205D", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - NULL STATIC SLICES");
-
- P1 (A10 (1 .. 0), 1, 0, "P1 11");
- P1 (A10 (2 .. 1), 2, 1, "P1 12");
-
- P1 (A10, 1, 10, "P1 1");
- P1 (A10(1 .. 10), 1, 10, "P1 2");
- P1 (A10(1..9), 1, 9, "P1 3");
- P1 (A10(2..10), 2, 10, "P1 4");
- P1 (A10 (2..9), 2, 9, "P1 5");
- P1 (A10 (4 .. 5), 4, 5, "P1 6");
- P1 (A10 (5 .. 5), 5, 5, "P1 7");
- P1 (A10 (I10..I10), 10, 10, "P1 8");
- P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9");
- P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10");
- P1 (A10 (9 .. 10), 9, 10, "P1 13");
- P1 (A10 (10 .. 9), 10, 9, "P1 14");
- P1 (A10 (9 .. I10 - 1), 9, 9, "P1 15");
- P1 (A10 (9 .. 8), 9, 8, "P1 16");
-
- RESULT;
-END C36205D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205e.ada b/gcc/testsuite/ada/acats/tests/c3/c36205e.ada
deleted file mode 100644
index f165a28..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205e.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C36205E.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF DYNAMIC NULL SLICES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205E IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205E", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - DYNAMIC NULL SLICES");
-
- P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10");
-
- RESULT;
-END C36205E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205f.ada b/gcc/testsuite/ada/acats/tests/c3/c36205f.ada
deleted file mode 100644
index 22e1c16..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205f.ada
+++ /dev/null
@@ -1,165 +0,0 @@
--- C36205F.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF STATIC NON-NULL AGGREGATES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205F IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205F", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - STATIC NON-NULL AGGREGATES");
-
- P1 ((3 .. 5 => 2), 3, 5, "P1 16");
- P1 ((5 .. 5 => 5), 5, 5, "P1 17");
-
- RESULT;
-END C36205F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205g.ada b/gcc/testsuite/ada/acats/tests/c3/c36205g.ada
deleted file mode 100644
index 93f5a2e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205g.ada
+++ /dev/null
@@ -1,165 +0,0 @@
--- C36205G.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF DYNAMIC NON-NULL AGGREGATES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205G IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205G", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - DYNAMIC NON-NULL AGGREGATES");
-
- P1 ((IDENT_INT(3) .. IDENT_INT(5) => 2), 3, 5, "P1 16");
- P1 ((IDENT_INT(5) .. 5 => 5), 5, 5, "P1 17");
-
- RESULT;
-END C36205G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205h.ada b/gcc/testsuite/ada/acats/tests/c3/c36205h.ada
deleted file mode 100644
index 00303bc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205h.ada
+++ /dev/null
@@ -1,166 +0,0 @@
--- C36205H.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF STATIC NULL AGGREGATES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205H IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205H", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - STATIC NULL AGGREGATES");
-
- P1 ((5 .. 4 => 4), 5, 4, "P1 18");
- P1 ((1 .. 0 => 0), 1, 0, "P1 19");
- P1 ((-12 .. -13 => 3), -12, -13, "P1 21");
-
- RESULT;
-END C36205H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205i.ada b/gcc/testsuite/ada/acats/tests/c3/c36205i.ada
deleted file mode 100644
index d61b3aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205i.ada
+++ /dev/null
@@ -1,167 +0,0 @@
--- C36205I.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF DYNAMIC NULL AGGREGATES
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205I IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- SUBTYPE STR IS STRING;
- ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE";
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205I", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - DYNAMIC NULL AGGREGATES");
-
-
- P1 ((IDENT_INT(5) .. IDENT_INT(4) => 4), 5, 4, "P1 18");
- P1 ((IDENT_INT(1) .. IDENT_INT(0) => 0), 1, 0, "P1 19");
- P1 ((IDENT_INT(-12) .. -13 => 3), -12, -13, "P1 21");
-
- RESULT;
-END C36205I;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205j.ada b/gcc/testsuite/ada/acats/tests/c3/c36205j.ada
deleted file mode 100644
index a0d8218..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205j.ada
+++ /dev/null
@@ -1,180 +0,0 @@
--- C36205J.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF SLICES AND AGGREGATES OF MORE COMPLEX FORMS
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205J IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- TYPE STR IS NEW STRING;
- ALF : CONSTANT STR := STR(IDENT_STR("ABCDE"));
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205J", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - COMPLEX MIXTURE OF SLICES/AGGREGATES");
-
- FOR J IN IDENT_INT (-3) .. IDENT_INT (3) LOOP
- FOR K IN J - 1 .. 2 LOOP
- P1 ((J .. K => 0), J, K, "X");
- P1 (A10 (J + 4 .. K + 4), J+4, K+4, "Y");
- END LOOP;
- END LOOP;
- FOR I IN 18 .. 20 LOOP
- FOR J IN I-1 .. 20 LOOP
- P1 (A20 (I .. J), I, J, "A20 88");
- END LOOP;
- END LOOP;
- FOR I IN 1 .. 5 LOOP
- FOR J IN I - 1 .. 5 LOOP
- S1( ALF (I .. J), I, J, "ALF 1");
- S1 (ARF (I+4..J+4), I+4, J+4, "ARF 4");
- END LOOP;
- END LOOP;
-
- RESULT;
-END C36205J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205k.ada b/gcc/testsuite/ada/acats/tests/c3/c36205k.ada
deleted file mode 100644
index 44a8076..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205k.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- C36205K.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 ATTRIBUTES GIVE THE CORRECT VALUES FOR
--- UNCONSTRAINED FORMAL PARAMETERS.
-
--- ATTRIBUTES OF SLICE OF SLICE
-
--- DAT 2/17/81
--- JBG 9/11/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36205K IS
-
- USE REPORT;
-
- TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- TYPE I_A_2 IS ARRAY (INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF INTEGER;
- A10 : I_A (1 .. 10);
- A20 : I_A (18 .. 20);
- I10 : INTEGER := IDENT_INT (10);
- A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20
- A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20
- TYPE STR IS NEW STRING;
- ALF : CONSTANT STR := STR(IDENT_STR("ABCDE"));
- ARF : STR(5 .. 9) := ALF;
-
- PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= FIR
- OR A'FIRST(1) /= FIR
- THEN
- FAILED ("'FIRST IS WRONG " & S);
- END IF;
-
- IF A'LAST /= LAS
- OR A'LAST(1) /= LAS
- THEN
- FAILED ("'LAST IS WRONG " & S);
- END IF;
-
- IF A'LENGTH /= LAS - FIR + 1
- OR A'LENGTH /= A'LENGTH(1)
- THEN
- FAILED ("'LENGTH IS WRONG " & S);
- END IF;
-
- IF (LAS NOT IN A'RANGE AND LAS >= FIR)
- OR (FIR NOT IN A'RANGE AND LAS >= FIR)
- OR FIR - 1 IN A'RANGE
- OR LAS + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE IS WRONG " & S);
- END IF;
-
- END P1;
-
- PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS
- BEGIN
- IF A'FIRST /= A'FIRST(1)
- OR A'FIRST /= F1
- THEN
- FAILED ("'FIRST(1) IS WRONG " & S);
- END IF;
-
- IF A'LAST(1) /= L1 THEN
- FAILED ("'LAST(1) IS WRONG " & S);
- END IF;
-
- IF A'LENGTH(1) /= A'LENGTH
- OR A'LENGTH /= L1 - F1 + 1
- THEN
- FAILED ("'LENGTH(1) IS WRONG " & S);
- END IF;
-
- IF F1 - 1 IN A'RANGE
- OR (F1 NOT IN A'RANGE AND F1 <= L1)
- OR (L1 NOT IN A'RANGE(1) AND F1 <= L1)
- OR L1 + 1 IN A'RANGE(1)
- THEN
- FAILED ("'RANGE(1) IS WRONG " & S);
- END IF;
-
- IF A'FIRST(2) /= F2 THEN
- FAILED ("'FIRST(2) IS WRONG " & S);
- END IF;
-
- IF A'LAST(2) /= L2 THEN
- FAILED ("'LAST(2) IS WRONG " & S);
- END IF;
-
- IF L2 - F2 /= A'LENGTH(2) - 1 THEN
- FAILED ("'LENGTH(2) IS WRONG " & S);
- END IF;
-
- IF F2 - 1 IN A'RANGE(2)
- OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0)
- OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0)
- OR L2 + 1 IN A'RANGE(2)
- THEN
- FAILED ("'RANGE(2) IS WRONG " & S);
- END IF;
- END P2;
-
- PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS
- BEGIN
- IF S'FIRST /= F THEN
- FAILED ("STRING 'FIRST IS WRONG " & MESS);
- END IF;
-
- IF S'LAST(1) /= L THEN
- FAILED ("STRING 'LAST IS WRONG " & MESS);
- END IF;
-
- IF S'LENGTH /= L - F + 1
- OR S'LENGTH(1) /= S'LENGTH
- THEN
- FAILED ("STRING 'LENGTH IS WRONG " & MESS);
- END IF;
-
- IF (F <= L AND
- (F NOT IN S'RANGE
- OR L NOT IN S'RANGE
- OR F NOT IN S'RANGE(1)
- OR L NOT IN S'RANGE(1)))
- OR F - 1 IN S'RANGE
- OR L + 1 IN S'RANGE(1)
- THEN
- FAILED ("STRING 'RANGE IS WRONG " & MESS);
- END IF;
- END S1;
-
-BEGIN
- TEST ( "C36205K", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "&
- "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " &
- "ARRAYS - SLICES OF SLICES");
-
- FOR I IN 18 .. 20 LOOP
- FOR J IN I-1 .. 20 LOOP
- P1 (A20 (A20'RANGE)(I..J), I, J, "A20 99");
- END LOOP;
- END LOOP;
- FOR I IN 1 .. 5 LOOP
- FOR J IN I - 1 .. 5 LOOP
- S1 (ALF (1..5)(I..J),I,J,"ALF 3");
- END LOOP;
- END LOOP;
-
- RESULT;
-END C36205K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36205l.ada b/gcc/testsuite/ada/acats/tests/c3/c36205l.ada
deleted file mode 100644
index 9a1126e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36205l.ada
+++ /dev/null
@@ -1,288 +0,0 @@
--- C36205L.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
--- FOR GENERIC PROCEDURES, CHECK THAT ATTRIBUTES GIVE THE
--- CORRECT VALUES FOR UNCONSTRAINED FORMAL PARAMETERS.
--- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS
--- PARAMETERS TO GENERIC PROCEDURES
-
--- HISTORY
--- EDWARD V. BERARD, 9 AUGUST 1990
--- DAS 8 OCT 1990 ADDED OUT MODE PARAMETER TO GENERIC
--- PROCEDURE TEST_PROCEDURE AND FORMAL
--- GENERIC PARAMETER COMPONENT_VALUE.
-
-WITH REPORT ;
-
-PROCEDURE C36205L IS
-
- SHORT_START : CONSTANT := -100 ;
- SHORT_END : CONSTANT := 100 ;
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
- SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ;
-
- MEDIUM_START : CONSTANT := 1 ;
- MEDIUM_END : CONSTANT := 100 ;
- TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ;
- MEDIUM_LENGTH : CONSTANT NATURAL := (MEDIUM_END - MEDIUM_START
- + 1) ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 9,
- YEAR => 1990) ;
-
- SUBTYPE SHORT_STRING IS STRING (1 ..5) ;
-
- DEFAULT_STRING : SHORT_STRING := "ABCDE" ;
-
- TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>,
- MEDIUM_RANGE RANGE <>) OF DATE ;
-
- TYPE SECOND_TEMPLATE IS ARRAY (MONTH_TYPE RANGE <>,
- DAY_TYPE RANGE <>) OF SHORT_STRING ;
-
- TYPE THIRD_TEMPLATE IS ARRAY (CHARACTER RANGE <>,
- BOOLEAN RANGE <>) OF DAY_TYPE ;
-
- FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 27 .. 35)
- := (-10 .. 10 =>
- (27 .. 35 => TODAY)) ;
- SECOND_ARRAY : SECOND_TEMPLATE (JAN .. JUN, 1 .. 25)
- := (JAN .. JUN =>
- (1 .. 25 => DEFAULT_STRING)) ;
- THIRD_ARRAY : THIRD_TEMPLATE ('A' .. 'Z', FALSE .. TRUE)
- := ('A' .. 'Z' =>
- (FALSE .. TRUE => DAY_TYPE (9))) ;
-
- FOURTH_ARRAY : FIRST_TEMPLATE (0 .. 27, 75 .. 100)
- := (0 .. 27 =>
- (75 .. 100 => TODAY)) ;
- FIFTH_ARRAY : SECOND_TEMPLATE (JUL .. OCT, 6 .. 10)
- := (JUL .. OCT =>
- (6 .. 10 => DEFAULT_STRING)) ;
- SIXTH_ARRAY : THIRD_TEMPLATE ('X' .. 'Z', TRUE .. TRUE)
- := ('X' .. 'Z' =>
- (TRUE .. TRUE => DAY_TYPE (31))) ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- TYPE UNCONSTRAINED_ARRAY IS ARRAY (FIRST_INDEX RANGE <>,
- SECOND_INDEX RANGE <>) OF COMPONENT_TYPE ;
- COMPONENT_VALUE: IN COMPONENT_TYPE;
-
- PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ;
- FFIFS : IN FIRST_INDEX ;
- FFILS : IN FIRST_INDEX ;
- FSIFS : IN SECOND_INDEX ;
- FSILS : IN SECOND_INDEX ;
- FFLEN : IN NATURAL ;
- FSLEN : IN NATURAL ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : OUT UNCONSTRAINED_ARRAY ;
- SFIFS : IN FIRST_INDEX ;
- SFILS : IN FIRST_INDEX ;
- SSIFS : IN SECOND_INDEX ;
- SSILS : IN SECOND_INDEX ;
- SFLEN : IN NATURAL ;
- SSLEN : IN NATURAL ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) ;
-
- PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ;
- FFIFS : IN FIRST_INDEX ;
- FFILS : IN FIRST_INDEX ;
- FSIFS : IN SECOND_INDEX ;
- FSILS : IN SECOND_INDEX ;
- FFLEN : IN NATURAL ;
- FSLEN : IN NATURAL ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : OUT UNCONSTRAINED_ARRAY ;
- SFIFS : IN FIRST_INDEX ;
- SFILS : IN FIRST_INDEX ;
- SSIFS : IN SECOND_INDEX ;
- SSILS : IN SECOND_INDEX ;
- SFLEN : IN NATURAL ;
- SSLEN : IN NATURAL ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) IS
-
- BEGIN -- TEST_PROCEDURE
-
- IF (FIRST'FIRST /= FFIFS) OR
- (FIRST'FIRST (1) /= FFIFS) OR
- (FIRST'FIRST (2) /= FSIFS) OR
- (SECOND'FIRST /= SFIFS) OR
- (SECOND'FIRST (1) /= SFIFS) OR
- (SECOND'FIRST (2) /= SSIFS) THEN
- REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LAST /= FFILS) OR
- (FIRST'LAST (1) /= FFILS) OR
- (FIRST'LAST (2) /= FSILS) OR
- (SECOND'LAST /= SFILS) OR
- (SECOND'LAST (1) /= SFILS) OR
- (SECOND'LAST (2) /= SSILS) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LENGTH /= FFLEN) OR
- (FIRST'LENGTH (1) /= FFLEN) OR
- (FIRST'LENGTH (2) /= FSLEN) OR
- (SECOND'LENGTH /= SFLEN) OR
- (SECOND'LENGTH (1) /= SFLEN) OR
- (SECOND'LENGTH (2) /= SSLEN) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ;
- END IF ;
-
- IF (FFIRT NOT IN FIRST'RANGE (1)) OR
- (FFIRT NOT IN FIRST'RANGE) OR
- (SFIRT NOT IN SECOND'RANGE (1)) OR
- (SFIRT NOT IN SECOND'RANGE) OR
- (FSIRT NOT IN FIRST'RANGE (2)) OR
- (SSIRT NOT IN SECOND'RANGE (2)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE " &
- "ATTRIBUTE. " & REMARKS) ;
- END IF ;
-
- -- ASSIGN VALUES TO THE ARRAY PARAMETER OF MODE OUT
- FOR I IN SECOND'RANGE(1) LOOP
- FOR J IN SECOND'RANGE(2) LOOP
- SECOND(I, J) := COMPONENT_VALUE;
- END LOOP;
- END LOOP;
-
- END TEST_PROCEDURE ;
-
- PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE (
- FIRST_INDEX => SHORT_RANGE,
- SECOND_INDEX => MEDIUM_RANGE,
- COMPONENT_TYPE => DATE,
- UNCONSTRAINED_ARRAY => FIRST_TEMPLATE,
- COMPONENT_VALUE => TODAY) ;
-
- PROCEDURE SECOND_TEST_PROCEDURE IS NEW TEST_PROCEDURE (
- FIRST_INDEX => MONTH_TYPE,
- SECOND_INDEX => DAY_TYPE,
- COMPONENT_TYPE => SHORT_STRING,
- UNCONSTRAINED_ARRAY => SECOND_TEMPLATE,
- COMPONENT_VALUE => DEFAULT_STRING) ;
-
- PROCEDURE THIRD_TEST_PROCEDURE IS NEW TEST_PROCEDURE (
- FIRST_INDEX => CHARACTER,
- SECOND_INDEX => BOOLEAN,
- COMPONENT_TYPE => DAY_TYPE,
- UNCONSTRAINED_ARRAY => THIRD_TEMPLATE,
- COMPONENT_VALUE => DAY_TYPE'FIRST) ;
-
-
-BEGIN -- C36205L
-
- REPORT.TEST ( "C36205L","FOR GENERIC PROCEDURES, CHECK THAT " &
- "ATTRIBUTES GIVE THE CORRECT VALUES FOR " &
- "UNCONSTRAINED FORMAL PARAMETERS. BASIC " &
- "CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS " &
- "PASSED AS PARAMETERS TO GENERIC PROCEDURES");
-
- FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY,
- FFIFS => -10,
- FFILS => 10,
- FSIFS => 27,
- FSILS => 35,
- FFLEN => 21,
- FSLEN => 9,
- FFIRT => 0,
- FSIRT => 29,
- SECOND => FOURTH_ARRAY,
- SFIFS => 0,
- SFILS => 27,
- SSIFS => 75,
- SSILS => 100,
- SFLEN => 28,
- SSLEN => 26,
- SFIRT => 5,
- SSIRT => 100,
- REMARKS => "FIRST_TEST_PROCEDURE") ;
-
- SECOND_TEST_PROCEDURE (FIRST => SECOND_ARRAY,
- FFIFS => JAN,
- FFILS => JUN,
- FSIFS => 1,
- FSILS => 25,
- FFLEN => 6,
- FSLEN => 25,
- FFIRT => MAR,
- FSIRT => 17,
- SECOND => FIFTH_ARRAY,
- SFIFS => JUL,
- SFILS => OCT,
- SSIFS => 6,
- SSILS => 10,
- SFLEN => 4,
- SSLEN => 5,
- SFIRT => JUL,
- SSIRT => 6,
- REMARKS => "SECOND_TEST_PROCEDURE") ;
-
- THIRD_TEST_PROCEDURE (FIRST => THIRD_ARRAY,
- FFIFS => 'A',
- FFILS => 'Z',
- FSIFS => FALSE,
- FSILS => TRUE,
- FFLEN => 26,
- FSLEN => 2,
- FFIRT => 'T',
- FSIRT => TRUE,
- SECOND => SIXTH_ARRAY,
- SFIFS => 'X',
- SFILS => 'Z',
- SSIFS => TRUE,
- SSILS => TRUE,
- SFLEN => 3,
- SSLEN => 1,
- SFIRT => 'Z',
- SSIRT => TRUE,
- REMARKS => "THIRD_TEST_PROCEDURE") ;
-
- REPORT.RESULT ;
-
-END C36205L ;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36301a.ada b/gcc/testsuite/ada/acats/tests/c3/c36301a.ada
deleted file mode 100644
index 9f93a7f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36301a.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- C36301A.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 PREDEFINED POSITIVE AND STRING TYPES
--- ARE CORRECTLY DEFINED.
-
--- DAT 2/17/81
--- JBG 12/27/82
--- RJW 1/20/86 - CHANGED 'NATURAL' TO 'POSITIVE'. ADDED ADDITIONAL
--- CASES, INCLUDING A CHECK FOR STRINGS WITH BOUNDS
--- OF INTEGER'FIRST AND INTEGER'LAST.
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C36301A IS
-
-BEGIN
- TEST ( "C36301A", "CHECK ATTRIBUTES OF PREDEFINED POSITIVE " &
- "AND STRING" );
-
- BEGIN
- IF POSITIVE'FIRST /= 1 THEN
- FAILED ( "POSITIVE'FIRST IS WRONG" );
- END IF;
-
- IF POSITIVE'LAST /= INTEGER'LAST THEN
- FAILED ( "POSITIVE'LAST IS WRONG" );
- END IF;
- END;
-
- DECLARE
-
- C : STRING (1..2) := ( 'A', 'B' );
-
- BEGIN
- IF C'LENGTH /= 2 THEN
- FAILED ( "LENGTH OF C IS WRONG" );
- END IF;
-
- IF C'FIRST /= 1 THEN
- FAILED ( "C'FIRST IS WRONG" );
- END IF;
-
- IF C'LAST /= 2 THEN
- FAILED ( "C'LAST IS WRONG" );
- END IF;
- END;
-
- DECLARE
-
- SUBTYPE LARGE IS STRING ( INTEGER'LAST - 3 .. INTEGER'LAST );
-
- BEGIN
- IF LARGE'LENGTH /= 4 THEN
- FAILED ( "LENGTH OF LARGE IS WRONG" );
- END IF;
-
- IF LARGE'FIRST /= INTEGER'LAST - 3 THEN
- FAILED ( "LARGE'FIRST IS WRONG" );
- END IF;
-
- IF LARGE'LAST /= INTEGER'LAST THEN
- FAILED ( "LARGE'LAST IS WRONG" );
- END IF;
- END;
-
- DECLARE
-
- SUBTYPE LARGER IS STRING ( 1 .. INTEGER'LAST );
-
- BEGIN
- IF LARGER'LENGTH /= INTEGER'LAST THEN
- FAILED ( "LENGTH OF LARGER IS WRONG" );
- END IF;
-
- IF LARGER'FIRST /= 1 THEN
- FAILED ( "LARGER'FIRST IS WRONG" );
- END IF;
-
- IF LARGER'LAST /= INTEGER'LAST THEN
- FAILED ( "LARGER'LAST IS WRONG" );
- END IF;
- END;
-
- BEGIN
- DECLARE
-
- D : STRING ( INTEGER'FIRST .. INTEGER'FIRST + 3 );
-
- BEGIN
- IF D'FIRST /= INTEGER'FIRST THEN -- USE D
- FAILED ("D'FIRST IS INCORRECT " & INTEGER'IMAGE(D'FIRST));
- END IF;
- FAILED ( "NO EXCEPTION RAISED" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED" );
- END;
-
- BEGIN
- DECLARE
-
- E : STRING ( -1 .. INTEGER'FIRST );
-
- BEGIN
- IF E'LENGTH /= 0 THEN
- FAILED ( "LENGTH OF E IS WRONG" );
- END IF;
-
- IF E'FIRST /= -1 THEN
- FAILED ( "E'FIRST IS WRONG" );
- END IF;
-
- IF E'LAST /= INTEGER'FIRST THEN
- FAILED ( "E'LAST IS WRONG" );
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED FOR NULL STRING" );
- END;
-
- RESULT;
-END C36301A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36301b.ada b/gcc/testsuite/ada/acats/tests/c3/c36301b.ada
deleted file mode 100644
index 4153db2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36301b.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- C36301B.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 PREDEFINED STRING ATTRIBUTES ARE CORRECTLY IMPLEMENTED.
-
--- CASE B: STRING OF LENGTH INTEGER'LAST
-
--- DAT 2/17/81
--- JBG 12/28/82
-
-WITH REPORT;
-PROCEDURE C36301B IS
-
- USE REPORT;
-
- SUBTYPE STR2 IS STRING (1..INTEGER'LAST);
-
-BEGIN
- TEST("C36301B", "CHECK ATTRIBUTES OF LONGEST STRING");
-
- IF STR2'FIRST /= 1 THEN
- FAILED ("STR'FIRST NOT 1");
- END IF;
-
- IF STR2'LAST /= INTEGER'LAST THEN
- FAILED ("STR'LAST NOT INTEGER'LAST");
- END IF;
-
- IF STR2'LENGTH /= INTEGER'LAST THEN
- FAILED ("'LENGTH NOT INTEGER'LAST");
- END IF;
-
- RESULT;
-END C36301B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36302a.ada b/gcc/testsuite/ada/acats/tests/c3/c36302a.ada
deleted file mode 100644
index 1e71598..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36302a.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- C36302A.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 STRING VARIABLE MAY BE DECLARED WITH AN INDEX
--- STARTING WITH AN INTEGER GREATER THAN 1.
-
--- DAT 2/17/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C36302A IS
-
- USE REPORT;
-
- S5 : STRING (5 .. 10);
- SX : STRING (INTEGER'LAST - 5 .. INTEGER'LAST);
-
-BEGIN
- TEST ("C36302A", "STRING VARIABLE INDICES NEEDN'T START AT 1");
-
- IF S5'FIRST /= 5
- OR S5'LAST /= 10
- OR S5'LENGTH /= 6
- OR SX'FIRST /= INTEGER'LAST - 5
- OR SX'LAST /= INTEGER'LAST
- OR SX'LENGTH /= 6
- THEN
- FAILED ("WRONG STRING ATTRIBUTES");
- END IF;
-
- RESULT;
-END C36302A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36304a.ada b/gcc/testsuite/ada/acats/tests/c3/c36304a.ada
deleted file mode 100644
index a561f3f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36304a.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- C36304A.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 BOUNDS OF CONSTANT STRING OBJECTS IF NOT GIVEN IN
--- THE DECLARATIONS ARE DETERMINED BY THE STRINGS' INITIAL VALUES.
-
--- DAT 2/17/81
--- JBG 8/21/83
-
-WITH REPORT;
-PROCEDURE C36304A IS
-
- USE REPORT;
-
- I3 : INTEGER := IDENT_INT (3);
-
- S3 : CONSTANT STRING := "ABC";
- S0 : CONSTANT STRING := "";
- S1 : CONSTANT STRING := "A";
- S2 : CONSTANT STRING := "AB";
- S5 : CONSTANT STRING := "ABCDE";
- S3A : CONSTANT STRING (I3 .. I3 + 2) := S3(I3 - 2 .. I3);
- S3C : CONSTANT STRING := S3A;
- S3D : CONSTANT STRING := S3C & "";
- S3E : CONSTANT STRING := S3D;
- X3 : CONSTANT STRING := (I3 .. 5 => 'X');
- Y3 : CONSTANT STRING := X3;
- Z0 : CONSTANT STRING := (-3..-5 => 'A');
-
- PROCEDURE C (S : STRING;
- FIRST, LAST, LENGTH : INTEGER;
- ID : STRING) IS
- BEGIN
- IF S'FIRST /= FIRST THEN
- FAILED ("'FIRST IS " & INTEGER'IMAGE(S'FIRST) &
- " INSTEAD OF " & INTEGER'IMAGE(FIRST) &
- " FOR " & ID);
- END IF;
-
- IF S'LAST /= LAST THEN
- FAILED ("'LAST IS " & INTEGER'IMAGE(S'LAST) &
- " INSTEAD OF " & INTEGER'IMAGE(LAST) &
- " FOR " & ID);
- END IF;
-
- IF S'LENGTH /= LENGTH THEN
- FAILED ("'LENGTH IS " & INTEGER'IMAGE(S'LENGTH) &
- " INSTEAD OF " & INTEGER'IMAGE(LENGTH) &
- " FOR " & ID);
- END IF;
- END C;
-
-BEGIN
- TEST ("C36304A", "CHECK UNUSUAL CONSTANT STRING BOUNDS");
-
-
- C(S0, 1, 0, 0, "S0");
- C(S1, 1, 1, 1, "S1");
- C(S2, 1, 2, 2, "S2");
- C(S5, 1, 5, 5, "S5");
- C(S3, 1, 3, 3, "S3");
- C(S3C, 3, 5, 3, "S3C");
- C(S3D, 3, 5, 3, "S3D");
- C(S3E, 3, 5, 3, "S3E");
- C(X3, 3, 5, 3, "X3");
- C(Y3, 3, 5, 3, "Y3");
- C(Z0, IDENT_INT(-3), IDENT_INT(-5), IDENT_INT(0), "Z0");
-
- RESULT;
-END C36304A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c36305a.ada b/gcc/testsuite/ada/acats/tests/c3/c36305a.ada
deleted file mode 100644
index 09adbe1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c36305a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C36305A.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 STRING VARIABLE IS CONSIDERED AN ARRAY.
-
--- DAT 2/17/81
--- SPS 10/25/82
--- EDS 07/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C36305A IS
-
- USE REPORT;
-
- S : STRING (IDENT_INT(5) .. IDENT_INT (10));
- T : STRING (S'RANGE);
- U : STRING (T'FIRST .. T'LAST);
- SUBTYPE I_5 IS INTEGER RANGE U'RANGE(1);
- I5 : I_5;
- C : CONSTANT STRING := "ABCDEF";
-
-BEGIN
- TEST ("C36305A", "CHECK THAT STRINGS ARE REALLY ARRAYS");
-
- IF S'FIRST /= 5
- OR S'LAST /= 10
- OR S'LENGTH /= 6
- OR U'FIRST(1) /= 5
- OR U'LAST(1) /= 10
- OR U'LENGTH(1) /= 6
- THEN
- FAILED ("INCORRECT STRING ATTRIBUTE VALUES");
- END IF;
-
- IF 4 IN U'RANGE
- OR 3 IN U'RANGE(1)
- OR 0 IN U'RANGE
- OR 1 IN U'RANGE
- OR 5 NOT IN U'RANGE
- OR 7 NOT IN U'RANGE
- OR 10 NOT IN U'RANGE
- OR NOT (11 NOT IN U'RANGE)
- THEN
- FAILED ("INCORRECT STRING RANGE ATTRIBUTE");
- END IF;
-
- BEGIN
- BEGIN
- BEGIN
- I5 := 4;
- FAILED ("BAD I5 SUBRANGE 1 " & INTEGER'IMAGE(I5)); --use I5
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
- I5 := INTEGER'(11);
- FAILED ("BAD I5 SUBRANGE 2 " & INTEGER'IMAGE(I5)); --use I5
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1");
- END;
- I5 := INTEGER'(5);
- I5 := I5 + I5;
- I5 := NATURAL'(8);
- EXCEPTION
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2");
- END;
-
- FOR I IN S'RANGE LOOP
- S(I) := C(11 - I);
- END LOOP;
- T := S;
- FOR I IN REVERSE U'RANGE LOOP
- U(I) := T(15 - I);
- END LOOP;
-
- FOR I IN 1 .. C'LENGTH LOOP
- IF C(1 .. I) /= U(5 .. I + 4)
- OR U(I + 4 .. U'LAST) /= C(I .. C'LAST)
- OR C(I) /= U (I + 4)
- OR C(I .. I)(I .. I)(I) /= U(U'RANGE)(I + 4) THEN
- FAILED ("INCORRECT CHARACTER MISMATCH IN STRING");
- EXIT;
- END IF;
- END LOOP;
-
- IF U /= C
- OR U /= "ABCDEF"
- OR U(U'RANGE) /= C(C'RANGE)
- OR U(5 .. 10) /= C(1 .. 6)
- OR U(5 .. 6) /= C(1 .. 2)
- THEN
- FAILED ("STRINGS AS ARRAYS BEHAVE INCORRECTLY");
- END IF;
-
- RESULT;
-END C36305A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37002a.ada b/gcc/testsuite/ada/acats/tests/c3/c37002a.ada
deleted file mode 100644
index fbb61cf..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37002a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C37002A.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 INDEX CONSTRAINTS WITH NON-STATIC EXPRESSIONS CAN BE
--- USED TO CONSTRAIN RECORD COMPONENTS HAVING AN ARRAY TYPE.
-
--- RJW 2/28/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37002A IS
-
-BEGIN
- TEST ( "C37002A", "CHECK THAT INDEX CONSTRAINTS WITH " &
- "NON-STATIC EXPRESSIONS CAN BE USED TO " &
- "CONSTRAIN RECORD COMPONENTS HAVING AN " &
- "ARRAY TYPE" );
-
- DECLARE
- X : INTEGER := IDENT_INT(5);
- SUBTYPE S IS INTEGER RANGE 1 .. X;
- TYPE AR1 IS ARRAY (S) OF INTEGER;
-
- SUBTYPE T IS INTEGER RANGE X .. 10;
- TYPE AR2 IS ARRAY (T) OF INTEGER;
- TYPE U IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE V IS INTEGER RANGE 1 .. 10;
-
- TYPE R IS
- RECORD
- A : STRING (1 .. X);
- B : STRING (X .. 10);
- C : AR1;
- D : AR2;
- E : STRING (S);
- F : U(T);
- G : U(V RANGE 1 ..X);
- H : STRING (POSITIVE RANGE X .. 10);
- I : U(AR1'RANGE);
- J : STRING (AR2'RANGE);
- END RECORD;
- RR : R;
-
- BEGIN
- IF RR.A'LAST /= 5 OR RR.B'FIRST /= 5 OR
- RR.C'LAST /= 5 OR RR.D'FIRST /= 5 OR
- RR.E'LAST /= 5 OR RR.F'FIRST /= 5 OR
- RR.G'LAST /= 5 OR RR.H'FIRST /= 5 OR
- RR.I'LAST /= 5 OR RR.J'FIRST /= 5 THEN
-
- FAILED("WRONG VALUE FOR NON-STATIC BOUND");
-
- END IF;
-
- END;
-
- RESULT;
-END C37002A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37003a.ada b/gcc/testsuite/ada/acats/tests/c3/c37003a.ada
deleted file mode 100644
index 5378f4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37003a.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- C37003A.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 MULTIPLE COMPONENT DECLARATIONS ARE TREATED AS A SERIES
--- OF SINGLE COMNENT DECLARATIONS, I.E., THE COMPONENTS ALL HAVE THE
--- SAME TYPE AND ANY EXPRESSION USED IN CONSTRAINTS OR INITIALIZATIONS
--- IS EVALUATED ONCE FOR EACH COMPONENT.
-
--- DAT 3/30/81
--- SPS 10/26/82
--- JWC 10/23/85 RENAMED FROM C37013A-AB.ADA.
--- ADDED TEST TO ENSURE THAT ANY EXPRESSION USED
--- IN A CONSTRAINT IS EVALUATED ONCE FOR EACH
--- COMPONENT.
--- JRK 11/15/85 ADDED INITIALIZATION EVALUATION CHECKS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37003A IS
-
- X : INTEGER := 0;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- X := X + 1;
- RETURN X;
- END F;
-
- PROCEDURE RESET IS
- BEGIN
- X := 0;
- END RESET;
-
-BEGIN
- TEST ("C37003A", "CHECK THAT MULTIPLE COMPONENT DECLARATIONS " &
- "ARE TREATED AS A SERIES OF SINGLE COMPONENT " &
- "DECLARATIONS");
-
- DECLARE
-
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE REC1 IS RECORD
- A1, A2 : ARR (1 .. F) := (OTHERS => F);
- END RECORD;
-
- R1 : REC1 := (OTHERS => (OTHERS => 1));
- Y : INTEGER := X;
- R1A : REC1;
-
- BEGIN
-
- IF R1.A1 = R1.A2 THEN -- TEST TO SEE IF THE COMPONENTS
- NULL; -- ARE OF THE SAME TYPE.
- END IF;
-
- IF Y /= 2 THEN
- FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " &
- "FOR ARRAYS");
- END IF;
-
- IF X /= 5 THEN
- FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " &
- "EACH ARRAY COMPONENT");
- END IF;
-
- RESET;
-
- END;
-
- DECLARE
-
- TYPE REC2 IS RECORD
- I1, I2 : INTEGER RANGE 1 .. F := F * IDENT_INT(0) + 1;
- END RECORD;
-
- R2 : REC2 := (OTHERS => 1);
- Y : INTEGER := X;
- R2A : REC2;
-
- BEGIN
-
- IF R2.I1 = R2.I2 THEN -- TEST TO SEE IF THE COMPONENTS
- NULL; -- ARE OF THE SAME TYPE.
- END IF;
-
- IF Y /= 2 THEN
- FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " &
- "FOR SCALARS");
- END IF;
-
- IF X /= 4 THEN
- FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " &
- "EACH SCALAR COMPONENT");
- END IF;
-
- RESET;
-
- END;
-
- DECLARE
-
- TYPE REC3X (DSC : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- TYPE REC3Y IS RECORD
- I : INTEGER;
- END RECORD;
-
- TYPE REC3 IS RECORD
- RX1, RX2 : REC3X (F);
- RY1, RY2 : REC3Y := (I => F);
- END RECORD;
-
- R3 : REC3 := ((DSC => 1), (DSC => 2), (I => 0), (I => 0));
- Y : INTEGER := X;
- R3A : REC3;
-
- BEGIN
-
- IF R3.RX1 = R3.RX2 THEN -- TEST TO SEE IF THE COMPONENTS
- NULL; -- ARE OF THE SAME TYPE.
- END IF;
-
- IF Y /= 2 THEN
- FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " &
- "FOR RECORDS");
- END IF;
-
- IF X /= 4 THEN
- FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " &
- "FOR EACH RECORD COMPONENT");
- END IF;
-
- RESET;
-
- END;
-
- DECLARE
-
- TYPE REC4X (DSC : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- TYPE ACR IS ACCESS REC4X;
- TYPE ACI IS ACCESS INTEGER;
-
- TYPE REC4 IS RECORD
- AC1, AC2 : ACR (F);
- AC3, AC4 : ACI := NEW INTEGER'(F);
- END RECORD;
-
- R4 : REC4 := (NULL, NULL, NULL, NULL);
- Y : INTEGER := X;
- R4A : REC4;
-
- BEGIN
-
- IF R4.AC1 = R4.AC2 THEN -- TEST TO SEE IF THE COMPONENTS
- NULL; -- ARE OF THE SAME TYPE.
- END IF;
-
- IF Y /= 2 THEN
- FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " &
- "FOR ACCESS");
- END IF;
-
- IF X /= 4 THEN
- FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " &
- "FOR EACH ACCESS COMPONENT");
- END IF;
-
- END;
-
- RESULT;
-END C37003A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37003b.ada b/gcc/testsuite/ada/acats/tests/c3/c37003b.ada
deleted file mode 100644
index 49ebdc0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37003b.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- C37003B.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 A RECORD WITH MULTIPLE DISCRIMINANTS WHICH HAVE
--- DEFAULT EXPRESSIONS, THE EXPRESSIONS ARE EVALUATED ONCE FOR
--- EACH DISCRIMINANT IN THE ASSOCIATION.
-
--- HISTORY:
--- DHH 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37003B IS
-
- X : INTEGER := 0;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- X := X + 1;
- RETURN X;
- END F1;
-
-BEGIN
- TEST("C37003B", "CHECK THAT FOR A RECORD WITH MULTIPLE " &
- "DISCRIMINANTS WHICH HAVE DEFAULT EXPRESSIONS, " &
- "THE EXPRESSIONS ARE EVALUATED ONCE FOR EACH " &
- "DISCRIMINANT IN THE ASSOCIATION");
-
- DECLARE
- TYPE REC(D1, D2, D3, D4, D5 : INTEGER := F1) IS
- RECORD
- Y : INTEGER := (D1 + D2 + D3 + D4 + D5);
- END RECORD;
-
- REC_F1 : REC;
-
- BEGIN
- IF REC_F1.Y /= IDENT_INT(15) THEN
- FAILED("MULTIPLE DISCRIMINANTS NOT EVALUATED " &
- "SEPARATELY");
- END IF;
- END;
-
- RESULT;
-END C37003B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37005a.ada b/gcc/testsuite/ada/acats/tests/c3/c37005a.ada
deleted file mode 100644
index 0983fe0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37005a.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C37005A.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 RECORD COMPONENTS MAY HAVE NON-STATIC
--- RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES.
-
--- DAT 3/6/81
--- JWC 6/28/85 RENAMED TO -AB
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C37005A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37005A", "SCALAR RECORD COMPONENTS MAY HAVE NON-STATIC"
- & " RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES");
-
- DECLARE
- SUBTYPE DT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5);
- L : INTEGER := IDENT_INT (DT'FIRST);
- R : INTEGER := IDENT_INT (DT'LAST);
- SUBTYPE DT2 IS INTEGER RANGE L .. R;
- M : INTEGER := (L + R) / 2;
-
- TYPE REC IS
- RECORD
- C1 : INTEGER := M;
- C2 : DT2 := (L + R) / 2;
- C3 : BOOLEAN RANGE (L < M) .. (R > M)
- := IDENT_BOOL (TRUE);
- C4 : INTEGER RANGE L .. R := DT'FIRST;
- END RECORD;
-
- R1, R2 : REC := ((L+R)/2, M, M IN DT, L);
- R3 : REC;
- BEGIN
- IF R3 /= R1
- THEN
- FAILED ("INCORRECT RECORD VALUES");
- END IF;
-
- R3 := (R2.C2, R2.C1, R3.C3, R); -- CONSTRAINTS CHECKED BY :=
- IF EQUAL(IDENT_INT(1), 2) THEN
- FAILED("IMPOSSIBLE " & INTEGER'IMAGE(R3.C1)); --USE R3
- END IF;
-
- BEGIN
- R3 := (M, M, IDENT_BOOL (FALSE), M); -- RAISES CON_ERR.
- FAILED ("CONSTRAINT ERROR NOT RAISED " & INTEGER'IMAGE(R3.C1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION");
- END;
-
- FOR I IN DT LOOP
- R3 := (I, I, I /= 100, I);
- R1.C2 := I;
- IF EQUAL(IDENT_INT(1), 2) THEN
- FAILED("IMPOSSIBLE " &
- INTEGER'IMAGE(R3.C1 + R1.C2)); --USE R3, R1
- END IF;
- END LOOP;
-
- EXCEPTION
- WHEN OTHERS => FAILED ("INVALID EXCEPTION");
- END;
-
- RESULT;
-END C37005A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37006a.ada b/gcc/testsuite/ada/acats/tests/c3/c37006a.ada
deleted file mode 100644
index ac926d1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37006a.ada
+++ /dev/null
@@ -1,272 +0,0 @@
--- C37006A.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.
---*
--- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A
--- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN
--- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE
--- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE.
-
--- R.WILLIAMS 8/28/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37006A IS
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 100;
-
- TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
-
- TYPE REC1 (D1, D2 : INT) IS
- RECORD
- A : ARR (D1 .. D2);
- END RECORD;
-
- TYPE REC1_NAME IS ACCESS REC1;
-
- PROCEDURE CHECK (AR : ARR; STR : STRING) IS
- BEGIN
- IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN
- FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " &
- "OF " & STR & " TYPE");
- ELSIF AR /= (3, 4) THEN
- FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " &
- STR & " TYPE FAILED" );
- END IF;
- END CHECK;
-
- PACKAGE PACK IS
- TYPE PRIV (D1, D2 : INT) IS PRIVATE;
- TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE;
- FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV;
- PROCEDURE PRIV_CHECK (R : PRIV);
- PROCEDURE LIM_CHECK (R : LIM);
-
- PRIVATE
- TYPE PRIV (D1, D2 : INT) IS
- RECORD
- A : ARR (D1 .. D2);
- END RECORD;
-
- TYPE LIM (D1, D2 : INT) IS
- RECORD
- A : ARR (D1 .. D2);
- END RECORD;
- END PACK;
-
- PACKAGE BODY PACK IS
-
- FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS
- BEGIN
- RETURN (IDENT_INT (1), IDENT_INT (2),
- ARR'(1 => 3, 2 => 4));
- END PRIV_FUN;
-
- PROCEDURE PRIV_CHECK (R : PRIV) IS
- BEGIN
- CHECK (R.A, "PRIVATE TYPE" );
- END PRIV_CHECK;
-
- PROCEDURE LIM_CHECK (R : LIM) IS
- BEGIN
- IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN
- FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " &
- "COMPONENT OF LIMITED PRIVATE TYPE");
- END IF;
- END LIM_CHECK;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " &
- "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " &
- "COMPONENT, CHECK THAT A NON-STATIC " &
- "EXPRESSION CAN BE USED IN A DISCRIMINANT " &
- "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " &
- "COMPONENTS) IN SPECIFYING A DEFAULT " &
- "INITIAL VALUE" );
-
- BEGIN
- DECLARE
-
- TYPE REC2 IS
- RECORD
- COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) :=
- (IDENT_INT (1), IDENT_INT (2),
- ARR'(1 => 3, 2 => 4));
- END RECORD;
-
- R : REC2;
-
- BEGIN
- IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
- CHECK (R.COMP.A, "RECORD");
- ELSE
- FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
- "OF RECORD TYPE COMPONENT" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "RECORD TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "RECORD TYPE COMPONENT" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
- "OF RECORD TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
- "OF RECORD TYPE COMPONENT" );
- END;
-
- BEGIN
- DECLARE
-
- TYPE REC2 IS
- RECORD
- COMP : REC1_NAME (IDENT_INT (1),
- IDENT_INT (2)) :=
- NEW REC1'(IDENT_INT (1),
- IDENT_INT (2),
- ARR'(1 => 3, 2 => 4));
- END RECORD;
-
- R : REC2;
-
- BEGIN
- IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
- CHECK (R.COMP.A, "ACCESS");
- ELSE
- FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
- "OF ACCESS TYPE COMPONENT" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "ACCESS TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "ACCESS TYPE COMPONENT" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
- "OF ACCESS TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
- "OF ACCESS TYPE COMPONENT" );
- END;
-
- BEGIN
- DECLARE
-
- TYPE REC2 IS
- RECORD
- COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) :=
- PRIV_FUN (IDENT_INT (1),
- IDENT_INT (2));
- END RECORD;
-
- R : REC2;
-
- BEGIN
- IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
- PRIV_CHECK (R.COMP);
- ELSE
- FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
- "OF PRIVATE TYPE COMPONENT" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "PRIVATE TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- "PRIVATE TYPE COMPONENT" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
- "OF PRIVATE TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
- "OF PRIVATE TYPE COMPONENT" );
- END;
-
- BEGIN
- DECLARE
-
- TYPE REC2 IS
- RECORD
- COMP : LIM (IDENT_INT (1), IDENT_INT (2));
- END RECORD;
-
- R : REC2;
-
- BEGIN
- IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN
- LIM_CHECK (R.COMP);
- ELSE
- FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " &
- "OF LIM PRIV TYPE COMPONENT" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- " LIM PRIV TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " &
- "SEQUENCE FOLLOWING DECLARATION OF " &
- " LIM PRIV TYPE COMPONENT" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " &
- "OF LIM PRIV TYPE COMPONENT" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " &
- "OF LIM PRIV TYPE COMPONENT" );
- END;
-
- RESULT;
-
-END C37006A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37008a.ada b/gcc/testsuite/ada/acats/tests/c3/c37008a.ada
deleted file mode 100644
index 5546ae0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37008a.ada
+++ /dev/null
@@ -1,270 +0,0 @@
--- C37008A.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 SPECIFYING AN INVALID DEFAULT INITIALIZATION
--- RAISES CONSTRAINT_ERROR WHEN AN OBJECT IS DECLARED.
-
--- DAT 3/6/81
--- SPS 10/26/82
--- RJW 1/9/86 - REVISED COMMENTS. ADDED 'IDENT_INT'.
--- EDS 7/22/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C37008A IS
-BEGIN
- TEST ("C37008A", "CHECK THAT INVALID DEFAULT RECORD"
- & " COMPONENT INITIALIZATIONS RAISE"
- & " CONSTRAINT_ERROR");
-
- BEGIN
- DECLARE
- TYPE R1 IS RECORD
- C1 : INTEGER RANGE 1 .. 5 := IDENT_INT (0);
- END RECORD;
- REC1 : R1;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 1 " & INTEGER'IMAGE(REC1.C1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1");
- END;
-
- BEGIN
- DECLARE
- TYPE R IS RECORD
- C : CHARACTER RANGE 'A' .. 'Y' := 'Z';
- END RECORD;
- REC2 : R;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 1A " & (REC2.C));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1A");
- END;
-
- BEGIN
- DECLARE
- TYPE R2 IS RECORD
- C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE;
- END RECORD;
- REC3 : R2;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 2 " & BOOLEAN'IMAGE(REC3.C2));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2");
- END;
-
- BEGIN
- DECLARE
- TYPE E IS (E1, E2, E3);
- TYPE R IS RECORD
- C : E RANGE E2 .. E3 := E1;
- END RECORD;
- REC4 : R;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 2A " & E'IMAGE(REC4.C));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2A");
- END;
-
- BEGIN
- DECLARE
- TYPE R3 IS RECORD
- C3 : INTEGER RANGE 1 .. 5;
- END RECORD;
- REC5 : R3;
- TYPE R3A IS RECORD
- C3A : R3 := (OTHERS => IDENT_INT (6));
- END RECORD;
- REC6 : R3A;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 3 " &
- INTEGER'IMAGE(REC6.C3A.C3));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9;
- TYPE R4 IS RECORD
- C4 : ARR
- := (1 => 8, 2 => 9, 3 => 10);
- END RECORD;
- REC7 : R4;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 4 " &
- INTEGER'IMAGE(REC7.C4(1)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 4");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A;
-
- TYPE R5 IS RECORD
- C5 : AA := NEW A' (4, 5, 6);
- END RECORD;
- REC8 : R5;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 5 " &
- INTEGER'IMAGE(REC8.C5(1)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 5");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A (1 .. 3);
-
- TYPE R6 IS RECORD
- C6 : AA := NEW A' (4, 4, 4, 4);
- END RECORD;
- REC9 : R6;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 6 " &
- INTEGER'IMAGE(REC9.C6(1)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 6");
- END;
-
- BEGIN
- DECLARE
- TYPE AI IS ACCESS INTEGER RANGE 6 .. 8;
-
- TYPE R7 IS RECORD
- C7 : AI := NEW INTEGER' (5);
- END RECORD;
- REC10 : R7;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 7 " &
- INTEGER'IMAGE(REC10.C7.ALL));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 7");
- END;
-
- BEGIN
- DECLARE
- TYPE UA IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 3 .. 5;
-
- SUBTYPE CA IS UA (7 .. 8);
-
- TYPE R8 IS RECORD
- C8 : CA := (6 .. 8 => 4);
- END RECORD;
- REC11 : R8;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 8 " &
- INTEGER'IMAGE(REC11.C8(7)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- TYPE UA IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 3 .. IDENT_INT(5);
-
- TYPE R9 IS RECORD
- C9 : UA (11 .. 11) := (11 => 6);
- END RECORD;
- REC12 : R9;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 9 " &
- INTEGER'IMAGE(REC12.C9(11)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. IDENT_INT (5);
-
- TYPE AA IS ACCESS A;
-
- TYPE R10 IS RECORD
- C10 : AA := NEW A '(4, 5, 6);
- END RECORD;
- REC13 : R10;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 10 " &
- INTEGER'IMAGE(REC13.C10(1)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3));
-
- TYPE R11 IS RECORD
- C11 : AA := NEW A '(4, 4, 4, 4);
- END RECORD;
- REC14 : R11;
- BEGIN
- FAILED ("NO EXCEPTION RAISED 11 " &
- INTEGER'IMAGE(REC14.C11(1)));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 11");
- END;
-
- RESULT;
-END C37008A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37008b.ada b/gcc/testsuite/ada/acats/tests/c3/c37008b.ada
deleted file mode 100644
index 369f08c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37008b.ada
+++ /dev/null
@@ -1,232 +0,0 @@
--- C37008B.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 CONSTRAINT ERROR IS RAISED FOR AN UNUSED TYPE
--- DECLARATION WITH AN INVALID DEFAULT VALUE
-
--- JBG 9/11/81
--- SPS 10/25/82
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C37008B IS
-BEGIN
- TEST ("C37008B", "CHECK THAT INVALID DEFAULT RECORD"
- & " COMPONENT INITIALIZATIONS DO NOT RAISE"
- & " CONSTRAINT_ERROR");
-
- BEGIN
- DECLARE
- TYPE R1 IS RECORD
- C1 : INTEGER RANGE 1 .. 5 := 0;
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 1");
- END;
-
- BEGIN
- DECLARE
- TYPE R IS RECORD
- C : CHARACTER RANGE 'A' .. 'Y' := 'Z';
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 1A");
- END;
-
- BEGIN
- DECLARE
- TYPE R2 IS RECORD
- C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE;
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 2");
- END;
-
- BEGIN
- DECLARE
- TYPE E IS (E1, E2, E3);
- TYPE R IS RECORD
- C : E RANGE E2 .. E3 := E1;
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 2A");
- END;
-
- BEGIN
- DECLARE
- TYPE R3 IS RECORD
- C3 : INTEGER RANGE 1 .. 5;
- END RECORD;
- TYPE R3A IS RECORD
- C3A : R3 := (OTHERS => 6);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9;
- TYPE R4 IS RECORD
- C4 : ARR
- := (1 => 8, 2 => 9, 3 => 10);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 4");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A;
-
- TYPE R5 IS RECORD
- C5 : AA := NEW A'(4, 5, 6);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 5");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A (1 .. 3);
-
- TYPE R6 IS RECORD
- C6 : AA := NEW A'(4, 4, 4, 4);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 6");
- END;
-
- BEGIN
- DECLARE
- TYPE AI IS ACCESS INTEGER RANGE 6 .. 8;
-
- TYPE R7 IS RECORD
- C7 : AI := NEW INTEGER'(5);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 7");
- END;
-
- BEGIN
- DECLARE
- TYPE UA IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 3 .. 5;
-
- SUBTYPE CA IS UA (7 .. 8);
-
- TYPE R8 IS RECORD
- C8 : CA := (6 .. 8 => 4);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 8");
- END;
-
- BEGIN
- DECLARE
- TYPE UA IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 3 .. IDENT_INT(5);
-
- TYPE R9 IS RECORD
- C9 : UA (11 .. 11) := (11 => 6);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 9");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. IDENT_INT (5);
-
- TYPE AA IS ACCESS A;
-
- TYPE R10 IS RECORD
- C10 : AA := NEW A'(4, 5, 6);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 10");
- END;
-
- BEGIN
- DECLARE
- TYPE A IS ARRAY (NATURAL RANGE <> )
- OF INTEGER RANGE 1 .. 5;
-
- TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3));
-
- TYPE R11 IS RECORD
- C11 : AA := NEW A'(4, 4, 4, 4);
- END RECORD;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED 11");
- END;
-
- RESULT;
-END C37008B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37009a.ada b/gcc/testsuite/ada/acats/tests/c3/c37009a.ada
deleted file mode 100644
index bdb3d81..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37009a.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C37009A.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 UNCONSTRAINED RECORD TYPE CAN BE USED TO DECLARE A
--- RECORD COMPONENT THAT CAN BE INITIALIZED WITH AN APPROPRIATE
--- EXPLICIT OR DEFAULT VALUE.
-
--- HISTORY:
--- DHH 02/01/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37009A IS
-
- TYPE FLOAT IS DIGITS 5;
- TYPE COLOR IS (RED, YELLOW, BLUE);
-
- TYPE COMPONENT IS
- RECORD
- I : INTEGER := 1;
- X : FLOAT := 3.5;
- BOL : BOOLEAN := FALSE;
- FIRST : COLOR := RED;
- END RECORD;
- TYPE COMP_DIS(A : INTEGER := 1) IS
- RECORD
- I : INTEGER := 1;
- X : FLOAT := 3.5;
- BOL : BOOLEAN := FALSE;
- FIRST : COLOR := RED;
- END RECORD;
- SUBTYPE SMAL_INTEGER IS INTEGER RANGE 1 .. 10;
- TYPE LIST IS ARRAY(INTEGER RANGE <>) OF FLOAT;
-
- TYPE DISCRIM(P : SMAL_INTEGER := 2) IS
- RECORD
- A : LIST(1 .. P) := (1 .. P => 1.25);
- END RECORD;
-
- TYPE REC_T IS -- EXPLICIT INIT.
- RECORD
- T : COMPONENT := (5, 6.0, TRUE, YELLOW);
- U : DISCRIM(3) := (3, (1 .. 3 => 2.25));
- L : COMP_DIS(5) := (A => 5, I => 5, X => 6.0,
- BOL =>TRUE, FIRST => YELLOW);
- END RECORD;
-
- TYPE REC_DEF_T IS -- DEFAULT INIT.
- RECORD
- T : COMPONENT;
- U : DISCRIM;
- L : COMP_DIS;
- END RECORD;
-
- REC : REC_T;
- REC_DEF : REC_DEF_T;
-
- FUNCTION IDENT_FLT(X : FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FLT;
-
- FUNCTION IDENT_ENUM(X : COLOR) RETURN COLOR IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN BLUE;
- END IF;
- END IDENT_ENUM;
-
-BEGIN
- TEST("C37009A", "CHECK THAT AN UNCONSTRAINED RECORD TYPE CAN " &
- "BE USED TO DECLARE A RECORD COMPONENT THAT " &
- "CAN BE INITIALIZED WITH AN APPROPRIATE " &
- "EXPLICIT OR DEFAULT VALUE");
-
- IF REC_DEF.T.I /= IDENT_INT(1) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER");
- END IF;
-
- IF IDENT_BOOL(REC_DEF.T.BOL) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN");
- END IF;
-
- IF REC_DEF.T.X /= IDENT_FLT(3.5) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL");
- END IF;
-
- IF REC_DEF.T.FIRST /= IDENT_ENUM(RED) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION");
- END IF;
-
- FOR I IN 1 .. 2 LOOP
- IF REC_DEF.U.A(I) /= IDENT_FLT(1.25) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF ARRAY " &
- "POSITION " & INTEGER'IMAGE(I));
- END IF;
- END LOOP;
-
- IF REC_DEF.L.A /= IDENT_INT(1) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF DISCRIMINANT " &
- "- L");
- END IF;
-
- IF REC_DEF.L.I /= IDENT_INT(1) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER - L");
- END IF;
-
- IF IDENT_BOOL(REC_DEF.L.BOL) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN - L");
- END IF;
-
- IF REC_DEF.L.X /= IDENT_FLT(3.5) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL - L");
- END IF;
-
- IF REC_DEF.L.FIRST /= IDENT_ENUM(RED) THEN
- FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION - L");
- END IF;
---------------------------------------------------------------------
- IF REC.T.I /= IDENT_INT(5) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER");
- END IF;
-
- IF NOT IDENT_BOOL(REC.T.BOL) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN");
- END IF;
-
- IF REC.T.X /= IDENT_FLT(6.0) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL");
- END IF;
-
- IF REC.T.FIRST /= YELLOW THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION");
- END IF;
-
- FOR I IN 1 .. 3 LOOP
- IF REC.U.A(I) /= IDENT_FLT(2.25) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF ARRAY " &
- "POSITION " & INTEGER'IMAGE(I));
- END IF;
- END LOOP;
-
- IF REC.L.A /= IDENT_INT(5) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF DISCRIMINANT " &
- "- L");
- END IF;
-
- IF REC.L.I /= IDENT_INT(5) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER - L");
- END IF;
-
- IF NOT IDENT_BOOL(REC.L.BOL) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN - L");
- END IF;
-
- IF REC.L.X /= IDENT_FLT(6.0) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL - L");
- END IF;
-
- IF REC.L.FIRST /= IDENT_ENUM(YELLOW) THEN
- FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION " &
- "- L");
- END IF;
-
- RESULT;
-
-END C37009A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37010a.ada b/gcc/testsuite/ada/acats/tests/c3/c37010a.ada
deleted file mode 100644
index 64ba420..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37010a.ada
+++ /dev/null
@@ -1,140 +0,0 @@
--- C37010A.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 EXPRESSIONS IN CONSTRAINTS OF COMPONENT DECLARATIONS ARE
--- EVALUATED IN THE ORDER THE COMPONENTS APPEAR.
-
--- R.WILLIAMS 8/22/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37010A IS
-
- TYPE R (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCR IS ACCESS R;
-
- TYPE ARR IS ARRAY (POSITIVE RANGE <> ) OF INTEGER;
-
- TYPE ACCA IS ACCESS ARR;
-
- BUMP : INTEGER := 0;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN BUMP;
- END;
-
-BEGIN
- TEST ( "C37010A", "CHECK THAT EXPRESSIONS IN CONSTRAINTS OF " &
- "COMPONENT DECLARATIONS ARE EVALUATED IN " &
- "THE ORDER THE COMPONENTS APPEAR" );
-
- DECLARE
-
- TYPE REC1 IS
- RECORD
- A1 : R (D => F);
- B1 : STRING (1 .. F);
- C1 : ACCR (F);
- D1 : ACCA (1 .. F);
- END RECORD;
-
- R1 : REC1;
-
- BEGIN
- IF R1.A1.D /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R1.A1.D" );
- END IF;
-
- IF R1.B1'LAST /= 2 THEN
- FAILED ( "INCORRECT VALUE FOR R1.B1'LAST" );
- END IF;
-
- BEGIN
- R1.C1 := NEW R'(D => 3);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R1.C1" );
- END;
-
- BEGIN
- R1.D1 := NEW ARR (1 .. 4);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R1.D1" );
- END;
-
- END;
-
- BUMP := 0;
-
- DECLARE
-
- TYPE REC2 (I : INTEGER) IS
- RECORD
- CASE I IS
- WHEN 1 =>
- NULL;
- WHEN OTHERS =>
- A2 : R (D => F);
- B2 : ARR (1 .. F);
- C2 : ACCR (F);
- D2 : ACCA (1 .. F);
- END CASE;
- END RECORD;
-
- R2 : REC2 (IDENT_INT (2));
-
- BEGIN
-
- IF R2.A2.D /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R2.A2.D" );
- END IF;
-
- IF R2.B2'LAST /= 2 THEN
- FAILED ( "INCORRECT VALUE FOR R2.B2'LAST" );
- END IF;
-
- BEGIN
- R2.C2 := NEW R (D => 3);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R2.C2" );
- END;
-
- BEGIN
- R2.D2 := NEW ARR (1 .. 4);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R2.D2" );
- END;
-
- END;
-
- RESULT;
-END C37010A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37010b.ada b/gcc/testsuite/ada/acats/tests/c3/c37010b.ada
deleted file mode 100644
index aa94b2d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37010b.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C37010B.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 EXPRESSIONS IN AN INDEX CONSTRAINT OR DISCRIMINANT
--- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT DECLARATION IS
--- ELABORATED EVEN IF SOME BOUNDS OR DISCRIMINANTS ARE GIVEN BY
--- A DISCRIMINANT OF AN ENCLOSING RECORD TYPE.
-
--- R.WILLIAMS 8/22/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37010B IS
-
- INIT :INTEGER := IDENT_INT (5);
-
- TYPE R (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCR IS ACCESS R;
-
- TYPE ARR IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
-
- TYPE ACCA IS ACCESS ARR;
-
- FUNCTION RESET (N : INTEGER) RETURN INTEGER IS
- BEGIN
- INIT := IDENT_INT (N);
- RETURN N;
- END RESET;
-
-BEGIN
- TEST ( "C37010B", "CHECK THAT EXPRESSIONS IN AN INDEX " &
- "CONSTRAINT OR DISCRIMINANT CONSTRAINT " &
- "ARE EVALUATED WHEN THE COMPONENT " &
- "DECLARATION IS ELABORATED EVEN IF SOME " &
- "BOUNDS OR DISCRIMINANTS ARE GIVEN BY " &
- "A DISCRIMINANT OF AN ENCLOSING RECORD TYPE" );
-
- DECLARE
-
- TYPE REC1 (D : INTEGER) IS
- RECORD
- W1 : R (D1 => INIT, D2 => D);
- X1 : ARR (INIT .. D);
- Y1 : ACCR (D, INIT);
- Z1 : ACCA (D .. INIT);
- END RECORD;
-
- INT1 : INTEGER := RESET (10);
-
- R1 : REC1 (D => 4);
-
- BEGIN
- IF R1.W1.D1 /= 5 THEN
- FAILED ( "INCORRECT VALUE FOR R1.W1.D1" );
- END IF;
-
- IF R1.W1.D2 /= 4 THEN
- FAILED ( "INCORRECT VALUE FOR R1.W1.D2" );
- END IF;
-
- IF R1.X1'FIRST /= 5 THEN
- FAILED ( "INCORRECT VALUE FOR R1.X1'FIRST" );
- END IF;
-
- IF R1.X1'LAST /= 4 THEN
- FAILED ( "INCORRECT VALUE FOR R1.X1'LAST" );
- END IF;
-
- BEGIN
- R1.Y1 := NEW R (4, 5);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R1.Y1" );
- END;
-
- BEGIN
- R1.Z1 := NEW ARR (4 .. 5);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R1.Z1" );
- END;
-
- END;
-
- DECLARE
-
- TYPE REC2 (D : INTEGER) IS
- RECORD
- CASE D IS
- WHEN 1 =>
- NULL;
- WHEN 2 =>
- NULL;
- WHEN OTHERS =>
- W2 : R (D1 => D, D2 => INIT);
- X2 : ARR (D .. INIT);
- Y2 : ACCR (INIT, D);
- Z2 : ACCA (D .. INIT);
- END CASE;
- END RECORD;
-
- INT2 : INTEGER := RESET (20);
-
- R2 : REC2 (D => 6);
-
- BEGIN
- IF R2.W2.D1 /= 6 THEN
- FAILED ( "INCORRECT VALUE FOR R2.W2.D1" );
- END IF;
-
- IF R2.W2.D2 /= 10 THEN
- FAILED ( "INCORRECT VALUE FOR R2.W2.D2" );
- END IF;
-
- IF R2.X2'FIRST /= 6 THEN
- FAILED ( "INCORRECT VALUE FOR R2.X2'FIRST" );
- END IF;
-
- IF R2.X2'LAST /= 10 THEN
- FAILED ( "INCORRECT VALUE FOR R2.X2'LAST" );
- END IF;
-
- BEGIN
- R2.Y2 := NEW R (10, 6);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R2.Y2" );
- END;
-
- BEGIN
- R2.Z2 := NEW ARR (6 .. 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "INCORRECT VALUE FOR R2.Z2" );
- END;
-
- END;
-
- RESULT;
-END C37010B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371001.a b/gcc/testsuite/ada/acats/tests/c3/c371001.a
deleted file mode 100644
index f682357..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371001.a
+++ /dev/null
@@ -1,388 +0,0 @@
--- C371001.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 discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred
--- until an object of the subtype is created. Check for cases of
--- records with private type component.
---
--- TEST DESCRIPTION:
--- This transition test defines record type and incomplete types with
--- discriminant components which depend on the discriminants. The
--- discriminants are calculated by function calls. The test verifies
--- that Constraint_Error is raised during the object creations when
--- values of discriminants are incompatible with the subtypes.
---
--- Inspired by C37214A.ADA and C37216A.ADA.
---
---
--- CHANGE HISTORY:
--- 11 Apr 96 SAIC Initial version for ACVC 2.1.
--- 06 Oct 96 SAIC Added LM references. Replaced "others exception"
--- with "unexpected exception"
---
---!
-
-with Report;
-
-procedure C371001 is
-
- subtype Small_Int is Integer range 1..10;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-
-begin
- Report.Test ("C371001", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- -- Constraint checks on an object declaration of a record.
-
- begin
-
- declare
-
- package C371001_0 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_0;
-
- --=====================================================--
-
- Obj : C371001_0.Rec(Report.Ident_Int(0)); -- Constraint_Error raised.
-
- begin
- Report.Failed ("Obj - Constraint_Error should be raised");
- if Obj.C1.D1 /= 0 then
- Report.Failed ("Obj - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an array.
-
- begin
- declare
-
- package C371001_1 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec_01 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- type Arr is array (1 .. 5) of
- Rec_01(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_1;
-
- --=====================================================--
-
- begin
- declare
- Obj1 : C371001_1.Arr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj1 - Constraint_Error should be raised");
- if Obj1(1).D3 /= 0 then
- Report.Failed ("Obj1 - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj1 - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj1 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Arr - Constraint_Error raised");
- when others =>
- Report.Failed ("Arr - unexpected exception raised");
- end;
-
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an access type.
-
- begin
- declare
-
- package C371001_2 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec_02 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- type Acc_Rec2 is access Rec_02 -- No Constraint_Error
- (Report.Ident_Int(11)); -- raised.
-
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_2;
-
- --=====================================================--
-
- begin
- declare
- Obj2 : C371001_2.Acc_Rec2; -- No Constraint_Error
- -- raised.
- begin
- Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj2 - Constraint_Error should be raised");
- if Obj2.D3 /= 1 then
- Report.Failed ("Obj2 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj2 - unexpected exception raised in " &
- "assignment");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Obj2 - Constraint_Error raised in declaration");
- when others =>
- Report.Failed ("Obj2 - unexpected exception raised in " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec2 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec2 - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of a subtype.
-
- Func1_Cons := -1;
-
- begin
- declare
-
- package C371001_3 is
-
- type PT_W_Disc (D1, D2 : Small_Int) is private;
- type Rec_W_Private (D3, D4 : Integer) is
- record
- C : PT_W_Disc (D3, D4);
- end record;
-
- type Rec_03 (D5 : Integer) is
- record
- C1 : Rec_W_Private (D5, Func1); -- Func1 evaluated,
- end record; -- value 0.
-
- subtype Subtype_Rec is Rec_03(1); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D1, D2 : Small_Int) is
- record
- Str1 : String (1 .. D1) := (others => '*');
- Str2 : String (1 .. D2) := (others => '*');
- end record;
-
- end C371001_3;
-
- --=====================================================--
-
- begin
- declare
- Obj3 : C371001_3.Subtype_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj3 - Constraint_Error should be raised");
- if Obj3.D5 /= 1 then
- Report.Failed ("Obj3 - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj3 - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj3 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_Rec - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an incomplete type.
-
- Func1_Cons := 10;
-
- begin
- declare
-
- package C371001_4 is
-
- type Rec_04 (D3 : Integer);
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1, D2 : Small_Int) is
- record
- C : PT_W_Disc (D2);
- end record;
-
- type Rec_04 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3, Func1); -- Func1 evaluated
- end record; -- value 11.
-
- type Acc_Rec4 is access Rec_04 (1); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_4;
-
- --=====================================================--
-
- begin
- declare
- Obj4 : C371001_4.Acc_Rec4; -- No Constraint_Error
- -- raised.
- begin
- Obj4 := new C371001_4.Rec_04 (1); -- Constraint_Error raised.
-
- Report.Failed ("Obj4 - Constraint_Error should be raised");
- if Obj4.D3 /= 1 then
- Report.Failed ("Obj4 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj4 - unexpected exception raised in " &
- "assignment");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Obj4 - Constraint_Error raised in declaration");
- when others =>
- Report.Failed ("Obj4 - unexpected exception raised in " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec4 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec4 - unexpected exception raised");
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371002.a b/gcc/testsuite/ada/acats/tests/c3/c371002.a
deleted file mode 100644
index ea532550..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371002.a
+++ /dev/null
@@ -1,364 +0,0 @@
--- C371002.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 discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred until
--- an object of the subtype is created. Check for cases of records.
---
--- TEST DESCRIPTION:
--- This transition test defines record types with discriminant components
--- which depend on the discriminants. The discriminants are calculated
--- by function calls. The test verifies that Constraint_Error is raised
--- during the object creations when values of discriminants are
--- incompatible with the subtypes.
---
--- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA.
---
---
--- CHANGE HISTORY:
--- 05 Apr 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-with Report;
-
-procedure C371002 is
-
- subtype Small_Int is Integer range 1..10;
-
- type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
- record
- Str1 : String (1 .. Disc1) := (others => '*');
- Str2 : String (1 .. Disc2) := (others => '*');
- end record;
-
- type My_Array is array (Small_Int range <>) of Integer;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Chk (Cons : Integer;
- Value : Integer;
- Message : String) return Boolean is
- begin
- if Cons /= Value then
- Report.Failed (Message & ": Func1_Cons is " &
- Integer'Image(Func1_Cons));
- end if;
- return True;
- end Chk;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-begin
- Report.Test ("C371002", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- declare
- type Rec1 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1.
- end record;
-
- Chk1 : Boolean := Chk (Func1_Cons, 1,
- "Func1 not evaluated for Rec1");
-
- Obj1 : Rec1 (1); -- Func1 not evaluated again.
- Obj2 : Rec1 (2); -- Func1 not evaluated again.
-
- Chk2 : Boolean := Chk (Func1_Cons, 1,
- "Func1 evaluated too many times");
- begin
- if Obj1 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) or
- Obj2 /= (D3 => 2,
- C1 => (Disc1 => 2,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Failed ("Obj1 & Obj2 - Discriminant values not correct");
- end if;
- end;
-
- ---------------------------------------------------------
- Func1_Cons := -11;
-
- declare
- type Rec_Of_Rec_01 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10.
- end record; -- Constraint_Error not raised.
-
- type Rec_Of_MyArr_01 (D3 : Integer) is
- record
- C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9.
- end record; -- Constraint_Error not raised.
-
- type Rec_Of_Rec_02 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, 1);
- end record;
-
- type Rec_Of_MyArr_02 (D3 : Integer) is
- record
- C1 : My_Array (D3 .. 1);
- end record;
-
- begin
-
- ---------------------------------------------------------
- begin
- declare
- Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised.
- begin
- Report.Failed ("Obj3 - Constraint_Error should be raised");
- if Obj3 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("Obj3 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj3 - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- subtype Subtype_Rec is Rec_Of_Rec_01(1);
- -- No Constraint_Error raised.
- begin
- declare
- Obj4 : Subtype_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj4 - Constraint_Error should be raised");
- if Obj4 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("Obj4 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj4 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Arr is array (1..5) -- No Constraint_Error raised.
- of Rec_Of_Rec_01(1);
-
- begin
- declare
- Obj5 : Arr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj5 - Constraint_Error should be raised");
- if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then
- Report.Comment ("Obj5 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj5 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Arr - Constraint_Error raised");
- when others =>
- Report.Failed ("Arr - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Rec_Of_Rec_Of_MyArr is
- record
- C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised.
- end record;
- begin
- declare
- Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj6 - Constraint_Error should be raised");
- if Obj6 /= (C1 => (1, (1, 1))) then
- Report.Comment ("Obj6 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj6 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type New_Rec is
- new Rec_Of_MyArr_01(1); -- No Constraint_Error raised.
-
- begin
- declare
- Obj7 : New_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj7 - Constraint_Error should be raised");
- if Obj7 /= (1, (1, 1)) then
- Report.Comment ("Obj7 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj7 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("New_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("New_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Acc_Rec is
- access Rec_Of_Rec_02 (Report.Ident_Int(0));
- -- No Constraint_Error raised.
- begin
- declare
- Obj8 : Acc_Rec; -- No Constraint_Error raised.
-
- begin
- Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj8 - Constraint_Error should be raised");
- if Obj8.all /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("Obj8 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj8 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Acc_Rec_MyArr is access
- Rec_Of_MyArr_02; -- No Constraint_Error
- -- raised for either
- Obj9 : Acc_Rec_MyArr; -- declaration.
-
- begin
- Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj9 - Constraint_Error should be raised");
-
- if Obj9.all /= (1, (1, 1)) then
- Report.Comment ("Obj9 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj9 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec_MyArr - others exception raised");
- end;
-
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371003.a b/gcc/testsuite/ada/acats/tests/c3/c371003.a
deleted file mode 100644
index c4a8345..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371003.a
+++ /dev/null
@@ -1,474 +0,0 @@
--- C371003.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 discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred
--- until an object of the subtype is created. Check for cases of
--- records where the component containing the constraint is present
--- in the subtype.
---
--- TEST DESCRIPTION:
--- This transition test defines record types with discriminant components
--- which depend on the discriminants. The discriminants are calculated
--- by function calls. The test verifies that Constraint_Error is raised
--- during the object creations when values of discriminants are
--- incompatible with the subtypes. Also check for cases, where the
--- component is absent.
---
--- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA.
---
---
--- CHANGE HISTORY:
--- 10 Apr 96 SAIC Initial version for ACVC 2.1.
--- 14 Jul 96 SAIC Modified test description. Added exception handler
--- for VObj_10 assignment.
--- 26 Oct 96 SAIC Added LM references.
---
---!
-
-with Report;
-
-procedure C371003 is
-
- subtype Small_Int is Integer range 1..10;
-
- type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
- record
- Str1 : String (1 .. Disc1) := (others => '*');
- Str2 : String (1 .. Disc2) := (others => '*');
- end record;
-
- type My_Array is array (Small_Int range <>) of Integer;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Chk (Cons : Integer;
- Value : Integer;
- Message : String) return Boolean is
- begin
- if Cons /= Value then
- Report.Failed (Message & ": Func1_Cons is " &
- Integer'Image(Func1_Cons));
- end if;
- return True;
- end Chk;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-
-begin
- Report.Test ("C371003", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- declare
- type VRec_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1.
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- Chk1 : Boolean := Chk (Func1_Cons, 1,
- "Func1 not evaluated for VRec_01");
-
- VObj_1 : VRec_01(1); -- Func1 not evaluated again
- VObj_2 : VRec_01(2); -- Func1 not evaluated again
-
- Chk2 : Boolean := Chk (Func1_Cons, 1,
- "Func1 evaluated too many times");
-
- begin
- if VObj_1 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) or
- VObj_2 /= (D3 => 2,
- C1 => (Disc1 => 2,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct");
- end if;
- end;
-
- ---------------------------------------------------------
- Func1_Cons := -11;
-
- declare
- type VRec_Of_VRec_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10.
- when others => -- Constraint_Error not raised.
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_VRec_02 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (1, D3);
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_MyArr_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9.
- when others => -- Constraint_Error not raised.
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_MyArr_02 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : My_Array (D3..1);
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- begin
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_3 - Constraint_Error should be raised");
- if VObj_3 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_3 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_3 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- subtype Subtype_VRec is -- No Constraint_Error raised.
- VRec_Of_VRec_01(Report.Ident_Int(1));
- begin
- declare
- VObj_4 : Subtype_VRec; -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_4 - Constraint_Error should be raised");
- if VObj_4 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("VObj_4 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_4 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_VRec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Arr is array (1..5) of
- VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error
- VObj_5 : Arr; -- for either declaration.
-
- begin
- if VObj_5 /= (1 .. 5 => (-6, 0)) then
- Report.Comment ("VObj_5 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Arr - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Rec_Of_Rec_Of_MyArr is
- record
- C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised.
- end record;
- begin
- declare
- Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj_6 - Constraint_Error should be raised");
- if Obj_6 /= (C1 => (1, (1, 1))) then
- Report.Comment ("Obj_6 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj_6 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " &
- "raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type New_VRec_Arr is
- new VRec_Of_MyArr_01(11); -- No Constraint_Error raised
- Obj_7 : New_VRec_Arr; -- for either declaration.
-
- begin
- if Obj_7 /= (11, 0) then
- Report.Failed ("Obj_7 - value incorrect");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("New_VRec_Arr - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type New_VRec is new
- VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- begin
- declare
- VObj_8 : New_VRec; -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_8 - Constraint_Error should be raised");
- if VObj_8 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_8 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_8 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("New_VRec - Constraint_Error raised");
- when others =>
- Report.Failed ("New_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- subtype Sub_VRec is
- VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error
- VObj_9 : Sub_VRec; -- raised for either
- -- declaration.
- begin
- if VObj_9 /= (11, 0) then
- Report.Comment ("VObj_9 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Sub_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Acc_VRec_01 is access
- VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- begin
- declare
- VObj_10 : Acc_VRec_01; -- No Constraint_Error
- -- raised.
- begin
- VObj_10 := new VRec_Of_VRec_02
- (Report.Ident_Int(0)); -- Constraint_Error
- -- raised.
- Report.Failed ("VObj_10 - Constraint_Error should be raised");
- if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_10 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_10 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("VObj_10 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("VObj_10 - unexpected exception raised at " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_VRec_01 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_VRec_01 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Acc_VRec_02 is access
- VRec_Of_VRec_02(11); -- No Constraint_Error
- -- raised for either
- VObj_11 : Acc_VRec_02; -- declaration.
-
- begin
- VObj_11 := new VRec_Of_VRec_02(11);
- if VObj_11.all /= (11, 0) then
- Report.Comment ("VObj_11 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Acc_VRec_02 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Acc_VRec_03 is access
- VRec_Of_MyArr_02; -- No Constraint_Error
- -- raised for either
- VObj_12 : Acc_VRec_03; -- declaration.
- begin
- VObj_12 := new VRec_Of_MyArr_02
- (Report.Ident_Int(0)); -- Constraint_Error raised.
-
- Report.Failed ("VObj_12 - Constraint_Error should be raised");
- if VObj_12.all /= (1, (1, 1)) then
- Report.Comment ("VObj_12 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_12 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_VRec_03 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_VRec_03 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Acc_VRec_04 is access
- VRec_Of_MyArr_02(11); -- No Constraint_Error
- -- raised for either
- VObj_13 : Acc_VRec_04; -- declaration.
-
- begin
- VObj_13 := new VRec_Of_MyArr_02(11);
- if VObj_13.all /= (11, 0) then
- Report.Comment ("VObj_13 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Acc_VRec_04 - unexpected exception raised");
- end;
-
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37102b.ada b/gcc/testsuite/ada/acats/tests/c3/c37102b.ada
deleted file mode 100644
index 13c4e5c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37102b.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C37102B.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 RECORD TYPE, THE IDENTIFIER FOR A DISCRIMINANT
--- CAN BE USED AS A SELECTED COMPONENT IN AN INDEX OR DISCRIMINANT
--- CONSTRAINT, AS THE NAME OF A DISCRIMINANT IN A DISCRIMINANT
--- SPECIFICATION, AND AS THE PARAMETER NAME IN A FUNCTION CALL IN A
--- DISCRIMINANT OR INDEX CONSTRAINT.
-
--- R.WILLIAMS 8/25/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37102B IS
-
-BEGIN
- TEST ( "C37102B", "CHECK THAT, FOR A RECORD TYPE, THE " &
- "IDENTIFIER FOR A DISCRIMINANT CAN BE USED " &
- "AS A SELECTED COMPONENT IN AN INDEX OR " &
- "DISCRIMINANT CONSTRAINT, AS THE NAME OF A " &
- "DISCRIMINANT IN A DISCRIMINANT " &
- "SPECIFICATION, AND AS THE PARAMETER NAME " &
- "IN A FUNCTION CALL IN A DISCRIMINANT OR " &
- "INDEX CONSTRAINT" );
-
- DECLARE
-
- FUNCTION F (D : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (D);
- END F;
-
- PACKAGE P IS
-
- TYPE D IS NEW INTEGER;
-
- TYPE REC1 IS
- RECORD
- D : INTEGER := IDENT_INT (1);
- END RECORD;
-
- G : REC1;
-
- TYPE REC2 (D : INTEGER := 3) IS
- RECORD
- NULL;
- END RECORD;
-
- H : REC2 (IDENT_INT (5));
-
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE Q (D : INTEGER := 0) IS
- RECORD
- J : REC2 (D => H.D);
- K : ARR (G.D .. F (D => 5));
- L : REC2 (F (D => 4));
- END RECORD;
-
- END P;
-
- USE P;
-
- BEGIN
- DECLARE
- R : Q;
-
- BEGIN
- IF R.J.D /= 5 THEN
- FAILED ( "INCORRECT VALUE FOR R.J" );
- END IF;
-
- IF R.K'FIRST /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R.K'FIRST" );
- END IF;
-
- IF R.K'LAST /= 5 THEN
- FAILED ( "INCORRECT VALUE FOR R.K'LAST" );
- END IF;
-
- IF R.L.D /= 4 THEN
- FAILED ( "INCORRECT VALUE FOR R.L" );
- END IF;
- END;
-
- END;
-
- RESULT;
-END C37102B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37103a.ada b/gcc/testsuite/ada/acats/tests/c3/c37103a.ada
deleted file mode 100644
index 1087835..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37103a.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C37103A.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 DISCRIMINANTS MAY BE BOOLEAN, CHARACTER, USER_ENUM,
--- INTEGER, DERIVED CHARACTER, DERIVED USER_ENUM, DERIVED INTEGER,
--- AND DERIVED DERIVED USER_ENUM.
-
--- DAT 5/18/81
--- SPS 10/25/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37103A IS
-BEGIN
- TEST ("C37103A", "MANY DIFFERENT DISCRIMINANT TYPES");
- DECLARE
- PACKAGE P1 IS
- TYPE ENUM IS (A, Z, Q, 'W', 'A');
- END P1;
-
- PACKAGE P2 IS
- TYPE E2 IS NEW P1.ENUM;
- END P2;
-
- PACKAGE P3 IS
- TYPE E3 IS NEW P2.E2;
- END P3;
-
- USE P1, P2, P3;
- TYPE INT IS NEW INTEGER RANGE -3 .. 7;
- TYPE CHAR IS NEW CHARACTER;
- TYPE R1 (D : ENUM) IS RECORD NULL; END RECORD;
- TYPE R2 (D : INTEGER) IS RECORD NULL; END RECORD;
- TYPE R3 (D : BOOLEAN) IS RECORD NULL; END RECORD;
- TYPE R4 (D : CHARACTER) IS RECORD NULL; END RECORD;
- TYPE R5 (D : CHAR) IS RECORD NULL; END RECORD;
- TYPE R6 (D : E2) IS RECORD NULL; END RECORD;
- TYPE R7 (D : E3) IS RECORD NULL; END RECORD;
- TYPE R8 (D : INT) IS RECORD NULL; END RECORD;
- O1 : R1(A) := (D => A);
- O2 : R2(3) := (D => 3);
- O3 : R3(TRUE) := (D => TRUE);
- O4 : R4(ASCII.NUL) := (D => ASCII.NUL);
- O5 : R5('A') := (D => 'A');
- O6 : R6('A') := (D => 'A');
- O7 : R7(A) := (D => A);
- O8 : R8(2) := (D => 2);
- BEGIN
- IF O1.D /= A
- OR O2.D /= 3
- OR NOT O3.D
- OR O4.D IN 'A' .. 'Z'
- OR O5.D /= 'A'
- OR O6.D /= 'A'
- OR O7.D /= A
- OR O8.D /= 2
- THEN FAILED ("WRONG DISCRIMINANT VALUE");
- END IF;
- END;
-
- RESULT;
-END C37103A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37105a.ada b/gcc/testsuite/ada/acats/tests/c3/c37105a.ada
deleted file mode 100644
index b8f836e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37105a.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- C37105A.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 RECORDS WITH ONLY DISCRIMINANTS ARE OK.
-
--- DAT 5/18/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37105A IS
-BEGIN
- TEST ("C37105A", "RECORDS WITH ONLY DISCRIMINANTS");
-
- DECLARE
- TYPE R1 (D : BOOLEAN) IS RECORD
- NULL; END RECORD;
- TYPE R2 (D, E : BOOLEAN) IS RECORD
- NULL; END RECORD;
- TYPE R3 (A,B,C,D : INTEGER; W,X,Y,Z : CHARACTER) IS
- RECORD NULL; END RECORD;
- OBJ1 : R1 (IDENT_BOOL(TRUE));
- OBJ2 : R2 (IDENT_BOOL(FALSE), IDENT_BOOL(TRUE));
- OBJ3 : R3 (1,2,3,4,'A','B','C',IDENT_CHAR('D'));
- BEGIN
- IF OBJ1 = (D => (FALSE))
- OR OBJ2 /= (FALSE, (TRUE))
- OR OBJ3 /= (1,2,3,4,'A','B','C',('D'))
- THEN FAILED ("DISCRIMINANT-ONLY RECORDS DON'T WORK");
- END IF;
- END;
-
- RESULT;
-END C37105A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37107a.ada b/gcc/testsuite/ada/acats/tests/c3/c37107a.ada
deleted file mode 100644
index a007f7c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37107a.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- C37107A.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 DEFAULT DISCRIMINANT EXPRESSION NEED NOT BE STATIC AND
--- IS EVALUATED ONLY WHEN NEEDED.
-
--- R.WILLIAMS 8/25/86
--- GMT 6/29/87 ADDED INTEGER ARGUMENT TO THE FUNCTION F.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37107A IS
-
- FUNCTION F ( B : BOOLEAN;
- I : INTEGER ) RETURN INTEGER IS
- BEGIN
- IF NOT B THEN
- FAILED ( "DEFAULT DISCRIMINANT EVALUATED " &
- "UNNECESSARILY - " &
- INTEGER'IMAGE(I) );
- END IF;
-
- RETURN IDENT_INT (1);
- END F;
-
-BEGIN
- TEST ( "C37107A", "CHECK THAT A DEFAULT DISCRIMINANT " &
- "EXPRESSION NEED NOT BE STATIC AND IS " &
- "EVALUATED ONLY WHEN NEEDED" );
-
- DECLARE
- TYPE REC1 ( D : INTEGER := F (TRUE,1) ) IS
- RECORD
- NULL;
- END RECORD;
-
- R1 : REC1;
-
- TYPE REC2 ( D : INTEGER := F (FALSE,2) ) IS
- RECORD
- NULL;
- END RECORD;
-
- R2 : REC2 (D => 0);
-
- BEGIN
- IF R1.D /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R1.D" );
- END IF;
-
- IF R2.D /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR R2.D" );
- END IF;
- END;
-
- DECLARE
-
- PACKAGE PRIV IS
- TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS PRIVATE;
- TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS PRIVATE;
-
- PRIVATE
- TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS
- RECORD
- NULL;
- END RECORD;
- END PRIV;
-
- USE PRIV;
-
- BEGIN
- DECLARE
- R3 : REC3;
- R4 : REC4 (D => 0);
-
- BEGIN
- IF R3.D /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R3.D" );
- END IF;
-
- IF R4.D /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR R4.D" );
- END IF;
- END;
-
- END;
-
- DECLARE
-
- PACKAGE LPRIV IS
- TYPE REC5
- ( D : INTEGER := F (TRUE,5) ) IS LIMITED PRIVATE;
- TYPE REC6
- ( D : INTEGER := F (FALSE,6) ) IS LIMITED PRIVATE;
-
- PRIVATE
- TYPE REC5 ( D : INTEGER := F (TRUE,5) ) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC6 ( D : INTEGER := F (FALSE,6) ) IS
- RECORD
- NULL;
- END RECORD;
- END LPRIV;
-
- USE LPRIV;
-
- BEGIN
- DECLARE
- R5 : REC5;
- R6 : REC6 (D => 0);
-
- BEGIN
- IF R5.D /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR R5.D" );
- END IF;
-
- IF R6.D /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR R6.D" );
- END IF;
- END;
-
- END;
-
- RESULT;
-END C37107A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37108b.ada b/gcc/testsuite/ada/acats/tests/c3/c37108b.ada
deleted file mode 100644
index 9d71e9a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37108b.ada
+++ /dev/null
@@ -1,247 +0,0 @@
--- C37108B.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 IN AN OBJECT DECLARATION IF
--- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE
--- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS
--- PROVIDED FOR THE OBJECT.
-
--- R.WILLIAMS 8/25/86
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37108B IS
-
- TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
-
- TYPE R (P : POSITIVE) IS
- RECORD
- NULL;
- END RECORD;
-
-BEGIN
- TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " &
- "AN OBJECT DECLARATION IF A DEFAULT INITIAL " &
- "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " &
- "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " &
- "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " &
- "AND NO EXPLICIT INITIALIZATION IS PROVIDED " &
- "FOR THE OBJECT" );
-
-
- BEGIN
- DECLARE
- TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS
- RECORD
- A : ARR (D .. 5);
- END RECORD;
-
- BEGIN
- DECLARE
- R1 : REC1;
-
- BEGIN
- R1.A (1) := IDENT_INT (2);
- FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
- "R1" & INTEGER'IMAGE(R1.A(5))); --USE R2
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " &
- "BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF R1" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
- "DECLARATION OF REC1" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
- "DECLARATION OF REC1" );
- END;
-
- BEGIN
- DECLARE
- TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS
- RECORD
- A : R (P => D);
- END RECORD;
-
- BEGIN
- DECLARE
- R2 : REC2;
-
- BEGIN
- R2.A := R'(P => IDENT_INT (1));
- FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
- "R2" & INTEGER'IMAGE(R2.A.P)); --USE R2
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " &
- "BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF R2" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
- "DECLARATION OF REC2" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
- "DECLARATION OF REC2" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE PRIV IS
- TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
- PRIVATE;
- PROCEDURE PROC (R :REC3);
-
- PRIVATE
- TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
- RECORD
- A : R (P => D);
- END RECORD;
- END PRIV;
-
- PACKAGE BODY PRIV IS
- PROCEDURE PROC (R : REC3) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (R.A.P);
- IF EQUAL(2, IDENT_INT(1)) THEN
- FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I
- END IF;
- END PROC;
- END PRIV;
-
- USE PRIV;
-
- BEGIN
- DECLARE
- R3 : REC3;
-
- BEGIN
- PROC (R3);
- FAILED ( "NO EXCEPTION RAISED AT " &
- "DECLARATION OF R3" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " &
- "BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF R3" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
- "DECLARATION OF REC3" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
- "DECLARATION OF REC3" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE LPRIV IS
- TYPE REC4 (D : NATURAL := IDENT_INT (0))
- IS LIMITED PRIVATE;
- PROCEDURE PROC (R :REC4);
-
- PRIVATE
- TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS
- RECORD
- A : ARR (D .. 5);
- END RECORD;
- END LPRIV;
-
- PACKAGE BODY LPRIV IS
- PROCEDURE PROC (R : REC4) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (R.A'FIRST);
- IF EQUAL(2, IDENT_INT(1)) THEN
- FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I
- END IF;
- END PROC;
- END LPRIV;
-
- USE LPRIV;
-
- BEGIN
- DECLARE
- R4 : REC4;
-
- BEGIN
- PROC (R4);
- FAILED ( "NO EXCEPTION RAISED AT " &
- "DECLARATION OF R4" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " &
- "BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF R4" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
- "DECLARATION OF REC4" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
- "DECLARATION OF REC4" );
- END;
-
- RESULT;
-END C37108B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37206a.ada b/gcc/testsuite/ada/acats/tests/c3/c37206a.ada
deleted file mode 100644
index d37c794..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37206a.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C37206A.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:
--- FOR A TYPE WITHOUT DEFAULT DISCRIMINANT VALUES (BUT WITH
--- DISCRIMINANTS) CHECK THAT A TYPEMARK WHICH DENOTES SUCH AN
--- UNCONSTRAINED TYPE CAN BE USED IN:
-
--- 1) A SUBTYPE DECLARATION, AND THE SUBTYPE NAME ACTS SIMPLY AS A
--- NEW NAME FOR THE UNCONSTRAINED TYPE;
--- 2) IN A CONSTANT DECLARATION.
-
--- HISTORY:
--- AH 08/21/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- DTN 11/13/91 DELETED SUBPARTS (2 and 3).
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37206A IS
-BEGIN
-
- TEST ("C37206A", "FOR TYPE WITH DEFAULT-LESS DISCRIMINANTS, " &
- "UNCONSTRAINED TYPE_MARK CAN BE USED IN A SUBTYPE " &
- "DECLARATION OR IN A CONSTANT DECLARATION");
-
- DECLARE
- TYPE REC(DISC : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE ST IS REC; -- 1.
-
- C1 : CONSTANT REC := (DISC => 5); -- 2.
- C2 : CONSTANT REC := (DISC => IDENT_INT(5)); -- 2.
- BEGIN
-
- IF C1 /= C2 OR C1 /= (DISC => 5) THEN
- FAILED ("CONSTANT DECLARATIONS INCORRECT");
- END IF;
- END;
-
- RESULT;
-END C37206A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37207a.ada b/gcc/testsuite/ada/acats/tests/c3/c37207a.ada
deleted file mode 100644
index e027240..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37207a.ada
+++ /dev/null
@@ -1,230 +0,0 @@
--- C37207A.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:
-
--- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK
--- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING
--- CONTEXTS AND HAS THE PROPER EFFECT:
-
--- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR
--- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE,
--- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT
--- VALUES WITHOUT RAISING CONSTRAINT_ERROR
-
--- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES
--- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES
--- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES.
-
--- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED
--- DISCRIMINANT VALUES.
-
--- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND
--- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO
--- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR,
--- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT
--- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS
--- RAISED.
-
--- HISTORY:
-
--- ASL 07/24/81
--- RJW 08/28/86 CORRECTED SYNTAX ERRORS.
--- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
--- EDS 07/16/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37207A IS
-
-BEGIN
- TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
- "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
- "DEFAULT DISCRIMINANT VALUES");
-
- DECLARE
- TYPE REC1 (DISC : INTEGER := 5) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC2 (DISC : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- OBJ1 : REC1(6); -- 1.
- OBJ2 : REC2(6); -- 1.
- BADOBJ1 : REC1(7); -- 1.
- BADOBJ2 : REC2(7); -- 1.
-
- TYPE REC3 IS
- RECORD
- COMP1 : REC1(6); -- 2.
- COMP2 : REC2(6); -- 2.
- END RECORD;
-
- OBJ3 : REC3;
-
- TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3.
- TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3.
-
- A1 : ARR1;
- A2 : ARR2;
-
- TYPE REC1_NAME IS ACCESS REC1(6); -- 4.
- TYPE REC2_NAME IS ACCESS REC2(6); -- 4.
-
- ACC1 : REC1_NAME;
- ACC2 : REC2_NAME;
-
- SUBTYPE REC16 IS REC1(6);
- SUBTYPE REC26 IS REC2(6);
-
- PROCEDURE PROC (P1 : IN OUT REC16; -- 6.
- P2 : IN OUT REC26) IS -- 6.
- BEGIN
- IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6.
- FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
- "CONSTRAINED FORMAL PARAMETERS");
- END IF;
- BEGIN
- P1 := (DISC => 7); -- 6.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO CHANGE DISCRIMINANT OF " &
- "CONSTRAINED FORMAL PARAMETER " &
- INTEGER'IMAGE(P1.DISC));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)");
- END;
- BEGIN
- P2 := (DISC => 7); -- 6.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO CHANGE DISCRIMINANT OF " &
- "CONSTRAINED FORMAL PARAMETER " &
- INTEGER'IMAGE(P2.DISC));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)");
- END;
- END PROC;
- BEGIN
----------------------------------------------------------------
-
- BEGIN
- OBJ1 := (DISC => IDENT_INT(7)); -- 1.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO CHANGE DISCRIMINANT OF " &
- "CONSTRAINED OBJECT");
- IF OBJ1 = (DISC => 7) THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)");
- END;
-
----------------------------------------------------------------
-
- BEGIN
- OBJ3 := ((DISC => IDENT_INT(7)), -- 2.
- (DISC => IDENT_INT(7))); -- 2.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO CHANGE DISCRIMINANT OF " &
- "CONSTRAINED RECORD COMPONENT");
- IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)");
- END;
-
---------------------------------------------------------------
-
- BEGIN
- A2(2) := (DISC => IDENT_INT(7)); -- 3.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO CHANGE DISCRIMINANT OF " &
- "CONSTRAINED ARRAY COMPONENT");
- IF A2(2) = (DISC => 7) THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)");
- END;
-
---------------------------------------------------------------
-
- BEGIN
- ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
- "TO ACCESS VARIABLE");
- IF ACC1 = NEW REC1(DISC => 7) THEN
- COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)");
- END;
-
-----------------------------------------------------------------
-
- ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK.
-
- BEGIN
- ACC1.ALL := BADOBJ1; -- 5.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
- "TO ACCESSED OBJECT");
- IF ACC1.ALL = BADOBJ1 THEN
- COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)");
- END;
-
------------------------------------------------------------------
-
- PROC (OBJ1,OBJ2); -- OK.
-
- BEGIN
- PROC (BADOBJ1,BADOBJ2); -- 6.
- FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
- "PASSING OF CONSTRAINED ACTUAL " &
- "PARAMETERS TO DIFFERENTLY CONSTRAINED " &
- "FORMAL PARAMETERS");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)");
- END;
-
----------------------------------------------------------------
- END;
-
- RESULT;
-END C37207A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37208a.ada b/gcc/testsuite/ada/acats/tests/c3/c37208a.ada
deleted file mode 100644
index a83b7ef..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37208a.ada
+++ /dev/null
@@ -1,172 +0,0 @@
--- C37208A.ADA (RA #534/1)
-
--- 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.
---*
--- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A
--- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN:
-
- -- AN OBJECT DECLARATION, AND HENCE ASSIGNMENTS TO THE OBJECT CAN
- -- CHANGE ITS DISCRIMINANTS;
-
- -- A COMPONENT_DECLARATION IN A RECORD TYPE DEFINITION, AND HENCE
- -- ASSIGNMENTS TO THE COMPONENT CAN CHANGE THE VALUE OF ITS
- -- DISCRIMINANTS;
-
- -- A SUBTYPE INDICATION IN AN ARRAY TYPE DEFINITION, AND HENCE
- -- ASSIGNMENTS TO ONE OF THE COMPONENTS CAN CHANGE ITS
- -- DISCRIMINANT VALUES;
-
- -- A FORMAL PARAMETER OF A SUBPROGRAM; EXCEPT FOR PARAMETERS OF
- -- MODE IN, THE 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER
- -- BECOMES THE 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER;
- -- FOR IN OUT AND OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS
- -- FALSE, ASSIGNMENTS TO THE FORMAL PARAMETER CAN CHANGE THE
- -- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED
- -- ATTRIBUTE IS TRUE, ASSIGNNMENTS THAT ATTEMPT TO CHANGE THE
- -- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR.
-
--- ASL 7/23/81
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C37208A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37208A","DISCRIMINANT CONSTRAINT CAN BE OMITTED " &
- "FROM OBJECT DECLARATION, COMPONENT DECLARATION, SUBTYPE " &
- "INDICATION OR FORMAL SUBPROGRAM PARAMETER, IF THE TYPE " &
- "HAS DEFAULT DISCRIMINANTS");
-
- DECLARE
- TYPE REC1(DISC : INTEGER := 7) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC2 IS
- RECORD
- COMP : REC1;
- END RECORD;
-
- R : REC2;
- U1,U2,U3 : REC1 := (DISC => 3);
- C1,C2,C3 : REC1(3) := (DISC => 3);
- ARR : ARRAY(INTEGER RANGE 1..10) OF REC1;
- ARR2 : ARRAY (1..10) OF REC1(4);
-
- PROCEDURE PROC(P_IN : IN REC1;
- P_OUT : OUT REC1;
- P_IN_OUT : IN OUT REC1;
- CONSTR : IN BOOLEAN) IS
- BEGIN
- IF P_OUT'CONSTRAINED /= CONSTR
- OR P_IN_OUT'CONSTRAINED /= CONSTR THEN
- FAILED ("CONSTRAINED ATTRIBUTES DO NOT MATCH " &
- "FOR ACTUAL AND FORMAL PARAMETERS");
- END IF;
-
- IF P_IN'CONSTRAINED /= IDENT_BOOL(TRUE) THEN
- FAILED ("'CONSTRAINED IS FALSE FOR IN " &
- "PARAMETER");
- END IF;
-
- IF NOT CONSTR THEN -- UNCONSTRAINED ACTUAL PARAM
- P_OUT := (DISC => IDENT_INT(0));
- P_IN_OUT := (DISC => IDENT_INT(0));
- ELSE
- BEGIN
- P_OUT := (DISC => IDENT_INT(0));
- FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " &
- "PARAMETER ILLEGALLY CHANGED - 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 1");
- END;
-
- BEGIN
- P_IN_OUT := (DISC => IDENT_INT(0));
- FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " &
- "PARAMETER ILLEGALLY CHANGED - 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 2");
- END;
- END IF;
- END PROC;
- BEGIN
- IF U1.DISC /= IDENT_INT(3) THEN
- FAILED ("INITIAL DISCRIMINANT VALUE WRONG - U1");
- END IF;
-
- U1 := (DISC => IDENT_INT(5));
- IF U1.DISC /= 5 THEN
- FAILED ("ASSIGNMENT FAILED FOR OBJECT");
- END IF;
-
- IF R.COMP.DISC /= IDENT_INT(7) THEN
- FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - R");
- END IF;
-
- R.COMP := (DISC => IDENT_INT(5));
- IF R.COMP.DISC /= 5 THEN
- FAILED ("ASSIGNMENT FAILED FOR RECORD COMPONENT");
- END IF;
-
- FOR I IN 1..10 LOOP
- IF ARR(I).DISC /= IDENT_INT(7) THEN
- FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - ARR");
- END IF;
- END LOOP;
-
- ARR(3) := (DISC => IDENT_INT(5));
- IF ARR(3).DISC /= 5 THEN
- FAILED ("ASSIGNMENT FAILED FOR ARRAY COMPONENT");
- END IF;
-
- IF ARR /= (1..2|4..10 => (DISC => 7), 3 => (DISC => 5)) THEN
- FAILED ("MODIFIED WRONG COMPONENTS");
- END IF;
-
- PROC(C1,C2,C3,IDENT_BOOL(TRUE));
- PROC(U1,U2,U3,IDENT_BOOL(FALSE));
- IF U2.DISC /= 0 OR U3.DISC /= 0 THEN
- FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL PARAMETER " &
- "FAILED TO CHANGE DISCRIMINANT");
- END IF;
-
- PROC(ARR(1), ARR(3), ARR(4), FALSE);
- IF ARR(3).DISC /= 0 OR ARR(4).DISC /= 0 THEN
- FAILED ("ARRAY COMPONENT ASSIGNMENTS DIDN'T CHANGE " &
- "DISCRIMINANT OF COMPONENT");
- END IF;
-
- PROC (ARR2(2), ARR2(5), ARR2(10), TRUE);
- END;
-
- RESULT;
-END C37208A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37208b.ada b/gcc/testsuite/ada/acats/tests/c3/c37208b.ada
deleted file mode 100644
index 3fc4e65..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37208b.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C37208B.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.
---*
--- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A
--- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN A GENERIC FORMAL
--- PARAMETER, AND HENCE, FOR BOTH IN AND IN OUT PARAMETERS, THE
--- 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER BECOMES THE
--- 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER, AND, FOR IN
--- OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS FALSE,
--- ASSIGNMENTS TO THE FORMAL PARAMETERS CAN CHANGE THE
--- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED
--- ATTRIBUTE IS TRUE, ASSIGNMENTS THAT ATTEMPT TO CHANGE THE
--- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR.
-
--- ASL 7/29/81
--- VKG 1/20/83
--- EDS 7/16/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-PROCEDURE C37208B IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37208B","FOR TYPES WITH DEFAULT DISCRIMINANT " &
- "VALUES, DISCRIMINANT CONSTRAINTS CAN BE OMITTED " &
- "IN GENERIC FORMAL PARAMETERS, AND THE " &
- "'CONSTRAINED ATTRIBUTE HAS CORRECT VALUES " &
- "DEPENDING ON THE ACTUAL PARAMETERS");
-
- DECLARE
- TYPE REC(DISC : INTEGER := 7) IS
- RECORD
- NULL;
- END RECORD;
-
- KC : CONSTANT REC(3) := (DISC => 3);
- KU : CONSTANT REC := (DISC => 3);
- OBJC1,OBJC2 : REC(3) := (DISC => 3);
- OBJU1,OBJU2 : REC := (DISC => 3);
-
- GENERIC
- P_IN1 : REC;
- P_IN2 : REC;
- P_IN_OUT : IN OUT REC;
- STATUS : BOOLEAN;
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- BEGIN
-
- IF P_IN1'CONSTRAINED /= TRUE OR
- P_IN2'CONSTRAINED /= TRUE OR
- P_IN_OUT'CONSTRAINED /= STATUS
- THEN
-
- FAILED ("'CONSTRAINED ATTRIBUTES DO NOT MATCH " &
- "FOR ACTUAL AND FORMAL PARAMETERS");
- END IF;
- IF NOT STATUS THEN
- BEGIN
- P_IN_OUT := (DISC => IDENT_INT(7));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED " &
- "WHEN TRYING TO " &
- "CHANGE UNCONSTRAINED " &
- "DISCRIMINANT VALUE");
- END;
- ELSE
- BEGIN
- P_IN_OUT := (DISC => IDENT_INT(7));
- FAILED ("DISCRIMINANT OF CONSTRAINED " &
- "ACTUAL PARAMETER ILLEGALLY " &
- "CHANGED BY ASSIGNMENT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION");
- END;
- END IF;
- END PROC;
-
- BEGIN
-
- DECLARE
- PROCEDURE PROC_C IS NEW PROC(KC,OBJC1,OBJC2,IDENT_BOOL(TRUE));
- PROCEDURE PROC_U IS NEW PROC(KU,OBJU1,OBJU2,IDENT_BOOL(FALSE));
- BEGIN
- PROC_C;
- PROC_U;
- IF OBJU2.DISC /= 7 THEN
- FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL " &
- "PARAMETER FAILED TO CHANGE DISCRIMINANT ");
- END IF;
- END;
-
- END;
- RESULT;
-END C37208B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37209a.ada b/gcc/testsuite/ada/acats/tests/c3/c37209a.ada
deleted file mode 100644
index 52d2507..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37209a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C37209A.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 A CONSTANT OBJECT
--- DECLARATION WHOSE SUBTYPE INDICATION SPECIFIES AN UNCONSTRAINED
--- TYPE WITH DEFAULT DISCRIMINANT VALUES AND WHOSE INITIALIZATION
--- EXPRESSION SPECIFIES A VALUE WHOSE DISCRIMINANTS ARE NOT EQUAL TO
--- THE DEFAULT VALUE.
-
--- R.WILLIAMS 8/25/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37209A IS
-
-BEGIN
- TEST ( "C37209A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
- "FOR A CONSTANT OBJECT DECLARATION WHOSE " &
- "SUBTYPE INDICATION SPECIFIES AN " &
- "UNCONSTRAINED TYPE WITH DEFAULT " &
- "DISCRIMINANT VALUES AND WHOSE " &
- "INITIALIZATION EXPRESSION SPECIFIES A VALUE " &
- "WHOSE DISCRIMINANTS ARE NOT EQUAL TO THE " &
- "DEFAULT VALUE" );
- DECLARE
-
- TYPE REC1 (D : INTEGER := IDENT_INT (5)) IS
- RECORD
- NULL;
- END RECORD;
-
- BEGIN
- DECLARE
- R1 : CONSTANT REC1 := (D => IDENT_INT (10));
- BEGIN
- COMMENT ( "NO EXCEPTION RAISED AT DECLARATION OF R1" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
- "R1" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " &
- "R1" );
- END;
-
-
- BEGIN
- DECLARE
- PACKAGE PRIV IS
- TYPE REC2 (D : INTEGER:= IDENT_INT (5)) IS PRIVATE;
- R2 : CONSTANT REC2;
-
- PRIVATE
- TYPE REC2 (D : INTEGER := IDENT_INT (5)) IS
- RECORD
- NULL;
- END RECORD;
-
- R2 : CONSTANT REC2 := (D => IDENT_INT (10));
- END PRIV;
-
- USE PRIV;
-
- BEGIN
- DECLARE
- I : INTEGER := R2.D;
- BEGIN
- COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " &
- "OF R2" );
- END;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
- "R2" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
- "OF R2" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE LPRIV IS
- TYPE REC3 (D : INTEGER:= IDENT_INT (5)) IS
- LIMITED PRIVATE;
-
- R3 : CONSTANT REC3;
-
- PRIVATE
- TYPE REC3 (D : INTEGER := IDENT_INT (5)) IS
- RECORD
- NULL;
- END RECORD;
-
- R3 : CONSTANT REC3 := (D => IDENT_INT (10));
- END LPRIV;
-
- USE LPRIV;
-
- BEGIN
- DECLARE
- I : INTEGER;
- BEGIN
- I := R3.D;
- COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " &
- "OF R3" );
- END;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " &
- "R3" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
- "OF R3" );
- END;
-
- RESULT;
-END C37209A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37209b.ada b/gcc/testsuite/ada/acats/tests/c3/c37209b.ada
deleted file mode 100644
index 9b1bfc8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37209b.ada
+++ /dev/null
@@ -1,194 +0,0 @@
--- C37209B.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 CONSTRAINT_ERROR IS RAISED WHEN THE SUBTYPE
--- INDICATION IN A CONSTANT OBJECT DECLARATION SPECIFIES A
--- CONSTRAINED SUBTYPE WITH DISCRIMINANTS AND THE INITIALIZATION
--- VALUE DOES NOT BELONG TO THE SUBTYPE (I. E., THE DISCRIMINANT
--- VALUE DOES NOT MATCH THOSE SPECIFIED BY THE CONSTRAINT).
-
--- HISTORY:
--- RJW 08/25/86 CREATED ORIGINAL TEST
--- VCL 08/19/87 CHANGED THE RETURN TYPE OF FUNTION 'INIT' IN
--- PACKAGE 'PRIV2' SO THAT 'INIT' IS UNCONSTRAINED,
--- THUS NOT RAISING A CONSTRAINT ERROR ON RETURN FROM
--- 'INIT'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37209B IS
-
-BEGIN
- TEST ( "C37209B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "THE SUBTYPE INDICATION IN A CONSTANT " &
- "OBJECT DECLARATION SPECIFIES A CONSTRAINED " &
- "SUBTYPE WITH DISCRIMINANTS AND THE " &
- "INITIALIZATION VALUE DOES NOT BELONG TO " &
- "THE SUBTYPE (I. E., THE DISCRIMINANT VALUE " &
- "DOES NOT MATCH THOSE SPECIFIED BY THE " &
- "CONSTRAINT)" );
- DECLARE
-
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE REC1 IS REC (IDENT_INT (5));
- BEGIN
- DECLARE
- R1 : CONSTANT REC1 := (D => IDENT_INT (10));
- I : INTEGER := IDENT_INT (R1.D);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED FOR DECLARATION OF " &
- "R1" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " &
- "R1" );
- END;
-
-
- BEGIN
- DECLARE
- PACKAGE PRIV1 IS
- TYPE REC (D : INTEGER) IS PRIVATE;
- SUBTYPE REC2 IS REC (IDENT_INT (5));
- R2 : CONSTANT REC2;
-
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- R2 : CONSTANT REC2 := (D => IDENT_INT (10));
- END PRIV1;
-
- USE PRIV1;
-
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (R2.D);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
- "OF R2" );
- END;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
- "OF R2" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE PRIV2 IS
- TYPE REC (D : INTEGER) IS PRIVATE;
- SUBTYPE REC3 IS REC (IDENT_INT (5));
-
- FUNCTION INIT (D : INTEGER) RETURN REC;
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- END PRIV2;
-
- PACKAGE BODY PRIV2 IS
- FUNCTION INIT (D : INTEGER) RETURN REC IS
- BEGIN
- RETURN (D => IDENT_INT (D));
- END INIT;
- END PRIV2;
-
- USE PRIV2;
-
- BEGIN
- DECLARE
- R3 : CONSTANT REC3 := INIT (10);
- I : INTEGER := IDENT_INT (R3.D);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
- "OF R3" );
- END;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
- "OF R3" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE LPRIV IS
- TYPE REC (D : INTEGER) IS
- LIMITED PRIVATE;
- SUBTYPE REC4 IS REC (IDENT_INT (5));
-
- R4 : CONSTANT REC4;
-
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- R4 : CONSTANT REC4 := (D => IDENT_INT (10));
- END LPRIV;
-
- USE LPRIV;
-
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (R4.D);
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT DECLARATION " &
- "OF R4" );
- END;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " &
- "OF R4" );
- END;
-
- RESULT;
-END C37209B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37210a.ada b/gcc/testsuite/ada/acats/tests/c3/c37210a.ada
deleted file mode 100644
index 8542bb5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37210a.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C37210A.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 EXPRESSION IN A DISCRIMINANT ASSOCIATION WITH MORE
--- THAN ONE NAME IS EVALUATED ONCE FOR EACH NAME.
-
--- R.WILLIAMS 8/28/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37210A IS
-
- BUMP : INTEGER := IDENT_INT (0);
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN BUMP;
- END F;
-
- FUNCTION CHECK (STR : STRING) RETURN INTEGER IS
- BEGIN
- IF BUMP /= 2 THEN
- FAILED ( "INCORRECT DISCRIMINANT VALUES FOR " & STR);
- END IF;
- BUMP := IDENT_INT (0);
- RETURN 5;
- END CHECK;
-
-BEGIN
- TEST ( "C37210A", "CHECK THAT THE EXPRESSION IN A " &
- "DISCRIMINANT ASSOCIATION WITH MORE THAN " &
- "ONE NAME IS EVALUATED ONCE FOR EACH NAME" );
-
- DECLARE
- TYPE REC (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- R : REC (D1 | D2 => F);
-
- I1 : INTEGER := CHECK ( "R" );
-
- TYPE ACC IS ACCESS REC;
-
- AC : ACC (D1 | D2 => F);
-
- I2 : INTEGER := CHECK ( "AC" );
-
- PACKAGE PKG IS
- TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE;
- TYPE PACC IS ACCESS PRIV;
-
- TYPE LIM (D1, D2 : INTEGER) IS LIMITED PRIVATE;
- TYPE LACC IS ACCESS LIM;
-
- PRIVATE
- TYPE PRIV (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE LIM (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG;
-
- USE PKG;
-
- BEGIN
-
- DECLARE
- P : PRIV (D1 | D2 => F);
-
- I1 : INTEGER := CHECK ( "P" );
-
- PA : PACC (D1 | D2 => F);
-
- I2 : INTEGER := CHECK ( "PA" );
-
- L : LIM (D1 | D2 => F);
-
- I3 : INTEGER := CHECK ( "L" );
-
- LA : LACC (D1 | D2 => F);
-
- I : INTEGER;
- BEGIN
- I := CHECK ( "LA" );
- END;
- END;
-
- RESULT;
-END C37210A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37211a.ada b/gcc/testsuite/ada/acats/tests/c3/c37211a.ada
deleted file mode 100644
index 4b718a9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37211a.ada
+++ /dev/null
@@ -1,242 +0,0 @@
--- C37211A.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 BY A DISCRIMINANT CONSTRAINT
--- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
--- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
--- INDICATIONS WHERE THE TYPE MARK DENOTES A RECORD TYPE.
-
--- R.WILLIAMS 8/28/86
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37211A IS
-
- TYPE REC (D : POSITIVE) IS
- RECORD
- NULL;
- END RECORD;
-
-BEGIN
- TEST ( "C37211A", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "A DISCRIMINANT CONSTRAINT IF A VALUE " &
- "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
- "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
- "TYPE MARK DENOTES A RECORD TYPE" );
-
- BEGIN
- DECLARE
- SUBTYPE SUBREC IS REC (IDENT_INT (-1));
- BEGIN
- DECLARE
- SR : SUBREC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBREC " & INTEGER'IMAGE(SR.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBREC" );
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1 .. 10) OF REC (IDENT_INT (-1));
- BEGIN
- DECLARE
- AR : ARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ARR " & INTEGER'IMAGE(AR(1).D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT AR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ARR" );
- END;
-
- BEGIN
- DECLARE
- TYPE REC1 IS
- RECORD
- X : REC (IDENT_INT (-1));
- END RECORD;
-
- BEGIN
- DECLARE
- R1 : REC1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT R1" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE REC1" );
- END;
-
- BEGIN
- DECLARE
- TYPE ACCREC IS ACCESS REC (IDENT_INT (-1));
- BEGIN
- DECLARE
- ACR : ACCREC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCREC " & INTEGER'IMAGE(ACR.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCREC" );
- END;
-
- BEGIN
- DECLARE
- TYPE NEWREC IS NEW REC (IDENT_INT (-1));
- BEGIN
- DECLARE
- NR : NEWREC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE NEWREC " & INTEGER'IMAGE(NR.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT NR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE NEWREC" );
- END;
-
- BEGIN
- DECLARE
- R : REC (IDENT_INT (-1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
- "R " & INTEGER'IMAGE(R.D));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
- "CONTAINING R" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
- "R" );
- END;
-
- BEGIN
- DECLARE
- TYPE REC_NAME IS ACCESS REC;
- BEGIN
- DECLARE
- RN : REC_NAME := NEW REC (IDENT_INT (-1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT RN " & INTEGER'IMAGE(RN.D));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT RN" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "REC_NAME" );
- END;
-
- BEGIN
- DECLARE
- TYPE BAD_REC (D : POSITIVE := IDENT_INT (-1)) IS
- RECORD
- NULL;
- END RECORD;
- BEGIN
- DECLARE
- BR : BAD_REC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT BR " & INTEGER'IMAGE(BR.D));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT BR" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "BAD_REC" );
- END;
-
- RESULT;
-END C37211A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37211b.ada b/gcc/testsuite/ada/acats/tests/c3/c37211b.ada
deleted file mode 100644
index fbc3591..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37211b.ada
+++ /dev/null
@@ -1,495 +0,0 @@
--- C37211B.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 BY A DISCRIMINANT CONSTRAINT
--- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
--- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
--- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED
--- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL
--- DECLARATION OF THE TYPE.
-
--- R.WILLIAMS 8/28/86
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37211B IS
-
- SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE;
-
- PACKAGE PKG IS
- TYPE PRIV (L : LIES) IS PRIVATE;
- TYPE LIM (L : LIES) IS LIMITED PRIVATE;
-
- PRIVATE
- TYPE PRIV (L : LIES) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE LIM (L : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PKG;
-
- USE PKG;
-
-BEGIN
- TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "A DISCRIMINANT CONSTRAINT IF A VALUE " &
- "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
- "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
- "TYPE MARK DENOTES A PRIVATE OR LIMITED " &
- "PRIVATE TYPE, AND THE DISCRIMINANT " &
- "CONSTRAINT OCCURS AFTER THE FULL " &
- "DECLARATION OF THE TYPE" );
-
- BEGIN
- DECLARE
- SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- SP : SUBPRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBPRIV " &
- BOOLEAN'IMAGE(SP.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SP" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBPRIV" );
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- SL : SUBLIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBLIM" &
- BOOLEAN'IMAGE(SL.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SL " );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBLIM" );
- END;
-
- BEGIN
- DECLARE
- TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- PAR : PARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE PARR " &
- BOOLEAN'IMAGE(PAR(1).L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT PAR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE PARR" );
- END;
-
- BEGIN
- DECLARE
- TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- LAR : LARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE LARR " &
- BOOLEAN'IMAGE(LAR(1).L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT LAR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE LARR" );
- END;
-
- BEGIN
- DECLARE
- TYPE PRIV1 IS
- RECORD
- X : PRIV (IDENT_BOOL (TRUE));
- END RECORD;
-
- BEGIN
- DECLARE
- P1 : PRIV1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE PRIV1 " &
- BOOLEAN'IMAGE(P1.X.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT P1" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE PRIV1" );
- END;
-
- BEGIN
- DECLARE
- TYPE LIM1 IS
- RECORD
- X : LIM (IDENT_BOOL (TRUE));
- END RECORD;
-
- BEGIN
- DECLARE
- L1 : LIM1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE LIM1 " &
- BOOLEAN'IMAGE(L1.X.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT L1" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE LIM1" );
- END;
-
- BEGIN
- DECLARE
- TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- ACP : ACCPRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCPRIV " &
- BOOLEAN'IMAGE(ACP.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACP" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCPRIV" );
- END;
-
- BEGIN
- DECLARE
- TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- ACL : ACCLIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCLIM " &
- BOOLEAN'IMAGE(ACL.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACL" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCLIM" );
- END;
-
- BEGIN
- DECLARE
- TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- NP : NEWPRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE NEWPRIV " &
- BOOLEAN'IMAGE(NP.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT NP" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE NEWPRIV" );
- END;
-
- BEGIN
- DECLARE
- TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE));
- BEGIN
- DECLARE
- NL : NEWLIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE NEWLIM " &
- BOOLEAN'IMAGE(NL.L));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT NL" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE NEWLIM" );
- END;
-
- BEGIN
- DECLARE
- P : PRIV (IDENT_BOOL (TRUE));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
- "P " & BOOLEAN'IMAGE(P.L));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
- "CONTAINING P" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
- "P" );
- END;
-
- BEGIN
- DECLARE
- L : LIM (IDENT_BOOL (TRUE));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
- "L " & BOOLEAN'IMAGE(L.L));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
- "CONTAINING L" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
- "L" );
- END;
-
- BEGIN
- DECLARE
- TYPE PRIV_NAME IS ACCESS PRIV;
- BEGIN
- DECLARE
- PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT PN " &
- BOOLEAN'IMAGE(PN.L));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT PN" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "PRIV_NAME" );
- END;
-
- BEGIN
- DECLARE
- TYPE LIM_NAME IS ACCESS LIM;
- BEGIN
- DECLARE
- LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT LN " &
- BOOLEAN'IMAGE(LN.L));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT LN" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "LIM_NAME" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE PP IS
- TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
- PRIVATE;
- PRIVATE
- TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS
- RECORD
- NULL;
- END RECORD;
- END PP;
-
- USE PP;
- BEGIN
- DECLARE
- BP : BAD_PRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT BP " &
- BOOLEAN'IMAGE(BP.D));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT BP" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "BAD_PRIV" );
- END;
-
- BEGIN
- DECLARE
- PACKAGE PL IS
- TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
- LIMITED PRIVATE;
- PRIVATE
- TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS
- RECORD
- NULL;
- END RECORD;
- END PL;
-
- USE PL;
- BEGIN
- DECLARE
- BL : BAD_LIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT BL " &
- BOOLEAN'IMAGE(BL.D));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT BL" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "BAD_LIM" );
- END;
-
- RESULT;
-END C37211B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37211c.ada b/gcc/testsuite/ada/acats/tests/c3/c37211c.ada
deleted file mode 100644
index ba15964..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37211c.ada
+++ /dev/null
@@ -1,426 +0,0 @@
--- C37211C.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 BY A DISCRIMINANT CONSTRAINT
--- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
--- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
--- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED
--- PRIVATE TYPE, THE DISCRIMINANT CONSTRAINT OCCURS BEFORE THE FULL
--- DECLARATION OF THE TYPE, AND THERE ARE NO COMPONENTS OF THE TYPE
--- DEPENDENT ON THE DISCRIMINANT.
-
--- R.WILLIAMS 8/28/86
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37211C IS
-
- GLOBAL : BOOLEAN;
-
- SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE;
-
- FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- GLOBAL := B;
- RETURN B;
- END SWITCH;
-
-BEGIN
- TEST ( "C37211C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "A DISCRIMINANT CONSTRAINT IF A VALUE " &
- "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
- "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
- "TYPE MARK DENOTES A PRIVATE OR LIMITED " &
- "PRIVATE TYPE, AND THE DISCRIMINANT " &
- "CONSTRAINT OCCURS BEFORE THE FULL " &
- "DECLARATION OF THE TYPE" );
-
- BEGIN
- DECLARE
-
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PP IS
- TYPE PRIV1 (D : LIES) IS PRIVATE;
- SUBTYPE SUBPRIV IS PRIV1 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE PRIV1 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PP;
-
- USE PP;
- BEGIN
- DECLARE
- SP : SUBPRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBPRIV " & BOOLEAN'IMAGE(SP.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SP" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE PRIV1 NOT SUBTYPE SUBPRIV" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBPRIV" );
- END;
-
- BEGIN
- DECLARE
-
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PL IS
- TYPE LIM1 (D : LIES) IS LIMITED PRIVATE;
- SUBTYPE SUBLIM IS LIM1 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE LIM1 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PL;
-
- USE PL;
- BEGIN
- DECLARE
- SL : SUBLIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBLIM " & BOOLEAN'IMAGE(SL.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SL" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE LIM1 NOT SUBTYPE SUBLIM" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBLIM" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PP IS
- TYPE PRIV2 (D : LIES) IS PRIVATE;
- TYPE PARR IS ARRAY (1 .. 5) OF
- PRIV2 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE PRIV2 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PP;
-
- USE PP;
- BEGIN
- DECLARE
- PAR : PARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE PARR " & BOOLEAN'IMAGE(PAR(1).D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT PAR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE PRIV2 NOT TYPE PARR" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE PARR" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PL IS
- TYPE LIM2 (D : LIES) IS LIMITED PRIVATE;
- TYPE LARR IS ARRAY (1 .. 5) OF
- LIM2 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE LIM2 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PL;
-
- USE PL;
- BEGIN
- DECLARE
- LAR : LARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE LARR " & BOOLEAN'IMAGE(LAR(1).D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT LAR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE LIM2 NOT TYPE LARR" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE LARR" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PP IS
- TYPE PRIV3 (D : LIES) IS PRIVATE;
-
- TYPE PRIV4 IS
- RECORD
- X : PRIV3 (IDENT_BOOL (TRUE));
- END RECORD;
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE PRIV3 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PP;
-
- USE PP;
- BEGIN
- DECLARE
- P4 : PRIV4;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE PRIV4 " & BOOLEAN'IMAGE(P4.X.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT P4" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE PRIV3 NOT TYPE PRIV4" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE PRIV4" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PL IS
- TYPE LIM3 (D : LIES) IS LIMITED PRIVATE;
-
- TYPE LIM4 IS
- RECORD
- X : LIM3 (IDENT_BOOL (TRUE));
- END RECORD;
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE LIM3 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PL;
-
- USE PL;
- BEGIN
- DECLARE
- L4 : LIM4;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE LIM4 " & BOOLEAN'IMAGE(L4.X.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT L4" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE LIM3 NOT TYPE LIM4" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE LIM4" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PP IS
- TYPE PRIV5 (D : LIES) IS PRIVATE;
- TYPE ACCPRIV IS ACCESS PRIV5 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE PRIV5 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PP;
-
- USE PP;
-
- BEGIN
- DECLARE
- ACP : ACCPRIV;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCPRIV " & BOOLEAN'IMAGE(ACP.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACP" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE PRIV5 NOT TYPE ACCPRIV" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCPRIV" );
- END;
-
- BEGIN
- DECLARE
- B1 : BOOLEAN := SWITCH (TRUE);
-
- PACKAGE PL IS
- TYPE LIM5 (D : LIES) IS LIMITED PRIVATE;
- TYPE ACCLIM IS ACCESS LIM5 (IDENT_BOOL (TRUE));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- PRIVATE
- TYPE LIM5 (D : LIES) IS
- RECORD
- NULL;
- END RECORD;
- END PL;
-
- USE PL;
-
- BEGIN
- DECLARE
- ACL : ACCLIM;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCLIM " & BOOLEAN'IMAGE(ACL.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACL" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE LIM5 NOT TYPE ACCLIM" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCLIM" );
- END;
-
- RESULT;
-END C37211C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37211d.ada b/gcc/testsuite/ada/acats/tests/c3/c37211d.ada
deleted file mode 100644
index 8d623c8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37211d.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C37211D.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 BY A DISCRIMINANT CONSTRAINT
--- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
--- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE
--- INDICATIONS WHERE THE TYPE MARK DENOTES AN INCOMPLETE TYPE.
-
--- R.WILLIAMS 8/28/86
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37211D IS
-
- GLOBAL : BOOLEAN;
-
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
-
- SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI;
-
- FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- GLOBAL := B;
- RETURN B;
- END SWITCH;
-
- FUNCTION IDENT (D : DAY) RETURN DAY IS
- BEGIN
- RETURN DAY'VAL (IDENT_INT (DAY'POS (D)));
- END IDENT;
-
-BEGIN
- TEST ( "C37211D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "A DISCRIMINANT CONSTRAINT IF A VALUE " &
- "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
- "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
- "TYPE MARK DENOTES AN INCOMPLETE TYPE" );
-
- BEGIN
- DECLARE
-
- B1 : BOOLEAN := SWITCH (TRUE);
-
- TYPE REC (D : WEEKDAY);
-
- TYPE ACCREC IS ACCESS REC (IDENT (SUN));
-
- B2 : BOOLEAN := SWITCH (FALSE);
-
- TYPE REC (D : WEEKDAY) IS
- RECORD
- NULL;
- END RECORD;
- BEGIN
- DECLARE
- AC : ACCREC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCREC " & DAY'IMAGE(AC.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT AC" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF GLOBAL THEN
- NULL;
- ELSE
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF " &
- "FULL TYPE REC NOT TYPE ACCREC" );
- END IF;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCREC" );
- END;
-
- RESULT;
-END C37211D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37211e.ada b/gcc/testsuite/ada/acats/tests/c3/c37211e.ada
deleted file mode 100644
index c4b12fa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37211e.ada
+++ /dev/null
@@ -1,233 +0,0 @@
--- C37211E.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 BY A DISCRIMINANT CONSTRAINT
--- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE
--- OF THE DISCRIMINANT.
-
--- R.WILLIAMS 8/28/86
--- PWN 10/27/95 REMOVED CHECK WHERE CONSTRAINT RULES HAVE CHANGED.
--- PWN 12/03/95 CORRECTED FORMATING PROBLEM.
--- TMB 11/20/96 REINTRODUCED CHECK REMOVED ON 10/27 WITH ADA95 CHANGES
--- TMB 12/2/96 DELETED CHECK OF CONSTRAINED ACCESS TYPE
--- EDS 07/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37211E IS
-
- TYPE REC (D : POSITIVE) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC IS ACCESS REC;
-BEGIN
- TEST ( "C37211E", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "A DISCRIMINANT CONSTRAINT IF A VALUE " &
- "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " &
- "IN THE RANGE OF THE DISCRIMINANT WHERE THE " &
- "TYPE MARK DENOTES AN ACCESS TYPE" );
-
- BEGIN
- DECLARE
- SUBTYPE SUBACC IS ACC (IDENT_INT (-1));
- BEGIN
- DECLARE
- SA : SUBACC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF SUBTYPE SUBACC " &
- INTEGER'IMAGE(SA.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT SA" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "SUBTYPE SUBACC" );
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1 .. 10) OF ACC (IDENT_INT (-1));
- BEGIN
- DECLARE
- AR : ARR;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ARR " &
- INTEGER'IMAGE(AR(1).D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT AR" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ARR" );
- END;
-
- BEGIN
- DECLARE
- TYPE REC1 IS
- RECORD
- X : ACC (IDENT_INT (-1));
- END RECORD;
-
- BEGIN
- DECLARE
- R1 : REC1;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT R1" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE REC1" );
- END;
-
- BEGIN
- DECLARE
- TYPE ACCA IS ACCESS ACC (IDENT_INT (-1));
- BEGIN
- DECLARE
- ACA : ACCA;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE ACCA " &
- INTEGER'IMAGE(ACA.ALL.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT ACA" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE ACCA" );
- END;
-
- BEGIN
- DECLARE
- TYPE NEWACC IS NEW ACC (IDENT_INT (-1));
- BEGIN
- DECLARE
- NA : NEWACC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "ELABORATION OF TYPE NEWACC " &
- INTEGER'IMAGE(NA.D));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT DECLARATION OF " &
- "OBJECT NA" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " &
- "TYPE NEWACC" );
- END;
-
- BEGIN
- DECLARE
- A : ACC (IDENT_INT (-1));
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " &
- "A " & INTEGER'IMAGE(A.D));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
- "CONTAINING A" );
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " &
- "A" );
- END;
-
-
- BEGIN
- DECLARE
- TYPE BAD_ACC (D : POSITIVE := IDENT_INT (-1)) IS
- RECORD
- NULL;
- END RECORD;
- BEGIN
- DECLARE
- BAC : BAD_ACC;
- BEGIN
- FAILED ( "NO EXCEPTION RAISED AT THE " &
- "DECLARATION OF OBJECT BAC " &
- INTEGER'IMAGE(BAC.D));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE BLOCK " &
- "DECLARING BAC" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
- "OF OBJECT BAC" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " &
- "BAD_ACC" );
- END;
-
- RESULT;
-END C37211E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213b.ada b/gcc/testsuite/ada/acats/tests/c3/c37213b.ada
deleted file mode 100644
index 2117ece0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213b.ada
+++ /dev/null
@@ -1,241 +0,0 @@
--- C37213B.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 DISCRIMINANT CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
--- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
--- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
---
--- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION.
-
--- JBG 10/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213B IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
-
- F1_CONS : INTEGER := 2;
-
- FUNCTION CHK (
- CONS : INTEGER;
- VALUE : INTEGER;
- MESSAGE : STRING) RETURN BOOLEAN IS
- BEGIN
- IF CONS /= VALUE THEN
- FAILED (MESSAGE & ": CONS IS " &
- INTEGER'IMAGE(CONS));
- END IF;
- RETURN TRUE;
- END CHK;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- F1_CONS := F1_CONS - IDENT_INT(1);
- RETURN F1_CONS;
- END F1;
-
-BEGIN
- TEST ("C37213B", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
- "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "AND DISCRIMINANTS HAVE DEFAULTS");
-
--- CASE B
-
- DECLARE
- TYPE CONS (D3 : INTEGER := 1) IS
- RECORD
- C1 : REC (D3, F1); -- F1 EVALUATED
- END RECORD;
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
- X : CONS; -- F1 NOT EVALUATED AGAIN
- Y : CONS; -- F1 NOT EVALUATED AGAIN
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
- BEGIN
- IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
- FAILED ("DISCRIMINANT VALUES NOT CORRECT");
- END IF;
- END;
-
- F1_CONS := 12;
-
- DECLARE
- TYPE CONS (D3 : INTEGER := 1) IS
- RECORD
- C1 : REC(D3, F1);
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
- BEGIN
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37213B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213d.ada b/gcc/testsuite/ada/acats/tests/c3/c37213d.ada
deleted file mode 100644
index dc2d672..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213d.ada
+++ /dev/null
@@ -1,240 +0,0 @@
--- C37213D.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 INDEX CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
--- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
--- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
---
--- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION.
-
--- JBG 10/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213D IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- F1_CONS : INTEGER := 2;
-
- FUNCTION CHK (
- CONS : INTEGER;
- VALUE : INTEGER;
- MESSAGE : STRING) RETURN BOOLEAN IS
- BEGIN
- IF CONS /= VALUE THEN
- FAILED (MESSAGE & ": CONS IS " &
- INTEGER'IMAGE(CONS));
- END IF;
- RETURN TRUE;
- END CHK;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- F1_CONS := F1_CONS - IDENT_INT(1);
- RETURN F1_CONS;
- END F1;
-
-BEGIN
- TEST ("C37213D", "CHECK EVALUATION OF INDEX BOUNDS " &
- "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "AND DISCRIMINANTS HAVE DEFAULTS");
-
--- CASE B
-
- DECLARE
- TYPE CONS (D3 : INTEGER := 1) IS
- RECORD
- C1 : MY_ARR (F1..D3); -- F1 EVALUATED.
- END RECORD;
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
- X : CONS; -- F1 NOT EVALUATED AGAIN
- Y : CONS; -- F1 NOT EVALUATED AGAIN
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
- BEGIN
- IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN
- FAILED ("INDEX BOUNDS NOT CORRECT");
- END IF;
- END;
-
- F1_CONS := 12;
-
- DECLARE
- TYPE CONS (D3 : INTEGER := 1) IS
- RECORD
- C1 : MY_ARR(D3..F1);
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("INDEX CHECK NOT PERFORMED - 2");
- BEGIN
- IF X.ALL /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1 => 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1 => 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37213D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213f.ada b/gcc/testsuite/ada/acats/tests/c3/c37213f.ada
deleted file mode 100644
index 3699c1a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213f.ada
+++ /dev/null
@@ -1,379 +0,0 @@
--- C37213F.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 DISCRIMINANT CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
--- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
--- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
---
--- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE.
-
--- JBG 10/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213F IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
-
- F1_CONS : INTEGER := 2;
-
- FUNCTION CHK (
- CONS : INTEGER;
- VALUE : INTEGER;
- MESSAGE : STRING) RETURN BOOLEAN IS
- BEGIN
- IF CONS /= VALUE THEN
- FAILED (MESSAGE & ": CONS IS " &
- INTEGER'IMAGE(CONS));
- END IF;
- RETURN TRUE;
- END CHK;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- F1_CONS := F1_CONS - IDENT_INT(1);
- RETURN F1_CONS;
- END F1;
-
-BEGIN
- TEST ("C37213F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
- "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT" &
- "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " &
- "BE CHECKED");
-
--- CASE D1: COMPONENT IS PRESENT
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, F1); -- F1 EVALUATED
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
- X : CONS; -- F1 NOT EVALUATED AGAIN
- Y : CONS; -- F1 NOT EVALUATED AGAIN
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
- BEGIN
- IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
- FAILED ("DISCRIMINANT VALUES NOT CORRECT");
- END IF;
- END;
-
- F1_CONS := 12;
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC(D3, F1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
--- CASE C2 : COMPONENT IS ABSENT
-
- F1_CONS := 2;
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(-6)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, F1); -- F1 EVALUATED
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED - 2");
- X : CONS; -- F1 NOT EVALUATED AGAIN
- Y : CONS; -- F1 NOT EVALUATED AGAIN
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED - 2");
- BEGIN
- IF X /= (-6, 0) OR Y /= (-6, 0) THEN
- FAILED ("DISCRIMINANT VALUES NOT CORRECT");
- END IF;
- END;
-
- F1_CONS := 12;
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC(D3, F1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("WRONG VALUE FOR X - 11");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("X VALUE WRONG - 12");
- END IF;
- END;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- X : ARR;
- BEGIN
- IF X /= (1..5 => (11, 0)) THEN
- FAILED ("X VALUE INCORRECT - 13");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- X : NREC;
- BEGIN
- IF X /= (C1 => (11, 0)) THEN
- FAILED ("X VALUE IS INCORRECT - 14");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- X : NREC;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("X VALUE INCORRECT - 15");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS := NEW CONS;
- BEGIN
- IF X.ALL /= (11, 0) THEN
- FAILED ("X VALUE INCORRECT - 17");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17");
- END;
- END;
-
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37213F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213h.ada b/gcc/testsuite/ada/acats/tests/c3/c37213h.ada
deleted file mode 100644
index e83ae07..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213h.ada
+++ /dev/null
@@ -1,457 +0,0 @@
--- C37213H.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, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD
--- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT
--- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS
--- IN THE INDEX CONSTRAINT ARE:
--- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION
--- IS ELABORATED,
--- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION
--- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT-
--- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE.
-
--- HISTORY:
--- JBG 10/17/86 CREATED ORIGINAL TEST.
--- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF
--- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST,
--- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED
--- FOR THE SUBTYPE DECLARATION AND FAILURE IF
--- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT
--- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO
--- REPORT.TEST SO THAT IT COMES BEFORE ANY
--- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY
--- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE
--- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS'
--- TO AN INTEGER SUBTYPE.
--- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT
--- PACKAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213H IS
-BEGIN
- TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " &
- "INDEX CONSTRAINT THAT DEPEND ON A " &
- "DISCRIMINANT WITH A DEFAULT VALUE ARE " &
- "PROPERLY EVALUATED AND CHECKED WHEN THE " &
- "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " &
- "THE COMPONENT IS AND IS NOT PRESENT IN THE " &
- "SUBTYPE");
-
- DECLARE
- SEQUENCE_NUMBER : INTEGER;
-
- SUBTYPE DISCR IS INTEGER RANGE -50..50;
- SUBTYPE SM IS INTEGER RANGE 1..10;
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- F1_CONS : INTEGER := 2;
-
- FUNCTION CHK (
- CONS : INTEGER;
- VALUE : INTEGER;
- MESSAGE : STRING) RETURN BOOLEAN IS
- BEGIN
- IF CONS /= VALUE THEN
- FAILED (MESSAGE & ": F1_CONS IS " &
- INTEGER'IMAGE(F1_CONS));
- END IF;
- RETURN TRUE;
- END CHK;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- F1_CONS := F1_CONS - IDENT_INT(1);
- RETURN F1_CONS;
- END F1;
- BEGIN
-
-
--- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT.
-
- SEQUENCE_NUMBER :=1;
- DECLARE
- TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(F1..D3); -- F1 EVALUATED.
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
-
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
-
- X : CONS; -- F1 NOT EVALUATED AGAIN.
- Y : CONS; -- F1 NOT EVALUATED AGAIN.
-
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
- BEGIN
- IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN
- FAILED ("VALUES NOT CORRECT");
- END IF;
- END;
-
-
- F1_CONS := 12;
-
- SEQUENCE_NUMBER := 2;
- DECLARE
- TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..F1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("INCORRECT VALUES FOR X - 1");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 2");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("INCORRECT VALUES FOR X " &
- "- 2");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "- 2A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 3");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("INCORRECT VALUES FOR X " &
- "- 3");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "- 3A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 4");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("INCORRECT VALUES FOR X " &
- "- 4");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "- 4A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 5");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("INCORRECT VALUES FOR X " &
- "- 5");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "- 5A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5B");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- BEGIN
- DECLARE
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("INDEX CHECK NOT PERFORMED - 6");
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("INCORRECT VALUES FOR X " &
- "- 6");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- COMMENT ("UNEXPECTED EXCEPTION " &
- "RAISED - 6A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- COMMENT ("UNEXPECTED EXCEPTION RAISED " &
- "- 6B");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6C");
- END;
- END;
-
-
--- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT.
-
- F1_CONS := 2;
-
- SEQUENCE_NUMBER := 3;
- DECLARE
- TYPE CONS (D3 : DISCR := IDENT_INT(-6)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..F1); -- F1 EVALUATED.
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
-
- X : CONS; -- F1 NOT EVALUATED AGAIN.
- Y : CONS; -- F1 NOT EVALUATED AGAIN.
-
- CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
- BEGIN
- IF X /= (-6, 0) OR Y /= (-6, 0) THEN
- FAILED ("VALUES NOT CORRECT");
- END IF;
- END;
-
- F1_CONS := 12;
-
- SEQUENCE_NUMBER := 4;
- DECLARE
- TYPE CONS (D3 : DISCR := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..F1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("X VALUE IS INCORRECT - 11");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 11");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("X VALUE INCORRECT - 12");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - " &
- "12A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 12B");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- IF X /= (1..5 => (11, 0)) THEN
- FAILED ("X VALUE INCORRECT - 13");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - " &
- "13A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 13B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- IF X /= (C1 => (11, 0)) THEN
- FAILED ("X VALUE INCORRECT - 14");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - " &
- "14A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 14B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- IF X /= (11, 0) THEN
- FAILED ("X VALUE INCORRECT - 15");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - " &
- "15A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 15B");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- IF X.ALL /= (11, 0) THEN
- FAILED ("X VALUE INCORRECT - 17");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - " &
- "17A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 17B");
- END;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("INDEX VALUES IMPROPERLY CHECKED - " &
- INTEGER'IMAGE (SEQUENCE_NUMBER));
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- INTEGER'IMAGE (SEQUENCE_NUMBER));
- END;
-
- RESULT;
-END C37213H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213j.ada b/gcc/testsuite/ada/acats/tests/c3/c37213j.ada
deleted file mode 100644
index f09d853..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213j.ada
+++ /dev/null
@@ -1,320 +0,0 @@
--- C37213J.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
--- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
--- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN
--- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
--- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
--- 1) ONLY IN AN OBJECT DECLARATION, AND
--- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
--- IN THE SUBTYPE.
-
--- HISTORY:
--- JBG 10/17/86 CREATED ORIGINAL TEST.
--- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO
--- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR
--- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE
--- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST
--- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED
--- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST
--- DECLARATION PART RAISES CONSTRAINT_ERROR.
--- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
--- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
--- PARAMETERS TO THE GENERIC UNITS AND THE
--- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
--- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
--- ARE TOGETHER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213J IS
-BEGIN
- TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
- "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
- "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
- "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
- "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
- "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " &
- "SUBTYPE");
-
- DECLARE
- SUBTYPE SM IS INTEGER RANGE 1..10;
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- SEQUENCE_NUMBER : INTEGER;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- OBJ_XCP : BOOLEAN;
- TAG : STRING;
- PACKAGE OBJ_CHK IS END OBJ_CHK;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING);
-
- PACKAGE BODY OBJ_CHK IS
- BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE.
- DECLARE
- X : CONS;
-
- FUNCTION VALUE RETURN CONS IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN X;
- ELSE
- RETURN X;
- END IF;
- END VALUE;
- BEGIN
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING DECLARATION " &
- "OF OBJECT OF TYPE CONS - " & TAG);
- ELSIF X /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT OF " &
- "TYPE CONS - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT CHECKED " &
- "DURING DECLARATION OF OBJECT " &
- "OF TYPE CONS - " & TAG);
- END IF;
- END OBJ_CHK;
-
- PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING) IS
- BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE.
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
-
- FUNCTION VALUE RETURN SCONS IS
- BEGIN
- IF EQUAL (5, 5) THEN
- RETURN X;
- ELSE
- RETURN X;
- END IF;
- END VALUE;
- BEGIN
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING DECLARATION " &
- "OF OBJECT OF SUBTYPE SCONS - " &
- TAG);
- ELSIF X /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT " &
- "OF SUBTYPE SCONS - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT CHECKED " &
- "DURING DECLARATION OF OBJECT " &
- "OF SUBTYPE SCONS - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING SUBTYPE DECLARATION - " & TAG);
- END SUBTYP_CHK;
- BEGIN
- SEQUENCE_NUMBER := 1;
- DECLARE
- TYPE REC_DEF (D3 : INTEGER := 1) IS
- RECORD
- C1 : REC (D3, 0);
- END RECORD;
-
- PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK1");
-
- PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF);
- BEGIN
- PROC1 (OBJ_XCP => TRUE, TAG => "PROC1");
- END;
-
- SEQUENCE_NUMBER := 2;
- DECLARE
- TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- C1 : MY_ARR (0..D3);
- END RECORD;
-
- PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK2");
-
- PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF);
- BEGIN
- PROC2 (OBJ_XCP => TRUE, TAG => "PROC2");
- END;
-
-
- SEQUENCE_NUMBER := 3;
- DECLARE
- TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK3");
-
- PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1);
- BEGIN
- PROC3 (OBJ_XCP => TRUE, TAG => "PROC3");
- END;
-
- SEQUENCE_NUMBER := 4;
- DECLARE
- TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK4");
-
- PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6);
- BEGIN
- PROC4 (OBJ_XCP => FALSE,TAG => "PROC4");
- END;
-
- SEQUENCE_NUMBER := 5;
- DECLARE
- TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK5");
-
- PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11);
- BEGIN
- PROC5 (OBJ_XCP => FALSE, TAG => "PROC5");
- END;
-
- SEQUENCE_NUMBER := 6;
- DECLARE
- TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK6");
-
- PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1);
- BEGIN
- PROC6 (OBJ_XCP => TRUE, TAG => "PROC6");
- END;
-
- SEQUENCE_NUMBER := 7;
- DECLARE
- TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK7");
-
- PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6);
- BEGIN
- PROC7 (OBJ_XCP => FALSE, TAG => "PROC7");
- END;
-
- SEQUENCE_NUMBER := 8;
- DECLARE
- TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK8");
-
- PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11);
- BEGIN
- PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
- END;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING DECLARATION / " &
- "INSTANTIATION ELABORATION - " &
- INTEGER'IMAGE(SEQUENCE_NUMBER));
- END;
-
- RESULT;
-END C37213J;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213k.ada b/gcc/testsuite/ada/acats/tests/c3/c37213k.ada
deleted file mode 100644
index d5b5dc3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213k.ada
+++ /dev/null
@@ -1,324 +0,0 @@
--- C37213K.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
--- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
--- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN
--- ARRAY OR RECORD COMPONENT, THAT THE NON-DISCRIMINANT EXPRESSIONS
--- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
--- 1) ONLY IN AN OBJECT DECLARATION, AND
--- 2) ONLY IF THE DESCRIMINANT-DEPENDENT COMPONENT IS PRESENT
--- IN THE SUBTYPE.
-
--- HISTORY:
--- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J.
--- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
--- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
--- PARAMETERS TO THE GENERIC UNITS AND THE
--- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
--- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
--- ARE TOGETHER; REWROTE ONE OF THE GENERIC
--- PACKAGES AS A GENERIC PROCEDURE TO BROADEN
--- COVERAGE OF TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213K IS
-BEGIN
- TEST ("C37213K", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
- "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
- "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
- "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
- "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
- "FORMAL TYPE USED TO DECLARE AN ARRAY OR A " &
- "RECORD COMPONENT");
-
- DECLARE
- SUBTYPE SM IS INTEGER RANGE 1..10;
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- SEQUENCE_NUMBER : INTEGER;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- OBJ_XCP : BOOLEAN;
- TAG : STRING;
- PACKAGE ARRAY_COMP_CHK IS END ARRAY_COMP_CHK;
-
- PACKAGE BODY ARRAY_COMP_CHK IS
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
-
- FUNCTION VALUE RETURN ARR IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN X;
- ELSE
- RETURN X;
- END IF;
- END VALUE;
- BEGIN
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING DECLARATION " &
- "OF OBJECT OF TYPE ARR - " & TAG);
- ELSIF X /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT OF " &
- "TYPE ARR - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT CHECKED " &
- "DURING DECLARATION OF OBJECT " &
- "OF TYPE ARR - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING DECLARATION OF ARR - " & TAG);
- END ARRAY_COMP_CHK;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING);
-
- PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING) IS
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
-
- FUNCTION VALUE RETURN NREC IS
- BEGIN
- IF EQUAL (5, 5) THEN
- RETURN X;
- ELSE
- RETURN X;
- END IF;
- END VALUE;
- BEGIN
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING DECLARATION " &
- "OF OBJECT OF TYPE NREC - " &
- TAG);
- ELSIF X /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT " &
- "OF TYPE NREC - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT CHECKED " &
- "DURING DECLARATION OF OBJECT " &
- "OF TYPE NREC - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING DECLARATION OF NREC - " & TAG);
- END;
- BEGIN
- SEQUENCE_NUMBER := 1;
- DECLARE
- TYPE REC_DEF (D3 : INTEGER := 1) IS
- RECORD
- C1 : REC (D3, 0);
- END RECORD;
-
- PACKAGE PACK1 IS NEW ARRAY_COMP_CHK (REC_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK1");
-
- PROCEDURE PROC1 IS NEW REC_COMP_CHK (REC_DEF);
- BEGIN
- PROC1 (OBJ_XCP => TRUE, TAG => "PROC1");
- END;
-
- SEQUENCE_NUMBER := 2;
- DECLARE
- TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- C1 : MY_ARR (0..D3);
- END RECORD;
-
- PACKAGE PACK2 IS NEW ARRAY_COMP_CHK (ARR_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK2");
-
- PROCEDURE PROC2 IS NEW REC_COMP_CHK (ARR_DEF);
- BEGIN
- PROC2 (OBJ_XCP => TRUE, TAG => "PROC2");
- END;
-
- SEQUENCE_NUMBER := 3;
- DECLARE
- TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK3 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK3");
-
- PROCEDURE PROC3 IS NEW REC_COMP_CHK (VAR_REC_DEF1);
- BEGIN
- PROC3 (OBJ_XCP => TRUE, TAG => "PROC3");
- END;
-
- SEQUENCE_NUMBER := 4;
- DECLARE
- TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK4 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK4");
-
- PROCEDURE PROC4 IS NEW REC_COMP_CHK (VAR_REC_DEF6);
- BEGIN
- PROC4 (OBJ_XCP => FALSE, TAG => "PROC4");
- END;
-
- SEQUENCE_NUMBER := 5;
- DECLARE
- TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK5 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK5");
-
- PROCEDURE PROC5 IS NEW REC_COMP_CHK (VAR_REC_DEF11);
- BEGIN
- PROC5 (OBJ_XCP => FALSE, TAG => "PROC5");
- END;
-
- SEQUENCE_NUMBER := 6;
- DECLARE
- TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK6 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK6");
-
- PROCEDURE PROC6 IS NEW REC_COMP_CHK (VAR_ARR_DEF1);
- BEGIN
- PROC6 (OBJ_XCP => TRUE, TAG => "PROC6");
- END;
-
- SEQUENCE_NUMBER := 7;
- DECLARE
- TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK7 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK7");
-
- PROCEDURE PROC7 IS NEW REC_COMP_CHK (VAR_ARR_DEF6);
- BEGIN
- PROC7 (OBJ_XCP => FALSE, TAG => "PROC7");
- END;
-
- SEQUENCE_NUMBER := 8;
- DECLARE
- TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK8 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK8");
-
- PROCEDURE PROC8 IS NEW REC_COMP_CHK (VAR_ARR_DEF11);
- BEGIN
- PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
- "DECLARATION / INSTANTIATION ELABORATION - " &
- INTEGER'IMAGE (SEQUENCE_NUMBER));
- END;
-
- RESULT;
-END C37213K;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37213l.ada b/gcc/testsuite/ada/acats/tests/c3/c37213l.ada
deleted file mode 100644
index 07bd124..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37213l.ada
+++ /dev/null
@@ -1,329 +0,0 @@
--- C37213L.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, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
--- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
--- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A
--- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
--- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
--- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND
--- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
--- IN THE SUBTYPE.
-
--- HISTORY:
--- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J.
--- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
--- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
--- PARAMETERS TO THE GENERIC UNITS AND THE
--- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
--- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
--- ARE TOGETHER; REWROTE ONE OF THE GENERIC
--- PACKAGES AS A GENERIC PROCEDURE TO BROADEN
--- COVERAGE OF TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37213L IS
-BEGIN
- TEST ("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
- "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
- "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
- "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
- "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
- "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " &
- "ACCESS TYPE");
-
- DECLARE
- SUBTYPE SM IS INTEGER RANGE 1..10;
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- SEQUENCE_NUMBER : INTEGER;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- OBJ_XCP : BOOLEAN;
- TAG : STRING;
- PACKAGE DER_CHK IS END DER_CHK;
-
- PACKAGE BODY DER_CHK IS
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
-
- FUNCTION VALUE RETURN DREC IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN X;
- ELSE
- RETURN X;
- END IF;
- END VALUE;
- BEGIN
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING DECLARATION " &
- "OF OBJECT OF TYPE DREC - " &
- TAG);
- ELSIF X /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT OF " &
- "TYPE DREC - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT CHECKED " &
- "DURING DECLARATION OF OBJECT " &
- "OF TYPE DREC - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING DECLARATION OF DREC - " & TAG);
- END;
-
- GENERIC
- TYPE CONS IS PRIVATE;
- PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING);
-
- PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
- TAG : STRING) IS
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- BEGIN
- DECLARE
- X : ACC_CONS;
-
- FUNCTION VALUE RETURN CONS IS
- BEGIN
- IF EQUAL (5, 5) THEN
- RETURN X.ALL;
- ELSE
- RETURN X.ALL;
- END IF;
- END VALUE;
- BEGIN
- X := NEW CONS;
-
- IF OBJ_XCP THEN
- FAILED ("NO CHECK DURING ALLOCATION " &
- "OF OBJECT OF TYPE CONS - " &
- TAG);
- ELSIF X.ALL /= VALUE THEN
- FAILED ("INCORRECT VALUE FOR OBJECT " &
- "OF TYPE CONS - " & TAG);
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OBJ_XCP THEN
- FAILED ("IMPROPER CONSTRAINT " &
- "CHECKED DURING " &
- "ALLOCATION OF OBJECT " &
- "OF TYPE CONS - " & TAG);
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING DECLARATION OF X - " & TAG);
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
- "DURING DECLARATION OF ACC_CONS - " & TAG);
- END ACC_CHK;
- BEGIN
- SEQUENCE_NUMBER := 1;
- DECLARE
- TYPE REC_DEF (D3 : INTEGER := 1) IS
- RECORD
- C1 : REC (D3, 0);
- END RECORD;
-
- PACKAGE PACK1 IS NEW DER_CHK (REC_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK1");
-
- PROCEDURE PROC1 IS NEW ACC_CHK (REC_DEF);
- BEGIN
- PROC1 (OBJ_XCP => TRUE, TAG => "PROC1");
- END;
-
- SEQUENCE_NUMBER := 2;
- DECLARE
- TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- C1 : MY_ARR (0..D3);
- END RECORD;
-
- PACKAGE PACK2 IS NEW DER_CHK (ARR_DEF,
- OBJ_XCP => TRUE,
- TAG => "PACK2");
-
- PROCEDURE PROC2 IS NEW ACC_CHK (ARR_DEF);
- BEGIN
- PROC2 (OBJ_XCP => TRUE, TAG => "PROC2");
- END;
-
- SEQUENCE_NUMBER := 3;
- DECLARE
- TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK3 IS NEW DER_CHK (VAR_REC_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK3");
-
- PROCEDURE PROC3 IS NEW ACC_CHK (VAR_REC_DEF1);
- BEGIN
- PROC3 (OBJ_XCP => TRUE, TAG => "PROC3");
- END;
-
- SEQUENCE_NUMBER := 4;
- DECLARE
- TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK4 IS NEW DER_CHK (VAR_REC_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK4");
-
- PROCEDURE PROC4 IS NEW ACC_CHK (VAR_REC_DEF6);
- BEGIN
- PROC4 (OBJ_XCP => FALSE, TAG => "PROC4");
- END;
-
- SEQUENCE_NUMBER := 5;
- DECLARE
- TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC (D3, IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK5 IS NEW DER_CHK (VAR_REC_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK5");
-
- PROCEDURE PROC5 IS NEW ACC_CHK (VAR_REC_DEF11);
- BEGIN
- PROC5 (OBJ_XCP => FALSE, TAG => "PROC5");
- END;
-
- SEQUENCE_NUMBER := 6;
- DECLARE
- TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK6 IS NEW DER_CHK (VAR_ARR_DEF1,
- OBJ_XCP => TRUE,
- TAG => "PACK6");
-
- PROCEDURE PROC6 IS NEW ACC_CHK (VAR_ARR_DEF1);
- BEGIN
- PROC6 (OBJ_XCP => TRUE, TAG => "PROC6");
- END;
-
- SEQUENCE_NUMBER := 7;
- DECLARE
- TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK7 IS NEW DER_CHK (VAR_ARR_DEF6,
- OBJ_XCP => FALSE,
- TAG => "PACK7");
-
- PROCEDURE PROC7 IS NEW ACC_CHK (VAR_ARR_DEF6);
- BEGIN
- PROC7 (OBJ_XCP => FALSE, TAG => "PROC7");
- END;
-
- SEQUENCE_NUMBER := 8;
- DECLARE
- TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..IDENT_INT(11));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
-
- PACKAGE PACK8 IS NEW DER_CHK (VAR_ARR_DEF11,
- OBJ_XCP => FALSE,
- TAG => "PACK8");
-
- PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11);
- BEGIN
- PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
- "DECLARATION / INSTANTIATION ELABORATION - " &
- INTEGER'IMAGE (SEQUENCE_NUMBER));
- END;
-
- RESULT;
-END C37213L;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37215b.ada b/gcc/testsuite/ada/acats/tests/c3/c37215b.ada
deleted file mode 100644
index 408804e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37215b.ada
+++ /dev/null
@@ -1,203 +0,0 @@
--- C37215B.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 DISCRIMINANT CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR
--- COMPATIBILITY WHEN THE RECORD TYPE IS:
---
--- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION.
-
--- JBG 10/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37215B IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
-
-BEGIN
- TEST ("C37215B", "CHECK COMPATIBILITY OF DISCRIMINANT EXPRESSIONS"&
- " WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "AND DISCRIMINANTS HAVE DEFAULTS");
-
--- CASE B
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- C1 : REC(D3, 1);
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
- BEGIN
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37215B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37215d.ada b/gcc/testsuite/ada/acats/tests/c3/c37215d.ada
deleted file mode 100644
index 3eefc53..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37215d.ada
+++ /dev/null
@@ -1,202 +0,0 @@
--- C37215D.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 INDEX CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR
--- COMPATIBILITY WHEN THE RECORD TYPE IS:
---
--- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION.
-
--- JBG 10/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37215D IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
-BEGIN
- TEST ("C37215D", "CHECK COMPATIBILITY OF INDEX BOUNDS " &
- "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "AND DISCRIMINANTS HAVE DEFAULTS");
-
--- CASE B
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- C1 : MY_ARR(2..D3);
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("INDEX CHECK NOT PERFORMED - 2");
- BEGIN
- IF X.ALL /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1 => 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1 => 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("INDEX CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1 => 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37215D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37215f.ada b/gcc/testsuite/ada/acats/tests/c3/c37215f.ada
deleted file mode 100644
index 1f34c4e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37215f.ada
+++ /dev/null
@@ -1,313 +0,0 @@
--- C37215F.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 DISCRIMINANT CONSTRAINT
--- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR
--- COMPATIBILITY WHEN THE RECORD TYPE IS:
---
--- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
--- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE.
-
--- JBG 10/17/86
--- PWN 05/31/96 Corrected format of call to "TEST"
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37215F IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
- TYPE REC (D1, D2 : SM) IS
- RECORD NULL; END RECORD;
-
-BEGIN
- TEST ("C37215F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
- "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
- "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT " &
- "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " &
- "BE CHECKED");
-
--- CASE D1: COMPONENT IS PRESENT
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC(D3, 1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 3");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 4");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 5");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
- END;
-
- BEGIN
- DECLARE
- TYPE DREC IS NEW CONS;
- BEGIN
- DECLARE
- X : DREC;
- BEGIN
- FAILED ("DISCRIMINANT CHECK NOT " &
- "PERFORMED - 6");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
- END;
-
- END;
-
--- CASE C2 : COMPONENT IS ABSENT
-
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : REC(D3, IDENT_INT(1));
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- IF X /= (11, 5) THEN
- FAILED ("WRONG VALUE FOR X - 11");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- IF X /= (11, 5) THEN
- FAILED ("X VALUE WRONG - 12");
- END IF;
- END;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- X : ARR;
- BEGIN
- IF X /= (1..5 => (11, 5)) THEN
- FAILED ("X VALUE INCORRECT - 13");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- X : NREC;
- BEGIN
- IF X /= (C1 => (11, 5)) THEN
- FAILED ("X VALUE IS INCORRECT - 14");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- X : NREC;
- BEGIN
- IF X /= (11, 5) THEN
- FAILED ("X VALUE INCORRECT - 15");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS := NEW CONS;
- BEGIN
- IF X.ALL /= (11, 5) THEN
- FAILED ("X VALUE INCORRECT - 17");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17");
- END;
- END;
-
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
- RESULT;
-
-END C37215F;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37215h.ada b/gcc/testsuite/ada/acats/tests/c3/c37215h.ada
deleted file mode 100644
index c98180a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37215h.ada
+++ /dev/null
@@ -1,345 +0,0 @@
--- C37215H.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 INDEX CONSTRAINT DEPENDS ON A DISCRIMINANT,
--- THE DISCRIMINANT VALUE IS CHECKED FOR COMPATIBILITY WHEN THE
--- RECORD TYPE IS:
---
--- CASE D: CONSTRAINED BY DEFAULT AND THE COMPONENT IS
--- PRESENT IN THE SUBTYPE.
-
--- HISTORY:
--- JBG 10/17/86 CREATED ORIGINAL TEST.
--- RJW 10/13/87 CORRECTED VARIOUS CONSTRAINT ERRORS IN 'CASE D1'.
--- VCL 03/30/88 CORRECTED VARIOUS CONSTRAINT ERRORS WITH TYPE
--- DECLARATIONS THROUGHOUT THE TEST. ADDED SEQUENCE
--- NUMBERS.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37215H IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
- TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
-
- SEQUENCE_NUMBER : INTEGER;
-BEGIN
- TEST ("C37215H", "THE DISCRIMINANT VALUES OF AN INDEX " &
- "CONSTRAINT ARE PROPERLY CHECK FOR " &
- "COMPATIBILITY WHEN THE DISCRIMINANT IS " &
- "DEFINED BY DEFAULT AND THE COMPONENT IS AND " &
- "IS NOT PRESENT IN THE SUBTYPE");
-
--- CASE D1: COMPONENT IS PRESENT
-
- SEQUENCE_NUMBER := 1;
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(D3..1);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(0);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 1");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 2");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 3");
- IF X /= (1..5 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 4");
- IF X /= (C1 => (1, (1, 1))) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- FAILED ("INDEX CHECK NOT PERFORMED - 5");
- IF X /= (1, (1, 1)) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5B");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- BEGIN
- DECLARE
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- FAILED ("INDEX CHECK NOT PERFORMED - 6");
- IF X.ALL /= (1, (1, 1)) THEN
- COMMENT ("WRONG VALUE FOR X - 6");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "- 6A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6B");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6C");
- END;
- END;
-
--- CASE D2: COMPONENT IS ABSENT
-
- SEQUENCE_NUMBER := 2;
- DECLARE
- TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
- RECORD
- CASE D3 IS
- WHEN -5..10 =>
- C1 : MY_ARR(IDENT_INT(2)..D3);
- WHEN OTHERS =>
- C2 : INTEGER := IDENT_INT(5);
- END CASE;
- END RECORD;
- BEGIN
- BEGIN
- DECLARE
- X : CONS;
- BEGIN
- IF X /= (11, 5) THEN
- COMMENT ("X VALUE IS INCORRECT - 11");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 11");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE SCONS IS CONS;
- BEGIN
- DECLARE
- X : SCONS;
- BEGIN
- IF X /= (11, 5) THEN
- FAILED ("X VALUE INCORRECT - 12");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 12A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 12B");
- END;
-
- BEGIN
- DECLARE
- TYPE ARR IS ARRAY (1..5) OF CONS;
- BEGIN
- DECLARE
- X : ARR;
- BEGIN
- IF X /= (1..5 => (11, 5)) THEN
- FAILED ("X VALUE INCORRECT - 13");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 13A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 13B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS
- RECORD
- C1 : CONS;
- END RECORD;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- IF X /= (C1 => (11, 5)) THEN
- FAILED ("X VALUE INCORRECT - 14");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 14A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 14B");
- END;
-
- BEGIN
- DECLARE
- TYPE NREC IS NEW CONS;
- BEGIN
- DECLARE
- X : NREC;
- BEGIN
- IF X /= (11, 5) THEN
- FAILED ("X VALUE INCORRECT - 15");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 15A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 15B");
- END;
-
- BEGIN
- DECLARE
- TYPE ACC_CONS IS ACCESS CONS;
- X : ACC_CONS;
- BEGIN
- X := NEW CONS;
- IF X.ALL /= (11, 5) THEN
- FAILED ("X VALUE INCORRECT - 17");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 17A");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 17B");
- END;
- END;
-
- RESULT;
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("INDEX VALUES CHECKED TOO SOON - " &
- INTEGER'IMAGE(SEQUENCE_NUMBER));
- RESULT;
-END C37215H;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37217a.ada b/gcc/testsuite/ada/acats/tests/c3/c37217a.ada
deleted file mode 100644
index bf0a9b4b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37217a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C37217A.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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS
--- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS
--- TYPE - AFTER THE TYPE'S FULL DECLARATION.
-
--- HISTORY:
--- DHH 02/05/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37217A IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
-BEGIN --C37217A BODY
- TEST ("C37217A", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " &
- "CHECK IS PERFORMED WHEN A DISCRIMINANT " &
- "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " &
- "- AFTER THE TYPE'S FULL DECLARATION");
-
- -- CHECK FULL DECLARATION
- -- LOWER LIMIT
- BEGIN
- DECLARE
-
- TYPE SM_REC(D : SM) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC(D1 : INTEGER) IS
- RECORD
- INT : SM_REC(D1);
- END RECORD;
-
- TYPE PTR IS ACCESS REC;
-
- Y : PTR(IDENT_INT(0)); -- OPTIONAL EXCEPTION.
- BEGIN
- COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " &
- "- LOWER");
- Y := NEW REC(IDENT_INT(0)); -- MANDATORY EXCEPTION.
- FAILED("CONSTRAINT ERROR NOT RAISED");
-
- IF IDENT_INT(Y.INT.D) /= IDENT_INT(-1) THEN
- COMMENT ("IRRELEVANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE ALLOCATION - LOWER");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT("OPTIONAL CONSTRAINT ERROR RAISED - LOWER");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE DECLARATION - LOWER");
- END;
----------------------------------------------------------------------
- -- CHECK FULL DECLARATION
- -- UPPER LIMIT
- BEGIN
- DECLARE
- TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER;
-
- TYPE REC(D1 : INTEGER) IS
- RECORD
- INT : SM_ARR(1 .. D1);
- END RECORD;
-
- TYPE PTR IS ACCESS REC;
-
- Y : PTR(IDENT_INT(11)); -- OPTIONAL EXCEPTION.
- BEGIN
- COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " &
- "- UPPER");
- Y := NEW REC'(IDENT_INT(11), -- MANDATORY EXCEPTION.
- INT => (OTHERS => IDENT_INT(0)));
- FAILED("CONSTRAINT ERROR NOT RAISED");
-
- IF IDENT_INT(Y.INT(IDENT_INT(1))) /= 11 THEN
- COMMENT ("IRRELEVANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE ALLOCATION - UPPER");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " &
- "- UPPER");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE DECLARATION - UPPER");
- END;
-
- RESULT;
-
-END C37217A; -- BODY
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37217b.ada b/gcc/testsuite/ada/acats/tests/c3/c37217b.ada
deleted file mode 100644
index 77a9d89..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37217b.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- C37217B.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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS
--- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS
--- TYPE - BEFORE THE DESIGNATED TYPE'S FULL DECLARATION.
-
--- HISTORY:
--- DHH 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37217B IS
-
- SUBTYPE SM IS INTEGER RANGE 1..10;
-
-BEGIN --C37217B BODY
- TEST ("C37217B", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " &
- "CHECK IS PERFORMED WHEN A DISCRIMINANT " &
- "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE - " &
- "BEFORE THE DESIGNATED TYPE'S FULL DECLARATION");
-
----------------------------------------------------------------------
- -- INCOMPLETE DECLARATION
- -- UPPER LIMIT
- BEGIN -- F
- DECLARE -- F
- TYPE REC(D1 : INTEGER);
-
- TYPE PTR IS ACCESS REC;
- X : PTR(IDENT_INT(11));
-
- TYPE SM_REC(D : SM) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC(D1 : INTEGER) IS
- RECORD
- INT : SM_REC(D1);
- END RECORD;
- BEGIN
- COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " &
- "- UPPER");
- X := NEW REC(IDENT_INT(11));
- FAILED("CONSTRAINT ERROR NOT RAISED - UPPER");
-
- IF IDENT_INT(X.INT.D) /= IDENT_INT(1) THEN
- COMMENT("IRREVELANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE USE - INCOMPLETE UPPER");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " &
- "- INCOMPLETE UPPER");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE DECLARATION - INCOMPLETE UPPER");
- END; -- F
-
------------------------------------------------------------------------
- -- INCOMPLETE DECLARATION
- -- LOWER LIMIT
- BEGIN -- A
- DECLARE -- A
- TYPE REC(D1 : INTEGER);
-
- TYPE PTR IS ACCESS REC;
- X : PTR(IDENT_INT(0));
-
- TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER;
-
- TYPE REC(D1 : INTEGER) IS
- RECORD
- INT : SM_ARR(D1 .. 2);
- END RECORD;
- BEGIN
- COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " &
- "- LOWER");
- X := NEW REC'(IDENT_INT(0), INT =>
- (OTHERS => IDENT_INT(1)));
- FAILED("CONSTRAINT ERROR NOT RAISED - LOWER");
-
- IF X.INT(IDENT_INT(1)) /= IDENT_INT(1) THEN
- COMMENT("IRREVELANT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE USE - INCOMPLETE LOWER");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " &
- "- INCOMPLETE LOWER");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE DECLARATION - INCOMPLETE LOWER");
- END;
------------------------------------------------------------------------
- RESULT;
-
-END C37217B; -- BODY
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37217c.ada b/gcc/testsuite/ada/acats/tests/c3/c37217c.ada
deleted file mode 100644
index f6fee5c1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37217c.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C37217C.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 WHETHER THE OPTIONAL COMPATIBILITY CHECK IS
--- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS
--- TYPE - WHEN THERE IS A "LOOP" IN THE DESIGNATED TYPE'S FULL
--- DECLARATION.
-
--- HISTORY:
--- DHH 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37217C IS
-
-BEGIN --C37217C BODY
- TEST ("C37217C", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " &
- "CHECK IS PERFORMED WHEN A DISCRIMINANT " &
- "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " &
- "- WHEN THERE IS A ""LOOP"" IN THE DESIGNATED " &
- "TYPE'S FULL DECLARATION");
-
- BEGIN
- DECLARE
- TYPE R1(D1 : INTEGER);
- TYPE R2(D2 : INTEGER);
- TYPE R3(D3 : POSITIVE);
-
- TYPE ACC_R1 IS ACCESS R1;
- TYPE ACC_R2 IS ACCESS R2;
- TYPE ACC_R3 IS ACCESS R3;
-
- TYPE R1(D1 : INTEGER) IS
- RECORD
- C1 : ACC_R2(D1);
- END RECORD;
-
- TYPE R2(D2 : INTEGER) IS
- RECORD
- C2 : ACC_R3(D2);
- END RECORD;
-
- TYPE R3(D3 : POSITIVE) IS
- RECORD
- C3 : ACC_R1(D3);
- END RECORD;
-
- X1 : ACC_R1(IDENT_INT(0));
-
- BEGIN
- COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED");
-
- X1 := NEW R1'(D1 =>IDENT_INT(0),
- C1 => NEW R2'(D2 => IDENT_INT(0),
- C2 => NEW R3(IDENT_INT(0))));
-
- FAILED("CONSTRAINT_ERROR NOT RAISED");
-
- IF IDENT_INT(X1.C1.C2.D3) /= IDENT_INT(0) THEN
- COMMENT("THIS LINE SHOULD NOT PRINT OUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE USE - LOOPED");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "VARIABLE DECLARATION - LOOPED");
- END;
-
- RESULT;
-
-END C37217C; -- BODY
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37304a.ada b/gcc/testsuite/ada/acats/tests/c3/c37304a.ada
deleted file mode 100644
index e521671..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37304a.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C37304A.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 FORMS OF CHOICE ARE PERMITTED IN A VARIANT_PART,
--- AND, IN PARTICULAR, THAT FORMS LIKE ST RANGE L..R, AND ST ARE
--- PERMITTED.
-
--- ASL 7/31/81
--- RM 8/26/82
--- SPS 1/21/83
-
-WITH REPORT;
-PROCEDURE C37304A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C37304A","ALL FORMS OF CHOICE ALLOWED IN A VARIANT_PART");
-
- DECLARE
-
- TYPE T IS RANGE 1 .. 10;
- C5 : CONSTANT T := 5;
- SUBTYPE S1 IS T RANGE 1 .. 5;
- SUBTYPE S2 IS T RANGE C5 + 1 .. 7;
- SUBTYPE SN IS T RANGE C5 + 4 .. C5 - 4 + 7; -- NULL RANGE.
- SUBTYPE S10 IS T RANGE C5 + 5 .. T'LAST;
-
- TYPE VREC( DISC : T := 8 ) IS
- RECORD
- CASE DISC IS
- WHEN SN -- 9..8
- | S1 RANGE 1 .. 0 -- 1..0
- | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6
- | 3 .. 2 -- 3..2
- => NULL;
-
- WHEN S1 RANGE 4 .. C5 -- 4..5
- | S1 RANGE C5 - 4 .. C5 / 2 -- 1..2
- | 3 .. 1 + C5 MOD 3 -- 3..3
- | SN -- 9..8
- | S1 RANGE 5 .. C5 - 1 -- 5..4
- | 6 .. 7 -- 6..7
- | S10 -- 10..10
- | 9 -- 9
- | S10 RANGE 10 .. 9 -- 10..9
- => NULL;
-
- WHEN C5 + C5 - 2 .. 8 -- 8
- => NULL;
-
- END CASE;
- END RECORD;
-
- V : VREC;
-
- BEGIN
-
- IF EQUAL(3,3) THEN
- V := (DISC => 5);
- END IF;
- IF V.DISC /= 5 THEN
- FAILED ("ASSIGNMENT FAILED");
- END IF;
-
- END;
-
- RESULT;
-
-END C37304A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37305a.ada b/gcc/testsuite/ada/acats/tests/c3/c37305a.ada
deleted file mode 100644
index 0282fa9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37305a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C37305A.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 CHOICES DENOTING A NULL RANGE OF VALUES ARE PERMITTED,
--- AND THAT FOR CHOICES CONSISTING OF A SUBTYPE NAME FOLLOWED BY A
--- RANGE CONSTRAINT WHERE THE LOWER BOUND IS GREATER THAN THE UPPER
--- BOUND, THE BOUNDS NEED NOT BE IN THE RANGE OF THE SUBTYPE VALUES.
-
--- CHECK THAT AN OTHERS ALTERNATIVE CAN BE PROVIDED EVEN IF ALL VALUES
--- OF THE CASE EXPRESSION HAVE BEEN COVERED BY PRECEDING ALTERNATIVES.
-
--- ASL 7/14/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C37305A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37305A","NULL RANGES ALLOWED IN CHOICES FOR VARIANT " &
- "PARTS. OTHERS ALTERNATIVE ALLOWED AFTER ALL VALUES " &
- "PREVIOUSLY COVERED");
-
- DECLARE
- SUBTYPE ST IS INTEGER RANGE 1..10;
-
- TYPE REC(DISC : ST := 1) IS
- RECORD
- CASE DISC IS
- WHEN 0..-1 => NULL;
- WHEN 1..-3 => NULL;
- WHEN 6..5 =>
- COMP : INTEGER;
- WHEN 11..10 => NULL;
- WHEN 15..12 => NULL;
- WHEN 11..0 => NULL;
- WHEN 1..10 => NULL;
- WHEN OTHERS => NULL;
- END CASE;
- END RECORD;
-
- R : REC;
- BEGIN
- R := (DISC => 4);
-
- IF EQUAL(3,4) THEN
- R := (DISC => 7);
- END IF;
-
- IF R.DISC /= 4 THEN
- FAILED ("ASSIGNMENT FAILED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-
-END C37305A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37306a.ada b/gcc/testsuite/ada/acats/tests/c3/c37306a.ada
deleted file mode 100644
index f50fe01..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37306a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C37306A.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 VARIANT PART OF A RECORD THE CHOICES WITHIN AND
--- BETWEEN ALTERNATIVES CAN APPEAR IN NON-MONOTONIC ORDER.
-
--- ASL 7/13/81
--- JWC 6/28/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE C37306A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37306A","NON-MONOTONIC ORDER OF CHOICES IN VARIANT PARTS");
-
- DECLARE
- TYPE COLOR IS (WHITE,RED,ORANGE,YELLOW,GREEN,AQUA,BLUE,BLACK);
-
- TYPE REC(DISC : COLOR := BLUE) IS
- RECORD
- CASE DISC IS
- WHEN ORANGE => NULL;
- WHEN GREEN | WHITE | BLACK => NULL;
- WHEN YELLOW => NULL;
- WHEN BLUE | RED => NULL;
- WHEN OTHERS => NULL;
- END CASE;
- END RECORD;
-
- R : REC;
- BEGIN
- R := (DISC => WHITE);
-
- IF EQUAL(3,4) THEN
- R := (DISC => RED);
- END IF;
-
- IF R.DISC /= WHITE THEN
- FAILED ("ASSIGNMENT FAILED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-END C37306A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37309a.ada b/gcc/testsuite/ada/acats/tests/c3/c37309a.ada
deleted file mode 100644
index 316c0e8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37309a.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C37309A.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 DISCRIMINANT HAS A STATIC SUBTYPE, AN OTHERS
--- CHOICE CAN BE OMITTED IF ALL VALUES IN THE
--- SUBTYPE'S RANGE ARE COVERED IN A VARIANT PART.
-
--- ASL 7/10/81
--- SPS 10/25/82
--- SPS 7/17/83
-
-WITH REPORT;
-PROCEDURE C37309A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37309A","OTHERS CHOICE CAN BE OMITTED IN VARIANT PART " &
- "IF ALL VALUES IN STATIC SUBTYPE RANGE OF DISCRIMINANT " &
- "ARE COVERED");
-
- DECLARE
- SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N';
- TYPE REC1(DISC : STATCHAR := 'J') IS
- RECORD
- CASE DISC IS
- WHEN 'I' => NULL;
- WHEN 'J' => NULL;
- WHEN 'K' => NULL;
- WHEN 'L' => NULL;
- WHEN 'M' => NULL;
- WHEN 'N' => NULL;
- END CASE;
- END RECORD;
-
- R1 : REC1;
- BEGIN
- R1 := (DISC => 'N');
- IF EQUAL(3,3) THEN
- R1 := (DISC => 'K');
- END IF;
- IF R1.DISC /= 'K' THEN
- FAILED ("ASSIGNMENT FAILED - 1");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-
-END C37309A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37310a.ada b/gcc/testsuite/ada/acats/tests/c3/c37310a.ada
deleted file mode 100644
index dfa3748..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37310a.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C37310A.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 DISCRIMINANT HAS A DYNAMIC SUBTYPE, AN OTHERS
--- CHOICE CAN BE OMITTED IF ALL VALUES IN THE BASE
--- TYPE'S RANGE ARE COVERED.
-
--- ASL 7/10/81
--- SPS 10/25/82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT;
-PROCEDURE C37310A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C37310A", "CHECK DYNAMIC DISCRIMINANT SUBTYPES " &
- "IN VARIANT RECORD DECLARATIONS");
-
- DECLARE
-
- ACHAR : CHARACTER := IDENT_CHAR('A');
- ECHAR : CHARACTER := IDENT_CHAR('E');
- JCHAR : CHARACTER := IDENT_CHAR('J');
- MCHAR : CHARACTER := IDENT_CHAR('M');
- SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N';
- SUBTYPE DYNCHAR IS CHARACTER RANGE ACHAR..ECHAR;
- SUBTYPE SSTAT IS STATCHAR RANGE JCHAR..MCHAR;
-
- TYPE LETTER IS NEW CHARACTER RANGE 'A'..'Z';
- SUBTYPE DYNLETTER IS
- LETTER RANGE LETTER(ECHAR)..LETTER(JCHAR);
-
- TYPE REC1(DISC : SSTAT := 'K') IS
- RECORD
- CASE DISC IS
- WHEN ASCII.NUL..CHARACTER'LAST => NULL;
- END CASE;
- END RECORD;
-
- TYPE REC2(DISC : DYNCHAR := 'C') IS
- RECORD
- CASE DISC IS
- WHEN ASCII.NUL..CHARACTER'LAST => NULL;
- END CASE;
- END RECORD;
-
- TYPE REC3(DISC: DYNCHAR := 'D') IS
- RECORD
- CASE DISC IS
- WHEN CHARACTER'FIRST..CHARACTER'LAST => NULL;
- END CASE;
- END RECORD;
-
- TYPE REC4(DISC : DYNLETTER := 'F') IS
- RECORD
- CASE DISC IS
- WHEN LETTER'BASE'FIRST..
- LETTER'BASE'LAST => NULL;
- END CASE;
- END RECORD;
-
- R1 : REC1;
- R2 : REC2;
- R3 : REC3;
- R4 : REC4;
- BEGIN
- IF EQUAL(3,3) THEN
- R1 := (DISC => 'L');
- END IF;
- IF R1.DISC /= 'L' THEN
- FAILED ("ASSIGNMENT FAILED - 1");
- END IF;
-
- IF EQUAL(3,3) THEN
- R2 := (DISC => 'B');
- END IF;
- IF R2.DISC /= 'B' THEN
- FAILED ("ASSIGNMENT FAILED - 2");
- END IF;
-
- IF EQUAL(3,3) THEN
- R3 := (DISC => 'B');
- END IF;
- IF R3.DISC /= 'B' THEN
- FAILED ("ASSIGNMENT FAILED - 3");
- END IF;
-
- IF EQUAL(3,3) THEN
- R4 := (DISC => 'H');
- END IF;
- IF R4.DISC /= 'H' THEN
- FAILED ("ASSIGNMENT FAILED - 4");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-
-END C37310A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37312a.ada b/gcc/testsuite/ada/acats/tests/c3/c37312a.ada
deleted file mode 100644
index f34eb7c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37312a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C37312A.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 DISCRIMINANT CAN HAVE A GENERIC FORMAL DISCRETE
--- TYPE WHEN IT DOES NOT GOVERN A VARIANT PART AND THAT AN
--- OBJECT OF A GENERIC FORMAL TYPE CAN CONSTRAIN A COMPONENT
--- IN A VARIANT PART.
-
--- HISTORY:
--- AH 08/22/86 CREATED ORIGINAL TEST.
--- JET 08/13/87 REVISED FROM CLASS 'A' TO CLASS 'C' TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C37312A IS
-
-BEGIN
- TEST ("C37312A", "DISCRIMINANT TYPE IS GENERIC FORMAL TYPE");
-
- DECLARE
- TYPE T IS RANGE 1 ..5;
-
- GENERIC
- TYPE G1 IS RANGE <>;
- PACKAGE P IS
- TYPE G2 (D1 : G1) IS
- RECORD
- R1 : G1;
- R2 : BOOLEAN;
- END RECORD;
-
- TYPE STR IS ARRAY(G1 RANGE <>) OF INTEGER;
- TYPE G3 (D : G1; E : INTEGER) IS
- RECORD
- CASE E IS
- WHEN 1 =>
- S1 : STR(G1'FIRST..D);
- WHEN OTHERS =>
- S2 : INTEGER;
- END CASE;
- END RECORD;
-
- END P;
-
- PACKAGE PKG IS NEW P (G1 => T);
- USE PKG;
-
- A2: G2(1) := (1, 5, FALSE);
- A3: G3(5, 1) := (5, 1, (1, 2, 3, 4, 5));
-
- BEGIN
- A2.R2 := IDENT_BOOL (TRUE);
- A3.S1(1) := IDENT_INT (6);
-
- IF A2 /= (1, 5, TRUE) THEN
- FAILED ("INVALID CONTENTS OF RECORD A2");
- END IF;
- IF A3 /= (5, 1, (6, 2, 3, 4, 5)) THEN
- FAILED ("INVALID CONTENTS OF RECORD A3");
- END IF;
- END;
-
- RESULT;
-
-END C37312A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37402a.ada b/gcc/testsuite/ada/acats/tests/c3/c37402a.ada
deleted file mode 100644
index ec21d74..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37402a.ada
+++ /dev/null
@@ -1,253 +0,0 @@
--- C37402A.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 A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR
--- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT
--- HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN APPLIED TO FORMAL
--- PARAMETERS OF MODE IN AND HAS THE VALUE OF THE ACTUAL PARAMETER
--- FOR THE OTHER MODES.
-
--- R.WILLIAMS 9/1/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37402A IS
-
-BEGIN
- TEST ( "C37402A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &
- "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &
- "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &
- "HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN " &
- "APPLIED TO FORMAL PARAMETERS OF MODE IN " &
- "AND HAS THE VALUE OF THE ACTUAL PARAMETER " &
- "FOR THE OTHER MODES" );
-
-
- DECLARE
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 5;
-
- TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)
- OF INTEGER;
-
- TYPE SQUARE (SIDE : INT := 1) IS
- RECORD
- MAT : MATRIX (1 .. SIDE, 1 .. SIDE);
- END RECORD;
-
- SC : CONSTANT SQUARE := (2, ((0, 0), (0, 0)));
-
- AC : SQUARE (2) := (2, ((1, 2), (3, 4)));
- AU : SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));
-
- BC : SQUARE (2) := AC;
- BU : SQUARE := AU;
-
- CC : SQUARE (2);
- CU : SQUARE;
-
- PROCEDURE P (CON, IN_CON : IN SQUARE;
- INOUT_CON : IN OUT SQUARE;
- OUT_CON : OUT SQUARE;
- IN_UNC : IN SQUARE;
- INOUT_UNC : IN OUT SQUARE;
- OUT_UNC : OUT SQUARE) IS
-
- BEGIN
- IF CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 1" );
- END IF;
-
- IF IN_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 2" );
- END IF;
-
- IF IN_UNC'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 3" );
- END IF;
-
- IF INOUT_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "CONSTRAINED OBJECT OF IN OUT MODE - 1" );
- END IF;
-
- IF OUT_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "CONSTRAINED OBJECT OF OUT MODE - 1" );
- END IF;
-
- IF INOUT_UNC'CONSTRAINED THEN
- FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
- "UNCONSTRAINED OBJECT OF IN OUT MODE " &
- "- 1" );
- END IF;
-
- IF OUT_UNC'CONSTRAINED THEN
- FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
- "UNCONSTRAINED OBJECT OF OUT MODE - 1" );
- END IF;
-
- OUT_CON := (2, ((1, 2), (3, 4)));
- OUT_UNC := (2, ((1, 2), (3, 4)));
- END P;
-
- TASK T IS
- ENTRY Q (CON, IN_CON : IN SQUARE;
- INOUT_CON : IN OUT SQUARE;
- OUT_CON : OUT SQUARE;
- IN_UNC : IN SQUARE;
- INOUT_UNC : IN OUT SQUARE;
- OUT_UNC : OUT SQUARE);
- END T;
-
- TASK BODY T IS
- BEGIN
- ACCEPT Q (CON, IN_CON : IN SQUARE;
- INOUT_CON : IN OUT SQUARE;
- OUT_CON : OUT SQUARE;
- IN_UNC : IN SQUARE;
- INOUT_UNC : IN OUT SQUARE;
- OUT_UNC : OUT SQUARE) DO
- BEGIN
- IF CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN MODE - 4" );
- END IF;
-
- IF IN_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN MODE - 5" );
- END IF;
-
- IF IN_UNC'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN MODE - 6" );
- END IF;
-
- IF INOUT_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "CONSTRAINED OBJECT OF " &
- "IN OUT MODE - 2" );
- END IF;
-
- IF OUT_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "CONSTRAINED OBJECT OF " &
- "OUT MODE - 2" );
- END IF;
-
- IF INOUT_UNC'CONSTRAINED THEN
- FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
- "UNCONSTRAINED OBJECT OF " &
- "IN OUT MODE - 2" );
- END IF;
-
- IF OUT_UNC'CONSTRAINED THEN
- FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
- "UNCONSTRAINED OBJECT OF " &
- "OUT MODE - 2" );
- END IF;
-
- OUT_CON := (2, ((1, 2), (3, 4)));
- OUT_UNC := (2, ((1, 2), (3, 4)));
- END;
- END Q;
- END T;
-
- GENERIC
- CON, IN_CON : IN SQUARE;
- INOUT_CON : IN OUT SQUARE;
- IN_UNC : IN SQUARE;
- INOUT_UNC : IN OUT SQUARE;
- PACKAGE R IS END R;
-
- PACKAGE BODY R IS
- BEGIN
- IF CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 7" );
- END IF;
-
- IF IN_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 8" );
- END IF;
-
- IF IN_UNC'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 9" );
- END IF;
-
- IF INOUT_CON'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "CONSTRAINED OBJECT OF IN OUT MODE - 3" );
- END IF;
-
- IF INOUT_UNC'CONSTRAINED THEN
- FAILED ( "'CONSTRAINED IS 'TRUE' FOR " &
- "UNCONSTRAINED OBJECT OF IN OUT MODE " &
- "- 3" );
- END IF;
-
- END R;
-
- PACKAGE S IS NEW R (SC, AC, BC, AU, BU);
-
- BEGIN
- P (SC, AC, BC, CC, AU, BU, CU);
- T.Q (SC, AC, BC, CC, AU, BU, CU);
- END;
-
- RESULT;
-END C37402A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37403a.ada b/gcc/testsuite/ada/acats/tests/c3/c37403a.ada
deleted file mode 100644
index baa65f5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37403a.ada
+++ /dev/null
@@ -1,186 +0,0 @@
--- C37403A.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 A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR
--- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO
--- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE
--- OF THE PARAMETER.
-
--- R.WILLIAMS 9/1/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37403A IS
-
-BEGIN
- TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &
- "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &
- "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &
- "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " &
- "'TRUE' REGARDLESS OF THE MODE OF THE " &
- "PARAMETER" );
-
-
- DECLARE
-
- SUBTYPE INT IS INTEGER RANGE 1.. 10;
-
- TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)
- OF INTEGER;
-
- TYPE SQUARE (SIDE : INT) IS
- RECORD
- MAT : MATRIX (1 .. SIDE, 1 .. SIDE);
- END RECORD;
-
- S1 : SQUARE (2) := (2, ((1, 2), (3, 4)));
-
- S2 : SQUARE (2) := S1;
-
- S3 : SQUARE (2);
-
- SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));
-
- PROCEDURE P (PIN1, PIN2 : IN SQUARE;
- PINOUT : IN OUT SQUARE;
- POUT : OUT SQUARE) IS
-
- BEGIN
- IF PIN1'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 1" );
- END IF;
-
- IF PIN2'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 2" );
- END IF;
-
- IF PINOUT'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN OUT MODE - 1" );
- END IF;
-
- IF POUT'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF OUT MODE - 1" );
- END IF;
-
- POUT := (2, ((1, 2), (3, 4)));
- END P;
-
- TASK T IS
- ENTRY Q (PIN1, PIN2 : IN SQUARE;
- PINOUT : IN OUT SQUARE;
- POUT : OUT SQUARE);
- END T;
-
- TASK BODY T IS
- BEGIN
- ACCEPT Q (PIN1, PIN2 : IN SQUARE;
- PINOUT : IN OUT SQUARE;
- POUT : OUT SQUARE) DO
-
- BEGIN
- IF PIN1'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN MODE - 3" );
- END IF;
-
- IF PIN2'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN MODE - 4" );
- END IF;
-
- IF PINOUT'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF " &
- "IN OUT MODE - 2" );
- END IF;
-
- IF POUT'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF " &
- "OUT MODE - 2" );
- END IF;
-
- POUT := (2, ((1, 2), (3, 4)));
- END;
- END Q;
- END T;
-
- GENERIC
- PIN1, PIN2 : IN SQUARE;
- PINOUT : IN OUT SQUARE;
- PACKAGE R IS END R;
-
- PACKAGE BODY R IS
- BEGIN
- IF PIN1'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 5" );
- END IF;
-
- IF PIN2'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
- "OF IN MODE - 6" );
- END IF;
-
- IF PINOUT'CONSTRAINED THEN
- NULL;
- ELSE
- FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
- "OBJECT OF IN OUT MODE - 3" );
- END IF;
-
- END R;
-
- PACKAGE S IS NEW R (S1, SC, S2);
-
- BEGIN
- P (S1, SC, S2, S3);
- T.Q (S1, SC, S2, S3);
- END;
-
- RESULT;
-END C37403A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37404a.ada b/gcc/testsuite/ada/acats/tests/c3/c37404a.ada
deleted file mode 100644
index 006d449..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37404a.ada
+++ /dev/null
@@ -1,168 +0,0 @@
---C37404A.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 'CONSTRAINED IS TRUE FOR VARIABLES DECLARED WITH A
--- CONSTRAINED TYPE, FOR CONSTANT OBJECTS (EVEN IF NOT DECLARED
--- WITH A CONSTRAINED TYPE), AND DESIGNATED OBJECTS.
-
--- HISTORY:
--- DHH 02/25/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37404A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
- TYPE REC(A : INT) IS
- RECORD
- I : INT;
- END RECORD;
-
- TYPE ACC_REC IS ACCESS REC(4);
- TYPE ACC_REC1 IS ACCESS REC;
- SUBTYPE REC4 IS REC(4);
- SUBTYPE REC5 IS REC;
-
- TYPE REC_DEF(A : INT := 5) IS
- RECORD
- I : INT := 1;
- END RECORD;
-
- TYPE ACC_DEF IS ACCESS REC_DEF(4);
- TYPE ACC_DEF1 IS ACCESS REC_DEF;
- SUBTYPE REC6 IS REC_DEF(6);
- SUBTYPE REC7 IS REC_DEF;
-
- A : REC4 := (A => 4, I => 1); -- CONSTRAINED.
- B : REC5(4) := (A => 4, I => 1); -- CONSTRAINED.
- C : REC6; -- CONSTRAINED.
- D : REC7(6); -- CONSTRAINED.
- E : ACC_REC1(4); -- CONSTRAINED.
- F : ACC_DEF1(4); -- CONSTRAINED.
- G : ACC_REC1; -- UNCONSTRAINED.
- H : ACC_DEF1; -- UNCONSTRAINED.
-
- R : REC(5) := (A => 5, I => 1); -- CONSTRAINED.
- T : REC_DEF(5); -- CONSTRAINED.
- U : ACC_REC; -- CONSTRAINED.
- V : ACC_DEF; -- CONSTRAINED.
- W : CONSTANT REC(5) := (A => 5, I => 1); -- CONSTANT.
- X : CONSTANT REC := (A => 5, I => 1); -- CONSTANT.
- Y : CONSTANT REC_DEF(5) := (A => 5, I => 1); -- CONSTANT.
- Z : CONSTANT REC_DEF := (A => 5, I => 1); -- CONSTANT.
-
-BEGIN
- TEST("C37404A", "CHECK THAT 'CONSTRAINED IS TRUE FOR VARIABLES " &
- "DECLARED WITH A CONSTRAINED TYPE, FOR " &
- "CONSTANT OBJECTS (EVEN IF NOT DECLARED WITH A " &
- "CONSTRAINED TYPE), AND DESIGNATED OBJECTS");
-
- U := NEW REC(4);
- V := NEW REC_DEF(4);
- E := NEW REC(4);
- F := NEW REC_DEF(4);
- G := NEW REC(4); -- CONSTRAINED.
- H := NEW REC_DEF(4); -- CONSTRAINED.
-
- IF NOT A'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE1");
- END IF;
-
- IF NOT B'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE2");
- END IF;
-
- IF NOT C'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE1");
- END IF;
-
- IF NOT D'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE2");
- END IF;
-
- IF NOT R'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR RECORD COMPONENT");
- END IF;
-
- IF NOT T'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT VARIABLE");
- END IF;
-
- IF NOT E.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 1");
- END IF;
-
- IF NOT F.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 1");
- END IF;
-
- IF NOT G.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 2");
- END IF;
-
- IF NOT H.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 2");
- END IF;
-
- IF NOT U.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 3");
- END IF;
-
- IF NOT V.ALL'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 3");
- END IF;
-
- IF NOT W'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, CONSTRAINED");
- END IF;
-
- IF NOT X'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, UNCONSTRAINED");
- END IF;
-
- IF NOT Y'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " &
- "CONSTRAINED");
- END IF;
-
- IF NOT Z'CONSTRAINED THEN
- FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " &
- "UNCONSTRAINED");
- END IF;
-
- IF IDENT_INT(T.I) /= 1 OR
- IDENT_INT(C.I) /= 1 OR
- IDENT_INT(D.I) /= 1 OR
- IDENT_INT(W.A) /= 5 OR
- IDENT_INT(X.A) /= 5 OR
- IDENT_INT(Y.A) /= 5 OR
- IDENT_INT(Z.I) /= 1 OR
- IDENT_INT(A.I) /= 1 OR
- IDENT_INT(B.I) /= 1 OR
- IDENT_BOOL(R.I /= 1) THEN
- FAILED("INCORRECT INITIALIZATION VALUES");
- END IF;
-
- RESULT;
-END C37404A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37404b.ada b/gcc/testsuite/ada/acats/tests/c3/c37404b.ada
deleted file mode 100644
index d7a03ec..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37404b.ada
+++ /dev/null
@@ -1,148 +0,0 @@
---C37404B.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 'CONSTRAINED IS FALSE FOR VARIABLES THAT HAVE
--- DISCRIMINANTS WITH DEFAULT VALUES.
-
--- HISTORY:
--- LDC 06/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37404B IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
-
- TYPE REC_DEF(A : INT := 5) IS
- RECORD
- I : INT := 1;
- END RECORD;
-
- SUBTYPE REC_DEF_SUB IS REC_DEF;
-
- TYPE REC_DEF_ARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF;
- TYPE REC_DEF_SARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF_SUB;
-
- PACKAGE PRI_PACK IS
- TYPE REC_DEF_PRI(A : INTEGER := 5) IS PRIVATE;
- TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS LIMITED PRIVATE;
-
- PRIVATE
-
- TYPE REC_DEF_PRI(A : INTEGER := 5) IS
- RECORD
- I : INTEGER := 1;
- END RECORD;
-
- TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS
- RECORD
- I : INTEGER := 1;
- END RECORD;
-
- END PRI_PACK;
- USE PRI_PACK;
-
- A : REC_DEF;
- B : REC_DEF_SUB;
- C : ARRAY (0..15) OF REC_DEF;
- D : ARRAY (0..15) OF REC_DEF_SUB;
- E : REC_DEF_ARR;
- F : REC_DEF_SARR;
- G : REC_DEF_PRI;
- H : REC_DEF_LIM_PRI;
-
- Z : REC_DEF;
-
- PROCEDURE SUBPROG(REC : OUT REC_DEF) IS
-
- BEGIN
- IF REC'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT " &
- "PARAMETER INSIDE THE SUBPROGRAM");
- END IF;
- END SUBPROG;
-
-BEGIN
- TEST("C37404B", "CHECK THAT 'CONSTRAINED IS FALSE FOR VARIABLES" &
- " THAT HAVE DISCRIMINANTS WITH DEFAULT VALUES.");
-
- IF A'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR RECORD COMPONENT");
- END IF;
-
- IF B'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR SUBTYPE");
- END IF;
-
- IF C(1)'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE");
- END IF;
-
- IF D(1)'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE");
- END IF;
-
- IF E(1)'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE");
- END IF;
-
- IF F(1)'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE");
- END IF;
-
- IF G'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR PRIVATE TYPE");
- END IF;
-
- IF H'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR LIMITED PRIVATE TYPE");
- END IF;
-
- SUBPROG(Z);
- IF Z'CONSTRAINED THEN
- FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT PARAMETER " &
- "AFTER THE CALL");
- END IF;
-
- IF IDENT_INT(A.I) /= 1 OR
- IDENT_INT(B.I) /= 1 OR
- IDENT_INT(C(1).I) /= 1 OR
- IDENT_INT(D(1).I) /= 1 OR
- IDENT_INT(E(1).I) /= 1 OR
- IDENT_INT(F(1).I) /= 1 OR
- IDENT_INT(Z.I) /= 1 OR
- IDENT_INT(A.A) /= 5 OR
- IDENT_INT(B.A) /= 5 OR
- IDENT_INT(C(1).A) /= 5 OR
- IDENT_INT(D(1).A) /= 5 OR
- IDENT_INT(E(1).A) /= 5 OR
- IDENT_INT(F(1).A) /= 5 OR
- IDENT_INT(G.A) /= 5 OR
- IDENT_INT(H.A) /= 5 OR
- IDENT_INT(Z.A) /= 5 THEN
- FAILED("INCORRECT INITIALIZATION VALUES");
- END IF;
-
- RESULT;
-END C37404B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37405a.ada b/gcc/testsuite/ada/acats/tests/c3/c37405a.ada
deleted file mode 100644
index 1870337..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37405a.ada
+++ /dev/null
@@ -1,161 +0,0 @@
--- C37405A.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 ASSIGNING TO A CONSTRAINED OR UNCONSTRAINED
--- OBJECT OR FORMAL PARAMETER OF A TYPE DECLARED WITH DEFAULT
--- DISCRIMINANTS, THE ASSIGNMENT DOES NOT CHANGE THE 'CONSTRAINED
--- ATTRIBUTE VALUE ASSOCIATED WITH THE OBJECT OR PARAMETER.
-
--- ASL 7/21/81
--- TBN 1/20/86 RENAMED FROM C37209A.ADA AND REVISED THE ASSIGNMENTS
--- OF CONSTRAINED AND UNCONSTRAINED OBJECTS TO ARRAY AND
--- RECORD COMPONENTS.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C37405A IS
-
- TYPE REC(DISC : INTEGER := 25) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- SUBTYPE CONSTR IS REC(10);
- SUBTYPE UNCONSTR IS REC;
-
- TYPE REC_C IS
- RECORD
- COMP: CONSTR;
- END RECORD;
-
- TYPE REC_U IS
- RECORD
- COMP: UNCONSTR;
- END RECORD;
-
- C1,C2 : CONSTR;
- U1,U2 : UNCONSTR;
--- C2 AND U2 ARE NOT PASSED TO EITHER PROC1 OR PROC2.
-
- ARR_C : ARRAY (1..5) OF CONSTR;
- ARR_U : ARRAY (1..5) OF UNCONSTR;
-
- REC_COMP_C : REC_C;
- REC_COMP_U : REC_U;
-
- PROCEDURE PROC11(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
- BEGIN
- PARM := C2;
- IF IDENT_BOOL(B) /= PARM'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
- "ASSIGNMENT - 1");
- END IF;
- END PROC11;
-
- PROCEDURE PROC12(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
- BEGIN
- PARM := U2;
- IF B /= PARM'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
- "ASSIGNMENT - 2");
- END IF;
- END PROC12;
-
- PROCEDURE PROC1(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS
- BEGIN
- IF B /= PARM'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
- "PASSING PARAMETER");
- END IF;
-
- PROC11(PARM, B);
-
- PROC12(PARM, B);
-
- END PROC1;
-
- PROCEDURE PROC2(PARM : IN OUT CONSTR) IS
- BEGIN
- COMMENT ("CALLING PROC1 FROM PROC2"); -- IN CASE TEST FAILS.
- PROC1(PARM,TRUE);
- PARM := U2;
- IF NOT PARM'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " &
- "ASSIGNMENT - 3");
- END IF;
- END PROC2;
-BEGIN
- TEST("C37405A", "'CONSTRAINED ATTRIBUTE OF OBJECTS, FORMAL " &
- "PARAMETERS CANNOT BE CHANGED BY ASSIGNMENT");
-
- C2 := (DISC => IDENT_INT(10), COMP => 3);
- U2 := (DISC => IDENT_INT(10), COMP => 4);
-
- ARR_C := (1..5 => U2);
- ARR_U := (1..5 => C2);
-
- REC_COMP_C := (COMP => U2);
- REC_COMP_U := (COMP => C2);
-
- C1 := U2;
- U1 := C2;
-
- IF U1'CONSTRAINED OR NOT C1'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 4");
- END IF;
-
- IF ARR_U(3)'CONSTRAINED OR NOT ARR_C(4)'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 5");
- END IF;
-
- IF REC_COMP_U.COMP'CONSTRAINED
- OR NOT REC_COMP_C.COMP'CONSTRAINED THEN
- FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 6");
- END IF;
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(C1,TRUE);
- PROC2(C1);
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(U1,FALSE);
- PROC2(U1);
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(ARR_C(4), TRUE);
- PROC2(ARR_C(5));
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(ARR_U(2), FALSE);
- PROC2(ARR_U(3));
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(REC_COMP_C.COMP, TRUE);
- PROC2(REC_COMP_C.COMP);
-
- COMMENT("CALLING PROC1 DIRECTLY");
- PROC1(REC_COMP_U.COMP, FALSE);
- PROC2(REC_COMP_U.COMP);
-
- RESULT;
-END C37405A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c37411a.ada b/gcc/testsuite/ada/acats/tests/c3/c37411a.ada
deleted file mode 100644
index d11574b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c37411a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C37411A.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 OPERATIONS OF ASSIGNMENT, COMPARISON, MEMBERSHIP
--- TESTS, QUALIFICATION, TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS,
--- ARE DEFINED FOR NULL RECORDS.
-
--- HISTORY:
--- DHH 03/04/88 CREATED ORIGINAL TEST.
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE C37411A IS
- TYPE S IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE SS IS S;
-
- U,V,W : S;
- X : SS;
-
-BEGIN
-
- TEST("C37411A", "CHECK THAT THE OPERATIONS OF ASSIGNMENT, " &
- "COMPARISON, MEMBERSHIP TESTS, QUALIFICATION, " &
- "TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS, " &
- "ARE DEFINED FOR NULL RECORDS");
- U := W;
- IF U /= W THEN
- FAILED("EQUALITY/ASSIGNMENT DOES NOT PERFORM CORRECTLY");
- END IF;
-
- IF V NOT IN S THEN
- FAILED("MEMBERSHIP DOES NOT PERFORM CORRECTLY");
- END IF;
-
- IF X /= SS(V) THEN
- FAILED("TYPE CONVERSION DOES NOT PERFORM CORRECTLY");
- END IF;
-
- IF S'(U) /= S'(W) THEN
- FAILED("QUALIFIED EXPRESSION DOES NOT PERFORM CORRECTLY");
- END IF;
-
- IF X'SIZE /= V'SIZE THEN
- FAILED("'BASE'SIZE DOES NOT PERFORM CORRECTLY WHEN PREFIX " &
- "IS AN OBJECT");
- END IF;
-
- IF X'ADDRESS = V'ADDRESS THEN
- COMMENT("NULL RECORDS HAVE THE SAME ADDRESS");
- ELSE
- COMMENT("NULL RECORDS DO NOT HAVE THE SAME ADDRESS");
- END IF;
-
- RESULT;
-END C37411A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380001.a b/gcc/testsuite/ada/acats/tests/c3/c380001.a
deleted file mode 100644
index 0ebe4d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380001.a
+++ /dev/null
@@ -1,128 +0,0 @@
--- C380001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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 checks are made properly when a per-object expression contains
--- an attribute whose prefix denotes the current instance of the type.
--- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
--- RM95 3.8(18/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C380001 is
-
- type Negative is range Integer'First .. -1;
-
- type R1 is
- record
- C : Negative := Negative (Ident_Int (R1'Size));
- end record;
-
-
- type R2;
-
- type R3 (D1 : access R2; D2 : Natural) is limited null record;
-
- type R2 is limited
- record
- C : R3 (R2'Access, Ident_Int (-1));
- end record;
-
-begin
- Test ("C380001", "Check that checks are made properly when a " &
- "per-object expression contains an attribute whose " &
- "prefix denotes the current instance of the type");
- begin
- declare
- X : R1;
- begin
- Failed
- ("No exception raised when evaluating a per-object expression " &
- "containing an attribute - 1");
- end;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 1");
- end;
-
- declare
- type A is access R1;
- X : A;
- begin
- X := new R1;
- Failed ("No exception raised when evaluating a per-object expression " &
- "containing an attribute - 2");
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 2");
- end;
-
- begin
- declare
- X : R2;
- begin
- Failed
- ("No exception raised when elaborating a per-object constraint " &
- "containing an attribute - 3");
- end;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 3");
- end;
-
- declare
- type A is access R2;
- X : A;
- begin
- X := new R2;
- Failed
- ("No exception raised when evaluating a per-object constraint " &
- "containing an attribute - 4");
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 4");
- end;
-
- Result;
-end C380001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380002.a b/gcc/testsuite/ada/acats/tests/c3/c380002.a
deleted file mode 100644
index ae58676..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380002.a
+++ /dev/null
@@ -1,72 +0,0 @@
--- C380002.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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 expression in a per-object discriminant constraint which is
--- part of a named association is evaluated once for each association.
--- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
--- RM95 3.8(18.1/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C380002 is
-
- F_Val : Integer := Ident_Int (0);
-
- function F return Integer is
- begin
- F_Val := F_Val + Ident_Int (1);
- return F_Val;
- end F;
-
- type R1;
-
- type R2 (D0 : Integer; D1 : access R1; D2 : Integer; D3 : Integer) is
- limited null record;
-
- type R1 is limited
- record
- C : R2 (D1 => R1'Access, D0 | D2 | D3 => F);
- end record;
-
-begin
- Test ("C380002", "Check that an expression in a per-object discriminant " &
- "constraint which is part of a named association is " &
- "evaluated once for each association");
-
- if not Equal (F_Val, 3) then
- Failed ("Expression not evaluated the proper number of times");
- end if;
-
- Result;
-end C380002;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380003.a b/gcc/testsuite/ada/acats/tests/c3/c380003.a
deleted file mode 100644
index 451d177..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380003.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- C380003.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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 per-object expressions are evaluated as specified for
--- protected components. (Defect Report 8652/0002, as reflected in
--- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Report;
-use Report;
-procedure C380003 is
-
- subtype Sm is Integer range 1 .. 10;
-
- type Rec (D1, D2 : Sm) is
- record
- null;
- end record;
-
-begin
- Test ("C380003",
- "Check compatibility of discriminant expressions" &
- " when the constraint depends on discriminants, " &
- "and the discriminants have defaults - protected components");
-
- declare
- protected type Cons (D3 : Integer := Ident_Int (11)) is
- function C1_D1 return Integer;
- function C1_D2 return Integer;
- private
- C1 : Rec (D3, 1);
- end Cons;
- protected body Cons is
- function C1_D1 return Integer is
- begin
- return C1.D1;
- end C1_D1;
- function C1_D2 return Integer is
- begin
- return C1.D2;
- end C1_D2;
- end Cons;
-
- function Is_Ok
- (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
- return Boolean is
- begin
- return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
- end Is_Ok;
-
- begin
- begin
- declare
- X : Cons;
- begin
- Failed ("Discriminant check not performed - 1");
- if not Is_Ok (X, 1, 1, 1) then
- Comment ("Shouldn't get here");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception - 1");
- end;
-
- begin
- declare
- type Acc_Cons is access Cons;
- X : Acc_Cons;
- begin
- X := new Cons;
- Failed ("Discriminant check not performed - 2");
- begin
- if not Is_Ok (X.all, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 2");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 2");
- end;
-
- begin
- declare
- subtype Scons is Cons;
- begin
- declare
- X : Scons;
- begin
- Failed ("Discriminant check not performed - 3");
- if not Is_Ok (X, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 3");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 3");
- end;
-
- begin
- declare
- type Arr is array (1 .. 5) of Cons;
- begin
- declare
- X : Arr;
- begin
- Failed ("Discriminant check not performed - 4");
- for I in Arr'Range loop
- if not Is_Ok (X (I), 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end loop;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 4");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 4");
- end;
-
- begin
- declare
- type Nrec is
- record
- C1 : Cons;
- end record;
- begin
- declare
- X : Nrec;
- begin
- Failed ("Discriminant check not performed - 5");
- if not Is_Ok (X.C1, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 5");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 5");
- end;
-
- begin
- declare
- type Drec is new Cons;
- begin
- declare
- X : Drec;
- begin
- Failed ("Discriminant check not performed - 6");
- if not Is_Ok (Cons (X), 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 6");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 6");
- end;
-
- end;
-
- Result;
-
-exception
- when others =>
- Failed ("Constraint check done too early");
- Result;
-end C380003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380004.a b/gcc/testsuite/ada/acats/tests/c3/c380004.a
deleted file mode 100644
index f83728b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380004.a
+++ /dev/null
@@ -1,385 +0,0 @@
--- C380004.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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 per-object expressions are evaluated as specified for entry
--- families and protected components. (Defect Report 8652/0002,
--- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
--- 9.5.2(22/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Report;
-use Report;
-procedure C380004 is
-
- type Rec (D1, D2 : Positive) is
- record
- null;
- end record;
-
- F1_Poe : Integer;
-
- function Chk (Poe : Integer; Value : Integer; Message : String)
- return Boolean is
- begin
- if Poe /= Value then
- Failed (Message & ": Poe is " & Integer'Image (Poe));
- end if;
- return True;
- end Chk;
-
- function F1 return Integer is
- begin
- F1_Poe := F1_Poe - Ident_Int (1);
- return F1_Poe;
- end F1;
-
- generic
- type T is limited private;
- with function Is_Ok (X : T;
- Param1 : Integer;
- Param2 : Integer;
- Param3 : Integer) return Boolean;
- procedure Check;
-
- procedure Check is
- begin
-
- declare
- type Poe is new T;
- Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
- X : Poe; -- F1 evaluated
- Y : Poe; -- F1 evaluated
- Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
- begin
- if not Is_Ok (T (X), 16, 16, 17) or
- not Is_Ok (T (Y), 15, 15, 17) then
- Failed ("Discriminant values not correct - 0");
- end if;
- end;
-
- declare
- type Poe is new T;
- begin
- begin
- declare
- X : Poe;
- begin
- if not Is_Ok (T (X), 14, 14, 17) then
- Failed ("Discriminant values not correct - 1");
- end if;
- end;
- exception
- when others =>
- Failed ("Unexpected exception - 1");
- end;
-
- declare
- type Acc_Poe is access Poe;
- X : Acc_Poe;
- begin
- X := new Poe;
- begin
- if not Is_Ok (T (X.all), 13, 13, 17) then
- Failed ("Discriminant values not correct - 2");
- end if;
- end;
- exception
- when others =>
- Failed ("Unexpected exception raised - 2");
- end;
-
- declare
- subtype Spoe is Poe;
- X : Spoe;
- begin
- if not Is_Ok (T (X), 12, 12, 17) then
- Failed ("Discriminant values not correct - 3");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 3");
- end;
-
- declare
- type Arr is array (1 .. 2) of Poe;
- X : Arr;
- begin
- if Is_Ok (T (X (1)), 11, 11, 17) and then
- Is_Ok (T (X (2)), 10, 10, 17) then
- null;
- elsif Is_Ok (T (X (2)), 11, 11, 17) and then
- Is_Ok (T (X (1)), 10, 10, 17) then
- null;
- else
- Failed ("Discriminant values not correct - 4");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 4");
- end;
-
- declare
- type Nrec is
- record
- C1, C2 : Poe;
- end record;
- X : Nrec;
- begin
- if Is_Ok (T (X.C1), 8, 8, 17) and then
- Is_Ok (T (X.C2), 9, 9, 17) then
- null;
- elsif Is_Ok (T (X.C2), 8, 8, 17) and then
- Is_Ok (T (X.C1), 9, 9, 17) then
- null;
- else
- Failed ("Discriminant values not correct - 5");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 5");
- end;
-
- declare
- type Drec is new Poe;
- X : Drec;
- begin
- if not Is_Ok (T (X), 7, 7, 17) then
- Failed ("Discriminant values not correct - 6");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 6");
- end;
- end;
- end Check;
-
-
-begin
- Test ("C380004",
- "Check evaluation of discriminant expressions " &
- "when the constraint depends on a discriminant, " &
- "and the discriminants have defaults - discriminant-dependent" &
- "entry families and protected components");
-
-
- Comment ("Discriminant-dependent entry families for task types");
-
- F1_Poe := 18;
-
- declare
- task type Poe (D3 : Positive := F1) is
- entry E (D3 .. F1); -- F1 evaluated
- entry Is_Ok (D3 : Integer;
- E_First : Integer;
- E_Last : Integer;
- Ok : out Boolean);
- end Poe;
- task body Poe is
- begin
- loop
- select
- accept Is_Ok (D3 : Integer;
- E_First : Integer;
- E_Last : Integer;
- Ok : out Boolean) do
- declare
- Cnt : Natural;
- begin
- if Poe.D3 = D3 then
- -- Can't think of a better way to check the
- -- bounds of the entry family.
- begin
- Cnt := E (E_First)'Count;
- Cnt := E (E_Last)'Count;
- exception
- when Constraint_Error =>
- Ok := False;
- return;
- end;
- begin
- Cnt := E (E_First - 1)'Count;
- Ok := False;
- return;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Ok := False;
- return;
- end;
- begin
- Cnt := E (E_Last + 1)'Count;
- Ok := False;
- return;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Ok := False;
- return;
- end;
- Ok := True;
- else
- Ok := False;
- return;
- end if;
- end;
- end Is_Ok;
- or
- terminate;
- end select;
- end loop;
- end Poe;
-
- function Is_Ok
- (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- Ok : Boolean;
- begin
- C.Is_Ok (D3, E_First, E_Last, Ok);
- return Ok;
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
-
- Comment ("Discriminant-dependent entry families for protected types");
-
- F1_Poe := 18;
-
- declare
- protected type Poe (D3 : Integer := F1) is
- entry E (D3 .. F1); -- F1 evaluated
- function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean;
- end Poe;
- protected body Poe is
- entry E (for I in D3 .. F1) when True is
- begin
- null;
- end E;
- function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- Cnt : Natural;
- begin
- if Poe.D3 = D3 then
- -- Can't think of a better way to check the
- -- bounds of the entry family.
- begin
- Cnt := E (E_First)'Count;
- Cnt := E (E_Last)'Count;
- exception
- when Constraint_Error =>
- return False;
- end;
- begin
- Cnt := E (E_First - 1)'Count;
- return False;
- exception
- when Constraint_Error =>
- null;
- when others =>
- return False;
- end;
- begin
- Cnt := E (E_Last + 1)'Count;
- return False;
- exception
- when Constraint_Error =>
- null;
- when others =>
- return False;
- end;
- return True;
- else
- return False;
- end if;
- end Is_Ok;
- end Poe;
-
- function Is_Ok
- (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- begin
- return C.Is_Ok (D3, E_First, E_Last);
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
- Comment ("Protected components");
-
- F1_Poe := 18;
-
- declare
- protected type Poe (D3 : Integer := F1) is
- function C1_D1 return Integer;
- function C1_D2 return Integer;
- private
- C1 : Rec (D3, F1); -- F1 evaluated
- end Poe;
- protected body Poe is
- function C1_D1 return Integer is
- begin
- return C1.D1;
- end C1_D1;
- function C1_D2 return Integer is
- begin
- return C1.D2;
- end C1_D2;
- end Poe;
-
- function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
- return Boolean is
- begin
- return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
- Result;
-
-exception
- when others =>
- Failed ("Unexpected exception");
- Result;
-
-end C380004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38002a.ada b/gcc/testsuite/ada/acats/tests/c3/c38002a.ada
deleted file mode 100644
index 33d6eba..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38002a.ada
+++ /dev/null
@@ -1,420 +0,0 @@
--- C38002A.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 UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT
--- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION
--- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.
---
--- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN
--- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT
--- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT
--- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,
--- DERIVED TYPE DEFINITION, PRIVATE TYPE.
---
--- CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE.
-
--- HISTORY:
--- AH 09/02/86 CREATED ORIGINAL TEST.
--- DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE
--- AND CORRECTED INDENTATION.
--- BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN
--- TYPE AND AN ARRAY AS A FORMAL PARAMETER.
--- LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED
--- AWAY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38002A IS
-
-BEGIN
- TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &
- "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &
- "ARRAY OR RECORD TYPES");
-
- DECLARE
- C3 : CONSTANT INTEGER := IDENT_INT(3);
-
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- TYPE ARR_NAME IS ACCESS ARR;
- SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3);
-
- TYPE REC(DISC : INTEGER) IS
- RECORD
- COMP : ARR_NAME(1..DISC);
- END RECORD;
- TYPE REC_NAME IS ACCESS REC;
-
- OBJ : REC_NAME(C3);
-
- TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3);
-
- TYPE REC2 IS
- RECORD
- COMP2 : REC_NAME(C3);
- END RECORD;
-
- TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3);
-
- TYPE DERIV IS NEW REC_NAME(C3);
- SUBTYPE REC_NAME_3 IS REC_NAME(C3);
-
- FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE F AWAY");
- END IF;
- RETURN PARM;
- END;
-
- PROCEDURE FPROC (PARM : REC_NAME_3) IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE FPROC AWAY");
- END IF;
- END FPROC;
-
- FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE G AWAY");
- END IF;
- RETURN PA;
- END G;
-
- PROCEDURE GPROC (PA : ARR_NAME_3) IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE GPROC AWAY");
- END IF;
- END GPROC;
-
- BEGIN
- DECLARE
- R : REC_NAME;
- BEGIN
- R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
- R := F(R);
- R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
- R := F(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY FUNCTION FOR RECORD");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R = NULL OR ELSE R.DISC /= 4 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
- "ACCESS VALUE - RECORD,FUNCTION");
- END IF;
- END;
-
- DECLARE
- R : REC_NAME;
- BEGIN
- R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
- FPROC(R);
- R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
- FPROC(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY PROCEDURE FOR RECORD");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R = NULL OR ELSE R.DISC /= 4 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
- "ACCESS VALUE - RECORD,PROCEDURE");
- END IF;
- END;
-
- DECLARE
- A : ARR_NAME;
- BEGIN
- A := NEW ARR'(1..3 => 5);
- A := G(A);
- A := NEW ARR'(1..4 => 6);
- A := G(A);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY FUNCTION FOR ARRAY");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF A = NULL OR ELSE A(4) /= 6 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
- "ACCESS VALUE - ARRAY,FUNCTION");
- END IF;
- END;
-
- DECLARE
- A : ARR_NAME;
- BEGIN
- A := NEW ARR'(1..3 => 5);
- GPROC(A);
- A := NEW ARR'(1..4 => 6);
- GPROC(A);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY PROCEDURE FOR ARRAY");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF A = NULL OR ELSE A(4) /= 6 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
- "ACCESS VALUE - ARRAY,PROCEDURE");
- END IF;
- END;
- END;
-
- DECLARE
- C3 : CONSTANT INTEGER := IDENT_INT(3);
-
- TYPE REC (DISC : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- TYPE P_ARR_NAME IS ACCESS P_ARR;
-
- TYPE P_REC_NAME IS ACCESS REC;
-
- GENERIC
- TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- PACKAGE P IS
- TYPE ACC_REC IS ACCESS REC;
- TYPE ACC_ARR IS ACCESS UNCON_ARR;
- TYPE ACC_P_ARR IS ACCESS P_ARR;
- SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3);
- OBJ : ACC_REC(C3);
-
- TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);
-
- TYPE REC1 IS
- RECORD
- COMP1 : ACC_REC(C3);
- END RECORD;
-
- TYPE REC2 IS
- RECORD
- COMP2 : ACC_ARR(1..C3);
- END RECORD;
-
- SUBTYPE ACC_REC_3 IS ACC_REC(C3);
-
- FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;
-
- PROCEDURE FPROC (PARM : ACC_REC_3);
-
- FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3;
-
- PROCEDURE GPROC (PA : ACC_P_ARR_3);
-
- TYPE ACC1 IS PRIVATE;
- TYPE ACC2 IS PRIVATE;
- TYPE DER1 IS PRIVATE;
- TYPE DER2 IS PRIVATE;
-
- PRIVATE
-
- TYPE ACC1 IS ACCESS ACC_REC(C3);
- TYPE ACC2 IS ACCESS ACC_ARR(1..C3);
- TYPE DER1 IS NEW ACC_REC(C3);
- TYPE DER2 IS NEW ACC_ARR(1..C3);
- END P;
-
- PACKAGE BODY P IS
- FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE F AWAY");
- END IF;
- RETURN PARM;
- END;
-
- PROCEDURE FPROC (PARM : ACC_REC_3) IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE FPROC AWAY");
- END IF;
- END FPROC;
-
- FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE G AWAY");
- END IF;
- RETURN PA;
- END;
-
- PROCEDURE GPROC (PA : ACC_P_ARR_3) IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE GPROC AWAY");
- END IF;
- END GPROC;
- END P;
-
- PACKAGE NP IS NEW P (UNCON_ARR => P_ARR);
-
- USE NP;
-
- BEGIN
- DECLARE
- R : ACC_REC;
- BEGIN
- R := NEW REC(DISC => 3);
- R := F(R);
- R := NEW REC(DISC => 4);
- R := F(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R = NULL OR ELSE R.DISC /= 4 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF ACCESS VALUE - RECORD," &
- "FUNCTION -GENERIC");
- END IF;
- END;
-
- DECLARE
- R : ACC_REC;
- BEGIN
- R := NEW REC(DISC => 3);
- FPROC(R);
- R := NEW REC(DISC => 4);
- FPROC(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R = NULL OR ELSE R.DISC /= 4 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF ACCESS VALUE - RECORD," &
- "PROCEDURE -GENERIC");
- END IF;
- END;
-
- DECLARE
- A : ACC_P_ARR;
- BEGIN
- A := NEW P_ARR'(1..3 => 5);
- A := G(A);
- A := NEW P_ARR'(1..4 => 6);
- A := G(A);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF A = NULL OR ELSE A(4) /= 6 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF ACCESS VALUE - ARRAY," &
- "FUNCTION -GENERIC");
- END IF;
- END;
-
- DECLARE
- A : ACC_P_ARR;
- BEGIN
- A := NEW P_ARR'(1..3 => 5);
- GPROC(A);
- A := NEW P_ARR'(1..4 => 6);
- GPROC(A);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF A = NULL OR ELSE A(4) /= 6 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF ACCESS VALUE - ARRAY," &
- "PROCEDURE -GENERIC");
- END IF;
- END;
- END;
-
- DECLARE
- TYPE CON_INT IS RANGE 1..10;
-
- GENERIC
- TYPE UNCON_INT IS RANGE <>;
- PACKAGE P2 IS
- SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5;
- FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT;
-
- PROCEDURE PROC_INT (PARM : NEW_INT);
- END P2;
-
- PACKAGE BODY P2 IS
- FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE F AWAY");
- END IF;
- RETURN PARM;
- END FUNC_INT;
-
- PROCEDURE PROC_INT (PARM : NEW_INT) IS
- BEGIN
- IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
- COMMENT("DON'T OPTIMIZE FPROC AWAY");
- END IF;
- END PROC_INT;
- END P2;
-
- PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT);
-
- USE NP2;
-
- BEGIN
- DECLARE
- R : CON_INT;
- BEGIN
- R := 2;
- R := FUNC_INT(R);
- R := 8;
- R := FUNC_INT(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " &
- "ACCEPTED BY FUNCTION -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R /= 8 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF VALUE -FUNCTION, GENERIC");
- END IF;
- END;
-
- DECLARE
- R : CON_INT;
- BEGIN
- R := 2;
- PROC_INT(R);
- R := 9;
- PROC_INT(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
- "ACCEPTED BY PROCEDURE -GENERIC");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R /= 9 THEN
- FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
- "OF ACCESS VALUE - PROCEDURE, " &
- "GENERIC");
- END IF;
- END;
- END;
-
- RESULT;
-END C38002A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38002b.ada b/gcc/testsuite/ada/acats/tests/c3/c38002b.ada
deleted file mode 100644
index 9a51c9b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38002b.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- C38002B.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 UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT
--- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION
--- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.
---
--- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN
--- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT
--- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT
--- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,
--- ALLOCATOR, DERIVED TYPE DEFINITION, PRIVATE TYPE, OR AS THE
--- RETURN TYPE IN A FUNCTION DECLARATION.
---
--- CHECK FOR GENERIC FORMAL ACCESS TYPES.
-
--- HISTORY:
--- AH 09/02/86 CREATED ORIGINAL TEST.
--- DHH 08/22/88 REVISED HEADER, ADDED 'PRIVATE TYPE' TO COMMENTS
--- AND CORRECTED INDENTATION.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38002B IS
-
- C3 : CONSTANT INTEGER := IDENT_INT(3);
-
- TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- TYPE REC (DISC : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE P_ARR_NAME IS ACCESS UNCON_ARR;
- TYPE P_REC_NAME IS ACCESS REC;
-
- GENERIC
- TYPE ACC_REC IS ACCESS REC;
- TYPE ACC_ARR IS ACCESS UNCON_ARR;
- PACKAGE P IS
- OBJ : ACC_REC(C3);
-
- TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);
-
- TYPE REC1 IS
- RECORD
- COMP1 : ACC_REC(C3);
- END RECORD;
-
- TYPE REC2 IS
- RECORD
- COMP2 : ACC_ARR(1..C3);
- END RECORD;
-
- SUBTYPE ACC_REC_3 IS ACC_REC(C3);
- R : ACC_REC;
-
- FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;
-
- TYPE ACC1 IS PRIVATE;
- TYPE ACC2 IS PRIVATE;
- TYPE DER1 IS PRIVATE;
- TYPE DER2 IS PRIVATE;
-
- PRIVATE
-
- TYPE ACC1 IS ACCESS ACC_REC(C3);
- TYPE ACC2 IS ACCESS ACC_ARR(1..C3);
- TYPE DER1 IS NEW ACC_REC(C3);
- TYPE DER2 IS NEW ACC_ARR(1..C3);
- END P;
-
- PACKAGE BODY P IS
- FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS
- BEGIN
- RETURN PARM;
- END;
- END P;
-
- PACKAGE NP IS NEW P (ACC_REC => P_REC_NAME, ACC_ARR => P_ARR_NAME);
-
- USE NP;
-BEGIN
- TEST ("C38002B", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &
- "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &
- "ARRAY OR RECORD TYPES");
-
- R := NEW REC(DISC => 3);
- R := F(R);
- R := NEW REC(DISC => 4);
- R := F(R);
- FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE ACCEPTED " &
- "BY GENERIC FUNCTION");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R = NULL OR ELSE R.DISC /= 4 THEN
- FAILED (" ERROR IN EVALUATION/ASSIGNMENT OF " &
- "GENERIC ACCESS VALUE");
- END IF;
-
- RESULT;
-END C38002B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38005a.ada b/gcc/testsuite/ada/acats/tests/c3/c38005a.ada
deleted file mode 100644
index 75a83a8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38005a.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C38005A.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 (UNINITIALIZED) ACCESS OBJECTS ARE INITIALIZED
--- TO NULL BY DEFAULT. VARIABLES, ARRAYS, RECORDS, ARRAYS OF RECORDS,
--- ARRAYS OF ARRAYS, RECORDS WITH ARRAYS AND RECORD COMPONENTS
--- ARE ALL CHECKED.
--- FUNCTION RESULTS (I.E. RETURNED FROM IMPLICIT FUNCTION RETURN)
--- ARE NOT CHECKED.
-
--- DAT 3/6/81
--- VKG 1/5/83
--- SPS 2/17/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38005A IS
-
- TYPE REC;
- TYPE ACC_REC IS ACCESS REC;
- TYPE VECTOR IS ARRAY ( NATURAL RANGE <> ) OF ACC_REC;
- TYPE REC IS RECORD
- VECT : VECTOR (3 .. 5);
- END RECORD;
-
- TYPE ACC_VECT IS ACCESS VECTOR;
- TYPE ARR_REC IS ARRAY (1 .. 2) OF REC;
- TYPE REC2;
- TYPE ACC_REC2 IS ACCESS REC2;
- TYPE REC2 IS RECORD
- C1 : ACC_REC;
- C2 : ACC_VECT;
- C3 : ARR_REC;
- C4 : REC;
- C5 : ACC_REC2;
- END RECORD;
-
- N_REC : REC;
- N_ACC_REC : ACC_REC;
- N_VEC : VECTOR (3 .. IDENT_INT (5));
- N_ACC_VECT : ACC_VECT;
- N_ARR_REC : ARR_REC;
- N_REC2 : REC2;
- N_ACC_REC2 : ACC_REC2;
- N_ARR : ARRAY (1..2) OF VECTOR (1..2);
- Q : REC2 :=
- (C1 => NEW REC,
- C2 => NEW VECTOR'(NEW REC, NEW REC'(N_REC)),
- C3 => (1 | 2 => (VECT=>(3|4=> NEW REC,
- 5=>N_ACC_REC)
- )),
- C4 => N_REC2.C4,
- C5 => NEW REC2'(N_REC2));
-
-BEGIN
- TEST ("C38005A", "DEFAULT VALUE FOR ACCESS OBJECTS IS NULL");
-
- IF N_REC /= REC'(VECT => (3..5 => NULL))
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 1");
- END IF;
-
- IF N_ACC_REC /= NULL
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 2");
- END IF;
-
- IF N_VEC /= N_REC.VECT
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 3");
- END IF;
-
- IF N_ARR /= ((NULL, NULL), (NULL, NULL))
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 4");
- END IF;
-
- IF N_ACC_VECT /= NULL
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 5");
- END IF;
-
- IF N_ARR_REC /= (N_REC, N_REC)
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 6");
- END IF;
-
- IF N_REC2 /= (NULL, NULL, N_ARR_REC, N_REC, NULL)
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 7");
- END IF;
-
- IF N_ACC_REC2 /= NULL
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 8");
- END IF;
-
- IF Q /= (Q.C1, Q.C2, (Q.C3(1), Q.C3(2)), N_REC, Q.C5)
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 9");
- END IF;
-
- IF Q.C1.ALL /= N_REC
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 10");
- END IF;
-
- IF Q.C2.ALL(0).ALL /= N_REC
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 11");
- END IF;
-
- IF Q.C2(1).VECT /= N_VEC
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 12");
- END IF;
-
- IF Q.C3(2).VECT /= (3 => Q.C3(2).VECT(3),
- 4 => Q.C3(2).VECT(4),
- 5=>NULL)
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 13");
- END IF;
-
- IF Q.C3(2).VECT(3).ALL /= N_REC
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 14");
- END IF;
-
- IF Q.C5.ALL /= N_REC2
- THEN
- FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 15");
- END IF;
-
- DECLARE
- PROCEDURE T (R : OUT REC2) IS
- BEGIN
- NULL;
- END T;
- BEGIN
- N_REC2 := Q;
- T(Q);
- IF Q /= N_REC2 THEN
- FAILED ("INCORRECT OUT PARM INIT 2");
- END IF;
- END;
-
- RESULT;
-END C38005A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38005b.ada b/gcc/testsuite/ada/acats/tests/c3/c38005b.ada
deleted file mode 100644
index 1c27704..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38005b.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C38005B.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 ANY OBJECT WITH A FORMAL PRIVATE TYPE, WHOSE ACTUAL
--- TYPE IN AN INSTANTIATION IS AN ACCESS TYPE, IS INITIALIZED BY
--- DEFAULT TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH ARE ARRAY
--- AND RECORD COMPONENTS.
-
--- HISTORY:
--- DHH 07/12/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38005B IS
-
-BEGIN
- TEST("C38005B", "CHECK THAT ANY OBJECT WITH A FORMAL PRIVATE " &
- "TYPE, WHOSE ACTUAL TYPE IN AN INSTANTIATION " &
- "IS AN ACCESS TYPE, IS INITIALIZED BY DEFAULT " &
- "TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH " &
- "ARE ARRAY AND RECORD COMPONENTS");
- DECLARE
- TYPE ARRY IS ARRAY(1 .. 10) OF BOOLEAN;
- TYPE REC1 IS
- RECORD
- A : INTEGER;
- B : ARRY;
- END RECORD;
-
- TYPE POINTER IS ACCESS REC1;
-
- GENERIC
- TYPE NEW_PTR IS PRIVATE;
- PACKAGE GEN_PACK IS
- TYPE PTR_ARY IS ARRAY(1 .. 5) OF NEW_PTR;
- TYPE RECORD1 IS
- RECORD
- A : NEW_PTR;
- B : PTR_ARY;
- END RECORD;
-
- OBJ : NEW_PTR;
- ARY : PTR_ARY;
- REC : RECORD1;
- END GEN_PACK;
-
- PACKAGE TEST_P IS NEW GEN_PACK(POINTER);
- USE TEST_P;
-
- BEGIN
- IF OBJ /= NULL THEN
- FAILED("OBJECT NOT INITIALIZED TO NULL");
- END IF;
-
- FOR I IN 1 .. 5 LOOP
- IF ARY(I) /= NULL THEN
- FAILED("ARRAY COMPONENT " &
- INTEGER'IMAGE(I) &
- " NOT INITIALIZED TO NULL");
- END IF;
- END LOOP;
-
- IF REC.A /= NULL THEN
- FAILED("RECORD OBJECT NOT INITIALIZED TO NULL");
- END IF;
-
- FOR I IN 1 .. 5 LOOP
- IF REC.B(I) /= NULL THEN
- FAILED("RECORD SUBCOMPONENT " &
- INTEGER'IMAGE(I) &
- " NOT INITIALIZED TO NULL");
- END IF;
- END LOOP;
- END;
-
- RESULT;
-END C38005B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38005c.ada b/gcc/testsuite/ada/acats/tests/c3/c38005c.ada
deleted file mode 100644
index 5512ecb..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38005c.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C38005C.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 ALL OBJECTS OF FORMAL ACCESS TYPE, INCLUDING ARRAY AND
--- RECORD COMPONENTS, ARE INITIALIZED BY DEFAULT WITH THE VALUE
--- NULL.
-
--- HISTORY:
--- DHH 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38005C IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
-
- TYPE ACC_I IS ACCESS INT;
-
- SUBTYPE NEW_NODE IS CHARACTER;
-
- TYPE ACC_CHAR IS ACCESS NEW_NODE;
-
- X : ACC_I := NEW INT'(IDENT_INT(5));
- Y : NEW_NODE := 'A';
- Z : ACC_CHAR := NEW NEW_NODE'(Y);
-
- GENERIC
- TYPE ACC_INT IS ACCESS INT;
- TYPE NODE IS PRIVATE;
- TYPE LINK IS ACCESS NODE;
- PROCEDURE P(U : ACC_INT; V : NODE; W : LINK);
-
- GENERIC
- TYPE ACC_INT IS ACCESS INT;
- TYPE NODE IS PRIVATE;
- TYPE LINK IS ACCESS NODE;
- PACKAGE PACK IS
-
- SUBTYPE NEW_ACC IS ACC_INT;
-
- SUBTYPE NEW_L IS LINK;
-
- TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT;
-
- TYPE REC IS
- RECORD
- I : ACC_INT;
- L : LINK;
- END RECORD;
-
- END PACK;
-
- PACKAGE NEW_PACK IS NEW PACK(ACC_I, NEW_NODE, ACC_CHAR);
- USE NEW_PACK;
-
- A : NEW_PACK.NEW_ACC;
- B : NEW_PACK.NEW_L;
- C : NEW_PACK.ARR;
- D : NEW_PACK.REC;
-
- PROCEDURE P(U : ACC_INT; V : NODE; W : LINK) IS
-
- TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT;
-
- TYPE REC IS
- RECORD
- I : ACC_INT;
- L : LINK;
- END RECORD;
-
- A : ACC_INT;
- B : LINK;
- C : ARR;
- D : REC;
-
- BEGIN
- IF A /= NULL THEN
- FAILED("OBJECT A NOT INITIALIZED - PROC");
- END IF;
-
- IF B /= NULL THEN
- FAILED("OBJECT B NOT INITIALIZED - PROC");
- END IF;
-
- FOR I IN 1 .. 4 LOOP
- IF C(I) /= NULL THEN
- FAILED("ARRAY " & INTEGER'IMAGE(I) &
- "NOT INITIALIZED - PROC");
- END IF;
- END LOOP;
-
- IF D.I /= NULL THEN
- FAILED("RECORD.I NOT INITIALIZED - PROC");
- END IF;
-
- IF D.L /= NULL THEN
- FAILED("RECORD.L NOT INITIALIZED - PROC");
- END IF;
-
- END P;
-
- PROCEDURE PROC IS NEW P(ACC_I, NEW_NODE, ACC_CHAR);
-
-BEGIN
- TEST("C38005C", "CHECK THAT ALL OBJECTS OF FORMAL ACCESS TYPE, " &
- "INCLUDING ARRAY AND RECORD COMPONENTS, ARE " &
- "INITIALIZED BY DEFAULT WITH THE VALUE NULL");
-
- PROC(X, Y, Z);
-
- IF A /= NULL THEN
- FAILED("OBJECT A NOT INITIALIZED - PACK");
- END IF;
-
- IF B /= NULL THEN
- FAILED("OBJECT B NOT INITIALIZED - PACK");
- END IF;
-
- FOR I IN 1 .. 4 LOOP
- IF C(I) /= NULL THEN
- FAILED("ARRAY " & INTEGER'IMAGE(I) &
- "NOT INITIALIZED - PACK");
- END IF;
- END LOOP;
-
- IF D.I /= NULL THEN
- FAILED("RECORD.I NOT INITIALIZED - PACK");
- END IF;
-
- IF D.L /= NULL THEN
- FAILED("RECORD.L NOT INITIALIZED - PACK");
- END IF;
-
- RESULT;
-END C38005C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38006a.ada b/gcc/testsuite/ada/acats/tests/c3/c38006a.ada
deleted file mode 100644
index a4f0c90..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38006a.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- C38006A.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 ACCESSED BY CONSTANTS CAN BE MODIFIED.
-
--- DAT 3/6/81
--- SPS 10/25/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38006A IS
-
- TYPE AI IS ACCESS INTEGER;
-
- C : CONSTANT AI := NEW INTEGER'(1);
-
-BEGIN
- TEST ("C38006A", "OBJECTS ACCESSED BY CONSTANTS MAY BE ASSIGNED");
-
- FOR I IN 1 .. 10 LOOP
- IF C.ALL /= I AND I > 1 THEN
- FAILED ("OBJECT ACCESSED THRU CONSTANT NOT CHANGED");
- EXIT;
- END IF;
- C.ALL := C.ALL + 1;
- END LOOP;
-
- RESULT;
-END C38006A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38102a.ada b/gcc/testsuite/ada/acats/tests/c3/c38102a.ada
deleted file mode 100644
index 32649ab..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38102a.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C38102A.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 INCOMPLETE TYPE DECLARATION CAN BE GIVEN FOR ANY TYPE.
--- FULL DECLARATIONS FOR INTEGER, ENUMERATION, CONSTRAINED AND
--- UNCONSTRAINED ARRAYS, RECORDS WITHOUT DISCRIMINANTS,
--- AN ACCESS TYPE, OR TYPES DERIVED FROM ANY OF THE ABOVE.
-
--- (FLOAT, FIXED, TASKS AND RECORDS WITH DISCRIMINANTS ARE CHECKED
--- IN OTHER TESTS).
-
--- DAT 3/24/81
--- SPS 10/25/82
--- SPS 2/17/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38102A IS
-BEGIN
- TEST ("C38102A", "ANY TYPE MAY BE INCOMPLETE");
-
- DECLARE
-
- TYPE X1;
- TYPE X2;
- TYPE X3;
- TYPE X4;
- TYPE X5;
- TYPE X6;
- TYPE X7;
- TYPE X8;
-
- TYPE D1;
- TYPE D2;
- TYPE D3;
- TYPE D4;
- TYPE D5;
- TYPE D6;
-
- TYPE X1 IS RANGE 1 .. 10;
- TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN);
- TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10);
- TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3;
- TYPE AR1 IS ARRAY (X2) OF X3;
- TYPE X5 IS RECORD
- C1 : X4 (1..3);
- C2 : AR1;
- END RECORD;
- TYPE X6 IS ACCESS X8;
- TYPE X7 IS ACCESS X6;
- TYPE X8 IS ACCESS X6;
-
- TYPE D1 IS NEW X1;
- TYPE D2 IS NEW X2;
- TYPE D3 IS NEW X3;
- TYPE D4 IS NEW X4;
- TYPE D5 IS NEW X5;
- SUBTYPE D7 IS X7;
- SUBTYPE D8 IS X8;
- TYPE D6 IS ACCESS D8;
-
- PACKAGE P IS
-
- TYPE X1;
- TYPE X2;
- TYPE X3;
- TYPE X4;
- TYPE X5;
- TYPE X6;
- TYPE X7 IS PRIVATE;
- TYPE X8 IS LIMITED PRIVATE;
-
- TYPE D1;
- TYPE D2;
- TYPE D3;
- TYPE D4;
- TYPE D5;
- TYPE D6;
-
- TYPE X1 IS RANGE 1 .. 10;
- TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN);
- TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10);
- TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3;
- TYPE AR1 IS ARRAY (X2) OF X3;
- TYPE X5 IS RECORD
- C1 : X4 (1..3);
- C2 : AR1;
- END RECORD;
- TYPE X6 IS ACCESS X8;
-
- TYPE D1 IS RANGE 1 .. 10;
- TYPE D2 IS NEW X2;
- TYPE D3 IS NEW X3;
- TYPE D4 IS NEW X4;
- TYPE D5 IS NEW X5;
- TYPE D6 IS NEW X6;
- SUBTYPE D7 IS X7;
- SUBTYPE D8 IS X8;
- TYPE D9 IS ACCESS D8;
-
- VX7 : CONSTANT X7;
-
- PRIVATE
-
- TYPE X7 IS RECORD
- C1 : X1;
- C3 : X3;
- C5 : X5;
- C6 : X6;
- C8 : D9;
- END RECORD;
-
- V3 : X3 := (X3'RANGE => "ABCDEFGHIJ");
- TYPE A7 IS ACCESS X7;
- TYPE X8 IS ARRAY (V3'RANGE) OF A7;
-
- VX7 : CONSTANT X7 := (3, V3, ((1..3=>V3),
- (TRUE..GREEN=>V3)), NULL,
- NEW D8);
- END P;
- USE P;
-
- VD7: P.D7;
-
- PACKAGE BODY P IS
- BEGIN
- VD7 := D7(VX7);
- END P;
-
- BEGIN
- IF VX7 /= P.X7(VD7) THEN
- FAILED ("WRONG VALUE SOMEWHERE");
- END IF;
- END;
-
- RESULT;
-END C38102A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38102b.ada b/gcc/testsuite/ada/acats/tests/c3/c38102b.ada
deleted file mode 100644
index c9e4bc2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38102b.ada
+++ /dev/null
@@ -1,56 +0,0 @@
--- C38102B.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 INCOMPLETE TYPES CAN BE FLOAT.
-
--- DAT 3/24/81
--- SPS 10/25/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38102B IS
-
-BEGIN
- TEST ("C38102B", "INCOMPLETE TYPE CAN BE FLOAT");
-
- DECLARE
-
- TYPE F;
- TYPE G;
- TYPE AF IS ACCESS F;
- TYPE F IS DIGITS 2;
- TYPE G IS NEW F RANGE 1.0 .. 1.5;
- TYPE AG IS ACCESS G RANGE 1.0 .. 1.3;
-
- XF : AF := NEW F' (2.0);
- XG : AG := NEW G' (G (XF.ALL/2.0));
-
- BEGIN
- IF XG.ALL NOT IN G THEN
- FAILED ("ACCESS TO FLOAT");
- END IF;
- END;
-
- RESULT;
-END C38102B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38102c.ada b/gcc/testsuite/ada/acats/tests/c3/c38102c.ada
deleted file mode 100644
index a4128ae..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38102c.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C38102C.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 INCOMPLETE TYPES CAN BE FIXED.
-
--- HISTORY:
--- DAT 03/24/81 CREATED ORIGINAL TEST.
--- SPS 10/25/82
--- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED VARIOUS
--- VALUES TO CORRECT CONSTRAINT PROBLEMS. CHANGED
--- THE VALUE OF F'DELTA, USING A POWER OF TWO.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38102C IS
-BEGIN
- TEST ("C38102C", "INCOMPLETE TYPE CAN BE FIXED");
-
- DECLARE
-
- TYPE F;
- TYPE G;
- TYPE AF IS ACCESS F;
- TYPE F IS DELTA 0.25 RANGE -2.0 .. 2.0;
- TYPE G IS NEW F RANGE -1.0 .. 1.5;
- TYPE AG IS ACCESS G RANGE -0.75 .. 1.25;
-
- XF : AF := NEW F '(1.0);
- XG : AG := NEW G '(G (XF.ALL/2));
-
- BEGIN
- IF XG.ALL NOT IN G THEN
- FAILED ("ACCESS TO FIXED");
- END IF;
- END;
-
- RESULT;
-END C38102C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38102d.ada b/gcc/testsuite/ada/acats/tests/c3/c38102d.ada
deleted file mode 100644
index 6036127..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38102d.ada
+++ /dev/null
@@ -1,54 +0,0 @@
--- C38102D.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 INCOMPLETE TYPE CAN BE REDECLARED AS A TASK TYPE.
-
--- AH 8/14/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38102D IS
- GLOBAL : INTEGER := 0;
-BEGIN
- TEST("C38102D", "INCOMPLETE TYPES CAN BE TASKS");
- DECLARE
- TYPE T1;
- TASK TYPE T1 IS
- ENTRY E(LOCAL : IN OUT INTEGER);
- END T1;
- T1_OBJ : T1;
- TASK BODY T1 IS
- BEGIN
- ACCEPT E(LOCAL : IN OUT INTEGER) DO
- LOCAL := IDENT_INT(2);
- END E;
- END T1;
- BEGIN
- T1_OBJ.E(GLOBAL);
- END;
-
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED ("TASK NOT EXECUTED");
- END IF;
- RESULT;
-END C38102D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38102e.ada b/gcc/testsuite/ada/acats/tests/c3/c38102e.ada
deleted file mode 100644
index 6ffec05..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38102e.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C38102E.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 INCOMPLETE TYPE CAN BE REDECLARED AS A DERIVED GENERIC
--- FORMAL TYPE.
-
--- AH 8/15/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--- DNT 11/28/95 CHANGED TO FLAG1 := F4.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38102E IS
- TYPE RAINBOW IS (RED, ORANGE, YELLOW, GREEN, BLUE, INDIGO, VIOLET);
- TYPE T_FLOAT IS DIGITS 5 RANGE -4.0 .. 4.0;
- TYPE T_FIXED IS DELTA 0.01 RANGE 0.0 .. 1.5;
- SUBTYPE P1 IS INTEGER;
- TYPE P2 IS RANGE 0 .. 10;
- TYPE P3 IS ARRAY (P2) OF INTEGER;
- TYPE P4 IS ARRAY (P2, P2) OF INTEGER;
-
- F1, F2 : BOOLEAN;
-
- GENERIC
- TYPE G1 IS (<>);
- TYPE G2 IS RANGE <>;
- FUNCTION G_DISCRETE RETURN BOOLEAN;
-
- FUNCTION G_DISCRETE RETURN BOOLEAN IS
- TYPE INC1;
- TYPE INC2;
- TYPE F1 IS NEW G1;
- TYPE INC1 IS NEW G1;
- TYPE INC2 IS NEW G2;
-
- OBJ1_0 : INC1;
- OBJ1_1 : INC1;
- OBJ2_0 : INC2;
- OBJ2_1 : INC2;
- OBJ3 : F1;
-
- RESULT_VALUE1 : BOOLEAN := FALSE;
- RESULT_VALUE2 : BOOLEAN := FALSE;
- BEGIN
- OBJ3 := F1'LAST;
- OBJ3 := F1'PRED(OBJ3);
- IF INC1(OBJ3) = INC1'PRED(INC1'LAST) THEN
- RESULT_VALUE1 := TRUE;
- END IF;
- OBJ2_0 := INC2'FIRST;
- OBJ2_1 := INC2'LAST;
- IF (OBJ2_0 + OBJ2_1) = (INC2'SUCC(OBJ2_0) +
- INC2'PRED(OBJ2_1)) THEN
- RESULT_VALUE2 := TRUE;
- END IF;
-
- RETURN (RESULT_VALUE1 AND RESULT_VALUE2);
- END G_DISCRETE;
-
- GENERIC
- TYPE G3 IS DIGITS <>;
- TYPE G4 IS DELTA <>;
- PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN);
-
- PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN) IS
- F1, F2, F3, F4, F5, F6, F7, F8 : BOOLEAN;
- TYPE INC3;
- TYPE INC4;
- TYPE P1 IS NEW G3;
- TYPE P2 IS NEW G4;
- TYPE INC3 IS NEW G3;
- TYPE INC4 IS NEW G4;
- BEGIN
- F4 := P1'LAST = P1(INC3'LAST) AND P1'FIRST = P1(INC3'FIRST);
-
- F5 := P2'FORE = INC4'FORE;
- F6 := P2'AFT = INC4'AFT;
- F7 := ABS(P2'LAST - P2'FIRST) = P2(ABS(INC4'LAST -
- INC4'FIRST));
- F8 := INC4(P2'LAST / P2'LAST) = INC4(INC4'LAST / INC4'LAST);
-
- FLAG1 := F4;
- FLAG2 := F5 AND F6 AND F7 AND F8;
- END REALS;
-
- GENERIC
- TYPE ITEM IS PRIVATE;
- TYPE INDEX IS RANGE <>;
- TYPE G5 IS ARRAY (INDEX) OF ITEM;
- TYPE G6 IS ARRAY (INDEX, INDEX) OF ITEM;
- PACKAGE DIMENSIONS IS
- TYPE INC5;
- TYPE INC6;
- TYPE D1 IS NEW G5;
- TYPE D2 IS NEW G6;
- TYPE INC5 IS NEW G5;
- TYPE INC6 IS NEW G6;
- FUNCTION CHECK RETURN BOOLEAN;
- END DIMENSIONS;
-
- PACKAGE BODY DIMENSIONS IS
- FUNCTION CHECK RETURN BOOLEAN IS
- A1 : INC5;
- A2 : INC6;
- DIM1 : D1;
- DIM2 : D2;
- F1, F2 : BOOLEAN;
- BEGIN
- F1 := A1(INDEX'FIRST)'SIZE = DIM1(INDEX'FIRST)'SIZE;
- F2 := A2(INDEX'FIRST, INDEX'LAST)'SIZE =
- DIM2(INDEX'FIRST, INDEX'LAST)'SIZE;
-
- RETURN (F1 AND F2);
- END CHECK;
- END DIMENSIONS;
-
- PROCEDURE PROC IS NEW REALS (G3 => T_FLOAT, G4 => T_FIXED);
- FUNCTION DISCRETE IS NEW G_DISCRETE (G1 => RAINBOW, G2 => P2);
- PACKAGE PKG IS NEW DIMENSIONS (ITEM => P1, INDEX => P2, G5 => P3,
- G6 => P4);
-
- USE PKG;
-BEGIN
- TEST ("C38102E", "INCOMPLETE TYPES CAN BE DERIVED GENERIC " &
- "FORMAL TYPES");
-
- IF NOT DISCRETE THEN
- FAILED ("INTEGER AND ENUMERATED TYPES NOT DERIVED");
- END IF;
-
- PROC (F1, F2);
- IF (NOT F1) THEN
- FAILED ("FLOAT TYPES NOT DERIVED");
- END IF;
- IF (NOT F2) THEN
- FAILED ("FIXED TYPES NOT DERIVED");
- END IF;
-
- IF NOT CHECK THEN
- FAILED ("ONE AND TWO DIMENSIONAL ARRAY TYPES NOT DERIVED");
- END IF;
-
- RESULT;
-END C38102E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38104a.ada b/gcc/testsuite/ada/acats/tests/c3/c38104a.ada
deleted file mode 100644
index f5f2873..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38104a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- C38104A.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 INCOMPLETE TYPE WITH DISCRIMINANTS CAN BE
--- USED IN AN ACCESS TYPE DEFINITION WITH A COMPATIBLE DISCRIMINANT
--- CONSTRAINT.
-
--- HISTORY:
--- PMW 09/01/88 CREATED ORIGINAL TEST BY RENAMING E38104A.ADA.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38104A IS
-
-BEGIN
-
- TEST ("C38104A","INCOMPLETELY DECLARED TYPE CAN BE USED AS TYPE " &
- "MARK IN ACCESS TYPE DEFINITION, AND CAN BE CONSTRAINED " &
- "THERE OR LATER IF INCOMPLETE TYPE HAD DISCRIMINANT(S)");
-
- DECLARE
- TYPE T1;
- TYPE T1_NAME IS ACCESS T1;
-
- TYPE T1 IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- TYPE T2(DISC : INTEGER := 5);
- TYPE T2_NAME1 IS ACCESS T2(5);
- TYPE T2_NAME2 IS ACCESS T2;
-
- SUBTYPE SUB_T2_NAME2 IS T2_NAME2(5);
- TYPE T2_NAME2_NAME IS ACCESS T2_NAME2(5);
- X : T2_NAME2(5);
-
- TYPE T2(DISC : INTEGER := 5) IS
- RECORD
- COMP : T2_NAME2(DISC);
- END RECORD;
-
- X1N : T1_NAME;
- X2A,X2B : T2;
- X2N2 : T2_NAME2;
-
- BEGIN
- IF EQUAL(3,3) THEN
- X1N := NEW T1 '(COMP => 5);
- END IF;
-
- IF X1N.COMP /= 5 THEN
- FAILED ("ASSIGNMENT FAILED - 1");
- END IF;
-
- X2A := (DISC => IDENT_INT(7), COMP => NULL);
- X2N2 := NEW T2(IDENT_INT(7));
- X2N2.ALL := X2A;
-
- IF EQUAL(3,3) THEN
- X2B := (DISC => IDENT_INT(7), COMP => X2N2);
- END IF;
-
- IF X2B.COMP.COMP /= NULL
- OR X2B.COMP.DISC /= 7 THEN
- FAILED ("ASSIGNMENT FAILED - 2");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
- END;
-
- RESULT;
-
-END C38104A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38107a.ada b/gcc/testsuite/ada/acats/tests/c3/c38107a.ada
deleted file mode 100644
index 75a2492..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38107a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C38107A.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:
--- FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS DECLARED IN THE
--- VISIBLE PART OF A PACKAGE OR IN A DECLARATIVE PART, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT IS
--- SPECIFIED FOR THE TYPE AND ONE OF THE DISCRIMINANT VALUES DOES
--- NOT BELONG TO THE CORRESPONDING DISCRIMINANT'S SUBTYPE.
-
--- HISTORY:
--- BCB 01/21/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38107A IS
-
-BEGIN
- TEST ("C38107A", "FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS " &
- "DECLARED IN THE VISIBLE PART OF A PACKAGE OR " &
- "IN A DECLARATIVE PART, CHECK THAT CONSTRAINT_" &
- "ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT " &
- "IS SPECIFIED FOR THE TYPE AND ONE OF THE " &
- "DISCRIMINANT VALUES DOES NOT BELONG TO THE " &
- "CORRESPONDING DISCRIMINANT'S SUBTYPE");
-
- BEGIN
- DECLARE
- PACKAGE P IS
- SUBTYPE INT6 IS INTEGER RANGE 1 .. 6;
- TYPE T_INT6 (D6 : INT6);
- TYPE TEST IS ACCESS T_INT6(7); -- CONSTRAINT_ERROR.
- TYPE T_INT6 (D6 : INT6) IS
- RECORD
- NULL;
- END RECORD;
- END P;
- USE P;
- BEGIN
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1");
- DECLARE
- T : P.TEST := NEW T_INT6(7);
- BEGIN
- IF EQUAL(T.D6, T.D6) THEN
- COMMENT ("DON'T OPTIMIZE T.D6");
- END IF;
- END;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE INT7 IS INTEGER RANGE 1 .. 7;
- TYPE T_INT7 (D7 : INT7);
- TYPE TEST IS ACCESS T_INT7(8); -- CONSTRAINT_ERROR.
- TYPE T_INT7 (D7 : INT7) IS
- RECORD
- NULL;
- END RECORD;
- BEGIN
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2");
- DECLARE
- T : TEST := NEW T_INT7(6);
- BEGIN
- IF EQUAL(T.D7, T.D7) THEN
- COMMENT ("DON'T OPTIMIZE T.D7");
- END IF;
- END;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 2");
- END;
- RESULT;
-END C38107A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38107b.ada b/gcc/testsuite/ada/acats/tests/c3/c38107b.ada
deleted file mode 100644
index 8e74581..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38107b.ada
+++ /dev/null
@@ -1,194 +0,0 @@
--- C38107B.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 A DISCRIMINANT CONSTRAINT IS APPLIED TO AN ACCESS TYPE WHICH
--- DESIGNATES AN INCOMPLETE TYPE WHICH WAS DECLARED IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN A DECLARATIVE
--- PART, CONSTRAINT_ERROR IS RAISED IF ONE OF THE
--- DISCRIMINANT'S VALUES DOES NOT BELONG TO THE CORRESPONDING
--- DISCRIMINANT'S SUBTYPE.
-
--- HISTORY:
--- DHH 08/05/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38107B IS
-
-BEGIN
- TEST("C38107B", "IF A DISCRIMINANT CONSTRAINT IS APPLIED TO AN " &
- "ACCESS TYPE WHICH DESIGNATES AN INCOMPLETE " &
- "TYPE WHICH WAS DECLARED IN THE VISIBLE OR " &
- "PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN " &
- "A DECLARATIVE PART, CONSTRAINT_ERROR IS " &
- "RAISED IF ONE OF THE DISCRIMINANT'S VALUES " &
- "DOES NOT BELONG TO THE CORRESPONDING " &
- "DISCRIMINANT'S SUBTYPE");
-
------------------------------- VISIBLE ------------------------------
- BEGIN
- DECLARE
- PACKAGE PACK IS
- SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5;
-
- TYPE INCOMPLETE(A : SMALLER);
-
- TYPE ACC_INC IS ACCESS INCOMPLETE;
- SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6));
-
- TYPE INCOMPLETE(A : SMALLER) IS
- RECORD
- T : INTEGER := A;
- END RECORD;
-
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- FAILED("CONSTRAINT_ERROR NOT RAISED - VISIBLE");
- DECLARE
- Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6));
- BEGIN
- IF IDENT_INT(Z.T) = IDENT_INT(6) THEN
- COMMENT("THIS LINE SHOULD NOT PRINT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR RAISED LATE " &
- "- VISIBLE");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED " &
- "LATE - VISIBLE");
- END PACK;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED " &
- "- VISIBLE");
- END;
-
------------------------------- PRIVATE ------------------------------
- BEGIN
- DECLARE
- PACKAGE PACK2 IS
- SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5;
-
- TYPE PRIV IS PRIVATE;
-
- PRIVATE
- TYPE PRIV IS
- RECORD
- V : INTEGER;
- END RECORD;
-
- TYPE INCOMPLETE(A : SMALLER);
-
- TYPE ACC_INC IS ACCESS INCOMPLETE;
- SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(0));
-
- TYPE INCOMPLETE(A : SMALLER) IS
- RECORD
- T : INTEGER := A;
- U : PRIV := (V => A ** IDENT_INT(2));
- END RECORD;
-
- END PACK2;
-
- PACKAGE BODY PACK2 IS
- BEGIN
- FAILED("CONSTRAINT_ERROR NOT RAISED - PRIVATE");
- DECLARE
- Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(0));
- BEGIN
- IF IDENT_INT(Z.T) = IDENT_INT(0) THEN
- COMMENT("THIS LINE SHOULD NOT PRINT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR RAISED TOO LATE " &
- "- PRIVATE");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED LATE" &
- "- PRIVATE");
- END PACK2;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED " &
- "- PRIVATE");
- END;
-
--------------------------- DECLARATIVE PART --------------------------
- BEGIN
- DECLARE
- SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5;
-
- TYPE INCOMPLETE(A : SMALLER);
-
- TYPE ACC_INC IS ACCESS INCOMPLETE;
- SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6));
-
- TYPE INCOMPLETE(A : SMALLER) IS
- RECORD
- T : INTEGER := INTEGER'(A);
- END RECORD;
-
- BEGIN
- FAILED("CONSTRAINT_ERROR NOT RAISED - BLOCK " &
- "STATEMENT");
- DECLARE
- Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6));
- BEGIN
- IF IDENT_INT(Z.T) = IDENT_INT(6) THEN
- COMMENT("THIS LINE SHOULD NOT PRINT");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR RAISED TOO LATE " &
- "- BLOCK STATEMENT");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED LATE" &
- "- BLOCK STATEMENT");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED " &
- "- BLOCK STATEMENT");
- END;
-
- RESULT;
-END C38107B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108a.ada b/gcc/testsuite/ada/acats/tests/c3/c38108a.ada
deleted file mode 100644
index 4e533b7..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C38108A.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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF
--- A PACKAGE, WITH THE FULL DECLARATION OCCURRING IN THE PACKAGE BODY.
-
--- AH 8/20/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C38108A IS
-
- PACKAGE P IS
- TYPE L IS LIMITED PRIVATE;
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L);
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN;
- PRIVATE
- TYPE INC (D : INTEGER);
- TYPE L IS ACCESS INC;
- END P;
-
- PACKAGE BODY P IS
- TYPE INC (D : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS
- BEGIN
- Y := NEW INC(1);
- Y.C := X;
- END ASSIGN;
-
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS
- BEGIN
- RETURN (X.C = Y.C);
- END "=";
-
- END P;
-
-USE P;
-BEGIN
-
- TEST ("C38108A", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " &
- "PRIVATE PART WITHOUT FULL DECLARATION");
- DECLARE
- VAL_1, VAL_2 : L;
- BEGIN
- ASSIGN (2, VAL_1);
- ASSIGN (2, VAL_2);
- IF NOT "=" (VAL_1, VAL_2) THEN
- FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED");
- END IF;
- END;
-
- RESULT;
-END C38108A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108b.ada b/gcc/testsuite/ada/acats/tests/c3/c38108b.ada
deleted file mode 100644
index 120e51a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108b.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- C38108B.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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF
--- A LIBRARY PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A
--- PACKAGE BODY.
-
--- AH 8/20/86
-
-PACKAGE C38108B_P IS
- TYPE L IS LIMITED PRIVATE;
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L);
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN;
-PRIVATE
- TYPE INC (D : INTEGER);
- TYPE L IS ACCESS INC;
-END C38108B_P;
-
-PACKAGE BODY C38108B_P IS
- TYPE INC (D : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS
- BEGIN
- Y := NEW INC(1);
- Y.C := X;
- END ASSIGN;
-
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS
- BEGIN
- RETURN (X.C = Y.C);
- END "=";
-
-END C38108B_P;
-
-WITH REPORT; USE REPORT;
-WITH C38108B_P; USE C38108B_P;
-PROCEDURE C38108B IS
- VAL_1, VAL_2 : L;
-BEGIN
-
- TEST ("C38108B", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " &
- "PRIVATE PART WITHOUT FULL DECLARATION - " &
- "LIBRARY PACKAGE");
-
- ASSIGN (2, VAL_1);
- ASSIGN (2, VAL_2);
- IF NOT "=" (VAL_1, VAL_2) THEN
- FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED");
- END IF;
-
- RESULT;
-END C38108B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada b/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada
deleted file mode 100644
index 780436a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- C38108C0.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.
---*
--- SPECIFICATION OF LIBRARY PACKAGE USED WITH C38108C1M.
-
--- AH 8/20/86
-
-PACKAGE C38108C0 IS
- TYPE L IS LIMITED PRIVATE;
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L);
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN;
-PRIVATE
- TYPE INC (D : INTEGER);
- TYPE L IS ACCESS INC;
-END C38108C0;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada b/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada
deleted file mode 100644
index 523663f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- C38108C1M.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 INCOMPLETE TYPE CAN BE DELCARED IN A SEPARATELY
--- COMPILED PACKAGE SPECIFICATION AND ITS FULL DECLARATION CAN LATER BE
--- GIVEN IN A SEPARATELY COMPILED BODY.
-
--- AH 8/20/86
-
--- C38108C0 THE PACKAGE SPECIFICATION.
--- C38108C1M THE MAIN PROGRAM.
--- C38108C2 THE PACKAGE BODY.
-
-WITH REPORT; USE REPORT;
-WITH C38108C0; USE C38108C0;
-PROCEDURE C38108C1M IS
- VAL_1, VAL_2 : L;
-BEGIN
-
- TEST ("C38108C", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " &
- "PRIVATE PART WITHOUT FULL DECLARATION - " &
- "LIBRARY PACKAGE");
-
- ASSIGN (2, VAL_1);
- ASSIGN (2, VAL_2);
- IF NOT "=" (VAL_1, VAL_2) THEN
- FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED");
- END IF;
-
- RESULT;
-END C38108C1M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada b/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada
deleted file mode 100644
index 9dda7aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada
+++ /dev/null
@@ -1,47 +0,0 @@
--- C38108C2.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.
---*
--- PACKAGE BODY FOR USE WITH C38108C1M.
--- SPECIFICATION IS IN C38108C0.
-
--- AH 8/20/86
-
-PACKAGE BODY C38108C0 IS
- TYPE INC (D : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS
- BEGIN
- Y := NEW INC(1);
- Y.C := X;
- END ASSIGN;
-
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS
- BEGIN
- RETURN (X.C = Y.C);
- END "=";
-
-END C38108C0;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada b/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada
deleted file mode 100644
index 4b24e7c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C38108D0M.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 INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF
--- A PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A
--- PACKAGE BODY SUBUNIT.
-
--- OTHER FILES: C38108D1.ADA (PACKAGE BODY SUBUNIT.)
-
--- AH 8/20/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C38108D0M IS
- PACKAGE C38108D1 IS
- TYPE L IS LIMITED PRIVATE;
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L);
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN;
- PRIVATE
- TYPE INC (D : INTEGER);
- TYPE L IS ACCESS INC;
- END C38108D1;
-
- PACKAGE BODY C38108D1 IS SEPARATE;
-
-USE C38108D1;
-BEGIN
-
- TEST ("C38108D", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " &
- "PRIVATE PART WITH FULL DECLARATION IN " &
- "A PACKAGE BODY SUBUNIT");
-
-DECLARE
- VAL_1, VAL_2 : L;
-BEGIN
- ASSIGN (2, VAL_1);
- ASSIGN (2, VAL_2);
- IF NOT "=" (VAL_1, VAL_2) THEN
- FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED");
- END IF;
-END;
-
- RESULT;
-END C38108D0M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada b/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada
deleted file mode 100644
index 895e956..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada
+++ /dev/null
@@ -1,47 +0,0 @@
--- C38108D1.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.
---*
--- PACKAGE BODY SUBUNIT USED WITH C38108D0M.
-
--- AH 8/20/86
-
-SEPARATE (C38108D0M)
-PACKAGE BODY C38108D1 IS
- TYPE INC (D : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS
- BEGIN
- Y := NEW INC(1);
- Y.C := X;
- END ASSIGN;
-
- FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS
- BEGIN
- RETURN (X.C = Y.C);
- END "=";
-
-END C38108D1;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c38202a.ada b/gcc/testsuite/ada/acats/tests/c3/c38202a.ada
deleted file mode 100644
index d0350fc..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c38202a.ada
+++ /dev/null
@@ -1,197 +0,0 @@
--- C38202A.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 ATTRIBUTES ARE DECLARED AND RETURN CORRECT
--- VALUES FOR OBJECTS HAVING AN ACCESS TYPE WHOSE DESIGNATED
--- TYPE IS A TASK TYPE.
--- CHECK THE ACCESS TYPE RESULTS OF FUNCTION CALLS.
-
--- AH 9/12/86
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-with Impdef;
-WITH REPORT; USE REPORT;
-PROCEDURE C38202A IS
-BEGIN
- TEST ("C38202A", "OBJECTS HAVING ACCESS TYPES WITH DESIGNATED " &
- "TASK TYPE CAN BE PREFIX OF TASKING ATTRIBUTES");
-
--- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED.
--- (2) TASK IS NOT CALLABLE, TERMINATED.
-
- DECLARE
- TASK TYPE TSK IS
- ENTRY GO_ON;
- END TSK;
-
- TASK DRIVER IS
- ENTRY TSK_DONE;
- END DRIVER;
-
- TYPE P_TYPE IS ACCESS TSK;
- P : P_TYPE;
-
- TASK BODY TSK IS
- I : INTEGER RANGE 0 .. 2;
- BEGIN
- ACCEPT GO_ON;
- I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED.
- FAILED ("CONSTAINT_ERROR NOT RAISED IN TASK " &
- " TSK - 1A " & INTEGER'IMAGE(I));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- DRIVER.TSK_DONE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED IN TASK " &
- "TSK - 1A ");
- DRIVER.TSK_DONE;
- END TSK;
-
- TASK BODY DRIVER IS
- COUNTER : INTEGER := 1;
- BEGIN
- P := NEW TSK;
- IF NOT P'CALLABLE THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE - 1B");
- END IF;
-
- IF P'TERMINATED THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE - 1C");
- END IF;
-
- P.GO_ON;
- ACCEPT TSK_DONE;
- WHILE (NOT P'TERMINATED AND COUNTER <= 3) LOOP
- DELAY 10.0 * Impdef.One_Second;
- COUNTER := COUNTER + 1;
- END LOOP;
-
- IF COUNTER > 3 THEN
- FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " &
- "TIME - 1D");
- END IF;
-
- IF P'CALLABLE THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE - 1E");
- END IF;
-
- IF NOT P'TERMINATED THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE - 1F");
- END IF;
- END DRIVER;
-
- BEGIN
- NULL;
- END; -- BLOCK
-
--- CHECK ACCESS TYPE RESULT RETURNED FROM FUNCTION.
--- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED.
--- (2) TASK IS NOT CALLABLE, TERMINATED.
-
- DECLARE
- TASK TYPE TSK IS
- ENTRY GO_ON;
- END TSK;
-
- TASK DRIVER IS
- ENTRY TSK_DONE;
- END DRIVER;
-
- TYPE P_TYPE IS ACCESS TSK;
- P : P_TYPE;
-
- TSK_CREATED : BOOLEAN := FALSE;
-
- FUNCTION F1 RETURN P_TYPE IS
- BEGIN
- RETURN P;
- END F1;
-
- TASK BODY TSK IS
- I : INTEGER RANGE 0 .. 2;
- BEGIN
- ACCEPT GO_ON;
- I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED.
- FAILED ("CONSTRAINT_ERROR NOT RAISED IN TASK " &
- "TSK - 2A " & INTEGER'IMAGE(I));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- DRIVER.TSK_DONE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED IN TASK " &
- "TSK - 2A ");
- DRIVER.TSK_DONE;
- END TSK;
-
- TASK BODY DRIVER IS
- COUNTER : INTEGER := 1;
- BEGIN
- P := NEW TSK; -- ACTIVATE P.ALL (F1.ALL).
- IF NOT F1'CALLABLE THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE WHEN PREFIX IS VALUE FROM " &
- "FUNCTION CALL - 2B");
- END IF;
-
- IF F1'TERMINATED THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE WHEN PREFIX IS VALUE FROM " &
- "FUNCTION CALL - 2C");
- END IF;
-
- F1.ALL.GO_ON;
- ACCEPT TSK_DONE;
- WHILE (NOT F1'TERMINATED AND COUNTER <= 3) LOOP
- DELAY 10.0 * Impdef.One_Second;
- COUNTER := COUNTER + 1;
- END LOOP;
-
- IF COUNTER > 3 THEN
- FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " &
- "TIME - 2D");
- END IF;
-
- IF F1'CALLABLE THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE WHEN PREFIX IS VALUE FROM " &
- "FUNCTION CALL - 2E");
- END IF;
-
- IF NOT F1'TERMINATED THEN
- FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " &
- "VALUE WHEN PREFIX IS VALUE FROM " &
- "FUNCTION CALL - 2F");
- END IF;
- END DRIVER;
-
- BEGIN
- NULL;
- END; -- BLOCK
-
- RESULT;
-END C38202A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900010.a b/gcc/testsuite/ada/acats/tests/c3/c3900010.a
deleted file mode 100644
index 6d9ddb4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900010.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C3900010.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:
--- See C3900011.AM.
---
--- TEST DESCRIPTION:
--- See C3900011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900010.A
--- C3900011.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900010 is
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
- -- Declarations required for component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be inherited by
- -- all derivatives.
-
-
-
- type Low_Alert_Type is new Alert_Type with record -- Record extension of
- Level : Integer := 0; -- root tagged type.
- end record;
-
- -- Inherits procedure Display from Alert.
- -- Inherits procedure Handle from Alert.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-
- -- Declarations required for component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody; -- Record extension of
- end record; -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits (inherited) procedure Handle from Low_Alert_Type.
-
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
-end C3900010;
-
-
- --==================================================================--
-
-
-package body C3900010 is
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- end Handle;
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
-end C3900010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900011.am b/gcc/testsuite/ada/acats/tests/c3/c3900011.am
deleted file mode 100644
index 68207f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900011.am
+++ /dev/null
@@ -1,253 +0,0 @@
--- C3900011.AM
---
--- 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 record extension can be declared in the same package
--- as its parent, and that this parent may be a tagged record or a
--- record extension. Check that each derivative inherits all user-
--- defined primitive subprograms of its parent (including those that
--- its parent inherited), and that it may declare its own primitive
--- subprograms.
---
--- Check that predefined equality operators are defined for the root
--- tagged type.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type in a package specification. Declare two
--- primitive subprograms for the type.
---
--- Extend the root type with a record extension in the same package
--- specification. Declare a new primitive subprogram for the extension
--- (in addition to its two inherited subprograms).
---
--- Extend the extension with a record extension in the same package
--- specification. Declare a new primitive subprogram for this second
--- extension (in addition to its three inherited subprograms).
---
--- In the main program, declare operations for the root tagged type which
--- utilize aggregates and equality operators to verify the correctness
--- of the components. Overload these operations for the two type
--- extensions. Within each of these overloading operations, utilize type
--- conversion to call the parent's implementation of the same operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- C3900010.A
--- => C3900011.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with C3900010;
-with Report;
-procedure C3900011 is
-
-
- package Check_Alert_Values is
-
- -- Declare functions to verify correctness of tagged record components
- -- before and after calls to their primitive subprograms.
-
-
- -- Alert_Type:
-
- function Initial_Values_Okay (A : in C3900010.Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (A : in C3900010.Alert_Type)
- return Boolean;
-
-
- -- Low_Alert_Type:
-
- function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
- return Boolean;
-
-
- -- Medium_Alert_Type:
-
- function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
- return Boolean;
-
-
- end Check_Alert_Values;
-
-
- --==========================================================--
-
-
- package body Check_Alert_Values is
-
-
- function Initial_Values_Okay (A : in C3900010.Alert_Type)
- return Boolean is
- use type C3900010.Alert_Type;
- begin -- "=" operator availability.
- return (A = (Arrival_Time => C3900010.Default_Time,
- Display_On => C3900010.Null_Device));
- end Initial_Values_Okay;
-
-
- function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
- return Boolean is
- begin -- Type conversion.
- return (Initial_Values_Okay (C3900010.Alert_Type (LA)) and
- LA.Level = 0);
- end Initial_Values_Okay;
-
-
- function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
- return Boolean is
- use type C3900010.Person_Enum;
- begin -- Type conversion.
- return (Initial_Values_Okay (C3900010.Low_Alert_Type (MA)) and
- MA.Action_Officer = C3900010.Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (A : in C3900010.Alert_Type)
- return Boolean is
- use type C3900010.Alert_Type;
- begin -- "/=" operator availability.
- return (A /= (Arrival_Time => C3900010.Alert_Time,
- Display_On => C3900010.Null_Device));
- end Bad_Final_Values;
-
-
- function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
- return Boolean is
- use type C3900010.Low_Alert_Type;
- begin -- "=" operator availability.
- return not ( LA = (Arrival_Time => C3900010.Alert_Time,
- Display_On => C3900010.Teletype,
- Level => 1) );
- end Bad_Final_Values;
-
-
- function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
- return Boolean is
- use type C3900010.Medium_Alert_Type;
- begin -- "/=" operator availability.
- return ( MA /= (C3900010.Alert_Time,
- C3900010.Console,
- 1,
- C3900010.Duty_Officer) );
- end Bad_Final_Values;
-
-
- end Check_Alert_Values;
-
-
- --==========================================================--
-
-
- use Check_Alert_Values;
- use C3900010;
-
- Root_Alarm : C3900010.Alert_Type;
- Low_Alarm : C3900010.Low_Alert_Type;
- Medium_Alarm : C3900010.Medium_Alert_Type;
-
-begin
-
- Report.Test ("C390001", "Primitive operation inheritance by type " &
- "extensions: all extensions declared in same package " &
- "as parent");
-
-
--- Check root tagged type:
-
- if Initial_Values_Okay (Root_Alarm) then
- Handle (Root_Alarm); -- Explicitly declared.
- Display (Root_Alarm); -- Explicitly declared.
-
- if Bad_Final_Values (Root_Alarm) then
- Report.Failed ("Wrong results after Alert_Type calls");
- end if;
- else
- Report.Failed ("Wrong initial values for Alert_Type");
- end if;
-
-
--- Check record extension of root tagged type:
-
- if Initial_Values_Okay (Low_Alarm) then
- Handle (Low_Alarm); -- Inherited.
- Low_Alarm.Display_On := Teletype;
- Display (Low_Alarm); -- Inherited.
- Low_Alarm.Level := Level_Of (Low_Alarm); -- Explicitly declared.
-
- if Bad_Final_Values (Low_Alarm) then
- Report.Failed ("Wrong results after Low_Alert_Type calls");
- end if;
- else
- Report.Failed ("Wrong initial values for Low_Alert_Type");
- end if;
-
-
--- Check record extension of record extension:
-
- if Initial_Values_Okay (Medium_Alarm) then
- Handle (Medium_Alarm); -- Inherited twice.
- Medium_Alarm.Display_On := Console;
- Display (Medium_Alarm); -- Inherited twice.
- Medium_Alarm.Level := Level_Of (Medium_Alarm); -- Inherited.
- Assign_Officer (Medium_Alarm, Duty_Officer); -- Explicitly declared.
-
- if Bad_Final_Values (Medium_Alarm) then
- Report.Failed ("Wrong results after Medium_Alert_Type calls");
- end if;
- else
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
-
--- Check final display counts:
-
- if C3900010.Display_Count_For /= (Null_Device => 1,
- Teletype => 1,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong final values for display counts");
- end if;
-
-
- Report.Result;
-
-end C3900011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390002.a b/gcc/testsuite/ada/acats/tests/c3/c390002.a
deleted file mode 100644
index b3d11af..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390002.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C390002.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 tagged base type may be declared, and derived
--- from in simple, private and extended forms. (Overlaps with C390B04)
--- Check that the package Ada.Tags is present and correctly implemented.
--- Check for the correct operation of Expanded_Name, External_Tag and
--- Internal_Tag within that package. Check that the exception Tag_Error
--- is correctly raised on calling Internal_Tag with bad input.
---
--- TEST DESCRIPTION:
--- This test declares a tagged type, and derives three types from it.
--- These types are then used to test the presence and function of the
--- package Ada.Tags.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 27 Jan 96 SAIC Update RM references for 2.1
---
---!
-
-with Report;
-with Ada.Tags;
-
-procedure C390002 is
-
- package Vehicle is
-
- type Object is tagged limited private; -- ancestor type
- procedure Create( The_Vehicle : in out Object; Wheels : in Natural );
- function Wheels( The_Vehicle : Object ) return Natural;
-
- private
-
- type Object is tagged limited record
- Wheel_Count : Natural := 0;
- end record;
-
- end Vehicle;
-
- package Motivators is
-
- type Bicycle is new Vehicle.Object with null record; -- simple
-
- type Car is new Vehicle.Object with record -- extended
- Convertible : Boolean;
- end record;
-
- type Truck is new Vehicle.Object with private; -- private
-
- private
-
- type Truck is new Vehicle.Object with record
- Air_Horn : Boolean;
- end record;
-
- end Motivators;
-
- package body Vehicle is
-
- procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is
- begin
- The_Vehicle.Wheel_Count := Wheels;
- end Create;
-
- function Wheels( The_Vehicle : Object ) return Natural is
- begin
- return The_Vehicle.Wheel_Count;
- end Wheels;
-
- end Vehicle;
-
- function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is
- begin
- return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) );
- Report.Comment("This message intentionally blank.");
- end TC_ID_Tag;
-
- procedure Check_Tags( Machine : in Vehicle.Object'Class;
- Expected_Name : in String;
- External_Tag : in String ) is
- The_Tag : constant Ada.Tags.Tag := Machine'Tag;
- use type Ada.Tags.Tag;
- begin
- if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then
- Report.Failed ("Failed in Check_Tags, Expanded_Name "
- & Expected_Name);
- end if;
- if Ada.Tags.External_Tag(The_Tag) /= External_Tag then
- Report.Failed ("Failed in Check_Tags, External_Tag "
- & Expected_Name);
- end if;
- if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then
- Report.Failed ("Failed in Check_Tags, Internal_Tag "
- & Expected_Name);
- end if;
- end Check_Tags;
-
- procedure Check_Exception is
- Boeing_777_Id : Ada.Tags.Tag;
- begin
- Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!");
- Report.Failed ("Failed in Check_Exception, no exception");
- Boeing_777_Id := TC_ID_Tag( Boeing_777_Id );
- exception
- when Ada.Tags.Tag_Error => null;
- when others =>
- Report.Failed ("Failed in Check_Exception, wrong exception");
- end Check_Exception;
-
- use Motivators;
- Two_Wheeler : Bicycle;
- Four_Wheeler : Car;
- Eighteen_Wheeler : Truck;
-
-begin -- Main test procedure.
-
- Report.Test ("C390002", "Check that a tagged type may be declared and " &
- "derived from in simple, private and extended forms. " &
- "Check package Ada.Tags" );
-
- Create( Two_Wheeler, 2 );
- Create( Four_Wheeler, 4 );
- Create( Eighteen_Wheeler, 18 );
-
- Check_Tags( Machine => Two_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.BICYCLE",
- External_Tag => Bicycle'External_Tag );
- Check_Tags( Machine => Four_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.CAR",
- External_Tag => Car'External_Tag );
- Check_Tags( Machine => Eighteen_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.TRUCK",
- External_Tag => Truck'External_Tag );
-
- Check_Exception;
-
- Report.Result;
-
-end C390002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc/testsuite/ada/acats/tests/c3/c390003.a
deleted file mode 100644
index 643aad1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390003.a
+++ /dev/null
@@ -1,419 +0,0 @@
--- C390003.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 for a subtype S of a tagged type T, S'Class denotes a
--- class-wide subtype. Check that T'Tag denotes the tag of the type T,
--- and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
--- Check that the tags of stand alone objects, record and array
--- components, aggregates, and formal parameters identify their type.
--- Check that the tag of a value of a formal parameter is that of the
--- actual parameter, even if the actual is passed by a view conversion.
---
--- TEST DESCRIPTION:
--- This test defines a class hierarchy (based on C390002) and
--- uses it to determine the correctness of the resulting tag
--- information generated by the compiler. A type is defined in the
--- class which contains components of the class as part of its
--- definition. This is to reduce the overall number of types
--- required, and to achieve the required nesting to accomplish
--- this test. The model is that of a car carrier truck; both car
--- and truck being in the class of Vehicle.
---
--- Class Hierarchy:
--- Vehicle - - - - - - - (Bicycle)
--- / | \ / \
--- Truck Car Q_Machine Tandem Motorcycle
--- |
--- Auto_Carrier
--- Contains:
--- Auto_Carrier( Car )
--- Q_Machine( Car, Motorcycle )
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed ARM references from objective text.
--- 20 Dec 94 SAIC Replaced three unnecessary extension
--- aggregates with simple aggregates.
--- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
------------------------------------------------------------------ C390003_1
-
-with Ada.Tags;
-package C390003_1 is -- Vehicle
-
- type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
- type States is (Good, Flat, Worn);
-
- type Wheel_List is array(Positive range <>) of States;
-
- type Object(Wheels: Positive) is tagged record
- Wheel_State : Wheel_List(1..Wheels);
- end record;
-
- procedure TC_Validate( It: Object; Key: TC_Keys );
- procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );
-
- procedure Create( The_Vehicle : in out Object; Tyres : in States );
- procedure Rotate( The_Vehicle : in out Object );
- function Wheels( The_Vehicle : Object ) return Positive;
-
-end C390003_1; -- Vehicle;
-
------------------------------------------------------------------ C390003_2
-
-with C390003_1;
-package C390003_2 is -- Motivators
-
- package Vehicle renames C390003_1;
- subtype Bicycle is Vehicle.Object(2); -- constrained subtype
-
- type Motorcycle is new Bicycle with record
- Displacement : Natural;
- end record;
- procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );
-
- type Tandem is new Bicycle with null record;
- procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );
-
- type Car is new Vehicle.Object(4) with -- extended, constrained
- record
- Displacement : Natural;
- end record;
- procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );
-
- type Truck is new Vehicle.Object with -- extended, unconstrained
- record
- Tare : Natural;
- end record;
- procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );
-
-end C390003_2; -- Motivators;
-
------------------------------------------------------------------ C390003_3
-
-with C390003_1;
-with C390003_2;
-package C390003_3 is -- Special_Trucks
- package Vehicle renames C390003_1;
- package Motivators renames C390003_2;
- Max_Cars_On_Vehicle : constant := 6;
- type Cargo_Index is range 0..Max_Cars_On_Vehicle;
- type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
- of Motivators.Car;
- type Auto_Carrier is new Motivators.Truck(18) with
- record
- Load_Count : Cargo_Index := 0;
- Payload : Cargo;
- end record;
- procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
- procedure Load ( The_Car : in Motivators.Car;
- Onto : in out Auto_Carrier);
- procedure Unload( The_Car : out Motivators.Car;
- Off_of : in out Auto_Carrier);
-end C390003_3;
-
------------------------------------------------------------------ C390003_4
-
-with C390003_1;
-with C390003_2;
-package C390003_4 is -- James_Bond
-
- package Vehicle renames C390003_1;
- package Motivators renames C390003_2;
-
- type Q_Machine is new Vehicle.Object(4) with record
- Car_Part : Motivators.Car;
- Bike_Part : Motivators.Motorcycle;
- end record;
- procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );
-
-end C390003_4;
-
------------------------------------------------------------------ C390003_1
-
-with Report;
-with Ada.Tags;
-package body C390003_1 is -- Vehicle
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
-
- procedure TC_Validate( It: Object; Key: TC_Keys ) is
- begin
- if Key /= Veh then
- Report.Failed("Expected Veh Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
- begin
- if It'Tag /= The_Tag then
- Report.Failed("Unexpected Tag for classwide formal");
- end if;
- end TC_Validate;
-
- procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
- begin
- The_Vehicle.Wheel_State := ( others => Tyres );
- end Create;
-
- function Wheels( The_Vehicle : Object ) return Positive is
- begin
- return The_Vehicle.Wheels;
- end Wheels;
-
- procedure Rotate( The_Vehicle : in out Object ) is
- Push : States;
- Pulled : States
- := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
- begin
- for Finger in
- The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
- Push := The_Vehicle.Wheel_State(Finger);
- The_Vehicle.Wheel_State(Finger) := Pulled;
- Pulled := Push;
- end loop;
- end Rotate;
-
-end C390003_1; -- Vehicle;
-
------------------------------------------------------------------ C390003_2
-
-with Ada.Tags;
-with Report;
-package body C390003_2 is -- Motivators
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.MC then
- Report.Failed("Expected MC Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Tand then
- Report.Failed("Expected Tand Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Car then
- Report.Failed("Expected Car Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Truk then
- Report.Failed("Expected Truk Key");
- end if;
- end TC_Validate;
-end C390003_2; -- Motivators;
-
------------------------------------------------------------------ C390003_3
-
-with Ada.Tags;
-with Report;
-package body C390003_3 is -- Special_Trucks
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Heavy then
- Report.Failed("Expected Heavy Key");
- end if;
- end TC_Validate;
-
- procedure Load ( The_Car : in Motivators.Car;
- Onto : in out Auto_Carrier) is
- begin
- Onto.Load_Count := Onto.Load_Count +1;
- Onto.Payload(Onto.Load_Count) := The_Car;
- end Load;
- procedure Unload( The_Car : out Motivators.Car;
- Off_of : in out Auto_Carrier) is
- begin
- The_Car := Off_of.Payload(Off_of.Load_Count);
- Off_of.Load_Count := Off_of.Load_Count -1;
- end Unload;
-
-end C390003_3;
-
------------------------------------------------------------------ C390003_4
-
-with Report, Ada.Tags;
-package body C390003_4 is -- James_Bond
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Q then
- Report.Failed("Expected Q Key");
- end if;
- end TC_Validate;
-
-end C390003_4;
-
-------------------------------------------------------------------- C390003
-
-with Report;
-with C390003_1;
-with C390003_2;
-with C390003_3;
-with C390003_4;
-procedure C390003 is
-
- package Vehicle renames C390003_1; use Vehicle;
- package Motivators renames C390003_2;
- package Special_Trucks renames C390003_3;
- package James_Bond renames C390003_4;
-
- -- The cast, in order of complexity:
-
- Pennys_Bike : Motivators.Bicycle;
- Weekender : Motivators.Tandem;
- Qs_Moped : Motivators.Motorcycle;
- Ms_Limo : Motivators.Car;
- Yard_Van : Motivators.Truck(8);
- Specter_X : Special_Trucks.Auto_Carrier;
- Gen_II : James_Bond.Q_Machine;
-
-
- -- Check compatibility with the corresponding class wide type.
-
- procedure Vehicle_Shop( It : in out Vehicle.Object'Class;
- Key : in Vehicle.TC_Keys ) is
-
- -- Check that Subtype'Class is defined for tagged subtypes.
- procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
- begin
- -- Dispatch to appropriate TC_Validate
- Vehicle.TC_Validate( Bike, Key );
- end Bike_Shop;
-
- begin
- Vehicle.TC_Validate( It, Key );
- if Vehicle.Wheels( It ) = 2 then
- Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels
- end if;
- end Vehicle_Shop;
-
-begin -- Main test procedure.
-
- Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
- "T, S'Class denotes a class-wide subtype. Check that " &
- "T'Tag denotes the tag of the type T, and that, for a " &
- "class-wide tagged type X, X'Tag denotes the tag of X. " &
- "Check that the tags of stand alone objects, record and " &
- "array components, aggregates, and formal parameters " &
- "identify their type. Check that the tag of a value of a " &
- "formal parameter is that of the actual parameter, even " &
- "if the actual is passed by a view conversion" );
-
--- Check that the tags of stand alone objects, record and array
--- components, aggregates, and formal parameters identify their type.
--- Check that the tag of a value of a formal parameter is that of the
--- actual parameter, even if the actual is passed by a view conversion.
-
- Vehicle_Shop( Pennys_Bike, Veh );
- Vehicle_Shop( Weekender, Tand );
- Vehicle_Shop( Qs_Moped, MC );
- Vehicle_Shop( Ms_Limo, Car );
- Vehicle_Shop( Yard_Van, Truk );
- Vehicle_Shop( Specter_X, Heavy );
- Vehicle_Shop( Specter_X.Payload(1), Car );
- Vehicle_Shop( Gen_II, Q );
- Vehicle_Shop( Gen_II.Car_Part, Car );
- Vehicle_Shop( Gen_II.Bike_Part, MC );
-
- Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
- Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag );
- Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag );
- Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag );
- Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag );
- Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
- Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag );
- Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag );
- Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag );
-
--- Check the tag generated for an aggregate.
-
- Rentals: declare
- Mikes_Rental : Vehicle.Object'Class :=
- Vehicle.Object'( 3, (Good, Flat, Worn));
- Diannes_Car : Vehicle.Object'Class :=
- Motivators.Tandem'( Wheels => 2,
- Wheel_State => (Good, Good) );
- Jims_Bike : Vehicle.Object'Class :=
- Motivators.Motorcycle'( Pennys_Bike
- with Displacement => 350 );
- Bills_Limo : Vehicle.Object'Class :=
- Motivators.Car'( Wheels => 4,
- Wheel_State => (others => Good),
- Displacement => 282 );
- Alans_Car : Vehicle.Object'Class :=
- Motivators.Truck'( 18, (others => Worn),
- Tare => 5_500 );
- Pats_Truck : Vehicle.Object'Class := Specter_X;
- Keiths_Car : Vehicle.Object'Class := Gen_II;
- Isaacs_Bus : Vehicle.Object'Class := Keiths_Car;
-
- begin
- Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
- Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag );
- Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag );
- Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag );
- Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag );
- Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag );
- end Rentals;
-
--- Check the tag of parameters.
--- Check that the tag is not affected by view conversion.
-
- Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag );
- Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
- Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
- Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
- Motivators.Motorcycle'Tag );
-
- Report.Result;
-
-end C390003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390004.a b/gcc/testsuite/ada/acats/tests/c3/c390004.a
deleted file mode 100644
index 2c120ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390004.a
+++ /dev/null
@@ -1,404 +0,0 @@
--- C390004.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 tags of allocated objects correctly identify the
--- type of the allocated object. Check that the tag corresponds
--- correctly to the value resulting from both normal and view
--- conversion. Check that the tags of accessed values designating
--- aliased objects correctly identify the type of the object. Check
--- that the tag of a function result correctly evaluates. Check this
--- for class-wide functions. The tag of a class-wide function result
--- should be the tag appropriate to the actual value returned, not the
--- tag of the ancestor type.
---
--- TEST DESCRIPTION:
--- This test defines a class hierarchy of types, with reference
--- semantics (an access type to the class-wide type). Similar in
--- structure to C392005, this test checks that dynamic allocation does
--- not adversely impact the tagging of types.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C390004_1 is -- DMV
- type Equipment is ( T_Veh, T_Car, T_Con, T_Jep );
-
- type Vehicle is tagged record
- Wheels : Natural := 4;
- Parked : Boolean := False;
- end record;
-
- function Wheels ( It: Vehicle ) return Natural;
- procedure Park ( It: in out Vehicle );
- procedure UnPark ( It: in out Vehicle );
- procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural );
- procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment );
-
- type Car is new Vehicle with record
- Passengers : Natural := 0;
- end record;
-
- function Passengers ( It: Car ) return Natural;
- procedure Load_Passengers( It: in out Car; To_Count: in Natural );
- procedure Park ( It: in out Car );
- procedure TC_Check ( It: in Car; To_Equip: in Equipment );
-
- type Convertible is new Car with record
- Top_Up : Boolean := True;
- end record;
-
- function Top_Up ( It: Convertible ) return Boolean;
- procedure Lower_Top( It: in out Convertible );
- procedure Park ( It: in out Convertible );
- procedure Raise_Top( It: in out Convertible );
- procedure TC_Check ( It: in Convertible; To_Equip: in Equipment );
-
- type Jeep is new Convertible with record
- Windshield_Up : Boolean := True;
- end record;
-
- function Windshield_Up ( It: Jeep ) return Boolean;
- procedure Lower_Windshield( It: in out Jeep );
- procedure Park ( It: in out Jeep );
- procedure Raise_Windshield( It: in out Jeep );
- procedure TC_Check ( It: in Jeep; To_Equip: in Equipment );
-
-end C390004_1;
-
-with Report;
-package body C390004_1 is
-
- procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is
- begin
- It.Wheels := To_Count;
- end Set_Wheels;
-
- function Wheels( It: Vehicle ) return Natural is
- begin
- return It.Wheels;
- end Wheels;
-
- procedure Park ( It: in out Vehicle ) is
- begin
- It.Parked := True;
- end Park;
-
- procedure UnPark ( It: in out Vehicle ) is
- begin
- It.Parked := False;
- end UnPark;
-
- procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Veh then
- Report.Failed ("Failed, called Vehicle for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Car then
- Report.Failed ("Failed, called Car for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Con then
- Report.Failed ("Failed, called Convertible for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Jep then
- Report.Failed ("Failed, called Jeep for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is
- begin
- It.Passengers := To_Count;
- UnPark( It );
- end Load_Passengers;
-
- procedure Park( It: in out Car ) is
- begin
- It.Passengers := 0;
- Park( Vehicle( It ) );
- end Park;
-
- function Passengers( It: Car ) return Natural is
- begin
- return It.Passengers;
- end Passengers;
-
- procedure Raise_Top( It: in out Convertible ) is
- begin
- It.Top_Up := True;
- end Raise_Top;
-
- procedure Lower_Top( It: in out Convertible ) is
- begin
- It.Top_Up := False;
- end Lower_Top;
-
- function Top_Up ( It: Convertible ) return Boolean is
- begin
- return It.Top_Up;
- end Top_Up;
-
- procedure Park ( It: in out Convertible ) is
- begin
- It.Top_Up := True;
- Park( Car( It ) );
- end Park;
-
- procedure Raise_Windshield( It: in out Jeep ) is
- begin
- It.Windshield_Up := True;
- end Raise_Windshield;
-
- procedure Lower_Windshield( It: in out Jeep ) is
- begin
- It.Windshield_Up := False;
- end Lower_Windshield;
-
- function Windshield_Up( It: Jeep ) return Boolean is
- begin
- return It.Windshield_Up;
- end Windshield_Up;
-
- procedure Park( It: in out Jeep ) is
- begin
- It.Windshield_Up := True;
- Park( Convertible( It ) );
- end Park;
-end C390004_1;
-
-with Report;
-with Ada.Tags;
-with C390004_1;
-procedure C390004 is
- package DMV renames C390004_1;
-
- The_Vehicle : aliased DMV.Vehicle;
- The_Car : aliased DMV.Car;
- The_Convertible : aliased DMV.Convertible;
- The_Jeep : aliased DMV.Jeep;
-
- type C_Reference is access all DMV.Car'Class;
- type V_Reference is access all DMV.Vehicle'Class;
-
- Designator : V_Reference;
- Storage : Natural;
-
- procedure Valet( It: in out DMV.Vehicle'Class ) is
- begin
- DMV.Park( It );
- end Valet;
-
- procedure TC_Match( Object: DMV.Vehicle'Class;
- Taglet: Ada.Tags.Tag;
- Where : String ) is
- use Ada.Tags;
- begin
- if Object'Tag /= Taglet then
- Report.Failed("Tag mismatch: " & Where);
- end if;
- end TC_Match;
-
- procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 1 or not It.Parked then
- Report.Failed ("Failed Vehicle " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0
- or not It.Parked then
- Report.Failed ("Failed Car " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Convertible;
- TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0
- or not DMV.Top_Up( It ) or not It.Parked then
- Report.Failed ("Failed Convertible " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0
- or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It )
- or not It.Parked then
- Report.Failed ("Failed Jeep " & TC_Message);
- end if;
- end Parking_Validation;
-
- function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag )
- return DMV.Vehicle'Class is
- This_Machine : DMV.Vehicle'Class := It.all;
- begin
- TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
- Storage := DMV.Wheels( This_Machine );
- return This_Machine;
- end Wash;
-
- function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag )
- return DMV.Car'Class is
- This_Machine : DMV.Car'Class := It.all;
- begin
- TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
- Storage := DMV.Wheels( This_Machine );
- return This_Machine;
- end Wash;
-
-begin
-
- Report.Test( "C390004", "Check that the tags of allocated objects "
- & "correctly identify the type of the allocated "
- & "object. Check that tags resulting from "
- & "normal and view conversions. Check tags of "
- & "accessed values designating aliased objects. "
- & "Check function result tags" );
-
- DMV.Set_Wheels( The_Vehicle, 1 );
- DMV.Set_Wheels( The_Car, 2 );
- DMV.Set_Wheels( The_Convertible, 3 );
- DMV.Set_Wheels( The_Jeep, 4 );
-
- Valet( The_Vehicle );
- Valet( The_Car );
- Valet( The_Convertible );
- Valet( The_Jeep );
-
- Parking_Validation( The_Vehicle, "setup" );
- Parking_Validation( The_Car, "setup" );
- Parking_Validation( The_Convertible, "setup" );
- Parking_Validation( The_Jeep, "setup" );
-
--- Check that the tags of allocated objects correctly identify the type
--- of the allocated object.
-
- Designator := new DMV.Vehicle;
- DMV.TC_Check( Designator.all, DMV.T_Veh );
- TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" );
-
- Designator := new DMV.Car;
- DMV.TC_Check( Designator.all, DMV.T_Car );
- TC_Match( Designator.all, DMV.Car'Tag, "allocated Car");
-
- Designator := new DMV.Convertible;
- DMV.TC_Check( Designator.all, DMV.T_Con );
- TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" );
-
- Designator := new DMV.Jeep;
- DMV.TC_Check( Designator.all, DMV.T_Jep );
- TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" );
-
--- Check that view conversion causes the correct dispatch
- DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh );
- DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car );
- DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con );
-
--- And that view conversion does not change the tag
- TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" );
- TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" );
- TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" );
-
--- Check that the tags of accessed values designating aliased objects
--- correctly identify the type of the object.
- Designator := The_Vehicle'Access;
- DMV.TC_Check( Designator.all, DMV.T_Veh );
- TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" );
-
- Designator := The_Car'Access;
- DMV.TC_Check( Designator.all, DMV.T_Car );
- TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" );
-
- Designator := The_Convertible'Access;
- DMV.TC_Check( Designator.all, DMV.T_Con );
- TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" );
-
- Designator := The_Jeep'Access;
- DMV.TC_Check( Designator.all, DMV.T_Jep );
- TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" );
-
--- Check that the tag of a function result correctly evaluates.
--- Check this for class-wide functions. The tag of a class-wide
--- function result should be the tag appropriate to the actual value
--- returned, not the tag of the ancestor type.
- Function_Check: declare
- A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle );
- A_Car : C_Reference := new DMV.Car'( The_Car );
- A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible );
- A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep );
- begin
- DMV.Unpark( A_Vehicle.all );
- DMV.Load_Passengers( A_Car.all, 5 );
- DMV.Load_Passengers( A_Convertible.all, 6 );
- DMV.Load_Passengers( A_Jeep.all, 7 );
- DMV.Lower_Top( DMV.Convertible(A_Convertible.all) );
- DMV.Lower_Top( DMV.Jeep(A_Jeep.all) );
- DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) );
-
- if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4
- or Storage /= 4 then
- Report.Failed("Did not correctly wash Jeep");
- end if;
-
- if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3
- or Storage /= 3 then
- Report.Failed("Did not correctly wash Convertible");
- end if;
-
- if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2
- or Storage /= 2 then
- Report.Failed("Did not correctly wash Car");
- end if;
-
- if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1
- or Storage /= 1 then
- Report.Failed("Did not correctly wash Vehicle");
- end if;
-
- end Function_Check;
-
- Report.Result;
-end C390004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900050.a b/gcc/testsuite/ada/acats/tests/c3/c3900050.a
deleted file mode 100644
index 8a00b26..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900050.a
+++ /dev/null
@@ -1,157 +0,0 @@
--- C3900050.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:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900050.A
--- C3900051.A
--- C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900050 is -- Alert system abstraction.
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
-
- type Alert_Type is tagged private; -- Root tagged type.
-
- procedure Set_Display (A : in out Alert_Type; -- To be inherited by
- D : in Device_Enum); -- all derivatives.
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- root tagged type's private components.
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time;
-
- function Get_Display (A: Alert_Type) return Device_Enum;
-
- function Initial_Values_Okay (A : in Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (A : in Alert_Type)
- return Boolean;
-
-private
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
-end C3900050;
-
-
- --==================================================================--
-
-
-package body C3900050 is -- Alert system abstraction.
-
-
- procedure Set_Display (A : in out Alert_Type;
- D : in Device_Enum) is
- begin
- A.Display_On := D;
- end Set_Display;
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time is
- begin
- return A.Arrival_Time;
- end Get_Time;
-
-
- function Get_Display (A: Alert_Type) return Device_Enum is
- begin
- return A.Display_On;
- end Get_Display;
-
-
- function Initial_Values_Okay (A : in Alert_Type) return Boolean is
- begin
- return (A = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device)); -- availability.
- end Initial_Values_Okay; -- Aggregate with
- -- named associations.
-
- function Bad_Final_Values (A : in Alert_Type) return Boolean is
- begin
- return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C3900050;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900051.a b/gcc/testsuite/ada/acats/tests/c3/c3900051.a
deleted file mode 100644
index d23a62b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900051.a
+++ /dev/null
@@ -1,137 +0,0 @@
--- C3900051.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:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900050.A
--- => C3900051.A
--- C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900050; -- Alert system abstraction.
-package C3900051 is -- Extended alert system abstraction.
-
-
- type Low_Alert_Type is new C3900050.Alert_Type
- with private; -- Private extension of
- -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by
- L : in Integer); -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Get_Level (LA: Low_Alert_Type) return Integer;
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-private
-
- type Low_Alert_Type is new C3900050.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-end C3900051;
-
-
- --==================================================================--
-
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900051 is -- Extended alert system abstraction.
-
- use C3900050; -- Alert system abstraction.
-
-
- procedure Set_Level (LA : in out Low_Alert_Type;
- L : in Integer) is
- begin
- LA.Level := L;
- end Set_Level;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- Set_Level (LA, 1); -- Call newly declared operation.
- Set_Display (Alert_Type(LA),
- Teletype); -- Call parent's operation (type conversion).
- Display (LA);
- end Handle;
-
-
- function Get_Level (LA: Low_Alert_Type) return Integer is
- begin
- return LA.Level;
- end Get_Level;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Alert_Type (LA)) and
- LA.Level = 0);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(LA) /= Alert_Time or
- Get_Display(LA) /= Teletype or
- LA.Level /= 1);
- end Bad_Final_Values;
-
-
-end C3900051;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900052.a b/gcc/testsuite/ada/acats/tests/c3/c3900052.a
deleted file mode 100644
index 11d26db..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900052.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3900052.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:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900050.A
--- C3900051.A
--- => C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900051; -- Extended alert system abstraction.
-package C3900052 is -- Further extended alert system abstraction.
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C3900051.Low_Alert_Type
- with private; -- Private extension of
- -- private extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-private
-
- type Medium_Alert_Type is new C3900051.Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C3900052;
-
-
- --==================================================================--
-
-
-with C3900050; -- Basic alert abstraction.
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900052 is -- Further extended alert system abstraction.
-
- use C3900050; -- Enumeration values directly visible.
- use C3900051; -- Extended alert system abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- Set_Level (MA, 2); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- Set_Display (MA, Console); -- Call inherited operation.
- Display (MA); -- Call doubly inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(MA) /= Alert_Time or
- Get_Display(MA) /= Console or
- Get_Level(MA) /= 2 or
- MA.Action_Officer /= Duty_Officer);
- end Bad_Final_Values;
-
-
-end C3900052;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900053.am b/gcc/testsuite/ada/acats/tests/c3/c3900053.am
deleted file mode 100644
index 8ea3c11..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900053.am
+++ /dev/null
@@ -1,191 +0,0 @@
--- C3900053.AM
---
--- 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 private tagged type declared in a package specification
--- may be extended with a private extension in a different package
--- specification, and that this private extension may in turn be extended
--- by a private extension in a third package.
---
--- Check that each derivative inherits the user-defined primitive
--- subprograms of its parent (including those that its parent inherited),
--- that it may override these inherited primitive subprograms, and that it
--- may also declare its own primitive subprograms.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged private type and two associated primitive
--- subprograms in a package specification. Declare operations to verify
--- the correctness of the components. Declare operations which return
--- values of the type's private components, and which will be
--- inherited by later derivatives.
---
--- Extend the root type with a private extension in a second package
--- specification. Declare a new primitive subprogram for the extension,
--- and override one of the two inherited subprograms. Within the
--- overriding subprogram, utilize type conversion to call the parent's
--- implementation of the same subprogram. Also within the overriding
--- subprogram, call the new primitive subprogram and each inherited
--- subprogram. Declare operations of the private extension which
--- override the verification operations of its parent. Declare operations
--- of the private extension which return values of the extension's
--- private components, and which will be inherited by later derivatives.
---
--- Extend the extension with a private extension in a third package
--- specification. Declare a new primitive subprogram for this private
--- extension, and override one of the three inherited subprograms.
--- Within the overriding subprogram, utilize type conversion to call the
--- parent's implementation of the same subprogram. Also within the
--- overriding subprogram, call the new primitive subprogram and each
--- inherited subprogram. Declare operations of the private extension
--- which override the verification operations of its parent.
---
--- In the main program, declare objects of the root tagged type and
--- the two type extensions. For each object, call the overriding
--- subprogram, and verify the correctness of the components by calling
--- the verification operations.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900050.A
--- C3900051.A
--- C3900052.A
--- => C3900053.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-with C3900050; -- Basic alert abstraction.
-with C3900051; -- Extended alert abstraction.
-with C3900052; -- Further extended alert abstraction.
-
-use C3900050; -- Primitive operations of Alert_Type directly visible.
-
-procedure C3900053 is
-begin
-
- Report.Test ("C390005", "Primitive operation inheritance by type " &
- "extensions: root type is private; all extensions are " &
- "private and declared in different packages");
-
-
- ALERT_SUBTEST: -------------------------------------------------------------
-
- declare
- Alarm : C3900050.Alert_Type; -- Root tagged private type.
- begin
- if not Initial_Values_Okay (Alarm) then
- Report.Failed ("Wrong initial values for Alert_Type");
- end if;
-
- Handle (Alarm);
-
- if Bad_Final_Values (Alarm) then
- Report.Failed ("Wrong values for Alert_Type after Handle");
- end if;
- end Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if C3900050.Display_Count_For (Null_Device) /= 1 or
- C3900050.Display_Count_For (Teletype) /= 0 or
- C3900050.Display_Count_For (Console) /= 0 or
- C3900050.Display_Count_For (Big_Screen) /= 0
- then
- Report.Failed ("Wrong display counts after Alert_Type");
- end if;
-
-
- LOW_ALERT_SUBTEST: ---------------------------------------------------------
-
- declare
- Low_Alarm : C3900051.Low_Alert_Type; -- Priv. ext. of tagged type.
- use C3900051; -- Primitive operations of extension directly visible.
- begin
- if not Initial_Values_Okay (Low_Alarm) then
- Report.Failed ("Wrong initial values for Low_Alert_Type");
- end if;
-
- Handle (Low_Alarm);
-
- if Bad_Final_Values (Low_Alarm) then
- Report.Failed ("Wrong values for Low_Alert_Type after Handle");
- end if;
- end Low_Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if C3900050.Display_Count_For /= (Null_Device => 2,
- Teletype => 1,
- Console => 0,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Low_Alert_Type");
- end if;
-
-
- MEDIUM_ALERT_SUBTEST: ------------------------------------------------------
-
- declare
- Medium_Alarm : C3900052.Medium_Alert_Type; -- Priv. ext. of extension.
- use C3900052; -- Primitive operations of extension directly visible.
- begin
- if not Initial_Values_Okay (Medium_Alarm) then
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
- Handle (Medium_Alarm);
-
- if Bad_Final_Values (Medium_Alarm) then
- Report.Failed ("Wrong values for Medium_Alert_Type after Handle");
- end if;
- end Medium_Alert_Subtest;
-
-
- -- Check final display counts:
-
- if C3900050.Display_Count_For /= (Null_Device => 3,
- Teletype => 2,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Medium_Alert_Type");
- end if;
-
-
- Report.Result;
-
-end C3900053;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900060.a b/gcc/testsuite/ada/acats/tests/c3/c3900060.a
deleted file mode 100644
index b77219c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900060.a
+++ /dev/null
@@ -1,159 +0,0 @@
--- C3900060.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:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900060.A
--- C3900061.A
--- C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900060 is -- Alert system abstraction.
-
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
-
- type Alert_Type is tagged private; -- Root tagged type.
-
- procedure Set_Display (A : in out Alert_Type; -- To be inherited by
- D : in Device_Enum); -- all derivatives.
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- root tagged type's private components.
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time;
-
- function Get_Display (A: Alert_Type) return Device_Enum;
-
- function Initial_Values_Okay (A : in Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (A : in Alert_Type)
- return Boolean;
-
-private
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
-end C3900060;
-
-
- --==================================================================--
-
-
-package body C3900060 is
-
-
- procedure Set_Display (A : in out Alert_Type;
- D : in Device_Enum) is
- begin
- A.Display_On := D;
- end Set_Display;
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time is
- begin
- return A.Arrival_Time;
- end Get_Time;
-
-
- function Get_Display (A: Alert_Type) return Device_Enum is
- begin
- return A.Display_On;
- end Get_Display;
-
-
- function Initial_Values_Okay (A : in Alert_Type) return Boolean is
- begin
- return (A = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device)); -- availability.
- end Initial_Values_Okay; -- Aggregate with
- -- named associations.
-
- function Bad_Final_Values (A : in Alert_Type) return Boolean is
- begin
- return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C3900060;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900061.a b/gcc/testsuite/ada/acats/tests/c3/c3900061.a
deleted file mode 100644
index f776dcd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900061.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3900061.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:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900060.A
--- => C3900061.A
--- C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900060; -- Alert system abstraction.
-package C3900061 is -- Extended alert abstraction.
-
-
- type Low_Alert_Type is new C3900060.Alert_Type
- with private; -- Private extension of
- -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by
- L : in Integer); -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Get_Level (LA: Low_Alert_Type) return Integer;
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-private
-
- type Low_Alert_Type is new C3900060.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-end C3900061;
-
-
- --==================================================================--
-
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900061 is
-
- use C3900060; -- Alert system abstraction.
-
-
- procedure Set_Level (LA : in out Low_Alert_Type;
- L : in Integer) is
- begin
- LA.Level := L;
- end Set_Level;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- Set_Level (LA, 1); -- Call newly declared operation.
- Set_Display (Alert_Type(LA),
- Teletype); -- Call parent's operation (type conversion).
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- function Get_Level (LA: Low_Alert_Type) return Integer is
- begin
- return LA.Level;
- end Get_Level;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Alert_Type (LA)) and
- LA.Level = 0);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(LA) /= Alert_Time or
- Get_Display(LA) /= Teletype or
- LA.Level /= 1);
- end Bad_Final_Values;
-
-
-end C3900061;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900062.a b/gcc/testsuite/ada/acats/tests/c3/c3900062.a
deleted file mode 100644
index 87a1cd5..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900062.a
+++ /dev/null
@@ -1,137 +0,0 @@
--- C3900062.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:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900060.A
--- C3900061.A
--- => C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900061; -- Extended alert system abstraction.
-package C3900062 is -- Further extended alert system abstraction.
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C3900061.Low_Alert_Type
- with record -- Record extension of
- Action_Officer : Person_Enum := Nobody; -- private extension.
- end record;
-
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-end C3900062;
-
-
- --==================================================================--
-
-
-with C3900060; -- Basic alert abstraction.
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900062 is
-
- use C3900060; -- Enumeration values directly visible.
- use C3900061; -- Extended alert system abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- Set_Level (MA, 2); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- Set_Display (MA, Console); -- Call inherited operation.
- Display (MA); -- Call doubly inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(MA) /= Alert_Time or
- Get_Display(MA) /= Console or
- Get_Level(MA) /= 2 or
- MA.Action_Officer /= Duty_Officer);
- end Bad_Final_Values;
-
-
-end C3900062;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900063.am b/gcc/testsuite/ada/acats/tests/c3/c3900063.am
deleted file mode 100644
index 7d88719..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900063.am
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3900063.AM
---
--- 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 private tagged type declared in a package specification
--- may be extended with a private extension in a different package
--- specification, and that this private extension may in turn be extended
--- by a record extension in a third package.
---
--- Check that each derivative inherits the user-defined primitive
--- subprograms of its parent (including those that its parent inherited),
--- that it may override these inherited primitive subprograms, and that it
--- may also declare its own primitive subprograms.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged private type and two associated primitive
--- subprograms in a package specification. Declare operations to verify
--- the correctness of the components. Declare operations which return
--- values of the type's private components, and which will be inherited
--- by later derivatives.
---
--- Extend the root type with a private extension in a second package
--- specification. Declare a new primitive subprogram for the extension,
--- and override one of the two inherited subprograms. Within the
--- overriding subprogram, utilize type conversion to call the parent's
--- implementation of the same subprogram. Also within the overriding
--- subprogram, call the new primitive subprogram and each inherited
--- subprogram. Declare operations of the private extension which
--- override the verification operations of its parent. Declare
--- operations which return values of the extension's private components,
--- and which will be inherited by later derivatives.
---
--- Extend the extension with a record extension in a third package
--- specification. Declare a new primitive subprogram for this record
--- extension, and override one of the three inherited subprograms.
--- Within the overriding subprogram, utilize type conversion to call the
--- parent's implementation of the same subprogram. Also within the
--- overriding subprogram, call the new primitive subprogram and each
--- inherited subprogram. Declare operations of the record extension
--- which override the verification operations of its parent.
---
--- In the main program, declare objects of the root tagged type and
--- the two type extensions. For each object, call the overriding
--- subprogram, and verify the correctness of the components by calling
--- the verification operations.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900060.A
--- C3900061.A
--- C3900062.A
--- => C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-with C3900060; -- Basic alert abstraction.
-with C3900062; -- Further extended alert abstraction.
-
-use C3900060; -- Primitive operations of Alert_Type directly visible.
-
-procedure C3900063 is
-begin
-
- Report.Test ("C390006", "Primitive operation inheritance by type " &
- "extensions: all extensions declared in different " &
- "packages; root type and 1st extension are private, " &
- "2nd extension is record extension");
-
-
- -- The cases for type C3900060.Alert_Type and C3900061.Low_Alert_Type
- -- are tested in C390005. Those subtests are not repeated here.
-
-
- MEDIUM_ALERT_SUBTEST: ------------------------------------------------------
-
- declare
- Medium_Alarm : C3900062.Medium_Alert_Type; -- Rec. ext. of extension.
- use C3900062; -- Primitive operations of extension directly visible.
- begin
- if not Initial_Values_Okay (Medium_Alarm) then
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
- Handle (Medium_Alarm);
-
- if Bad_Final_Values (Medium_Alarm) then
- Report.Failed ("Wrong values for Medium_Alert_Type after Handle");
- end if;
- end Medium_Alert_Subtest;
-
-
- -- Check final display counts:
-
- if C3900060.Display_Count_For /= (Null_Device => 1,
- Teletype => 1,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Medium_Alert_Type");
- end if;
-
-
- Report.Result;
-
-end C3900063;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc/testsuite/ada/acats/tests/c3/c390007.a
deleted file mode 100644
index 46f59f6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390007.a
+++ /dev/null
@@ -1,374 +0,0 @@
--- C390007.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 tag of an object of a tagged type is preserved by
--- type conversion and parameter passing.
---
--- TEST DESCRIPTION:
--- The fact that the tag of an object is not changed is verified by
--- making dispatching calls to primitive operations, and confirming that
--- the proper body is executed. Objects of both specific and class-wide
--- types are checked.
---
--- The dispatching calls are made in two contexts. The first is a
--- straightforward dispatching call made from within a class-wide
--- operation. The second is a redispatch from within a primitive
--- operation.
---
--- For the parameter passing case, the initial class-wide and specific
--- objects are passed directly in calls to the class-wide and primitive
--- operations. The redispatch is accomplished by initializing a local
--- class-wide object in the primitive operation to the value of the
--- formal parameter, and using the local object as the actual in the
--- (re)dispatching call.
---
--- For the type conversion case, the initial class-wide object is assigned
--- a view conversion of an object of a specific type:
---
--- type T is tagged ...
--- type DT is new T with ...
---
--- A : DT;
--- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT.
---
--- The class-wide object is then passed directly in calls to the
--- class-wide and primitive operations. For the initial object of a
--- specific type, however, a view conversion of the object is passed,
--- forcing a non-dispatching call in the primitive operation case. Within
--- the primitive operation, a view conversion of the formal parameter to
--- a class-wide type is then used to force a (re)dispatching call.
---
--- For the type conversion and parameter passing case, a combining of
--- view conversion and parameter passing of initial specific objects are
--- called directly to the class-wide and primitive operations.
---
---
--- CHANGE HISTORY:
--- 28 Jun 95 SAIC Initial prerelease version.
--- 23 Apr 96 SAIC Added use C390007_0 in the main.
---
---!
-
-package C390007_0 is
-
- type Call_ID_Kind is (None, Parent_Outer, Parent_Inner,
- Derived_Outer, Derived_Inner);
-
- type Root_Type is abstract tagged null record;
-
- procedure Outer_Proc (X : in out Root_Type) is abstract;
- procedure Inner_Proc (X : in out Root_Type) is abstract;
-
- procedure ClassWide_Proc (X : in out Root_Type'Class);
-
-end C390007_0;
-
-
- --==================================================================--
-
-
-package body C390007_0 is
-
- procedure ClassWide_Proc (X : in out Root_Type'Class) is
- begin
- Inner_Proc (X);
- end ClassWide_Proc;
-
-end C390007_0;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_1 is
-
- type Param_Parent_Type is new Root_Type with record
- Last_Call : Call_ID_Kind := None;
- end record;
-
- procedure Outer_Proc (X : in out Param_Parent_Type);
- procedure Inner_Proc (X : in out Param_Parent_Type);
-
-end C390007_0.C390007_1;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_1 is
-
- procedure Outer_Proc (X : in out Param_Parent_Type) is
- begin
- X.Last_Call := Parent_Outer;
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Param_Parent_Type) is
- begin
- X.Last_Call := Parent_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_1;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_1.C390007_2 is
-
- type Param_Derived_Type is new Param_Parent_Type with null record;
-
- procedure Outer_Proc (X : in out Param_Derived_Type);
- procedure Inner_Proc (X : in out Param_Derived_Type);
-
-end C390007_0.C390007_1.C390007_2;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_1.C390007_2 is
-
- procedure Outer_Proc (X : in out Param_Derived_Type) is
- Y : Root_Type'Class := X;
- begin
- Inner_Proc (Y); -- Redispatch.
- Root_Type'Class (X) := Y;
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Param_Derived_Type) is
- begin
- X.Last_Call := Derived_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_1.C390007_2;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_3 is
-
- type Convert_Parent_Type is new Root_Type with record
- First_Call : Call_ID_Kind := None;
- Second_Call : Call_ID_Kind := None;
- end record;
-
- procedure Outer_Proc (X : in out Convert_Parent_Type);
- procedure Inner_Proc (X : in out Convert_Parent_Type);
-
-end C390007_0.C390007_3;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_3 is
-
- procedure Outer_Proc (X : in out Convert_Parent_Type) is
- begin
- X.First_Call := Parent_Outer;
- Inner_Proc (Root_Type'Class(X)); -- Redispatch.
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Convert_Parent_Type) is
- begin
- X.Second_Call := Parent_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_3;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_3.C390007_4 is
-
- type Convert_Derived_Type is new Convert_Parent_Type with null record;
-
- procedure Outer_Proc (X : in out Convert_Derived_Type);
- procedure Inner_Proc (X : in out Convert_Derived_Type);
-
-end C390007_0.C390007_3.C390007_4;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_3.C390007_4 is
-
- procedure Outer_Proc (X : in out Convert_Derived_Type) is
- begin
- X.First_Call := Derived_Outer;
- Inner_Proc (Root_Type'Class(X)); -- Redispatch.
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Convert_Derived_Type) is
- begin
- X.Second_Call := Derived_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_3.C390007_4;
-
-
- --==================================================================--
-
-
-with C390007_0.C390007_1.C390007_2;
-with C390007_0.C390007_3.C390007_4;
-use C390007_0;
-
-with Report;
-procedure C390007 is
-begin
- Report.Test ("C390007", "Check that the tag of an object of a tagged " &
- "type is preserved by type conversion and parameter passing");
-
-
- --
- -- Check that tags are preserved by parameter passing:
- --
-
- Parameter_Passing_Subtest:
- declare
- Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
- Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
-
- ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A;
- ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B;
-
- use C390007_0.C390007_1;
- use C390007_0.C390007_1.C390007_2;
- begin
-
- Outer_Proc (Specific_A);
- if Specific_A.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "primitive operation with specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (Specific_B);
- if Specific_B.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "class-wide operation with specific operand");
- end if;
-
- Outer_Proc (ClassWide_A);
- if ClassWide_A.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "primitive operation with class-wide operand");
- end if;
-
- C390007_0.ClassWide_Proc (ClassWide_B);
- if ClassWide_B.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "class-wide operation with class-wide operand");
- end if;
-
- end Parameter_Passing_Subtest;
-
-
- --
- -- Check that tags are preserved by type conversion:
- --
-
- Type_Conversion_Subtest:
- declare
- Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
- Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
-
- ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class :=
- C390007_0.C390007_3.Convert_Parent_Type(Specific_A);
- ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class :=
- C390007_0.C390007_3.Convert_Parent_Type(Specific_B);
-
- use C390007_0.C390007_3;
- use C390007_0.C390007_3.C390007_4;
- begin
-
- Outer_Proc (Convert_Parent_Type(Specific_A));
- if (Specific_A.First_Call /= Parent_Outer) or
- (Specific_A.Second_Call /= Derived_Inner)
- then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "primitive operation with specific operand");
- end if;
-
- Outer_Proc (ClassWide_A);
- if (ClassWide_A.First_Call /= Derived_Outer) or
- (ClassWide_A.Second_Call /= Derived_Inner)
- then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "primitive operation with class-wide operand");
- end if;
-
- C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B));
- if (Specific_B.Second_Call /= Derived_Inner) then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "class-wide operation with specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (ClassWide_B);
- if (ClassWide_A.Second_Call /= Derived_Inner) then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "class-wide operation with class-wide operand");
- end if;
-
- end Type_Conversion_Subtest;
-
-
- --
- -- Check that tags are preserved by type conversion and parameter passing:
- --
-
- Type_Conversion_And_Parameter_Passing_Subtest:
- declare
- Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
- Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
-
- use C390007_0.C390007_1;
- use C390007_0.C390007_1.C390007_2;
- begin
-
- Outer_Proc (Param_Parent_Type (Specific_A));
- if Specific_A.Last_Call /= Parent_Outer then
- Report.Failed ("Type conversion and parameter passing: tag not " &
- "preserved in call to primitive operation with " &
- "specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B));
- if Specific_B.Last_Call /= Derived_Inner then
- Report.Failed ("Type conversion and parameter passing: tag not " &
- "preserved in call to class-wide operation with " &
- "specific operand");
- end if;
-
- end Type_Conversion_And_Parameter_Passing_Subtest;
-
-
- Report.Result;
-
-end C390007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390010.a b/gcc/testsuite/ada/acats/tests/c3/c390010.a
deleted file mode 100644
index 1590e50..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390010.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- C390010.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 S is a subtype of a tagged type T, and if S is
--- constrained, then the allowable values of S'Class are only those
--- that, when converted to T, belong to S.
---
--- TEST DESCRIPTION:
--- This test defines a small tagged hierarchy of discriminated tagged
--- records, and constrained subtypes of those tagged record types.
--- It then uses access to the classwide of the constrained subtype
--- to check the objective.
---
---
--- CHANGE HISTORY:
--- 09 APR 96 SAIC Initial version
--- 03 NOV 96 SAIC Revised for 2.1 release
--- 31 DEC 97 EDS Restored use of intermediate access variable
--- to eliminate raising of Program_Error
--- 13 SEP 99 RLB Repaired previous change to avoid premature
--- subtype check.
--- 28 JUN 02 RLB Added pragma Elaborate_All (Report);.
---!
-
------------------------------------------------------------------ C390010_0
-
-with Report; pragma Elaborate_All (Report);
-package C390010_0 is
-
- -- the defined subprograms will allow checking the placement of
- -- constraint_checks
-
- -- define a discriminated tagged type, and a constrained subtype of
- -- that type:
-
- type Discr_Tag_Record( Disc: Boolean ) is tagged record
- FieldA : Character := 'A';
- case Disc is
- when True => FieldB : Character := 'B';
- when False => FieldC : Character := 'C';
- end case;
- end record;
-
- procedure Dispatching_Op( DTO : in out Discr_Tag_Record );
-
- Authentic : Boolean := Report.Ident_Bool( True );
-
- subtype True_Record is Discr_Tag_Record( Authentic );
-
-
- -- derive a type, "passing through" one discriminant, adding one
- -- discriminant, and a constrained subtype of THAT type:
-
- type Derived_Record( Disc1, Disc2: Boolean ) is
- new Discr_Tag_Record( Disc1 ) with record
- FieldD : Character := 'D';
- case Disc2 is
- when True => FieldE : Character := 'E';
- when False => FieldF : Character := 'F';
- end case;
- end record;
-
- procedure Dispatching_Op( DR : in out Derived_Record );
-
- subtype True_True_Derived is Derived_Record( Authentic, Authentic );
-
-
- -- now, define an access to classwide type, using the classwide from the
- -- constrained subtype of the root (or parent) type:
-
- type Subtype_Parent_Class_Access is access all True_Record'Class;
- type Parent_Class_Access is access all Discr_Tag_Record'Class;
-
- procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access );
-
-end C390010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0
-
-with Report;
-with TCTouch;
-package body C390010_0 is
-
- procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is
- begin
- TCTouch.Touch('1'); --------------------------------------------------- 1
- if DTO.Disc then
- TCTouch.Touch(DTO.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(DTO.FieldC); ------------------------------------------ C
- end if;
- end Dispatching_Op;
-
-
- procedure Dispatching_Op( DR : in out Derived_Record ) is
- begin
- TCTouch.Touch('2'); --------------------------------------------------- 2
- if DR.Disc1 then
- TCTouch.Touch(DR.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(DR.FieldC); ------------------------------------------ C
- end if;
- if DR.Disc2 then
- TCTouch.Touch(DR.FieldE); ------------------------------------------ E
- else
- TCTouch.Touch(DR.FieldF); ------------------------------------------ F
- end if;
- end Dispatching_Op;
-
- procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is
- begin
-
- -- the following line is the "heart" of this test, objects of all types
- -- covered by the classwide type will be passed to this subprogram in
- -- the execution of the test.
- if SPCA.Disc then
- TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C
- end if;
-
- Dispatching_Op( SPCA.all ); -- check that this dispatches correctly,
- -- with discriminants correctly represented
-
- end PCW_Op;
-
-end C390010_0;
-
-------------------------------------------------------------------- C390010
-
-with Report;
-with TCTouch;
-with C390010_0;
-procedure C390010 is
-
- package CP renames C390010_0;
-
- procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is
- begin
-
- -- the implicit conversion from the general access parameter to the more
- -- constrained subtype access type in the following call should cause
- -- Constraint_Error in the cases where the object is not correctly
- -- constrained
-
- CP.PCW_Op( Item.all'Access );
-
- exception
- when Constraint_Error => TCTouch.Touch('X'); -------------------------- X
- when others => Report.Failed("Unanticipated exception in Check_Element");
-
- end Check_Element;
-
- An_Item : CP.Parent_Class_Access;
-
-begin -- Main test procedure.
-
- Report.Test ("C390010", "Check that if S is a subtype of a tagged type " &
- "T, and if S is constrained, then the allowable " &
- "values of S'Class are only those that, when " &
- "converted to T, belong to S" );
-
- An_Item := new CP.Discr_Tag_Record(True);
- Check_Element( An_Item );
- TCTouch.Validate("B1B","Case 1");
-
- An_Item := new CP.Discr_Tag_Record(False);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 2");
-
- An_Item := new CP.True_Record;
- Check_Element( An_Item );
- TCTouch.Validate("B1B","Case 3");
-
- An_Item := new CP.Derived_Record(False, False);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 4");
-
- An_Item := new CP.Derived_Record(False, True);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 5");
-
- An_Item := new CP.Derived_Record(True, False);
- Check_Element( An_Item );
- TCTouch.Validate("B2BF","Case 6");
-
- An_Item := new CP.True_True_Derived;
- Check_Element( An_Item );
- TCTouch.Validate("B2BE","Case 7");
-
- Report.Result;
-
-end C390010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390011.a b/gcc/testsuite/ada/acats/tests/c3/c390011.a
deleted file mode 100644
index 74cf0eb..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390011.a
+++ /dev/null
@@ -1,250 +0,0 @@
--- C390011.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 tagged types declared within generic package declarations
--- generate distinct tags for each instance of the generic.
---
--- TEST DESCRIPTION:
--- This test defines a very simple generic package (with the expectation
--- that it should be easily be shared), and a few instances of that
--- package. In true user-like fashion, two of the instances are identical
--- (to wit: IIO is new Integer_IO(Integer)). The tags generated for each
--- of them are placed into a list. The last action of the test is to
--- check that everything in the list is unique.
---
--- Almost as an aside, this test defines functions that return T'Base and
--- T'Class, and then exercises these functions.
---
--- (JPR) persistent objects really need a function like:
--- function Get_Object return T'class;
---
---
--- CHANGE HISTORY:
--- 20 OCT 95 SAIC Initial version
--- 23 APR 96 SAIC Commentary Corrections 2.1
---
---!
-
------------------------------------------------------------------ C390011_0
-
-with Ada.Tags;
-package C390011_0 is
-
- procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String );
-
- procedure Check_List_For_Duplicates;
-
-end C390011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C390011_0 is
-
- use type Ada.Tags.Tag;
- type SP is access String;
-
- type List_Item;
- type List_P is access List_Item;
- type List_Item is record
- The_Tag : Ada.Tags.Tag;
- Exp_Name : SP;
- Ext_Tag : SP;
- Next : List_P;
- end record;
-
- The_List : List_P;
-
- procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is
- begin -- prepend the tag information to the list
- The_List := new List_Item'( The_Tag => T,
- Exp_Name => new String'(X_Name),
- Ext_Tag => new String'(X_Tag),
- Next => The_List );
- end Add_Tag_To_List;
-
- procedure Check_List_For_Duplicates is
- Finger : List_P;
- Thumb : List_P := The_List;
- begin --
- while Thumb /= null loop
- Finger := Thumb.Next;
- while Finger /= null loop
- -- Check that the tag is unique
- if Finger.The_Tag = Thumb.The_Tag then
- Report.Failed("Duplicate Tag");
- end if;
-
- -- Check that the Expanded name is unique
- if Finger.Exp_Name.all = Thumb.Exp_Name.all then
- Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats");
- end if;
-
- -- Check that the External Tag is unique
-
- if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then
- Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats");
- end if;
- Finger := Finger.Next;
- end loop;
- Thumb := Thumb.Next;
- end loop;
- end Check_List_For_Duplicates;
-
-begin
- -- some things I just don't trust...
- if The_List /= null then
- Report.Failed("Implicit default for The_List not null");
- end if;
-end C390011_0;
-
------------------------------------------------------------------ C390011_1
-
-generic
- type Index is (<>);
- type Item is private;
-package C390011_1 is
-
- type List is array(Index range <>) of Item;
- type ListP is access all List;
-
- type Table is tagged record
- Data: ListP;
- end record;
-
- function Sort( T: in Table'Class ) return Table'Class;
-
- function Stable_Table return Table'Class;
-
- function Table_End( T: Table ) return Index'Base;
-
-end C390011_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C390011_1 is
-
- -- In a user program this package would DO something
-
- function Sort( T: in Table'Class ) return Table'Class is
- begin
- return T;
- end Sort;
-
- Empty : Table'Class := Table'( Data => null );
-
- function Stable_Table return Table'Class is
- begin
- return Empty;
- end Stable_Table;
-
- function Table_End( T: Table ) return Index'Base is
- begin
- return Index'Base( T.Data.all'Last );
- end Table_End;
-
-end C390011_1;
-
------------------------------------------------------------------ C390011_2
-
-with C390011_1;
-package C390011_2 is new C390011_1( Index => Character, Item => Float );
-
------------------------------------------------------------------ C390011_3
-
-with C390011_1;
-package C390011_3 is new C390011_1( Index => Character, Item => Float );
-
------------------------------------------------------------------ C390011_4
-
-with C390011_1;
-package C390011_4 is new C390011_1( Index => Integer, Item => Character );
-
------------------------------------------------------------------ C390011_5
-
-with C390011_3;
-with C390011_4;
-package C390011_5 is
-
- type Table_3 is new C390011_3.Table with record
- Serial_Number : Integer;
- end record;
-
- type Table_4 is new C390011_4.Table with record
- Serial_Number : Integer;
- end record;
-
-end C390011_5;
-
--- no package body C390011_5 required
-
-------------------------------------------------------------------- C390011
-
-with Report;
-with C390011_0;
-with C390011_2;
-with C390011_3;
-with C390011_4;
-with C390011_5;
-with Ada.Tags;
-procedure C390011 is
-
-begin -- Main test procedure.
-
- Report.Test ("C390011", "Check that tagged types declared within " &
- "generic package declarations generate distinct " &
- "tags for each instance of the generic. " &
- "Check that 'Base may be used as a subtype mark. " &
- "Check that T'Base and T'Class are allowed as " &
- "the subtype mark in a function result" );
-
- -- build the tag information table
- C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_2.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_3.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_4.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) );
-
- -- preform the check for distinct tags
- C390011_0.Check_List_For_Duplicates;
-
- Report.Result;
-
-end C390011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006a.ada b/gcc/testsuite/ada/acats/tests/c3/c39006a.ada
deleted file mode 100644
index 7e5f43d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006a.ada
+++ /dev/null
@@ -1,207 +0,0 @@
--- C39006A.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 AN ATTEMPT IS MADE TO CALL A
--- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE
--- FOLLOWING:
--- A) A FUNCTION IS CALLED IN THE INITIALIZATION EXPRESSION OF A
--- SCALAR VARIABLE OR A RECORD COMPONENT, AND THE SCALAR OR
--- RECORD VARIABLE'S DECLARATION IS ELABORATED BEFORE THE
--- SUBPROGRAM BODY IS ELABORATED.
-
--- TBN 8/14/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39006A IS
-
-BEGIN
- TEST ("C39006A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " &
- "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " &
- "BODY HAS NOT YET BEEN ELABORATED");
- BEGIN
- DECLARE
-
- FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER;
-
- VAR1 : INTEGER := INIT_1 (1);
-
- FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN (A + IDENT_INT(1));
- END INIT_1;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 1");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
-
- FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER;
-
- TYPE REC1 IS
- RECORD
- NUMBER : INTEGER := INIT_2 (2);
- END RECORD;
-
- VAR2 : REC1;
-
- FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN (A + IDENT_INT(1));
- END INIT_2;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 2");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DECLARE
-
- FUNCTION F1 RETURN INTEGER;
-
- PACKAGE PACK IS
- VAR1 : INTEGER := F1;
- END PACK;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(1));
- END F1;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 3");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- DECLARE
-
- PACKAGE PACK IS
- FUNCTION F2 RETURN INTEGER;
- VAR2 : INTEGER := F2;
- END PACK;
-
- PACKAGE BODY PACK IS
- FUNCTION F2 RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(3));
- END F2;
- END PACK;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 4");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- DECLARE
-
- FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER;
-
- GENERIC
- PACKAGE Q IS
- VAR1 : INTEGER := INIT_3 (1);
- END Q;
-
- PACKAGE NEW_Q IS NEW Q;
-
- FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN (A + IDENT_INT(3));
- END INIT_3;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 5");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- DECLARE
-
- FUNCTION FUN RETURN INTEGER;
-
- TYPE PARAM IS
- RECORD
- COMP : INTEGER := FUN;
- END RECORD;
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE GP IS
- OBJ : T;
- END GP;
-
- PACKAGE INST IS NEW GP(PARAM);
-
- FUNCTION FUN RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(3));
- END FUN;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 6");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
-
- RESULT;
-END C39006A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006b.ada b/gcc/testsuite/ada/acats/tests/c3/c39006b.ada
deleted file mode 100644
index f7b4f27..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006b.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- C39006B.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 AN ATTEMPT IS MADE TO CALL A
--- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE
--- FOLLOWING:
--- B) THE SUBPROGRAM IS CALLED IN A PACKAGE BODY.
--- C) THE SUBPROGRAM IS AN ACTUAL GENERIC PARAMETER CALLED DURING
--- ELABORATION OF THE GENERIC INSTANTIATION.
--- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL
--- PACKAGE BODY.
-
--- TBN 8/19/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39006B IS
-
-BEGIN
- TEST ("C39006B", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " &
- "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " &
- "BODY HAS NOT YET BEEN ELABORATED");
- BEGIN
- DECLARE
- PACKAGE PACK IS
- FUNCTION FUN RETURN INTEGER;
- PROCEDURE PROC (A : IN OUT INTEGER);
- END PACK;
-
- PACKAGE BODY PACK IS
-
- VAR1 : INTEGER := 0;
-
- PROCEDURE PROC (A : IN OUT INTEGER) IS
- BEGIN
- IF A = IDENT_INT(1) THEN
- A := A + FUN;
- FAILED ("PROGRAM_ERROR NOT RAISED - 1");
- ELSE
- A := IDENT_INT(1);
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "1");
- END PROC;
-
- PACKAGE INSIDE IS
- END INSIDE;
-
- PACKAGE BODY INSIDE IS
- BEGIN
- PROC (VAR1);
- PROC (VAR1);
- END INSIDE;
-
- FUNCTION FUN RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(1));
- END FUN;
-
- BEGIN
- NULL;
- END PACK;
-
- BEGIN
- NULL;
- END;
- END;
-
- BEGIN
- DECLARE
- FUNCTION INIT_2 RETURN INTEGER;
-
- GENERIC
- WITH FUNCTION FF RETURN INTEGER;
- PACKAGE P IS
- Y : INTEGER;
- END P;
-
- GLOBAL_INT : INTEGER := IDENT_INT(1);
-
- PACKAGE BODY P IS
- BEGIN
- IF GLOBAL_INT = 1 THEN
- Y := FF;
- END IF;
- END P;
-
- PACKAGE N IS
- PACKAGE NEW_P IS NEW P(INIT_2);
- END N;
-
- FUNCTION INIT_2 RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT (1));
- END INIT_2;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 2");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- DECLARE
-
- PROCEDURE ADD1 (A : IN OUT INTEGER);
-
- PACKAGE P IS
- VAR : INTEGER := IDENT_INT(1);
- END P;
-
- PACKAGE BODY P IS
- BEGIN
- IF VAR = 1 THEN
- ADD1 (VAR);
- FAILED ("PROGRAM_ERROR NOT RAISED - 3");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END P;
-
- PROCEDURE ADD1 (A : IN OUT INTEGER) IS
- BEGIN
- A := A + IDENT_INT(1);
- END ADD1;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C39006B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada b/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada
deleted file mode 100644
index c29dd6f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C39006C0M.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 AN ATTEMPT IS MADE TO CALL A
--- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE
--- FOLLOWING:
--- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL
--- PACKAGE BODY SUBUNIT THAT IS IN C39006C1.ADA.
-
--- SEPARATE FILES ARE:
--- C39006C0M THE MAIN PROCEDURE.
--- C39006C1 A SUBUNIT PACKAGE BODY.
-
--- TBN 8/19/86
--- LDC 5/26/88 CHANGED TEST NAME PARAMETER FROM C39006C0M TO
--- C39006C IN THE TEST CALL.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39006C0M IS
-
- PACKAGE CALL_TEST_FIRST IS
- END CALL_TEST_FIRST;
-
- PACKAGE BODY CALL_TEST_FIRST IS
- BEGIN
- TEST ("C39006C", "CHECK THAT PROGRAM_ERROR IS RAISED IF " &
- "THE SUBPROGRAM WHOSE BODY HAS NOT BEEN " &
- "ELABORATED IS CALLED DURING " &
- "ELABORATION OF AN OPTIONAL PACKAGE " &
- "BODY SUBUNIT");
- END CALL_TEST_FIRST;
-
- PROCEDURE ADD1 (A : IN OUT INTEGER);
-
- PACKAGE C39006C1 IS
- VAR : INTEGER := IDENT_INT(1);
- END C39006C1;
-
- PACKAGE BODY C39006C1 IS SEPARATE;
-
- PROCEDURE ADD1 (A : IN OUT INTEGER) IS
- BEGIN
- A := A + IDENT_INT(1);
- END ADD1;
-
-BEGIN
- RESULT;
-END C39006C0M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada b/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada
deleted file mode 100644
index 0665cf0..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada
+++ /dev/null
@@ -1,41 +0,0 @@
--- C39006C1.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.
---*
--- PACKAGE BODY SUBUNIT FOR C39006C0M.ADA.
-
--- TBN 8/19/86
-
-SEPARATE (C39006C0M)
-PACKAGE BODY C39006C1 IS
-BEGIN
- IF VAR = IDENT_INT(1) THEN
- ADD1 (VAR);
- FAILED ("PROGRAM_ERROR NOT RAISED");
- END IF;
-EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
-END C39006C1;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006d.ada b/gcc/testsuite/ada/acats/tests/c3/c39006d.ada
deleted file mode 100644
index f2969e8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006d.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- C39006D.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 FUNCTION IS USED IN A DEFAULT EXPRESSION FOR A
--- SUBPROGRAM OR FORMAL GENERIC PARAMETER, PROGRAM_ERROR IS RAISED
--- WHEN AN ATTEMPT IS MADE TO EVALUATE THE DEFAULT EXPRESSION,
--- BECAUSE THE FUNCTION'S BODY HAS NOT BEEN ELABORATED YET.
-
--- TBN 8/20/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39006D IS
-
-BEGIN
- TEST ("C39006D", "CHECK THAT IF A FUNCTION IS USED IN A DEFAULT " &
- "EXPRESSION FOR A SUBPROGRAM OR FORMAL GENERIC " &
- "PARAMETER, PROGRAM_ERROR IS RAISED WHEN AN " &
- "ATTEMPT IS MADE TO EVALUATE THE DEFAULT " &
- "EXPRESSION");
- DECLARE
- FUNCTION FUN RETURN INTEGER;
-
- PACKAGE P IS
- PROCEDURE DEFAULT (A : INTEGER := FUN);
- END P;
-
- PACKAGE BODY P IS
- PROCEDURE DEFAULT (A : INTEGER := FUN) IS
- B : INTEGER := 1;
- BEGIN
- B := B + IDENT_INT(A);
- END DEFAULT;
- BEGIN
- DEFAULT (2);
- DEFAULT;
- FAILED ("PROGRAM_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END P;
-
- FUNCTION FUN RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(1));
- END FUN;
- BEGIN
- NULL;
- END;
-
- BEGIN
- DECLARE
- FUNCTION INIT_1 RETURN INTEGER;
-
- GENERIC
- LENGTH : INTEGER := INIT_1;
- PACKAGE P IS
- TYPE ARRAY1 IS ARRAY (1 .. LENGTH) OF INTEGER;
- END P;
-
- PACKAGE NEW_P1 IS NEW P (4);
- PACKAGE NEW_P2 IS NEW P;
-
- FUNCTION INIT_1 RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(2));
- END INIT_1;
-
- BEGIN
- FAILED ("PROGRAM_ERROR NOT RAISED - 2");
- END;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- DECLARE
- FUNCTION INIT_2 RETURN INTEGER;
-
- GLOBAL_INT : INTEGER := IDENT_INT(1);
-
- GENERIC
- PACKAGE Q IS
- PROCEDURE ADD1 (A : INTEGER := INIT_2);
- END Q;
-
- PACKAGE BODY Q IS
- PROCEDURE ADD1 (A : INTEGER := INIT_2) IS
- B : INTEGER;
- BEGIN
- B := A;
- END ADD1;
- BEGIN
- IF GLOBAL_INT = IDENT_INT(1) THEN
- ADD1;
- FAILED ("PROGRAM_ERROR NOT RAISED - 3");
- ELSE
- ADD1 (2);
- END IF;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END Q;
-
- PACKAGE NEW_Q IS NEW Q;
-
- FUNCTION INIT_2 RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT(1));
- END INIT_2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C39006D;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006e.ada b/gcc/testsuite/ada/acats/tests/c3/c39006e.ada
deleted file mode 100644
index 77e5271..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006e.ada
+++ /dev/null
@@ -1,213 +0,0 @@
--- C39006E.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 NOT RAISED IF A SUBPROGRAM'S BODY HAS
--- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING:
--- A) A SUBPROGRAM CAN APPEAR IN A NON-ELABORATED DECLARATIVE PART
--- OR PACKAGE SPECIFICATION BEFORE ITS BODY.
-
--- TBN 8/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39006E IS
-
-BEGIN
- TEST ("C39006E", "CHECK THAT PROGRAM_ERROR IS NOT RAISED IF A " &
- "SUBPROGRAM IS CALLED IN A NON-ELABORATED " &
- "DECLARATIVE PART OR PACKAGE SPECIFICATION " &
- "BEFORE ITS BODY IS ELABORATED");
- DECLARE -- (A)
-
- FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER;
-
- PACKAGE P IS
- PROCEDURE USE_INIT1;
- END P;
-
- PACKAGE BODY P IS
- PROCEDURE USE_INIT1 IS
- BEGIN
- IF NOT EQUAL (3, 3) THEN
- DECLARE
- X : INTEGER := INIT_1 (1);
- BEGIN
- NULL;
- END;
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END USE_INIT1;
-
- BEGIN
- USE_INIT1;
- END P;
-
- FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN (A + IDENT_INT(1));
- END INIT_1;
-
- BEGIN -- (A)
- NULL;
- END; -- (A)
-
- DECLARE -- (B)
-
- PROCEDURE INIT_2 (A : IN OUT INTEGER);
-
- PACKAGE P IS
- FUNCTION USE_INIT2 RETURN BOOLEAN;
- END P;
-
- PACKAGE BODY P IS
- FUNCTION USE_INIT2 RETURN BOOLEAN IS
- BEGIN
- IF NOT EQUAL (3, 3) THEN
- DECLARE
- X : INTEGER;
- BEGIN
- INIT_2 (X);
- END;
- END IF;
- RETURN IDENT_BOOL (FALSE);
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 2");
- RETURN FALSE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- RETURN FALSE;
- END USE_INIT2;
- BEGIN
- IF USE_INIT2 THEN
- FAILED ("INCORRECT RESULTS FROM FUNCTION CALL - 2");
- END IF;
- END P;
-
- PROCEDURE INIT_2 (A : IN OUT INTEGER) IS
- BEGIN
- A := A + IDENT_INT(1);
- END INIT_2;
-
- BEGIN -- (B)
- NULL;
- END; -- (B)
-
- DECLARE -- (C)
- FUNCTION INIT_3 RETURN INTEGER;
-
- PACKAGE Q IS
- VAR : INTEGER;
- END Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF NOT EQUAL (3, 3) THEN
- VAR := INIT_3;
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 3");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END Q;
-
- FUNCTION INIT_3 RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (1);
- END INIT_3;
-
- BEGIN -- (C)
- NULL;
- END; -- (C)
-
- DECLARE -- (D)
- PROCEDURE INIT_4 (A : IN OUT INTEGER);
-
- PACKAGE Q IS
- VAR : INTEGER := 1;
- END Q;
-
- PACKAGE BODY Q IS
- BEGIN
- IF NOT EQUAL (3, 3) THEN
- INIT_4 (VAR);
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 4");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END Q;
-
- PROCEDURE INIT_4 (A : IN OUT INTEGER) IS
- BEGIN
- A := IDENT_INT (4);
- END INIT_4;
-
- BEGIN -- (D)
- NULL;
- END; -- (D)
-
- BEGIN -- (E)
-
- DECLARE
- FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER;
-
- PROCEDURE USE_INIT5 IS
- PACKAGE Q IS
- X : INTEGER := INIT_5 (1);
- END Q;
- USE Q;
- BEGIN
- X := IDENT_INT (5);
-
- END USE_INIT5;
-
- FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN (A + IDENT_INT(1));
- END INIT_5;
-
- BEGIN
- USE_INIT5;
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 5");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
-
- END; -- (E)
-
- RESULT;
-END C39006E;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada b/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada
deleted file mode 100644
index 58a9b89..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada
+++ /dev/null
@@ -1,44 +0,0 @@
--- C39006F0.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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS
--- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING:
--- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO
--- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE
--- SUBPROGRAM.
-
--- THIS SUBPROGRAM LIBRARY UNIT IS USED BY C39006F2.ADA.
-
--- HISTORY:
--- TBN 08/22/86 CREATED ORIGINAL TEST.
--- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL
--- TO 'TEST'.
-
-WITH REPORT; USE REPORT;
-
-FUNCTION C39006F0 (A : INTEGER) RETURN INTEGER IS
-BEGIN
- RETURN (IDENT_INT(A));
-END C39006F0;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada b/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada
deleted file mode 100644
index b90477d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada
+++ /dev/null
@@ -1,42 +0,0 @@
--- C39006F1.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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS
--- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING:
--- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO
--- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE
--- SUBPROGRAM.
-
--- THIS LIBRARY PACKAGE SPECIFICATION IS USED BY C39006F3M.ADA.
-
--- HISTORY:
--- TBN 08/22/86 CREATED ORIGINAL TEST.
--- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL
--- TO 'TEST'.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-PACKAGE C39006F1 IS
- PROCEDURE REQUIRE_BODY;
-END C39006F1;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada b/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada
deleted file mode 100644
index 2559b59..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- C39006F2.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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS
--- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING:
--- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO
--- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE
--- SUBPROGRAM.
-
--- THIS LIBRARY PACKAGE BODY IS USED BY C39006F3M.ADA.
-
--- HISTORY:
--- TBN 08/22/86 CREATED ORIGINAL TEST.
--- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL
--- TO 'TEST'.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-WITH C39006F0;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (C39006F0, REPORT);
-
-PACKAGE BODY C39006F1 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
-BEGIN
- TEST ("C39006F", "CHECK THAT NO PROGRAM_ERROR IS RAISED IF A " &
- "SUBPROGRAM'S BODY HAS BEEN ELABORATED " &
- "BEFORE IT IS CALLED, WHEN A SUBPROGRAM " &
- "LIBRARY UNIT IS USED IN ANOTHER UNIT AND " &
- "PRAGMA ELABORATE IS USED");
- BEGIN
- DECLARE
- VAR1 : INTEGER := C39006F0 (IDENT_INT(1));
- BEGIN
- IF VAR1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- END;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- DECLARE
- VAR2 : INTEGER := 1;
-
- PROCEDURE CHECK (B : IN OUT INTEGER) IS
- BEGIN
- B := C39006F0 (IDENT_INT(2));
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END CHECK;
- BEGIN
- CHECK (VAR2);
- IF VAR2 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- END;
-
- DECLARE
- PACKAGE P IS
- VAR3 : INTEGER;
- END P;
-
- PACKAGE BODY P IS
- BEGIN
- VAR3 := C39006F0 (IDENT_INT(3));
- IF VAR3 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED - 3");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 3");
- END P;
- BEGIN
- NULL;
- END;
-
- DECLARE
- GENERIC
- VAR4 : INTEGER := 1;
- PACKAGE Q IS
- TYPE ARRAY_TYP1 IS ARRAY (1 .. VAR4) OF INTEGER;
- ARRAY_1 : ARRAY_TYP1;
- END Q;
-
- PACKAGE NEW_Q IS NEW Q (C39006F0 (IDENT_INT(4)));
-
- USE NEW_Q;
-
- BEGIN
- IF ARRAY_1'LAST /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- END;
-
-END C39006F1;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada b/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada
deleted file mode 100644
index 206a475..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada
+++ /dev/null
@@ -1,49 +0,0 @@
--- C39006F3M.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 NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS
--- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING:
--- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO
--- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE
--- SUBPROGRAM.
-
--- SEPARATE FILES ARE:
--- C39006F0 A LIBRARY FUNCTION.
--- C39006F1 A LIBRARY PACKAGE SPECIFICATION.
--- C39006F2 A LIBRARY PACKAGE BODY.
--- C39006F3M (THIS FILE) THE MAIN PROCEDURE.
-
--- HISTORY:
--- TBN 08/22/86 CREATED ORIGINAL TEST.
--- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL
--- TO 'TEST'.
-
-WITH C39006F1;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C39006F3M IS
-BEGIN
- RESULT;
-END C39006F3M;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39006g.ada b/gcc/testsuite/ada/acats/tests/c3/c39006g.ada
deleted file mode 100644
index 48990a4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39006g.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C39006G.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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO CALL A
--- SUBPROGRAM WHOSE BODY IS NOT YET ELABORATED. USE A PACKAGE
--- WITH OPTIONAL BODY, WHERE THE SUBPROGRAM IS CALLED IN THE BODY.
-
--- HISTORY:
--- BCB 08/01/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C39006G IS
-
- PROCEDURE INIT (X : IN OUT INTEGER);
-
- PACKAGE P IS
- END P;
-
- PACKAGE BODY P IS
- X : INTEGER := IDENT_INT(5);
- BEGIN
- TEST ("C39006G", "CHECK THAT PROGRAM_ERROR IS RAISED BY " &
- "AN ATTEMPT TO CALL A SUBPROGRAM WHOSE " &
- "BODY IS NOT YET ELABORATED. USE A " &
- "PACKAGE WITH OPTIONAL BODY, WHERE THE " &
- "SUBPROGRAM IS CALLED IN THE BODY");
- INIT(X);
- FAILED ("NO EXCEPTION RAISED");
- IF X /= IDENT_INT(10) THEN
- COMMENT ("TOTALLY IRRELEVANT");
- END IF;
- RESULT;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- RESULT;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION WAS RAISED");
- RESULT;
- END P;
-
- PROCEDURE INIT (X : IN OUT INTEGER) IS
- BEGIN
- X := IDENT_INT(10);
- END INIT;
-
-BEGIN
- NULL;
-END C39006G;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39007a.ada b/gcc/testsuite/ada/acats/tests/c3/c39007a.ada
deleted file mode 100644
index e25d96a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39007a.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- C39007A.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 AN ATTEMPT IS MADE TO
--- INSTANTIATE A GENERIC UNIT WHOSE BODY HAS NOT BEEN ELABORATED.
--- CHECK THE FOLLOWING CASE:
--- A) A SIMPLE CASE WHERE THE GENERIC UNIT BODY OCCURS LATER IN
--- THE SAME DECLARATIVE PART.
-
--- TBN 9/12/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C39007A IS
-
-BEGIN
- TEST ("C39007A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " &
- "ATTEMPT IS MADE TO INSTANTIATE A GENERIC " &
- "UNIT WHOSE BODY HAS NOT BEEN ELABORATED, " &
- "BUT OCCURS IN THE SAME DECLARATIVE PART");
-
- BEGIN
- IF EQUAL (1, 1) THEN
- DECLARE
- GENERIC
- PACKAGE P IS
- A : INTEGER;
- PROCEDURE ASSIGN (X : OUT INTEGER);
- END P;
-
- PACKAGE NEW_P IS NEW P;
-
- PACKAGE BODY P IS
- PROCEDURE ASSIGN (X : OUT INTEGER) IS
- BEGIN
- X := IDENT_INT (1);
- END ASSIGN;
- BEGIN
- ASSIGN (A);
- END P;
-
- BEGIN
- NULL;
- END;
- FAILED ("PROGRAM_ERROR WAS NOT RAISED - 1");
- END IF;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
-------------------------------------------------------------------------
-
- BEGIN
- IF EQUAL (2, 2) THEN
- DECLARE
- GENERIC
- PROCEDURE ADD1 (X : IN OUT INTEGER);
-
- PROCEDURE NEW_ADD1 IS NEW ADD1;
-
- PROCEDURE ADD1 (X : IN OUT INTEGER) IS
- BEGIN
- X := X + IDENT_INT (1);
- END ADD1;
- BEGIN
- NULL;
- END;
- FAILED ("PROGRAM_ERROR WAS NOT RAISED - 2");
- END IF;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
-------------------------------------------------------------------------
-
- BEGIN
- IF EQUAL (3, 3) THEN
- DECLARE
- GENERIC
- FUNCTION INIT RETURN INTEGER;
-
- FUNCTION NEW_INIT IS NEW INIT;
-
- FUNCTION INIT RETURN INTEGER IS
- BEGIN
- RETURN (IDENT_INT (1));
- END INIT;
- BEGIN
- NULL;
- END;
- FAILED ("PROGRAM_ERROR WAS NOT RAISED - 3");
- END IF;
-
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
-
-------------------------------------------------------------------------
-
- RESULT;
-END C39007A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39007b.ada b/gcc/testsuite/ada/acats/tests/c3/c39007b.ada
deleted file mode 100644
index c95c064..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39007b.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C39007B.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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO INSTANTIATE
--- A GENERIC UNIT WHOSE BODY IS NOT YET ELABORATED. USE A GENERIC
--- UNIT THAT IS DECLARED AND INSTANTIATED IN A PACKAGE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 08/01/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C39007B IS
-
-BEGIN
- TEST ("C39007B", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " &
- "ATTEMPT TO INSTANTIATE A GENERIC UNIT WHOSE " &
- "BODY IS NOT YET ELABORATED. USE A GENERIC " &
- "UNIT THAT IS DECLARED AND INSTANTIATED IN A " &
- "PACKAGE SPECIFICATION");
-
- DECLARE
- BEGIN
- DECLARE
- PACKAGE P IS
- GENERIC
- FUNCTION F RETURN BOOLEAN;
-
- FUNCTION NEW_F IS NEW F;
- END P;
-
- PACKAGE BODY P IS
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END F;
- END P;
- BEGIN
- FAILED ("NO EXCEPTION RAISED");
- DECLARE
- X : BOOLEAN := IDENT_BOOL(FALSE);
- BEGIN
- X := P.NEW_F;
- IF X /= IDENT_BOOL(TRUE) THEN
- COMMENT ("NOT RELEVANT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED TOO LATE");
- END;
- END;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END;
-
- RESULT;
-END C39007B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39008a.ada b/gcc/testsuite/ada/acats/tests/c3/c39008a.ada
deleted file mode 100644
index 4e40dc3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39008a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C39008A.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 PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO ACTIVATE
--- A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE CASE IN
--- WHICH A TASK VARIABLE IS DECLARED IN A PACKAGE SPECIFICATION AND
--- THE PACKAGE BODY OCCURS BEFORE THE TASK BODY.
-
--- HISTORY:
--- BCB 01/21/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C39008A IS
-
-BEGIN
- TEST ("C39008A", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " &
- "ATTEMPT TO ACTIVATE A TASK BEFORE ITS BODY " &
- "HAS BEEN ELABORATED. CHECK THE CASE IN WHICH " &
- "A TASK VARIABLE IS DECLARED IN A PACKAGE " &
- "SPECIFICATION AND THE PACKAGE BODY OCCURS " &
- "BEFORE THE TASK BODY");
-
- BEGIN
- DECLARE
- TASK TYPE T;
-
- PACKAGE P IS
- X : T;
- END P;
-
- PACKAGE BODY P IS
- END P; -- PROGRAM_ERROR.
-
- TASK BODY T IS
- BEGIN
- COMMENT ("TASK MESSAGE");
- END T;
- BEGIN
- FAILED ("PROGRAM_ERROR WAS NOT RAISED");
- END;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR WAS RAISED");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " &
- "RAISED");
- END;
-
- RESULT;
-END C39008A;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39008b.ada b/gcc/testsuite/ada/acats/tests/c3/c39008b.ada
deleted file mode 100644
index d148e0c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39008b.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C39008B.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 ACTIVATION OF A TASK IS ATTEMPTED BEFORE THE
--- ELABORATION OF THE CORRESPONDING BODY IS FINISHED, THE EXCEPTION
--- PROGRAM_ERROR IS RAISED, NOT TASKING_ERROR (SEE AI-00149).
-
--- WEI 3/04/82
--- JBG 2/17/84
--- EG 11/02/84
--- JBG 5/23/85
--- JWC 6/28/85 RENAMED FROM C93007B-B.ADA
-
-WITH REPORT;
- USE REPORT;
-
-PROCEDURE C39008B IS
-
-BEGIN
-
- TEST ("C39008B", "PROGRAM_ERROR AFTER ATTEMPT OF ACTIVATION " &
- "BEFORE ELABORATION");
-BLOCK1:
- BEGIN
-BLOCK2:
- DECLARE
- TASK TYPE TT1;
-
- TYPE ATT1 IS ACCESS TT1;
-
- POINTER_TT1 : ATT1 := NEW TT1; -- ACCESSING TASK BODY
- -- BEFORE ITS ELABORATION
-
- TASK BODY TT1 IS
- BEGIN
- FAILED ("TT1 ACTIVATED");
- END TT1;
-
- BEGIN
-
- FAILED ("TT1 ACTIVATED - 2");
-
- END BLOCK2;
-
- EXCEPTION
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED");
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END BLOCK1;
-
- RESULT;
-
-END C39008B;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c39008c.ada b/gcc/testsuite/ada/acats/tests/c3/c39008c.ada
deleted file mode 100644
index 22d4825..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c39008c.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- C39008C.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 PROGRAM_ERROR IS RAISED WHEN AN ATTEMPT IS MADE TO
--- ACTIVATE A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE
--- CASE IN WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND ONLY SOME
--- HAVE UNELABORATED BODIES; NO TASKS SHOULD BE ACTIVATED.
-
--- HISTORY:
--- BCB 07/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C39008C IS
-
-BEGIN
- TEST ("C39008C", "CHECK THAT PROGRAM_ERROR IS RAISED WHEN AN " &
- "ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS " &
- "BODY HAS BEEN ELABORATED. CHECK THE CASE IN " &
- "WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND " &
- "ONLY SOME HAVE UNELABORATED BODIES; NO TASKS " &
- "SHOULD BE ACTIVATED");
-
- BEGIN
- DECLARE
- TASK TYPE A;
-
- TASK TYPE B;
-
- TASK TYPE C;
-
- TASK TYPE D;
-
- PACKAGE P IS
- W : A;
- X : B;
- Y : C;
- Z : D;
- END P;
-
- TASK BODY A IS
- BEGIN
- FAILED ("TASK A ACTIVATED");
- END A;
-
- TASK BODY D IS
- BEGIN
- FAILED ("TASK D ACTIVATED");
- END D;
-
- PACKAGE BODY P IS
- END P;
-
- TASK BODY B IS
- BEGIN
- FAILED ("TASK B ACTIVATED");
- END B;
-
- TASK BODY C IS
- BEGIN
- FAILED ("TASK C ACTIVATED");
- END C;
- BEGIN
- FAILED ("PROGRAM_ERROR WAS NOT RAISED");
- END;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " &
- "RAISED");
- END;
-
- RESULT;
-END C39008C;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a010.a b/gcc/testsuite/ada/acats/tests/c3/c390a010.a
deleted file mode 100644
index 18016de..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a010.a
+++ /dev/null
@@ -1,127 +0,0 @@
--- C390A010.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:
--- See C390A011.AM.
---
--- TEST DESCRIPTION:
--- See C390A011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A010.A
--- C390A011.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A010 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0; -- Record extension of
- end record; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-
- -- Declarations required for component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody; -- Record extension of
- end record; -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
-end C390A010;
-
-
- --==================================================================--
-
-
-package body C390A010 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's op (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
-end C390A010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a011.am b/gcc/testsuite/ada/acats/tests/c3/c390a011.am
deleted file mode 100644
index b5234e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a011.am
+++ /dev/null
@@ -1,218 +0,0 @@
--- C390A011.AM
---
--- 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 nonprivate tagged type declared in a package specification
--- may be extended with a record extension in a different package
--- specification, and that this record extension may in turn be extended
--- by a record extension.
---
--- Check that each derivative inherits the user-defined primitive
--- subprograms of its parent (including those that its parent inherited),
--- that it may override these inherited primitive subprograms, and that it
--- may also declare its own primitive subprograms.
---
--- Check that predefined equality operators are defined for the tagged
--- type and its derivatives.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type and two associated primitive subprograms
--- in a package specification (foundation code).
---
--- Extend the root type with a record extension in a different package
--- specification. Declare a new primitive subprogram for the extension,
--- and override one of the two inherited subprograms. Within the
--- overriding subprogram, utilize type conversion to call the parent's
--- implementation of the same subprogram. Also within the overriding
--- subprogram, call the new primitive subprogram and each inherited
--- subprogram.
---
--- Extend the extension with a record extension in the same package
--- specification. Declare a new primitive subprogram for this second
--- extension, and override one of the three inherited subprograms.
--- Within the overriding subprogram, utilize type conversion to call the
--- parent's implementation of the same subprogram. Also within the
--- overriding subprogram, call the new primitive subprogram and each
--- inherited subprogram.
---
--- In the main program, declare objects of the root tagged type
--- and the two type extensions. For each object, call the overriding
--- subprogram, and verify the correctness of the components by using
--- aggregates and equality operators, or by checking the components
--- directly.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- C390A010.A
--- => C390A011.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-with F390A00; -- Basic alert abstraction.
-with C390A010; -- Extended alert abstraction.
-
-use F390A00; -- Primitive operations of Alert_Type directly visible.
-
-with Ada.Calendar;
-
-procedure C390A011 is
- use type Ada.Calendar.Time; -- Equality/inequality ops directly visible.
-begin
-
- Report.Test ("C390A01", "Primitive operation inheritance by type " &
- "extensions: all extensions declared in same package, " &
- "but a different package from that of root type");
-
-
- ALERT_SUBTEST: -------------------------------------------------------------
-
- declare
- Alarm : F390A00.Alert_Type; -- Root tagged type.
- begin
-
- -- Check "/=" operator availability. Aggregate with positional
- -- associations:
- if Alarm /= (Default_Time, Null_Device) then
- Report.Failed ("Wrong initial values for Alert_Type");
- end if;
-
- Handle (Alarm);
-
- -- Check "=" operator availability. Aggregate with named
- -- associations:
- if not (Alarm = (Arrival_Time => Alert_Time,
- Display_On => Null_Device))
- then
- Report.Failed ("Wrong values for Alert_Type after Handle");
- end if;
-
- end Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if F390A00.Display_Count_For (Null_Device) /= 1 or
- F390A00.Display_Count_For (Teletype) /= 0 or
- F390A00.Display_Count_For (Console) /= 0 or
- F390A00.Display_Count_For (Big_Screen) /= 0
- then
- Report.Failed ("Wrong display counts after Alert_Type");
- end if;
-
-
- LOW_ALERT_SUBTEST: ---------------------------------------------------------
-
- declare
- Low_Alarm : C390A010.Low_Alert_Type; -- Extension of tagged type.
- use C390A010; -- Primitive operations of extension directly visible.
- begin
-
- -- Check "=" operator availability. Aggregate with positional
- -- associations:
- if not (Low_Alarm = (Default_Time, Null_Device, 0)) then
- Report.Failed ("Wrong initial values for Low_Alert_Type");
- end if;
-
- Handle (Low_Alarm);
-
- -- Check component availability:
- if Low_Alarm.Arrival_Time /= Alert_Time or
- Low_Alarm.Display_On /= Teletype or
- Low_Alarm.Level /= 1
- then
- Report.Failed ("Wrong values for Low_Alert_Type after Handle");
- end if;
-
- end Low_Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 2,
- Teletype => 1,
- Console => 0,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Low_Alert_Type");
- end if;
-
-
- MEDIUM_ALERT_SUBTEST: ------------------------------------------------------
-
- declare
- Medium_Alarm : C390A010.Medium_Alert_Type; -- Extension of extension.
- use C390A010; -- Primitive operations of extension directly visible.
- begin
-
- -- Check component availability:
- if Medium_Alarm.Level /= 0 or
- Medium_Alarm.Arrival_Time /= Default_Time or
- Medium_Alarm.Action_Officer /= Nobody or
- Medium_Alarm.Display_On /= Null_Device
- then
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
- Handle (Medium_Alarm);
-
- -- Check "/=" operator availability. Aggregate with named
- -- associations:
- if Medium_Alarm /= (Arrival_Time => Alert_Time,
- Display_On => Console,
- Level => 2,
- Action_Officer => Duty_Officer)
- then
- Report.Failed ("Wrong values for Medium_Alert_Type after Handle");
- end if;
-
- end Medium_Alert_Subtest;
-
-
- -- Check final display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 3,
- Teletype => 2,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Medium_Alert_Type");
- end if;
-
-
- Report.Result;
-
-end C390A011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a020.a b/gcc/testsuite/ada/acats/tests/c3/c390a020.a
deleted file mode 100644
index 29cd3ca..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a020.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- C390A020.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:
--- See C390A022.AM.
---
--- TEST DESCRIPTION:
--- See C390A022.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A020.A
--- C390A021.A
--- C390A022.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A020 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0; -- Record extension of
- end record; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-end C390A020;
-
-
- --==================================================================--
-
-
-package body C390A020 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's oper. (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
-end C390A020;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a021.a b/gcc/testsuite/ada/acats/tests/c3/c390a021.a
deleted file mode 100644
index 5d099f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a021.a
+++ /dev/null
@@ -1,133 +0,0 @@
--- C390A021.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:
--- See C390A022.AM.
---
--- TEST DESCRIPTION:
--- See C390A022.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- C390A020.A
--- => C390A021.A
--- C390A022.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with C390A020; -- Extended alert abstraction.
-package C390A021 is
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C390A020.Low_Alert_Type
- with private; -- Private extension of
- -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (MA : in Medium_Alert_Type)
- return Boolean;
-
-
-private
-
- type Medium_Alert_Type is new C390A020.Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C390A021;
-
-
- --==================================================================--
-
-
-with F390A00; -- Basic alert abstraction.
-use F390A00;
-package body C390A021 is
-
- use C390A020; -- Extended alert abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- return (MA = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device, -- availability.
- Level => 0, -- Aggregate with
- Action_Officer => Nobody)); -- named associations.
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- begin
- return (MA /= (Alert_Time, Console, -- Check "/=" operator
- 2 , Duty_Officer)); -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C390A021;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a022.am b/gcc/testsuite/ada/acats/tests/c3/c390a022.am
deleted file mode 100644
index 3ba273f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a022.am
+++ /dev/null
@@ -1,179 +0,0 @@
--- C390A022.AM
---
--- 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 nonprivate tagged type declared in a package specification
--- may be extended with a record extension in a different package
--- specification, and that this record extension may in turn be extended
--- by a private extension in a third package.
---
--- Check that each derivative inherits the user-defined primitive
--- subprograms of its parent (including those that its parent inherited),
--- that it may override these inherited primitive subprograms, and that it
--- may also declare its own primitive subprograms.
---
--- Check that predefined equality operators are defined for the tagged
--- type and its derivatives.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type and two associated primitive subprograms
--- in a package specification (foundation code).
---
--- Extend the root type with a record extension in a different package
--- specification. Declare a new primitive subprogram for the extension,
--- and override one of the two inherited subprograms. Within the
--- overriding subprogram, utilize type conversion to call the parent's
--- implementation of the same subprogram. Also within the overriding
--- subprogram, call the new primitive subprogram and each inherited
--- subprogram.
---
--- Extend the extension with a private extension in a third package
--- specification. Declare a new primitive subprogram for this private
--- extension, and override one of the three inherited subprograms.
--- Within the overriding subprogram, utilize type conversion to call the
--- parent's implementation of the same subprogram. Also within the
--- overriding subprogram, call the new primitive subprogram and each
--- inherited subprogram.
---
--- Also in the third package, declare two operations of the private
--- extension which utilize aggregates and equality operators to verify
--- the correctness of the components.
---
--- In the main program, declare objects of the two extended types.
--- For each object, call the overriding subprogram, and verify the
--- correctness of the components by using aggregates and equality
--- operators, or by checking the components directly, or, for the private
--- extension, by calling the verification operations declared in the
--- third package.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- C390A020.A
--- C390A021.A
--- => C390A022.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-with F390A00; -- Basic alert abstraction.
-with C390A020; -- Extended alert abstraction.
-with C390A021; -- Further extended alert abstraction.
-
-use F390A00; -- Primitive operations of Alert_Type directly visible.
-
-with Ada.Calendar;
-
-procedure C390A022 is
- use type Ada.Calendar.Time; -- Equality/inequality ops directly visible.
-begin
-
- Report.Test ("C390A02", "Primitive operation inheritance by type " &
- "extensions: all extensions declared in different " &
- "packages; second extension is private");
-
-
- -- The case for type F390A00.Alert_Type is tested in C390A01.
- -- That subtest is not repeated here.
-
-
- LOW_ALERT_SUBTEST: ---------------------------------------------------------
-
- declare
- Low_Alarm : C390A020.Low_Alert_Type; -- Extension of tagged type.
- use C390A020; -- Primitive operations of extension directly visible.
- begin
-
- -- Check "=" operator availability. Aggregate with positional
- -- associations:
- if not (Low_Alarm = (Default_Time, Null_Device, 0)) then
- Report.Failed ("Wrong initial values for Low_Alert_Type");
- end if;
-
- Handle (Low_Alarm);
-
- -- Check component availability:
- if Low_Alarm.Arrival_Time /= Alert_Time or
- Low_Alarm.Display_On /= Teletype or
- Low_Alarm.Level /= 1
- then
- Report.Failed ("Wrong values for Low_Alert_Type after Handle");
- end if;
- end Low_Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 1,
- Teletype => 1,
- Console => 0,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Low_Alert_Type");
- end if;
-
-
- MEDIUM_ALERT_SUBTEST: ------------------------------------------------------
-
- declare
- Medium_Alarm : C390A021.Medium_Alert_Type; -- Priv. ext. of extension.
- use C390A021; -- Primitive operations of extension directly visible.
- begin
- if not C390A021.Initial_Values_Okay (Medium_Alarm) then
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
- Handle (Medium_Alarm);
-
- if C390A021.Bad_Final_Values (Medium_Alarm) then
- Report.Failed ("Wrong values for Medium_Alert_Type after Handle");
- end if;
- end Medium_Alert_Subtest;
-
-
- -- Check final display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 2,
- Teletype => 2,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Medium_Alert_Type");
- end if;
-
-
- Report.Result;
-
-end C390A022;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a030.a b/gcc/testsuite/ada/acats/tests/c3/c390a030.a
deleted file mode 100644
index 51554a4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a030.a
+++ /dev/null
@@ -1,188 +0,0 @@
--- C390A030.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:
--- See C390A031.AM.
---
--- TEST DESCRIPTION:
--- See C390A031.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A030.A
--- C390A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A030 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type -- Private extension of
- with private; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (LA : in Low_Alert_Type)
- return Boolean;
-
-
- -- Declarations used by private extension component.
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new Low_Alert_Type -- Private extension of
- with private; -- private extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- operation.
-
- function Bad_Final_Values (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- operation.
-
-private
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C390A030;
-
-
- --==================================================================--
-
-
-package body C390A030 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- return (LA = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device, -- availability.
- Level => 0)); -- Aggregate with
- end Initial_Values_Okay; -- named associations.
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- begin
- return (LA /= (Alert_Time, Teletype, 1)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- begin
- return not (MA = (Arrival_Time => Alert_Time, -- Check "=" operator
- Display_On => Console, -- availability.
- Level => 2, -- Aggregate with
- Action_Officer => Duty_Officer));-- named associations.
- end Bad_Final_Values;
-
-
-end C390A030;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a031.am b/gcc/testsuite/ada/acats/tests/c3/c390a031.am
deleted file mode 100644
index 7f380c6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a031.am
+++ /dev/null
@@ -1,167 +0,0 @@
--- C390A031.AM
---
--- 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 nonprivate tagged type declared in a package specification
--- may be extended with a private extension in a different package
--- specification, and that this private extension may in turn be extended
--- by a private extension.
---
--- Check that each derivative inherits the user-defined primitive
--- subprograms of its parent (including those that its parent inherited),
--- that it may override these inherited primitive subprograms, and that it
--- may also declare its own primitive subprograms.
---
--- Check that predefined equality operators are defined for the tagged
--- type and its derivatives.
---
--- Check that type conversion is defined from a type extension to its
--- parent, and that this parent itself may be a type extension.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type and two associated primitive subprograms
--- in a package specification (foundation code).
---
--- Extend the root type with a private extension in a different package
--- specification. Declare a new primitive subprogram for the extension,
--- and override one of the two inherited subprograms. Within the
--- overriding subprogram, utilize type conversion to call the parent's
--- implementation of the same subprogram. Also within the overriding
--- subprogram, call the new primitive subprogram and each inherited
--- subprogram. Declare operations of the private extension which utilize
--- aggregates and equality operators to verify the correctness of the
--- components.
---
--- Extend the extension with a private extension in the same package
--- specification. Declare a new primitive subprogram for this second
--- extension, and override one of the three inherited subprograms.
--- Within the overriding subprogram, utilize type conversion to call the
--- parent's implementation of the same subprogram. Also within the
--- overriding subprogram, call the new primitive subprogram and each
--- inherited subprogram. Declare operations of the private extension
--- which override the verification operations of its parent. Within
--- these overriding operations, utilize type conversion to call the
--- parent's implementations of the same operations.
---
--- In the main program, declare objects of the two extended types.
--- For each object, call the overriding subprogram, and verify the
--- correctness of the components by calling the verification operations
--- declared in the second package.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- C390A030.A
--- => C390A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-with F390A00; -- Basic alert abstraction.
-with C390A030; -- Extended alert abstraction.
-
-use F390A00; -- Primitive operations of Alert_Type directly visible.
-
-procedure C390A031 is
-begin
-
- Report.Test ("C390A03", "Primitive operation inheritance by type " &
- "extensions: all extensions are private and declared " &
- "in same package, but a different package from that " &
- "of root type");
-
-
- -- The case for type F390A00.Alert_Type is tested in C390A01.
- -- That subtest is not repeated here.
-
-
- LOW_ALERT_SUBTEST: ---------------------------------------------------------
-
- declare
- Low_Alarm : C390A030.Low_Alert_Type; -- Priv. ext. of tagged type.
- use C390A030; -- Primitive operations of extension directly visible.
- begin
- if not C390A030.Initial_Values_Okay (Low_Alarm) then
- Report.Failed ("Wrong initial values for Low_Alert_Type");
- end if;
-
- Handle (Low_Alarm);
-
- if C390A030.Bad_Final_Values (Low_Alarm) then
- Report.Failed ("Wrong values for Low_Alert_Type after Handle");
- end if;
- end Low_Alert_Subtest;
-
-
- -- Check intermediate display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 1,
- Teletype => 1,
- Console => 0,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Low_Alert");
- end if;
-
-
- MEDIUM_ALERT_SUBTEST: ------------------------------------------------------
-
- declare
- Medium_Alarm : C390A030.Medium_Alert_Type; -- Priv. ext. of extension.
- use C390A030; -- Primitive operations of extension directly visible.
- begin
- if not C390A030.Initial_Values_Okay (Medium_Alarm) then
- Report.Failed ("Wrong initial values for Medium_Alert_Type");
- end if;
-
- Handle (Medium_Alarm);
-
- if C390A030.Bad_Final_Values (Medium_Alarm) then
- Report.Failed ("Wrong values for Medium_Alert_Type after Handle");
- end if;
- end Medium_Alert_Subtest;
-
-
- -- Check final display counts:
-
- if F390A00.Display_Count_For /= (Null_Device => 2,
- Teletype => 2,
- Console => 1,
- Big_Screen => 0)
- then
- Report.Failed ("Wrong display counts after Medium_Alert_Type");
- end if;
-
-
- Report.Result;
-
-end C390A031;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c391001.a b/gcc/testsuite/ada/acats/tests/c3/c391001.a
deleted file mode 100644
index bca7525..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c391001.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- C391001.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 structures nesting discriminated records as
--- components in record extension are correctly supported. Check
--- for this using limited private structures.
--- Check that record extensions inherit all the visible components
--- of their ancestor types.
--- Check that discriminants are correctly inherited.
---
--- TEST DESCRIPTION:
--- This test defines a textbook object, a serial number plaque.
--- This object is used in each of several other structures modeled
--- after those used in an existing antenna modeling software system.
--- Record types discriminated and undiscriminated are nested to
--- produce a layered design. Some parametrization is programmatic;
--- some parametrization is data-driven.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 19 Apr 95 SAIC Added "limited" to full type def of "Object"
---
---!
-
- package C391001_1 is
- type Object is tagged limited private;
- -- Constructor operation
- procedure Create( The_Plaque : in out Object );
- -- Selector operations
- function "="( Left_Plaque,Right_Plaque : Object ) return Boolean;
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean;
- function Serial_Number( A_Plaque : Object ) return Natural;
- Unserialized : exception; -- Serial_Number called before Create
- Reserialized : exception; -- Create called twice
- private
- type Object is tagged limited record
- Serial_Number : Natural := 0;
- end record;
- end C391001_1;
-
- package body C391001_1 is
- Counter : Natural := 0;
- procedure Create( The_Plaque : in out Object ) is
- begin
- if The_Plaque.Serial_Number = 0 then
- Counter := Counter +1;
- The_Plaque.Serial_Number := Counter;
- else
- raise Reserialized;
- end if;
- end Create;
-
- function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number)
- and then -- two uninitialized plates are unequal
- (Left_Plaque.Serial_Number /= 0);
- end "=";
-
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Natural);
- end TC_Match;
-
- function Serial_Number( A_Plaque : Object ) return Natural is
- begin
- if A_Plaque.Serial_Number = 0 then
- raise Unserialized;
- end if;
- return A_Plaque.Serial_Number;
- end Serial_Number;
- end C391001_1;
-
- with C391001_1;
- package C391001_2 is -- package Boards is
-
- package Plaque renames C391001_1;
-
- type Modes is (Receiving, Transmitting, Standby);
- type Link(Mode: Modes := Standby) is record
- case Mode is
- when Receiving => TC_R : Integer := 100;
- when Transmitting => TC_T : Integer := 200;
- when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA
- end case;
- end record;
-
- type Data_Formats is (S_Band, KU_Band, UHF);
-
-
- type Transceiver(Band: Data_Formats) is tagged limited record
- ID : Plaque.Object;
- The_Link: Link;
- case Band is
- when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA
- when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA
- when UHF => TC_UHF_Data : Integer := 3;
- end case;
- end record;
- end C391001_2;
-
- with C391001_1;
- with C391001_2;
- package C391001_3 is -- package Modules
- package Plaque renames C391001_1;
- package Boards renames C391001_2;
- use type Boards.Modes;
- use type Boards.Data_Formats;
-
- type Command_Formats is ( Set_Compression_Code,
- Set_Data_Rate,
- Set_Power_State );
-
- type Electronics_Module(EBand : Boards.Data_Formats;
- The_Command_Format: Command_Formats)
- is new Boards.Transceiver(EBand) with record
- case The_Command_Format is
- when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA
- when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA
- when Set_Power_State => TC_SPS : Integer := 30; -- TSA
- end case;
- end record;
- end C391001_3;
-
- with Report;
- with C391001_1;
- with C391001_2;
- with C391001_3;
- procedure C391001 is
- package Plaque renames C391001_1;
- package Boards renames C391001_2;
- package Modules renames C391001_3;
- use type Boards.Modes;
- use type Boards.Data_Formats;
- use type Modules.Command_Formats;
-
- type Azimuth is range 0..359;
-
- type Ground_Antenna(The_Band : Boards.Data_Formats;
- The_Command_Format: Modules.Command_Formats) is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command_Format);
- Pointing : Azimuth;
- end record;
-
- type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band;
- The_Command : Modules.Command_Formats
- := Modules.Set_Power_State)
- is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- end record;
-
- The_Ground_Antenna : Ground_Antenna (Boards.S_Band,
- Modules.Set_Data_Rate);
- The_Space_Antenna : Space_Antenna;
- Space_Station_Antenna : Space_Antenna (Boards.S_Band,
- Modules.Set_Compression_Code);
-
-
- procedure Validate( Condition : Boolean; Message: String ) is
- begin
- if not Condition then
- Report.Failed("Failed " & Message );
- end if;
- end Validate;
-
- begin
- Report.Test("C391001", "Check nested tagged discriminated "
- & "record structures");
-
- Plaque.Create( The_Ground_Antenna.ID ); -- 1
- Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2
- Plaque.Create( The_Space_Antenna.ID ); -- 3
- Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4
- Plaque.Create( Space_Station_Antenna.ID ); -- 5
- Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6
-
- The_Ground_Antenna.Pointing := 180;
- Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" );
- Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate,
- "TGA discr 2" );
- Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" );
- Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
- "TGA comp 2.discr 1" );
- Validate( The_Ground_Antenna.Electronics.The_Command_Format
- = Modules.Set_Data_Rate, "TGA comp 2.discr 2" );
- Validate( The_Ground_Antenna.Electronics.TC_SDR = 20,
- "TGA comp 2.1" );
- Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
- "TGA comp 2.inher.1" );
- Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "TGA comp 2.inher.2.discr" );
- Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300,
- "TGA comp 2.inher.2.1" );
- Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1,
- "TGA comp 2.inher.3" );
- Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" );
-
- Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1");
- Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State,
- "TSA discr 2");
- Validate( Plaque.TC_Match(The_Space_Antenna.ID,3),
- "TSA comp 1");
- Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band,
- "TSA comp 2.discr 1");
- Validate( The_Space_Antenna.Electronics.The_Command_Format
- = Modules.Set_Power_State, "TSA comp 2.discr 2");
- Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
- "TSA comp 2.inher.1");
- Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "TSA comp 2.inher.2.discr");
- Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300,
- "TSA comp 2.inher.2.1");
- Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2,
- "TSA comp 2.inher.3");
- Validate( The_Space_Antenna.Electronics.TC_SPS = 30,
- "TSA comp 2.1");
-
- Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1");
- Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
- "SSA discr 2");
- Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5),
- "SSA comp 1");
- Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band,
- "SSA comp 2.discr 1");
- Validate( Space_Station_Antenna.Electronics.The_Command_Format
- = Modules.Set_Compression_Code, "SSA comp 2.discr 2");
- Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
- "SSA comp 2.inher.1");
- Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "SSA comp 2.inher.2.discr");
- Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300,
- "SSA comp 2.inher.2.1");
- Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1,
- "SSA comp 2.inher.3");
- Validate( Space_Station_Antenna.Electronics.TC_SCC = 10,
- "SSA comp 2.1");
-
- The_Ground_Antenna.Electronics.TC_SDR := 1001;
- The_Ground_Antenna.Electronics.The_Link :=
-(Boards.Transmitting,2001);
- The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001;
- The_Ground_Antenna.Pointing := 41;
-
- The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010);
- The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020;
- The_Space_Antenna.Electronics.TC_SPS := 3030;
-
- Space_Station_Antenna.Electronics.The_Link
- := The_Space_Antenna.Electronics.The_Link;
- Space_Station_Antenna.Electronics.The_Link.TC_R := 111;
- Space_Station_Antenna.Electronics.TC_S_Band_Data := 222;
- Space_Station_Antenna.Electronics.TC_SCC := 333;
-
- ----------------------------------------------------------------------
- begin -- should fail discriminant check
- The_Ground_Antenna.Electronics.TC_SCC := 909;
- Report.Failed("Discriminant check, no exception");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed("Discriminant check, wrong exception");
- end;
-
- Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001,
- "assigned value 1");
- Validate( The_Ground_Antenna.Electronics.The_Link.Mode
- = Boards.Transmitting,
- "assigned value 2.1");
- Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001,
- "assigned value 2.2");
- Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001,
- "assigned value 3");
- Validate( The_Ground_Antenna.Pointing = 41,
- "assigned value 4");
-
- Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving,
- "assigned value 5.1");
- Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010,
- "assigned value 5.2");
- Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020,
- "assigned value 6");
- Validate( The_Space_Antenna.Electronics.TC_SPS = 3030,
- "assigned value 7");
-
- Validate( Space_Station_Antenna.Electronics.The_Link.Mode
- = Boards.Receiving,
- "assigned value 8.1");
- Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111,
- "assigned value 8.2");
- Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222,
- "assigned value 9");
- Validate( Space_Station_Antenna.Electronics.TC_SCC = 333,
- "assigned value 10");
-
- Report.Result;
-
-end C391001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c391002.a b/gcc/testsuite/ada/acats/tests/c3/c391002.a
deleted file mode 100644
index 77fbfb3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c391002.a
+++ /dev/null
@@ -1,493 +0,0 @@
--- C391002.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 structures nesting discriminated records as
--- components in record extension are correctly supported.
--- Check that record extensions inherit all the visible components
--- of their ancestor types.
--- Check that discriminants are correctly inherited.
---
--- TEST DESCRIPTION:
--- This test defines a simple class hierarchy, where the final
--- derivations exercise the different possible "permissions" available
--- to a designer. Extension aggregates for discriminated types are used
--- to set values of these final types. The key difference between
--- this test and C391001 is that the types are visible, and allow the
--- creation of complex discriminated extension aggregates. Another
--- layer of derivation is present to more robustly check that the
--- inheritance is correctly supported.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Removed offending parenthesis in aggregate
--- extensions, corrected typo: TC_MC SB TC_PC,
--- corrected visibility errors for literals,
--- added qualification for aggregate expressions
--- used in extension aggregates, corrected parameter
--- order in call to Communications.Creator
--- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm
--- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1
--- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates
--- 11 APR 96 SAIC Updated documentation for 2.1
--- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association
---!
-
------------------------------------------------------------------ C391002_1
-
-package C391002_1 is
-
- type Object is tagged private;
-
- -- Constructor operation
- procedure Create( The_Plaque : in out Object );
-
- -- Selector operations
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean;
-
- function Serial_Number( A_Plaque : Object ) return Natural;
-
- Unserialized : exception; -- Serial_Number called before Create
- Reserialized : exception; -- Create called twice
-
-private
- type Object is tagged record
- Serial_Number : Natural := 0;
- end record;
-end C391002_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C391002_1 is
-
- Counter : Natural := 0;
-
- procedure Create( The_Plaque : in out Object ) is
- begin
- if The_Plaque.Serial_Number = 0 then
- Counter := Counter +1;
- The_Plaque.Serial_Number := Counter;
- else
- raise Reserialized;
- end if;
- end Create;
-
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Natural);
- end TC_Match;
-
- function Serial_Number( A_Plaque : Object ) return Natural is
- begin
- if A_Plaque.Serial_Number = 0 then
- raise Unserialized;
- end if;
- return A_Plaque.Serial_Number;
- end Serial_Number;
-end C391002_1;
-
------------------------------------------------------------------ C391002_2
-
-with C391002_1;
-package C391002_2 is -- package Boards is
-
- package Plaque renames C391002_1;
-
- type Modes is (Receiving, Transmitting, Standby);
- type Link(Mode: Modes := Standby) is record
- case Mode is
- when Receiving => TC_R : Integer := 100;
- when Transmitting => TC_T : Integer := 200;
- when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA
- end case;
- end record;
-
- type Data_Formats is (S_Band, KU_Band, UHF);
-
- type Transceiver(Band: Data_Formats) is tagged record
- ID : Plaque.Object;
- The_Link: Link;
- case Band is
- when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet
- when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet
- when UHF => TC_UHF_Data : Integer := 3; -- Gossip
- end case;
- end record;
-end C391002_2;
-
------------------------------------------------------------------ C391002_3
-
-with C391002_1;
-with C391002_2;
-package C391002_3 is -- package Modules
-
- package Plaque renames C391002_1;
- package Boards renames C391002_2;
- use type Boards.Modes;
- use type Boards.Data_Formats;
-
- type Command_Formats is ( Set_Compression_Code,
- Set_Data_Rate,
- Set_Power_State );
-
- type Electronics_Module(EBand : Boards.Data_Formats;
- The_Command : Command_Formats)
- is new Boards.Transceiver(EBand) with record
- case The_Command is
- when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip
- when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet
- when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet
- end case;
- end record;
-end C391002_3;
-
------------------------------------------------------------------ C391002_4
-
-with C391002_3;
-package C391002_4 is -- Communications
- package Modules renames C391002_3;
-
- type Public_Comm is new Modules.Electronics_Module with
- record
- TC_VC : Integer;
- end record;
-
- type Private_Comm is new Modules.Electronics_Module with private;
-
- type Mil_Comm is new Modules.Electronics_Module with private;
-
- procedure Creator( Plugs : in Modules.Electronics_Module;
- Gives : out Mil_Comm);
-
- function Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
- return Private_Comm;
-
- procedure Setup( It : in out Public_Comm; Value : in Integer );
- procedure Setup( It : in out Private_Comm; Value : in Integer );
- procedure Setup( It : in out Mil_Comm; Value : in Integer );
-
- function Selector( It : Public_Comm ) return Integer;
- function Selector( It : Private_Comm ) return Integer;
- function Selector( It : Mil_Comm ) return Integer;
-
-private
- type Private_Comm is new Modules.Electronics_Module with
- record
- TC_PC : Integer;
- end record;
-
- type Mil_Comm is new Modules.Electronics_Module with
- record
- TC_MC : Integer;
- end record;
-end C391002_4; -- Communications
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C391002_4 is -- Communications
-
- procedure Creator( Plugs : in Modules.Electronics_Module;
- Gives : out Mil_Comm) is
- begin
- Gives := ( Plugs with TC_MC => -1 );
- end Creator;
-
- function Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
- return Private_Comm is
- begin
- return ( Plugs with TC_PC => Key );
- end Creator;
-
- procedure Setup( It : in out Public_Comm; Value : in Integer ) is
- begin
- It.TC_VC := Value;
- TCTouch.Assert( Value = 1, "Public_Comm");
- end Setup;
-
- procedure Setup( It : in out Private_Comm; Value : in Integer ) is
- begin
- It.TC_PC := Value;
- TCTouch.Assert( Value = 2, "Private_Comm");
- end Setup;
-
- procedure Setup( It : in out Mil_Comm; Value : in Integer ) is
- begin
- It.TC_MC := Value;
- TCTouch.Assert( Value = 3, "Private_Comm");
- end Setup;
-
- function Selector( It : Public_Comm ) return Integer is
- begin
- return It.TC_VC;
- end Selector;
-
- function Selector( It : Private_Comm ) return Integer is
- begin
- return It.TC_PC;
- end Selector;
-
- function Selector( It : Mil_Comm ) return Integer is
- begin
- return It.TC_MC;
- end Selector;
-
-end C391002_4; -- Communications
-
-------------------------------------------------------------------- C391002
-
-with Report;
-with TCTouch;
-with C391002_1;
-with C391002_2;
-with C391002_3;
-with C391002_4;
-procedure C391002 is
-
- package Plaque renames C391002_1;
- package Boards renames C391002_2;
- package Modules renames C391002_3;
- package Communications renames C391002_4;
-
- procedure Assert( Condition: Boolean; Message: String )
- renames TCTouch.Assert;
-
- use type Boards.Modes;
- use type Boards.Data_Formats;
- use type Modules.Command_Formats;
-
- type Azimuth is range 0..359;
-
- type Ground_Antenna(The_Band : Boards.Data_Formats;
- The_Command : Modules.Command_Formats) is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- Pointing : Azimuth;
- end record;
-
- type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band;
- The_Command : Modules.Command_Formats
- := Modules.Set_Power_State)
- is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- end record;
-
- The_Ground_Antenna : Ground_Antenna (Boards.S_Band,
- Modules.Set_Data_Rate);
- The_Space_Antenna : Space_Antenna;
- Space_Station_Antenna : Space_Antenna (Boards.UHF,
- Modules.Set_Compression_Code);
-
- Gossip : Communications.Public_Comm (Boards.UHF,
- Modules.Set_Compression_Code);
- Usenet : Communications.Private_Comm (Boards.KU_Band,
- Modules.Set_Data_Rate);
- Milnet : Communications.Mil_Comm (Boards.S_Band,
- Modules.Set_Power_State);
-
-
-begin
-
- Report.Test("C391002", "Check nested tagged discriminated"
- & " record structures");
-
- Plaque.Create( The_Ground_Antenna.ID ); -- 1
- Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2
- Plaque.Create( The_Space_Antenna.ID ); -- 3
- Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4
- Plaque.Create( Space_Station_Antenna.ID ); -- 5
- Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6
-
- The_Ground_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- ID => The_Ground_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Ground_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 222 ),
- TC_S_Band_Data => 8 )
- with EBand => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- TC_SDR => 11 ),
- Pointing => 270 );
-
- The_Space_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- ID => The_Space_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 456 ),
- TC_S_Band_Data => 88 )
- with
- EBand => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- TC_SDR => 42
- ) );
-
- Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code,
- Space_Station_Antenna.ID,
- ( Boards.Transceiver'(
- Boards.UHF,
- Space_Station_Antenna.Electronics.ID,
- ( Boards.Transmitting, 202 ),
- 42 )
- with Boards.UHF,
- Modules.Set_Compression_Code,
- TC_SCC => 101
- ) );
-
- Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" );
- Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate,
- "TGA disc 2" );
- Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" );
- Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
- "TGA comp 2.disc 1" );
- Assert( The_Ground_Antenna.Electronics.The_Command
- = Modules.Set_Data_Rate,
- "TGA comp 2.disc 2" );
- Assert( The_Ground_Antenna.Electronics.TC_SDR = 11,
- "TGA comp 2.1" );
- Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
- "TGA comp 2.inher.1" );
- Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
- "TGA comp 2.inher.2.disc" );
- Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222,
- "TGA comp 2.inher.2.1" );
- Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8,
- "TGA comp 2.inher.3" );
- Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" );
-
- Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1");
- Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate,
- "TSA disc 2");
- Assert( Plaque.TC_Match(The_Space_Antenna.ID,3),
- "TSA comp 1");
- Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band,
- "TSA comp 2.disc 1");
- Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate,
- "TSA comp 2.disc 2");
- Assert( The_Space_Antenna.Electronics.TC_SDR = 42,
- "TSA comp 2.1");
- Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
- "TSA comp 2.inher.1");
- Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
- "TSA comp 2.inher.2.disc");
- Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456,
- "TSA comp 2.inher.2.1");
- Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88,
- "TSA comp 2.inher.3");
-
- Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1");
- Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
- "SSA disc 2");
- Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5),
- "SSA comp 1");
- Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF,
- "SSA comp 2.disc 1");
- Assert( Space_Station_Antenna.Electronics.The_Command
- = Modules.Set_Compression_Code,
- "SSA comp 2.disc 2");
- Assert( Space_Station_Antenna.Electronics.TC_SCC = 101,
- "SSA comp 2.1");
- Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
- "SSA comp 2.inher.1");
- Assert( Space_Station_Antenna.Electronics.The_Link.Mode
- = Boards.Transmitting,
- "SSA comp 2.inher.2.disc");
- Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202,
- "SSA comp 2.inher.2.1");
- Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42,
- "SSA comp 2.inher.3");
-
-
- The_Space_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Power_State,
- ID => The_Space_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 1 ),
- TC_S_Band_Data => 5 )
- with
- EBand => Boards.S_Band,
- The_Command => Modules.Set_Power_State,
- TC_SPS => 101
- ) );
-
- Communications.Creator( The_Space_Antenna.Electronics, Milnet );
- Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" );
-
- Usenet := Communications.Creator( -2,
- ( Boards.Transceiver'(
- Band => Boards.KU_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Boards.Transmitting, TC_T => 101 ),
- TC_KU_Band_Data => 395 )
- with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) );
-
- Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" );
-
- Gossip := (
- Modules.Electronics_Module'(
- Boards.Transceiver'(
- Band => Boards.UHF,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Boards.Transmitting, TC_T => 101 ),
- TC_UHF_Data => 395 )
- with
- Boards.UHF, Modules.Set_Compression_Code, 66 )
- with
- TC_VC => -3 );
-
- Assert( Gossip.TC_VC = -3, "Gossip Aggregate" );
-
- Communications.Setup( Gossip, 1 ); -- (Boards.UHF,
- -- Modules.Set_Compression_Code)
- Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band,
- -- Modules.Set_Data_Rate)
- Communications.Setup( Milnet, 3 ); -- (Boards.S_Band,
- -- Modules.Set_Power_State)
-
- Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" );
- Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" );
- Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" );
-
- Report.Result;
-
-end C391002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392002.a b/gcc/testsuite/ada/acats/tests/c3/c392002.a
deleted file mode 100644
index 41493c2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392002.a
+++ /dev/null
@@ -1,349 +0,0 @@
--- C392002.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 use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this in the case where the root tagged
--- type is defined in a generic package, and the type derived from it is
--- defined in that same generic package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations.
--- Extend the root type, and override one or more primitive operations,
--- inheriting the other primitive operations from the root type.
--- Derive from the extended type, again overriding some primitive
--- operations and inheriting others (including some that the parent
--- inherited).
--- Define a subprogram with a class-wide parameter, inside of which is a
--- call on a dispatching primitive operation. These primitive operations
--- modify global variables (the class-wide parameter has mode IN).
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
---
--- type Vehicle (root)
--- |
--- type Motorcycle
--- |
--- | Operations
--- | Engine_Size
--- | Catalytic_Converter
--- | Emissions_Produced
--- |
--- type Automobile (extended from Motorcycle)
--- |
--- | Operations
--- | (Engine_Size) (inherited)
--- | Catalytic_Converter (overridden)
--- | Emissions_Produced (overridden)
--- |
--- type Truck (extended from Automobile)
--- |
--- | Operations
--- | (Engine_Size) (inherited twice - Motorcycle)
--- | (Catalytic_Converter) (inherited - Automobile)
--- | Emissions_Produced (overridden)
---
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Vehicle'Class IN procedure
--- parameter :
---
--- \ Type
--- Prim. Op \ Motorcycle Automobile Truck
--- \------------------------------------------------
--- Engine_Size | X X X
--- Catalytic_Converter | X X X
--- Emissions_Produced | X X X
---
---
---
--- The location of the declaration and derivation of the root and extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- Declared in package.
--- * Declared in generic package.
---
--- Extended types:
---
--- * Derived in parent location.
--- Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- * Functions with same parameter profile.
--- Functions with different parameter profile.
--- * Mixture of Procedures and Functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 09 May 96 SAIC Made single-file for 2.1
---
---!
-
-------------------------------------------------------------------- C392002_0
-
--- Declare the root and extended types, along with their primitive
--- operations in a generic package.
-
-generic
-
- type Cubic_Inches is range <>;
- type Emission_Measure is digits <>;
- Emissions_per_Engine_Cubic_Inch : Emission_Measure;
-
-package C392002_0 is -- package Vehicle_Simulation
-
- --
- -- Equipment types and their primitive operations.
- --
-
- -- Root type.
-
- type Vehicle is abstract tagged
- record
- Weight : Integer;
- Wheels : Positive;
- end record;
-
- -- Abstract operations of type Vehicle.
- function Engine_Size (V : in Vehicle) return Cubic_Inches
- is abstract;
- function Catalytic_Converter (V : in Vehicle) return Boolean
- is abstract;
- function Emissions_Produced (V : in Vehicle) return Emission_Measure
- is abstract;
-
- --
-
- type Motorcycle is new Vehicle with
- record
- Size_Of_Engine : Cubic_Inches;
- end record;
-
- -- Primitive operations of type Motorcycle.
- function Engine_Size (V : in Motorcycle) return Cubic_Inches;
- function Catalytic_Converter (V : in Motorcycle) return Boolean;
- function Emissions_Produced (V : in Motorcycle) return Emission_Measure;
-
- --
-
- type Automobile is new Motorcycle with
- record
- Passenger_Capacity : Integer;
- end record;
-
- -- Function Engine_Size inherited from parent (Motorcycle).
- -- Primitive operations (Overridden).
- function Catalytic_Converter (V : in Automobile) return Boolean;
- function Emissions_Produced (V : in Automobile) return Emission_Measure;
-
- --
-
- type Truck is new Automobile with
- record
- Hauling_Capacity : Natural;
- end record;
-
- -- Function Engine_Size inherited twice.
- -- Function Catalytic_Converter inherited from parent (Automobile).
- -- Primitive operation (Overridden).
- function Emissions_Produced (V : in Truck) return Emission_Measure;
-
-end C392002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body c392002_0 is
-
- --
- -- Primitive operations for Motorcycle.
- --
-
- function Engine_Size (V : in Motorcycle) return Cubic_Inches is
- begin
- return (V.Size_Of_Engine);
- end Engine_Size;
-
-
- function Catalytic_Converter (V : in Motorcycle) return Boolean is
- begin
- return (False);
- end Catalytic_Converter;
-
-
- function Emissions_Produced (V : in Motorcycle) return Emission_Measure is
- begin
- return 100.00;
- end Emissions_Produced;
-
- --
- -- Overridden operations for Automobile type.
- --
-
- function Catalytic_Converter (V : in Automobile) return Boolean is
- begin
- return (True);
- end Catalytic_Converter;
-
-
- function Emissions_Produced (V : in Automobile) return Emission_Measure is
- begin
- return 200.00;
- end Emissions_Produced;
-
- --
- -- Overridden operation for Truck type.
- --
-
- function Emissions_Produced (V : in Truck) return Emission_Measure is
- begin
- return 300.00;
- end Emissions_Produced;
-
-end C392002_0;
-
---------------------------------------------------------------------- C392002
-
-with C392002_0; -- with Vehicle_Simulation;
-with Report;
-
-procedure C392002 is
-
- type Decade is (c1970, c1980, c1990);
- type Vehicle_Emissions is digits 6;
- type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions;
- subtype Engine_Size is Integer range 100 .. 1000;
-
- Five_Tons : constant Natural := 10000;
- Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8;
- Truck_Adjustment_Factor : constant Vehicle_Emissions := 1.2;
-
-
- Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00,
- c1980 => 8.00,
- c1990 => 5.00);
-
- -- Instantiate generic package for 1970 simulation.
-
- package Sim_1970 is new C392002_0
- (Cubic_Inches => Engine_Size,
- Emission_Measure => Vehicle_Emissions,
- Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970));
-
-
- -- Declare and initialize vehicle objects.
-
- Cycle_1970 : Sim_1970.Motorcycle := (Weight => 400,
- Wheels => 2,
- Size_Of_Engine => 100);
-
- Auto_1970 : Sim_1970.Automobile := (2000, 4, 500, 5);
-
- Truck_1970 : Sim_1970.Truck := (Weight => 5000,
- Wheels => 18,
- Size_Of_Engine => 1000,
- Passenger_Capacity => 2,
- Hauling_Capacity => Five_Tons);
-
- -- Function Get_Engine_Size performs a dispatching call on a
- -- primitive operation that has been defined for an ancestor type and
- -- inherited by each type derived from the ancestor.
-
- function Get_Engine_Size (V : in Sim_1970.Vehicle'Class)
- return Engine_Size is
- begin
- return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag.
- end Get_Engine_Size;
-
-
- -- Function Catalytic_Converter_Present performs a dispatching call on
- -- a primitive operation that has been defined for an ancestor type,
- -- overridden in the parent extended type, and inherited by the subsequent
- -- extended type.
-
- function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class)
- return Boolean is
- begin
- return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag.
- end Catalytic_Converter_Present;
-
-
- -- Function Air_Quality_Measure performs a dispatching call on
- -- a primitive operation that has been defined for an ancestor type, and
- -- overridden in each subsequent extended type.
-
- function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class)
- return Vehicle_Emissions is
- begin
- return (Sim_1970.Emissions_Produced (V)); -- Dispatch according to tag.
- end Air_Quality_Measure;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C392002", "Check that the use of a class-wide parameter "
- & "allows for proper dispatching where root type "
- & "and extended types are declared in the same "
- & "generic package" );
-
- if (Get_Engine_Size (Cycle_1970) /= 100) or
- (Get_Engine_Size (Auto_1970) /= 500) or
- (Get_Engine_Size (Truck_1970) /= 1000)
- then
- Report.Failed ("Failed dispatch to Get_Engine_Size");
- end if;
-
- if Catalytic_Converter_Present (Cycle_1970) or
- not Catalytic_Converter_Present (Auto_1970) or
- not Catalytic_Converter_Present (Truck_1970)
- then
- Report.Failed ("Failed dispatch to Catalytic_Converter_Present");
- end if;
-
- if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or
- (Air_Quality_Measure (Auto_1970) /= 200.00) or
- (Air_Quality_Measure (Truck_1970) /= 300.00))
- then
- Report.Failed ("Failed dispatch to Air_Quality_Measure");
- end if;
-
- Report.Result;
-
-end C392002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc/testsuite/ada/acats/tests/c3/c392003.a
deleted file mode 100644
index d7c5be2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392003.a
+++ /dev/null
@@ -1,453 +0,0 @@
--- C392003.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 use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this where the root tagged type is
--- defined in a package, and the extended type is defined in a nested
--- package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations.
--- Extend the root type, and override one or more primitive operations,
--- inheriting the other primitive operations from the root type.
--- Derive from the extended type, again overriding some primitive
--- operations and inheriting others (including some that the parent
--- inherited).
--- Define a subprogram with a class-wide parameter, inside of which is a
--- call on a dispatching primitive operation. These primitive operations
--- modify global variables (the class-wide parameter has mode IN).
---
---
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
--- type Bank_Account (root)
--- |
--- | Operations
--- | Increment_Bank_Reserve
--- | Assign_Representative
--- | Increment_Counters
--- | Open
--- |
--- type Savings_Account (extended from Bank_Account)
--- |
--- | Operations
--- | (Increment_Bank_Reserve) (inherited)
--- | Assign_Representative (overridden)
--- | Increment_Counters (overridden)
--- | Open (overridden)
--- |
--- type Preferred_Account (extended from Savings_Account)
--- |
--- | Operations
--- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
--- | (Assign_Representative) (inherited - Savings_Acct.)
--- | Increment_Counters (overridden)
--- | Open (overridden)
---
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Bank_Account'Class IN procedure
--- parameter :
---
--- \ Type
--- Prim. Op \ Bank_Account Savings_Account Preferred_Account
--- \------------------------------------------------
--- Increment_Bank_Reserve| X X
--- Assign_Representative | X
--- Increment_Counters | X X X
---
---
---
--- The location of the declaration and derivation of the root and extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- * Declared in package.
--- Declared in generic package.
---
--- Extended types:
---
--- Derived in parent location.
--- * Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- * Functions with same parameter profile.
--- Functions with different parameter profile.
--- * Mixture of Procedures and Functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
- with Report;
-
- procedure C392003 is
-
- --
- -- Types and subtypes.
- --
-
- type Dollar_Amount is new float;
- type Interest_Rate is delta 0.001 range 0.000 .. 1.000;
- type Account_Types is (Bank, Savings, Preferred, Total);
- type Account_Counter is array (Account_Types) of integer;
- type Account_Rep is (President, Manager, New_Account_Manager, Teller);
-
- --
- -- Constants.
- --
-
- Opening_Balance : constant Dollar_Amount := 100.00;
- Current_Rate : constant Interest_Rate := 0.030;
- Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;
-
- --
- -- Global Variables
- --
-
- Bank_Reserve : Dollar_Amount := 0.00;
- Daily_Representative : Account_Rep := New_Account_Manager;
- Number_Of_Accounts : Account_Counter := (Bank => 0,
- Savings => 0,
- Preferred => 0,
- Total => 0);
-
- -- Root tagged type and primitive operations declared in internal
- -- package (Accounts).
- -- Extended types (and primitive operations) derived in nested packages.
-
- --=================================================================--
-
- package Accounts is
-
- --
- -- Root account type and primitive operations.
- --
-
- -- Root type.
-
- type Bank_Account is tagged
- record
- Balance : Dollar_Amount;
- end record;
-
- -- Primitive operations of Bank_Account.
-
- function Increment_Bank_Reserve (Acct : in Bank_Account)
- return Dollar_Amount;
- function Assign_Representative (Acct : in Bank_Account)
- return Account_Rep;
- procedure Increment_Counters (Acct : in Bank_Account);
- procedure Open (Acct : in out Bank_Account);
-
- --=================================================================--
-
- package S_And_L is
-
- -- Declare extended type in a nested package.
-
- type Savings_Account is new Bank_Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Function Increment_Bank_Reserve inherited from
- -- parent (Bank_Account).
-
- -- Primitive operations (Overridden).
- function Assign_Representative (Acct : in Savings_Account)
- return Account_Rep;
- procedure Increment_Counters (Acct : in Savings_Account);
- procedure Open (Acct : in out Savings_Account);
-
-
- --=================================================================--
-
- package Premium is
-
- -- Declare further extended type in a nested package.
-
- type Preferred_Account is new Savings_Account with
- record
- Minimum_Balance : Dollar_Amount;
- end record;
-
- -- Function Increment_Bank_Reserve inherited twice.
- -- Function Assign_Representative inherited from parent
- -- (Savings_Account).
-
- -- Primitive operation (Overridden).
- procedure Increment_Counters (Acct : in Preferred_Account);
- procedure Open (Acct : in out Preferred_Account);
-
- -- Function used to verify Open operation for Preferred_Account
- -- objects.
- function Verify_Open (Acct : in Preferred_Account) return Boolean;
-
- end Premium;
-
- end S_And_L;
-
- end Accounts;
-
- --=================================================================--
-
- package body Accounts is
-
- --
- -- Primitive operations for Bank_Account.
- --
-
- function Increment_Bank_Reserve (Acct : in Bank_Account)
- return Dollar_Amount is
- begin
- return (Bank_Reserve + Acct.Balance);
- end Increment_Bank_Reserve;
-
- function Assign_Representative (Acct : in Bank_Account)
- return Account_Rep is
- begin
- return Account_Rep'(Teller);
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Bank_Account) is
- begin
- Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Bank_Account) is
- begin
- Acct.Balance := Opening_Balance;
- end Open;
-
- --=================================================================--
-
- package body S_And_L is
-
- --
- -- Overridden operations for Savings_Account type.
- --
-
- function Assign_Representative (Acct : in Savings_Account)
- return Account_Rep is
- begin
- return (Manager);
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Savings_Account) is
- begin
- Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Savings_Account) is
- begin
- Open (Bank_Account(Acct));
- Acct.Rate := Current_Rate;
- Acct.Balance := 2.0 * Opening_Balance;
- end Open;
-
- --=================================================================--
-
- package body Premium is
-
- --
- -- Overridden operations for Preferred_Account type.
- --
-
- procedure Increment_Counters (Acct : in Preferred_Account) is
- begin
- Number_Of_Accounts (Preferred) :=
- Number_Of_Accounts (Preferred) + 1;
- Number_Of_Accounts (Total) :=
- Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Preferred_Account) is
- begin
- Open (Savings_Account(Acct));
- Acct.Minimum_Balance := Preferred_Minimum_Balance;
- Acct.Balance := Acct.Minimum_Balance;
- end Open;
-
- --
- -- Function used to verify Open operation for Preferred_Account
- -- objects.
- --
-
- function Verify_Open (Acct : in Preferred_Account)
- return Boolean is
- begin
- return (Acct.Balance = Preferred_Minimum_Balance and
- Acct.Rate = Current_Rate and
- Acct.Minimum_Balance = Preferred_Minimum_Balance);
- end Verify_Open;
-
- end Premium;
-
- end S_And_L;
-
- end Accounts;
-
- --=================================================================--
-
- -- Declare account objects.
-
- B_Account : Accounts.Bank_Account;
- S_Account : Accounts.S_And_L.Savings_Account;
- P_Account : Accounts.S_And_L.Premium.Preferred_Account;
-
- -- Procedures to operate on accounts.
- -- Each uses a class-wide IN parameter, as well as a call to a
- -- dispatching operation.
-
- -- Function Tabulate_Account performs a dispatching call on a primitive
- -- operation that has been overridden for each of the extended types.
-
- procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Counters (Acct); -- Dispatch according to tag.
- end Tabulate_Account;
-
- -- Function Accumulate_Reserve performs a dispatching call on a
- -- primitive operation that has been defined for the root type and
- -- inherited by each derived type.
-
- function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class)
- return Dollar_Amount is
- begin
- -- Dispatch according to tag.
- return (Accounts.Increment_Bank_Reserve (Acct));
- end Accumulate_Reserve;
-
- -- Procedure Resolve_Dispute performs a dispatching call on a primitive
- -- operation that has been defined in the root type, overridden in the
- -- first derived extended type, and inherited by the subsequent extended
- -- type.
-
- procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is
- begin
- -- Dispatch according to tag.
- Daily_Representative := Accounts.Assign_Representative (Acct);
- end Resolve_Dispute;
-
- --=================================================================--
-
- begin -- Main test procedure.
-
- Report.Test ("C392003", "Check that the use of a class-wide parameter " &
- "allows for proper dispatching where root type " &
- "is declared in a nested package, and " &
- "subsequent extended types are derived in " &
- "further nested packages" );
-
- Bank_Account_Subtest:
- begin
- Accounts.Open (B_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been defined for this specific type.
- Bank_Reserve := Accumulate_Reserve (Acct => B_Account);
- Tabulate_Account (B_Account);
-
- if (Bank_Reserve /= Opening_Balance) or
- (Number_Of_Accounts (Bank) /= 1) or
- (Number_Of_Accounts (Total) /= 1)
- then
- Report.Failed ("Failed in Bank_Account_Subtest");
- end if;
-
- end Bank_Account_Subtest;
-
-
- Savings_Account_Subtest:
- begin
- Accounts.S_And_L.Open (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type.
- Resolve_Dispute (Acct => S_Account);
- Tabulate_Account (S_Account);
-
- if (Daily_Representative /= Manager) or
- (Number_Of_Accounts (Savings) /= 1) or
- (Number_Of_Accounts (Total) /= 2)
- then
- Report.Failed ("Failed in Savings_Account_Subtest");
- end if;
-
- end Savings_Account_Subtest;
-
-
-
- Preferred_Account_Subtest:
- begin
- Accounts.S_And_L.Premium.Open (P_Account);
-
- -- Verify that the correct implementation of Open (overridden) was
- -- used for the Preferred_Account object.
- if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then
- Report.Failed ("Incorrect values for init. Preferred Acct object");
- end if;
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been twice inherited by this extended type.
- Bank_Reserve := Accumulate_Reserve (Acct => P_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type (the
- -- operation was overridden by its parent type as well).
- Tabulate_Account (P_Account);
-
- if Bank_Reserve /= 1100.00 or
- Number_Of_Accounts (Preferred) /= 1 or
- Number_Of_Accounts (Total) /= 3
- then
- Report.Failed ("Failed in Preferred_Account_Subtest");
- end if;
-
- end Preferred_Account_Subtest;
-
- Report.Result;
-
- end C392003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392004.a b/gcc/testsuite/ada/acats/tests/c3/c392004.a
deleted file mode 100644
index 0851db1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392004.a
+++ /dev/null
@@ -1,189 +0,0 @@
--- C392004.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 subprograms inherited from tagged derivations, which are
--- subsequently redefined for the derived type, are available to the
--- package defining the new class via view conversion. Check
--- that operations performed on objects using view conversion do not
--- affect the extended fields. Check that visible operations not masked
--- by the deriving package remain available to the client, and do not
--- affect the extended fields.
---
--- TEST DESCRIPTION:
--- This test declares a tagged type, with a constructor operation,
--- derives a type from that tagged type, and declares a constructor
--- operation which masks the inherited operation. It then tests
--- that the correct constructor is called, and that the extended
--- part of the derived type remains untouched as appropriate.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 04 Jan 94 SAIC Fixed objective typo, removed dead code.
---
---!
-
-with Report;
-
-package C392004_1 is
-
- type Vehicle is tagged private;
-
- procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural );
- procedure Start ( The_Vehicle : in out Vehicle );
-
-private
-
- type Vehicle is tagged record
- Engine_On : Boolean;
- end record;
-
-end C392004_1;
-
-package body C392004_1 is
- procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 1 => null; -- expected flag for this subprogram
- when others =>
- Report.Failed ("Called Vehicle Create");
- end case;
- The_Vehicle := (Engine_On => False);
- end Create;
-
- procedure Start ( The_Vehicle : in out Vehicle ) is
- begin
- The_Vehicle.Engine_On := True;
- end Start;
-
-end C392004_1;
-
-----------------------------------------------------------------------------
-
-with C392004_1;
-package C392004_2 is
-
- type Car is new C392004_1.Vehicle with record
- Convertible : Boolean;
- end record;
-
- -- masking definition
- procedure Create( The_Car : out Car; TC_Flag : Natural );
-
- type Limo is new Car with null record;
-
- procedure Create( The_Limo : out Limo; TC_Flag : Natural );
-
-end C392004_2;
-
-----------------------------------------------------------------------------
-
-with Report;
-package body C392004_2 is
-
- procedure Create( The_Car : out Car; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 2 => null; -- expected flag for this subprogram
- when others => Report.Failed ("Called Car Create");
- end case;
- C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
- The_Car.Convertible := False;
- end Create;
-
- procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 3 => null; -- expected flag for this subprogram
- when others => Report.Failed ("Called Limo Create");
- end case;
- C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
- The_Limo.Convertible := True;
- end Create;
-
-end C392004_2;
-
-----------------------------------------------------------------------------
-
-with Report;
-with C392004_1; use C392004_1;
-with C392004_2; use C392004_2;
-procedure C392004 is
-
- My_Car : Car;
- Your_Car : Limo;
-
- procedure TC_Assert( Is_True : Boolean; Message : String ) is
- begin
- if not Is_True then
- Report.Failed (Message);
- end if;
- end TC_Assert;
-
-begin -- Main test procedure.
-
- Report.Test ("C392004", "Check subprogram inheritance & visibility " &
- "for derived tagged types" );
-
- My_Car.Convertible := False;
- Create( Vehicle( My_Car ), 1 );
- TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
-
- Create( Your_Car, 3 );
- TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
-
- My_Car.Convertible := True;
- Create( Vehicle( My_Car ), 1 );
- TC_Assert( My_Car.Convertible, "Altered descendent component 3");
-
- Create( My_Car, 2 );
- TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
-
- My_Car.Convertible := False;
- Start( Vehicle( My_Car ) );
- TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
-
- Start( My_Car );
- TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
-
- Your_Car.Convertible := False;
- Start( Vehicle( Your_Car ) );
- TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
-
- Start( Your_Car );
- TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
-
- My_Car.Convertible := True;
- Start( Vehicle( My_Car ) );
- TC_Assert( My_Car.Convertible, "Altered descendent component 9");
-
- Start( My_Car );
- TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
-
- Report.Result;
-
-end C392004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392005.a b/gcc/testsuite/ada/acats/tests/c3/c392005.a
deleted file mode 100644
index be49cd4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392005.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- C392005.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, for an implicitly declared dispatching operation that is
--- overridden, the body executed is the body for the overriding
--- subprogram, even if the overriding occurs in a private part.
---
--- Check for the case where the overriding operations are declared in a
--- public child unit of the package declaring the parent type, and the
--- descendant type is a private extension.
---
--- Check for both dispatching and nondispatching calls.
---
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type Root is tagged ...
--- procedure Vis_Op (P: Root);
--- private
--- procedure Pri_Op (P: Root);
--- end Parent;
---
--- package Parent.Child is
--- type Derived is new Root with private;
--- -- Implicit Vis_Op (P: Derived) declared here.
---
--- procedure Pri_Op (P: Derived); -- (A)
--- ...
--- private
--- type Derived is new Root with record...
--- -- Implicit Pri_Op (P: Derived) declared here.
-
--- procedure Vis_Op (P: Derived); -- (B)
--- ...
--- end Parent.Child;
---
--- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
--- Root. Note, however, that Vis_Op is implicitly declared in the visible
--- part, whereas Pri_Op is implicitly declared in the private part
--- (inherited subprograms for a private extension are implicitly declared
--- after the private_extension_declaration if the corresponding
--- declaration from the ancestor is visible at that place; otherwise the
--- inherited subprogram is not declared for the private extension,
--- although it might be for the full type).
---
--- Even though Root's version of Pri_Op hasn't been implicitly declared
--- for Derived at the time Derived's version of Pri_Op has been
--- explicitly declared, the explicit Pri_Op still overrides the implicit
--- version.
--- Also, even though the explicit Vis_Op for Derived is declared in the
--- private part it still overrides the implicit version declared in the
--- visible part. Calls with tag Derived will execute (A) and (B).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Nov 96 SAIC Improved for ACVC 2.1
---
---!
-
-package C392005_0 is
-
- type Remote_Camera is tagged private;
-
- type Depth_Of_Field is range 5 .. 100;
- type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand);
- type Aperture is (Eight, Sixteen, Thirty_Two);
-
- -- ...Other declarations.
-
- procedure Focus (Cam : in out Remote_Camera;
- Depth : in Depth_Of_Field);
-
- procedure Self_Test (C: in out Remote_Camera'Class);
-
- -- ...Other operations.
-
- function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
- function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;
-
-private
-
- type Remote_Camera is tagged record
- DOF : Depth_Of_Field := 10;
- Shutter: Shutter_Speed := One;
- FStop : Aperture := Eight;
- end record;
-
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed);
-
- -- For the basic remote camera, shutter speed might be set as a function of
- -- focus perhaps, thus it is declared as a private operation (usable
- -- only internally within the abstraction).
-
- function Set_Aperture (C : Remote_Camera) return Aperture;
-
-end C392005_0;
-
-
- --==================================================================--
-
-
-package body C392005_0 is
-
- procedure Focus (Cam : in out Remote_Camera;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- Cam.DOF := 46;
- end Focus;
-
- -----------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Thousand;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- function Set_Aperture (C : Remote_Camera) return Aperture is
- begin
- -- Artificial for testing purposes.
- return Thirty_Two;
- end Set_Aperture;
-
- -----------------------------------------------------------
- procedure Self_Test (C: in out Remote_Camera'Class) is
- TC_Dummy_Depth : constant Depth_Of_Field := 23;
- TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred;
- begin
-
- -- Test focus at various depths:
- Focus(C, TC_Dummy_Depth);
- -- ...Additional calls to Focus.
-
- -- Test various shutter speeds:
- Set_Shutter_Speed(C, TC_Dummy_Speed);
- -- ...Additional calls to Set_Shutter_Speed.
-
- end Self_Test;
-
- -----------------------------------------------------------
- function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
- begin
- return C.DOF;
- end TC_Get_Depth;
-
- -----------------------------------------------------------
- function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
- begin
- return C.Shutter;
- end TC_Get_Speed;
-
-end C392005_0;
-
- --==================================================================--
-
-
-package C392005_0.C392005_1 is
-
- type Auto_Speed is new Remote_Camera with private;
-
-
- -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared
- -- Depth : in Depth_Of_Field) -- here.
-
- -- For the improved remote camera, shutter speed can be set manually,
- -- so it is declared as a public operation.
-
- -- The order of declarations for Set_Aperture and Set_Shutter_Speed are
- -- reversed from the original declarations to trap potential compiler
- -- problems related to subprogram ordering.
-
- function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides
- -- inherited op.
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides
- Speed : in Shutter_Speed);-- inherited op.
-
- -- Set_Shutter_Speed and Set_Aperture override the operations inherited
- -- from the parent, even though the inherited operations are not implicitly
- -- declared until the private part below.
-
- type New_Camera is private;
-
- function TC_Get_Aper (C: New_Camera) return Aperture;
-
- -- ...Other operations.
-
-private
- type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
-
- type Auto_Speed is new Remote_Camera with record
- ASA : Film_Speed;
- end record;
-
- -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly
- -- Speed : in Shutter_Speed) -- declared
- -- here.
-
- -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly
- -- declared.
-
- procedure Focus (C : in out Auto_Speed; -- Overrides
- Depth : in Depth_Of_Field); -- inherited op.
-
- -- For the improved remote camera, perhaps the focusing algorithm is
- -- different, so the original Focus operation is overridden here.
-
- Auto_Camera : Auto_Speed;
-
- type New_Camera is record
- Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden,
- end record; -- not the inherited op.
-
-end C392005_0.C392005_1;
-
-
- --==================================================================--
-
-
-package body C392005_0.C392005_1 is
-
- procedure Focus (C : in out Auto_Speed;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 57;
- end Focus;
-
- ---------------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Two_Fifty;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- function Set_Aperture (C : Auto_Speed) return Aperture is
- begin
- -- Artificial for testing purposes.
- return Sixteen;
- end Set_Aperture;
-
- -----------------------------------------------------------
- function TC_Get_Aper (C: New_Camera) return Aperture is
- begin
- return C.Aper;
- end TC_Get_Aper;
-
-end C392005_0.C392005_1;
-
-
- --==================================================================--
-
-
-with C392005_0.C392005_1;
-
-with Report;
-
-procedure C392005 is
- Basic_Camera : C392005_0.Remote_Camera;
- Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
- Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
- Auto_Depth : C392005_0.Depth_Of_Field := 67;
- New_Camera1 : C392005_0.C392005_1.New_Camera;
- TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
- TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57;
- TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed
- := C392005_0.Thousand;
- TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed
- := C392005_0.Two_Fifty;
- TC_Expected_New_Aper : constant C392005_0.Aperture
- := C392005_0.Sixteen;
-
- use type C392005_0.Depth_Of_Field;
- use type C392005_0.Shutter_Speed;
- use type C392005_0.Aperture;
-
-begin
- Report.Test ("C392005", "Dispatching for overridden primitive " &
- "subprograms: private extension declared in child unit, " &
- "parent is tagged private whose full view is tagged record");
-
--- Call the class-wide operation for Remote_Camera'Class, which itself makes
--- dispatching calls to Focus and Set_Shutter_Speed:
-
-
- -- For an object of type Remote_Camera, the dispatching calls should
- -- dispatch to the bodies declared for the root type:
-
- C392005_0.Self_Test(Basic_Camera);
-
- if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth
- or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
- then
- Report.Failed ("Calls dispatched incorrectly for root type");
- end if;
-
-
- -- For an object of type Auto_Speed, the dispatching calls should
- -- dispatch to the bodies declared for the derived type:
-
- C392005_0.Self_Test(Auto_Camera1);
-
- if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth
-
- or
- C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
- then
- Report.Failed ("Calls dispatched incorrectly for derived type");
- end if;
-
- -- For an object of type Auto_Speed, a non-dispatching call to Focus should
-
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);
-
- if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth
-
- then
- Report.Failed ("Non-dispatching call to privately overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of type New_Camera, the initialization using Set_Ap
- -- should execute the overridden body, not the inherited one.
-
- if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper
- then
- Report.Failed ("Non-dispatching call to visible overriding " &
- "subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392005;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392008.a b/gcc/testsuite/ada/acats/tests/c3/c392008.a
deleted file mode 100644
index 27b4e2a..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392008.a
+++ /dev/null
@@ -1,401 +0,0 @@
--- C392008.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 use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this for the case where the root tagged
--- type is defined in a package and the extended type is defined in a
--- dependent package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations,
--- in a visible library package.
--- Extend the root type in another visible library package, and override
--- one or more primitive operations, inheriting the other primitive
--- operations from the root type.
--- Derive from the extended type in yet another visible library package,
--- again overriding some primitive operations and inheriting others
--- (including some that the parent inherited).
--- Define subprograms with class-wide parameters, inside of which is a
--- call on a dispatching primitive operation. These primitive
--- operations modify the objects of the specific class passed as actuals
--- to the class-wide formal parameter (class-wide formal parameter has
--- mode IN OUT).
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
--- package Bank
--- type Account (root)
--- |
--- | Operations
--- | proc Deposit
--- | proc Withdrawal
--- | func Balance
--- | proc Service_Charge
--- | proc Add_Interest
--- | proc Open
--- |
--- package Checking
--- type Account (extended from Bank.Account)
--- |
--- | Operations
--- | proc Deposit (inherited)
--- | proc Withdrawal (inherited)
--- | func Balance (inherited)
--- | proc Service_Charge (inherited)
--- | proc Add_Interest (inherited)
--- | proc Open (overridden)
--- |
--- package Interest_Checking
--- type Account (extended from Checking.Account)
--- |
--- | Operations
--- | proc Deposit (inherited twice - Bank.Acct.)
--- | proc Withdrawal (inherited twice - Bank.Acct.)
--- | func Balance (inherited twice - Bank.Acct.)
--- | proc Service_Charge (inherited twice - Bank.Acct.)
--- | proc Add_Interest (overridden)
--- | proc Open (overridden)
--- |
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Bank.Account'Class IN OUT formal
--- parameter :
---
--- \ Type
--- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account
--- \---------------------------------------------------------
-
--- Service_Charge | X X X
--- Add_Interest | X X X
--- Open | X X X
---
---
---
--- The location of the declaration of the root and derivation of extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- * Declared in package.
--- Declared in generic package.
---
--- Extended types:
---
--- Derived in parent location.
--- Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- * Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- Functions with same parameter profile.
--- Functions with different parameter profile.
--- Mixture of Procedures and Functions.
---
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- C392008_0.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1
---
---!
-
------------------------------------------------------------------ C392008_0
-
-package C392008_0 is -- package Bank
-
- type Dollar_Amount is range -30_000..30_000;
-
- type Account is tagged
- record
- Current_Balance: Dollar_Amount;
- end record;
-
- -- Primitive operations.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount);
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount);
- function Balance (A : in Account) return Dollar_Amount;
- procedure Service_Charge (A : in out Account);
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end C392008_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_0 is
-
- -- Primitive operations for type Account.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance + X;
- end Deposit;
-
- procedure Withdrawal(A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance - X;
- end Withdrawal;
-
- function Balance (A : in Account) return Dollar_Amount is
- begin
- return (A.Current_Balance);
- end Balance;
-
- procedure Service_Charge (A : in out Account) is
- begin
- A.Current_Balance := A.Current_Balance - 5_00;
- end Service_Charge;
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Dollar_Amount := 0_00;
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Dollar_Amount := 10_00;
- begin
- A.Current_Balance := Initial_Deposit;
- end Open;
-
-end C392008_0;
-
------------------------------------------------------------------ C392008_1
-
-with C392008_0; -- package Bank
-
-package C392008_1 is -- package Checking
-
- package Bank renames C392008_0;
-
- type Account is new Bank.Account with
- record
- Overdraft_Fee : Bank.Dollar_Amount;
- end record;
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account);
-
- -- Inherited primitive operations.
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
- -- procedure Add_Interest (A : in out Account);
-
-end C392008_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_1 is
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account) is
- Check_Guarantee : Bank.Dollar_Amount := 10_00;
- Initial_Deposit : Bank.Dollar_Amount := 20_00;
- begin
- A.Current_Balance := Initial_Deposit;
- A.Overdraft_Fee := Check_Guarantee;
- end Open;
-
-end C392008_1;
-
------------------------------------------------------------------ C392008_2
-
-with C392008_0; -- with Bank;
-with C392008_1; -- with Checking;
-
-package C392008_2 is -- package Interest_Checking
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
-
- subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4;
-
- Current_Rate : Interest_Rate := 0_02;
-
- type Account is new Checking.Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
- -- "Twice" inherited primitive operations (from Bank.Account)
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
-
-end C392008_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_2 is
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Bank.Dollar_Amount
- := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate ));
- begin
- A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account);
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Bank.Dollar_Amount := 30_00;
- begin
- Checking.Open (Checking.Account (A));
- A.Current_Balance := Initial_Deposit;
- A.Rate := Current_Rate;
- end Open;
-
-end C392008_2;
-
-------------------------------------------------------------------- C392008
-
-with C392008_0; use C392008_0; -- package Bank
-with C392008_1; use C392008_1; -- package Checking;
-with C392008_2; use C392008_2; -- package Interest_Checking;
-with Report;
-
-procedure C392008 is
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
- package Interest_Checking renames C392008_2;
-
- B_Acct : Bank.Account;
- C_Acct : Checking.Account;
- IC_Acct : Interest_Checking.Account;
-
- --
- -- Define procedures with class-wide formal parameters of mode IN OUT.
- --
-
- -- This procedure will perform a dispatching call on the
- -- overridden primitive operation Open.
-
- procedure New_Account (Acct : in out Bank.Account'Class) is
- begin
- Open (Acct); -- Dispatch according to tag of class-wide parameter.
- end New_Account;
-
- -- This procedure will perform a dispatching call on the inherited
- -- primitive operation (for all types derived from the root Bank.Account)
- -- Service_Charge.
-
- procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is
- begin
- Service_Charge (Acct); -- Dispatch according to tag of class-wide parm.
- end Apply_Service_Charge;
-
- -- This procedure will perform a dispatching call on the
- -- inherited/overridden primitive operation Add_Interest.
-
- procedure Annual_Interest (Acct: in out Bank.Account'Class) is
- begin
- Add_Interest (Acct); -- Dispatch according to tag of class-wide parm.
- end Annual_Interest;
-
-begin
-
- Report.Test ("C392008", "Check that the use of a class-wide formal " &
- "parameter allows for the proper dispatching " &
- "of objects to the appropriate implementation " &
- "of a primitive operation");
-
- -- Check the dispatch to primitive operations overridden for each
- -- extended type.
- New_Account (B_Acct);
- New_Account (C_Acct);
- New_Account (IC_Acct);
-
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 30_00)
- then
- Report.Failed ("Failed dispatch to multiply overridden prim. oper.");
- end if;
-
-
- Annual_Interest (B_Acct);
- Annual_Interest (C_Acct);
- Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation
- -- overridden from a parent type which inherited
- -- the operation from the root type.
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 90_00)
- then
- Report.Failed ("Failed dispatch to overridden primitive operation");
- end if;
-
-
- Apply_Service_Charge (Acct => B_Acct);
- Apply_Service_Charge (Acct => C_Acct);
- Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a
- -- primitive operation twice
- -- inherited from the root
- -- tagged type.
- if (B_Acct.Current_Balance /= 5_00) or
- (C_Acct.Current_Balance /= 15_00) or
- (IC_Acct.Current_Balance /= 85_00)
- then
- Report.Failed ("Failed dispatch to Apply_Service_Charge");
- end if;
-
- Report.Result;
-
-end C392008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392010.a b/gcc/testsuite/ada/acats/tests/c3/c392010.a
deleted file mode 100644
index ec16878..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392010.a
+++ /dev/null
@@ -1,512 +0,0 @@
--- C392010.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 subprogram dispatches correctly with a controlling
--- access parameter. Check that a subprogram dispatches correctly
--- when it has access parameters that are not controlling.
--- Check with and without default expressions.
---
--- TEST DESCRIPTION:
--- The three packages define layers of tagged types. The root tagged
--- type contains a character value used to check that the right object
--- got passed to the right routine. Each subprogram has a unique
--- TCTouch tag, upper case values are used for subprograms, lower case
--- values are used for object values.
---
--- Notes on style: the "tagged" comment lines --I and --A represent
--- commentary about what gets inherited and what becomes abstract,
--- respectively. The author felt these to be necessary with this test
--- to reduce some of the additional complexities.
---
---3.9.2(16,17,18,20);6.0
---
--- CHANGE HISTORY:
--- 22 SEP 95 SAIC Initial version
--- 22 APR 96 SAIC Revised for 2.1
--- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make
--- it override.
--- 21 JUN 00 RLB Changed expected result to reflect the appropriate
--- value of the default expression.
--- 20 JUL 00 RLB Removed entire call pending resolution by the ARG.
-
---!
-
------------------------------------------------------------------ C392010_0
-
-package C392010_0 is
-
- -- define a root tagged type
- type Tagtype_Level_0 is tagged record
- Ch_Item : Character;
- end record;
-
- type Access_Procedure is access procedure( P: Tagtype_Level_0 );
-
- procedure Proc_1( P: Tagtype_Level_0 );
-
- procedure Proc_2( P: Tagtype_Level_0 );
-
- function A_Default_Value return Tagtype_Level_0;
-
- procedure Proc_w_Ap_and_Cp( AP : Access_Procedure;
- Cp : Tagtype_Level_0 );
- -- has both access procedure and controlling parameter
-
- procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
- Cp : Tagtype_Level_0
- := A_Default_Value ); ------------ z
- -- has both access procedure and controlling parameter with defaults
-
- -- for the objective:
--- Check that access parameters may be controlling.
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 );
- -- has access parameter that is controlling
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
- return Tagtype_Level_0;
- -- has access parameter that is controlling, and controlling result
-
- Level_0_Global_Object : aliased Tagtype_Level_0
- := ( Ch_Item => 'a' ); ---------------------------- a
-
-end C392010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392010_0 is
-
- procedure Proc_1( P: Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
- TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
- end Proc_1;
-
- procedure Proc_2( P: Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('B'); --------------------------------------------------- B
- TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
- end Proc_2;
-
- function A_Default_Value return Tagtype_Level_0 is
- begin
- return (Ch_Item => 'z'); ---------------------------------------------- z
- end A_Default_Value;
-
- procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure;
- Cp : Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('C'); --------------------------------------------------- C
- Ap.all( Cp );
- end Proc_w_Ap_and_Cp;
-
- procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
- Cp : Tagtype_Level_0
- := A_Default_Value ) is
- begin
- TCTouch.Touch('D'); --------------------------------------------------- D
- Ap.all( Cp );
- end Proc_w_Ap_and_Cp_w_Def;
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('E'); --------------------------------------------------- E
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- end Proc_w_Cp_Ap;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
- return Tagtype_Level_0 is
- begin
- TCTouch.Touch('F'); --------------------------------------------------- F
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- return ( Ch_Item => 'b' ); -------------------------------------------- b
- end Func_w_Cp_Ap_and_Cr;
-
-end C392010_0;
-
------------------------------------------------------------------ C392010_1
-
-with C392010_0;
-package C392010_1 is
-
- type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record
- Int_Item : Integer;
- end record;
-
- type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class;
-
- -- the following procedures are inherited by the above declaration:
- --I procedure Proc_1( P: Tagtype_Level_1 );
- --I
- --I procedure Proc_2( P: Tagtype_Level_1 );
- --I
- --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- --I Cp : Tagtype_Level_1 );
- --I
- --I procedure Proc_w_Ap_and_Cp_w_Def
- --I ( AP : C392010_0.Access_Procedure := Proc_2'Access;
- --I Cp : Tagtype_Level_1 := A_Default_Value );
- --I
- --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
- --I
-
- -- the following functions become abstract due to the above declaration:
- --A function A_Default_Value return Tagtype_Level_1;
- --A
- --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- --A return Tagtype_Level_1;
-
- -- so, in the interest of testing dispatching, we override them all:
- -- except Proc_1 and Proc_2
-
- procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- Cp : Tagtype_Level_1 );
-
- function A_Default_Value return Tagtype_Level_1;
-
- procedure Proc_w_Ap_and_Cp_w_Def(
- AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
- Cp : Tagtype_Level_1 := A_Default_Value );
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- return Tagtype_Level_1;
-
- -- to test the objective:
--- Check that a subprogram dispatches correctly when it has
--- access parameters that are not controlling.
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access )
- return Access_Tagtype_Level_1;
-
- Level_1_Global_Object : aliased Tagtype_Level_1
- := ( Int_Item => 0,
- Ch_Item => 'c' ); --------------------------- c
-
-end C392010_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392010_1 is
-
- procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- Cp : Tagtype_Level_1 ) is
- begin
- TCTouch.Touch('G'); --------------------------------------------------- G
- Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
- end Proc_w_Ap_and_Cp;
-
- procedure Proc_w_Ap_and_Cp_w_Def(
- AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
- Cp : Tagtype_Level_1 := A_Default_Value )
- is
- begin
- TCTouch.Touch('H'); --------------------------------------------------- H
- Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
- end Proc_w_Ap_and_Cp_w_Def;
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is
- begin
- TCTouch.Touch('I'); --------------------------------------------------- I
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- end Proc_w_Cp_Ap;
-
- function A_Default_Value return Tagtype_Level_1 is
- begin
- return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y
- end A_Default_Value;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- return Tagtype_Level_1 is
- begin
- TCTouch.Touch('J'); --------------------------------------------------- J
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d
- end Func_w_Cp_Ap_and_Cr;
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access ) is
- begin
- TCTouch.Touch('K'); --------------------------------------------------- K
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- end Proc_w_Non;
-
- Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access )
- return Access_Tagtype_Level_1 is
- begin
- TCTouch.Touch('L'); --------------------------------------------------- L
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- return Own_Item'Access; ----------------------------------------------- e
- end Func_w_Non;
-
-end C392010_1;
-
-
-
------------------------------------------------------------------ C392010_2
-
-with C392010_0;
-with C392010_1;
-package C392010_2 is
-
- Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0
- := ( Ch_Item => 'f' ); ---------------------------- f
-
- type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record
- Another_Int_Item : Integer;
- end record;
-
- type Access_Tagtype_Level_2 is access all Tagtype_Level_2;
-
- -- the following procedures are inherited by the above declaration:
- --I procedure Proc_1( P: Tagtype_Level_2 );
- --I
- --I procedure Proc_2( P: Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- --I Cp : Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Ap_and_Cp_w_Def
- --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
- --I CP: Tagtype_Level_2 := A_Default_Value );
- --I
- --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- --I NonCp_Ap : access C392010_0.Tagtype_Level_0
- --I := C392010_0.Level_0_Global_Object'Access );
-
- -- the following functions become abstract due to the above declaration:
- --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- --A return Tagtype_Level_2;
- --A
- --A function A_Default_Value
- --A return Access_Tagtype_Level_2;
-
- -- so we override the interesting ones to check the objective:
--- Check that a subprogram with parameters of distinct tagged types may
--- be primitive for only one type (i.e. the other tagged types must be
--- declared in other packages). Check that the subprogram does not
--- dispatch for the other type(s).
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access )
- return C392010_1.Access_Tagtype_Level_1;
-
- -- and override the other abstract functions
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- return Tagtype_Level_2;
-
- function A_Default_Value return Tagtype_Level_2;
-
-end C392010_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Report;
-package body C392010_2 is
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access ) is
- begin
- TCTouch.Touch('M'); --------------------------------------------------- M
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- end Proc_w_Non;
-
- function A_Default_Value return Tagtype_Level_2 is
- begin
- return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x
- end A_Default_Value;
-
- Own : aliased Tagtype_Level_2
- := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access )
- return C392010_1.Access_Tagtype_Level_1 is
- begin
- TCTouch.Touch('N'); --------------------------------------------------- N
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- return Own'Access; ---------------------------------------------------- g
- end Func_w_Non;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- return Tagtype_Level_2 is
- begin
- TCTouch.Touch('P'); --------------------------------------------------- P
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h
- end Func_w_Cp_Ap_and_Cr;
-
-end C392010_2;
-
-
-
-------------------------------------------------------------------- C392010
-
-with Report;
-with TCTouch;
-with C392010_0, C392010_1, C392010_2;
-
-procedure C392010 is
-
- type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class;
-
- -- define an array of class-wide pointers:
- type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0;
-
- Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k
- Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m
- Int_Item => 1 );
- Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n
- Int_Item => 1,
- Another_Int_Item => 1 );
-
- Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access);
-
- procedure Subtest_1( Items: Zero_Dispatch_List ) is
- -- there is little difference between the actions for _1 and _2 in
- -- this subtest due to the nature of _2 inheriting most operations
- --
- -- this subtest checks operations available to Level_0'Class
- begin
- for I in Items'Range loop
-
- C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all );
- -- CAk, GAm, GAn
- -- actual is class-wide, operation should dispatch
-
- case I is -- use defaults
- when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def;
- -- DBz
- when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def;
- -- HBy
- when 3 => null; -- Removed following pending resolution by ARG
- -- (see AI-00239):
- -- C392010_2.Proc_w_Ap_and_Cp_w_Def;
- -- HBx
- when others => Report.Failed("Unexpected loop value");
- end case;
-
- C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults
- ( C392010_0.Proc_1'Access, Items(I).all );
- -- DAk, HAm, HAn
-
- C392010_0.Proc_w_Cp_Ap( Items(I) );
- -- Ek, Im, In
-
- -- function return value is controlling for procedure call
- C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access,
- C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) );
- -- FkDAb, JmHAd, PnHAh
- -- note that the function evaluates first
-
- end loop;
- end Subtest_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class;
-
- type One_Dispatch_List is array(Natural range <>) of Access_Class_1;
-
- Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p
- Int_Item => 1 );
- Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q
- Int_Item => 1,
- Another_Int_Item => 1 );
-
- D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access);
-
- procedure Subtest_2( Items: One_Dispatch_List ) is
- -- this subtest checks operations available to Level_1'Class,
- -- specifically those operations that are not testable in subtest_1,
- -- the operations with parameters of the two tagged type objects.
- begin
- for I in Items'Range loop
-
- C392010_1.Proc_w_Non( -- t_1, t_2
- C392010_1.Func_w_Non( Items(I),
- C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm
- C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn
-
- end loop;
- end Subtest_2;
-
-begin -- Main test procedure.
-
- Report.Test ("C392010", "Check that a subprogram dispatches correctly " &
- "with a controlling access parameter. " &
- "Check that a subprogram dispatches correctly " &
- "when it has access parameters that are not " &
- "controlling. Check with and without default " &
- "expressions" );
-
- Subtest_1( Z );
-
- -- Original result:
- --TCTouch.Validate( "CAkDBzDAkEkFkDAb"
- -- & "GAmHByHAmImJmHAd"
- -- & "GAnHBxHAnInPnHAh", "Subtest 1" );
-
- -- Result pending resultion of AI-239:
- TCTouch.Validate( "CAkDBzDAkEkFkDAb"
- & "GAmHByHAmImJmHAd"
- & "GAnHAnInPnHAh", "Subtest 1" );
-
- Subtest_2( D );
-
- TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" );
-
- Report.Result;
-
-end C392010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392011.a b/gcc/testsuite/ada/acats/tests/c3/c392011.a
deleted file mode 100644
index c32ec77..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392011.a
+++ /dev/null
@@ -1,299 +0,0 @@
--- C392011.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 function call with a controlling result is itself
--- a controlling operand of an enclosing call on a dispatching operation,
--- then its controlling tag value is determined by the controlling tag
--- value of the enclosing call.
---
--- TEST DESCRIPTION:
--- The test builds and traverses a "ragged" list; a linked list which
--- contains data elements of three different types (all rooted at
--- Level_0'Class). The traversal of this list checks the objective
--- by calling the dispatching operation "Check" using an item from the
--- list, and calling the function create; thus causing the controlling
--- result of the function to be determined by evaluating the value of
--- the other controlling parameter to the two-parameter Check.
---
---
--- CHANGE HISTORY:
--- 22 SEP 95 SAIC Initial version
--- 23 APR 96 SAIC Corrected commentary, differentiated integer.
---
---!
-
------------------------------------------------------------------ C392011_0
-
-package C392011_0 is
-
- type Level_0 is tagged record
- Ch_Item : Character;
- end record;
-
- function Create return Level_0;
- -- primitive dispatching function
-
- procedure Check( Left, Right: in Level_0 );
- -- has controlling parameters
-
-end C392011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C392011_0 is
-
- The_Character : Character := 'A';
-
- function Create return Level_0 is
- Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character );
- begin
- The_Character := Character'Succ(The_Character);
- TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A
- return Created_Item_0;
- end Create;
-
- procedure Check( Left, Right: in Level_0 ) is
- begin
- TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B
- end Check;
-
-end C392011_0;
-
------------------------------------------------------------------ C392011_1
-
-with C392011_0;
-package C392011_1 is
-
- type Level_1 is new C392011_0.Level_0 with record
- Int_Item : Integer;
- end record;
-
- -- note that Create becomes abstract upon this derivation hence:
-
- function Create return Level_1;
-
- procedure Check( Left, Right: in Level_1 );
-
-end C392011_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392011_1 is
-
- Integer_1 : Integer := 0;
-
- function Create return Level_1 is
- Created_Item_1 : constant Level_1
- := ( C392011_0.Create with Int_Item => Integer_1 );
- -- note call to ^--------------^ -- A
- begin
- Integer_1 := Integer'Succ(Integer_1);
- TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C
- return Created_Item_1;
- end Create;
-
- procedure Check( Left, Right: in Level_1 ) is
- begin
- TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D
- end Check;
-
-end C392011_1;
-
------------------------------------------------------------------ C392011_2
-
-with C392011_1;
-package C392011_2 is
-
- type Level_2 is new C392011_1.Level_1 with record
- Another_Int_Item : Integer;
- end record;
-
- -- note that Create becomes abstract upon this derivation hence:
-
- function Create return Level_2;
-
- procedure Check( Left, Right: in Level_2 );
-
-end C392011_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392011_2 is
-
- Integer_2 : Integer := 100;
-
- function Create return Level_2 is
- Created_Item_2 : constant Level_2
- := ( C392011_1.Create with Another_Int_Item => Integer_2 );
- -- note call to ^--------------^ -- AC
- begin
- Integer_2 := Integer'Succ(Integer_2);
- TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E
- return Created_Item_2;
- end Create;
-
- procedure Check( Left, Right: in Level_2 ) is
- begin
- TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F
- end Check;
-
-end C392011_2;
-
-------------------------------------------------------- C392011_2.C392011_3
-
-with C392011_0;
-package C392011_2.C392011_3 is
-
- type Wide_Reference is access all C392011_0.Level_0'Class;
-
- type Ragged_Element;
-
- type List_Pointer is access Ragged_Element;
-
- type Ragged_Element is record
- Data : Wide_Reference;
- Next : List_Pointer;
- end record;
-
- procedure Build_List;
-
- procedure Traverse_List;
-
-end C392011_2.C392011_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392011_2.C392011_3 is
-
- The_List : List_Pointer;
-
- procedure Build_List is
- begin
-
- -- build a list that looks like:
- -- Level_2, Level_1, Level_2, Level_1, Level_0
- --
- -- the mechanism is to create each object, "pushing" the existing list
- -- onto the end: cons( new_item, car, cdr )
-
- The_List :=
- new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null );
- -- Level_0 >> A
-
- The_List :=
- new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
- -- Level_1 -> Level_0 >> AC
-
- The_List :=
- new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
- -- Level_2 -> Level_1 -> Level_0 >> ACE
-
- The_List :=
- new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
- -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC
-
- The_List :=
- new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
- -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE
-
- end Build_List;
-
- procedure Traverse_List is
-
- Next_Item : List_Pointer := The_List;
-
- -- Check that if a function call with a controlling result is itself
- -- a controlling operand of an enclosing call on a dispatching operation,
- -- then its controlling tag value is determined by the controlling tag
- -- value of the enclosing call.
-
- -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0
-
- begin
-
- while Next_Item /= null loop -- here we go!
- -- these calls better dispatch according to the value in the particular
- -- list item; causing the call to create to dispatch accordingly.
- -- why do it twice? To make sure order makes no difference
-
- C392011_0.Check(Next_Item.Data.all, C392011_0.Create);
- -- Create will touch first, then Check touches
-
- C392011_0.Check(C392011_0.Create, Next_Item.Data.all);
-
- -- Here's what's s'pos'd to 'appen:
- -- Check( Lev_2, Create ) >> ACEF
- -- Check( Create, Lev_2 ) >> ACEF
- -- Check( Lev_1, Create ) >> ACD
- -- Check( Create, Lev_1 ) >> ACD
- -- Check( Lev_2, Create ) >> ACEF
- -- Check( Create, Lev_2 ) >> ACEF
- -- Check( Lev_1, Create ) >> ACD
- -- Check( Create, Lev_1 ) >> ACD
- -- Check( Lev_0, Create ) >> AB
- -- Check( Create, Lev_0 ) >> AB
-
- Next_Item := Next_Item.Next;
- end loop;
- end Traverse_List;
-
-end C392011_2.C392011_3;
-
-------------------------------------------------------------------- C392011
-
-with Report;
-with TCTouch;
-with C392011_2.C392011_3;
-
-procedure C392011 is
-
-begin -- Main test procedure.
-
- Report.Test ("C392011", "Check that if a function call with a " &
- "controlling result is itself a controlling " &
- "operand of an enclosing call on a dispatching " &
- "operation, then its controlling tag value is " &
- "determined by the controlling tag value of " &
- "the enclosing call" );
-
- C392011_2.C392011_3.Build_List;
- TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" );
-
- C392011_2.C392011_3.Traverse_List;
- TCTouch.Validate( "ACEFACEF" &
- "ACDACD" &
- "ACEFACEF" &
- "ACDACD" &
- "ABAB",
- "Traverse List" );
-
- Report.Result;
-
-end C392011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392013.a b/gcc/testsuite/ada/acats/tests/c3/c392013.a
deleted file mode 100644
index 3873d9e..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392013.a
+++ /dev/null
@@ -1,179 +0,0 @@
--- C392013.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 "/=" implicitly declared with the declaration of "=" for
--- a tagged type is legal and can be used in a dispatching call.
--- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1).
---
--- CHANGE HISTORY:
--- 23 JAN 2001 PHL Initial version.
--- 16 MAR 2001 RLB Readied for release; added identity and negative
--- result cases.
--- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case.
---!
-with Report;
-use Report;
-procedure C392013 is
-
- package P1 is
- type T is tagged
- record
- C1 : Integer;
- end record;
- function "=" (L, R : T) return Boolean;
- end P1;
-
- package P2 is
- type T is new P1.T with private;
- function Make (Ancestor : P1.T; X : Float) return T;
- private
- type T is new P1.T with
- record
- C2 : Float;
- end record;
- function "=" (L, R : T) return Boolean;
- end P2;
-
- package P3 is
- type T is new P2.T with
- record
- C3 : Character;
- end record;
- private
- function "=" (L, R : T) return Boolean;
- function Make (Ancestor : P1.T; X : Float) return T;
- end P3;
-
-
- package body P1 is separate;
- package body P2 is separate;
- package body P3 is separate;
-
-
- type Cwat is access P1.T'Class;
- type Cwat_Array is array (Positive range <>) of Cwat;
-
- A : constant Cwat_Array :=
- (1 => new P1.T'(C1 => Ident_Int (3)),
- 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)),
- 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)),
- 4 => new P1.T'(C1 => Ident_Int (-3)),
- 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)),
- 6 => new P1.T'(C1 => Ident_Int (4)),
- 7 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with
- Ident_Char ('a')),
- 8 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with
- Ident_Char ('A')),
- 9 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with
- Ident_Char ('B')));
-
- type Truth is ('F', 'T');
- type Truth_Table is array (Positive range <>, Positive range <>) of Truth;
-
- Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF",
- "FTTFTFFFF",
- "FTTFFFFFF",
- "TFFTFFFFF",
- "FTFFTFFFF",
- "FFFFFTFFF",
- "FFFFFFTTF",
- "FFFFFFTTF",
- "FFFFFFFFT");
-
-begin
- Test ("C392013", "Check that the ""/="" implicitly declared " &
- "with the declaration of ""="" for a tagged " &
- "type is legal and can be used in a dispatching call");
-
- for I in A'Range loop
- for J in A'Range loop
- -- Test identity:
- if P1."=" (A (I).all, A (J).all) /=
- (not P1."/=" (A (I).all, A (J).all)) then
- Failed ("Incorrect identity comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J));
- end if;
- -- Test the result of "/=":
- if Equality (I, J) = 'T' then
- if P1."/=" (A (I).all, A (J).all) then
- Failed ("Incorrect result comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J) & " - T");
- end if;
- else
- if not P1."/=" (A (I).all, A (J).all) then
- Failed ("Incorrect result comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J) & " - F");
- end if;
- end if;
- end loop;
- end loop;
-
- Result;
-end C392013;
-separate (C392013)
-package body P1 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return abs L.C1 = abs R.C1;
- end "=";
-
-end P1;
-separate (C392013)
-package body P2 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5;
- end "=";
-
-
- function Make (Ancestor : P1.T; X : Float) return T is
- begin
- return (Ancestor with X);
- end Make;
-
-end P2;
-with Ada.Characters.Handling;
-separate (C392013)
-package body P3 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return P2."=" (P2.T (L), P2.T (R)) and then
- Ada.Characters.Handling.To_Upper (L.C3) =
- Ada.Characters.Handling.To_Upper (R.C3);
- end "=";
-
- function Make (Ancestor : P1.T; X : Float) return T is
- begin
- return (P2.Make (Ancestor, X) with ' ');
- end Make;
-
-end P3;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392014.a b/gcc/testsuite/ada/acats/tests/c3/c392014.a
deleted file mode 100644
index 8ecb414..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392014.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- C392014.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 objects designated by X'Access (where X is of a class-wide
--- type) and new T'Class'(...) are dynamically tagged and can be used in
--- dispatching calls. (Defect Report 8652/0010).
---
--- CHANGE HISTORY:
--- 18 JAN 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release.
--- 03 JUN 2004 RLB Removed constraint for S0, as the subtype has
--- unknown discriminants.
-
---!
-package C392014_0 is
-
- type T (D : Integer) is abstract tagged private;
-
- procedure P (X : access T) is abstract;
- function Create (X : Integer) return T'Class;
-
- Result : Natural := 0;
-
-private
- type T (D : Integer) is abstract tagged null record;
-end C392014_0;
-
-with C392014_0;
-package C392014_1 is
- type T is new C392014_0.T with private;
- function Create (X : Integer) return T'Class;
-private
- type T is new C392014_0.T with
- record
- C1 : Integer;
- end record;
- procedure P (X : access T);
-end C392014_1;
-
-package C392014_1.Child is
- type T is new C392014_1.T with private;
- procedure P (X : access T);
- function Create (X : Integer) return T'Class;
-private
- type T is new C392014_1.T with
- record
- C1C : Integer;
- end record;
-end C392014_1.Child;
-
-with Report;
-use Report;
-with C392014_1.Child;
-package body C392014_1 is
-
- procedure P (X : access T) is
- begin
- C392014_0.Result := C392014_0.Result + X.D + X.C1;
- end P;
-
- function Create (X : Integer) return T'Class is
- begin
- case X mod Ident_Int (2) is
- when 0 =>
- return C392014_1.Child.Create (X / Ident_Int (2));
- when 1 =>
- declare
- Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20));
- begin
- Y.C1 := X / Ident_Int (40);
- return T'Class (Y);
- end;
- when others =>
- null;
- end case;
- end Create;
-
-end C392014_1;
-
-with C392014_0;
-with C392014_1;
-package C392014_2 is
- type T is new C392014_0.T with private;
- function Create (X : Integer) return T'Class;
-private
- type T is new C392014_1.T with
- record
- C2 : Integer;
- end record;
- procedure P (X : access T);
-end C392014_2;
-
-with Report;
-use Report;
-with C392014_1.Child;
-with C392014_2;
-package body C392014_0 is
-
- function Create (X : Integer) return T'Class is
- begin
- case X mod 3 is
- when 0 =>
- return C392014_1.Create (X / Ident_Int (3));
- when 1 =>
- return C392014_1.Child.Create (X / Ident_Int (3));
- when 2 =>
- return C392014_2.Create (X / Ident_Int (3));
- when others =>
- null;
- end case;
- end Create;
-
-end C392014_0;
-
-with Report;
-use Report;
-with C392014_0;
-package body C392014_1.Child is
-
- procedure P (X : access T) is
- begin
- C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C;
- end P;
-
- function Create (X : Integer) return T'Class is
- Y : T (D => X mod Ident_Int (20));
- begin
- Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20);
- Y.C1C := X / Ident_Int (400);
- return T'Class (Y);
- end Create;
-
-end C392014_1.Child;
-
-with Report;
-use Report;
-package body C392014_2 is
-
- procedure P (X : access T) is
- begin
- C392014_0.Result := C392014_0.Result + X.D + X.C2;
- end P;
-
- function Create (X : Integer) return T'Class is
- Y : T (D => X mod Ident_Int (20));
- begin
- Y.C2 := X / Ident_Int (600);
- return T'Class (Y);
- end Create;
-
-end C392014_2;
-
-with Report;
-use Report;
-with C392014_0;
-with C392014_1.Child;
-with C392014_2;
-procedure C392014 is
-
- subtype S0 is C392014_0.T'Class;
- subtype S1 is C392014_1.T'Class;
-
- X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218));
- X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253));
-
- Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693));
- Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622));
-
- procedure TC_Check (Subtest : String; Expected : Integer) is
- begin
- if C392014_0.Result = Expected then
- Comment ("Subtest " & Subtest & " Passed");
- else
- Failed ("Subtest " & Subtest & " Failed");
- end if;
- C392014_0.Result := Ident_Int (0);
- end TC_Check;
-
-begin
- Test ("C392014",
- "Check that objects designated by X'Access " &
- "(where X is of a class-wide type) and New T'Class'(...) " &
- "are dynamically tagged and can be used in dispatching " &
- "calls");
-
- C392014_0.P (X0'Access);
- TC_Check ("X0'Access", Ident_Int (29));
- C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850))));
- TC_Check ("New C392014_0.T'Class", Ident_Int (27));
- C392014_1.P (X1'Access);
- TC_Check ("X1'Access", Ident_Int (212));
- C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031))));
- TC_Check ("New C392014_1.T'Class", Ident_Int (65));
- C392014_0.P (Y0'Access);
- TC_Check ("Y0'Access", Ident_Int (18));
- C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893))));
- TC_Check ("New S0", Ident_Int (20));
- C392014_1.P (Y1'Access);
- TC_Check ("Y1'Access", Ident_Int (18));
- C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861))));
- TC_Check ("New S1", Ident_Int (56));
-
- Result;
-end C392014;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392a01.a b/gcc/testsuite/ada/acats/tests/c3/c392a01.a
deleted file mode 100644
index 8ad7891..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392a01.a
+++ /dev/null
@@ -1,265 +0,0 @@
--- C392A01.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 use of a class-wide formal parameter allows for the
- -- proper dispatching of objects to the appropriate implementation of
- -- a primitive operation. Check this for the root tagged type defined
- -- in a package, and the extended type is defined in that same package.
- --
- -- TEST DESCRIPTION:
- -- Declare a root tagged type, and some associated primitive operations.
- -- Extend the root type, and override one or more primitive operations,
- -- inheriting the other primitive operations from the root type.
- -- Derive from the extended type, again overriding some primitive
- -- operations and inheriting others (including some that the parent
- -- inherited).
- -- Define a subprogram with a class-wide parameter, inside of which is a
- -- call on a dispatching primitive operation. These primitive operations
- -- modify global variables (the class-wide parameter has mode IN).
- --
- --
- --
- -- The following hierarchy of tagged types and primitive operations is
- -- utilized in this test:
- --
- -- type Bank_Account (root)
- -- |
- -- | Operations
- -- | Increment_Bank_Reserve
- -- | Assign_Representative
- -- | Increment_Counters
- -- | Open
- -- |
- -- type Savings_Account (extended from Bank_Account)
- -- |
- -- | Operations
- -- | (Increment_Bank_Reserve) (inherited)
- -- | Assign_Representative (overridden)
- -- | Increment_Counters (overridden)
- -- | Open (overridden)
- -- |
- -- type Preferred_Account (extended from Savings_Account)
- -- |
- -- | Operations
- -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
- -- | (Assign_Representative) (inherited - Savings_Acct.)
- -- | Increment_Counters (overridden)
- -- | Open (overridden)
- --
- --
- -- In this test, we are concerned with the following selection of dispatching
- -- calls, accomplished with the use of a Bank_Account'Class IN procedure
- -- parameter :
- --
- -- \ Type
- -- Prim. Op \ Bank_Account Savings_Account Preferred_Account
- -- \------------------------------------------------
- -- Increment_Bank_Reserve| X X X
- -- Assign_Representative | X
- -- Increment_Counters | X X X
- --
- --
- --
- -- The location of the declaration and derivation of the root and extended
- -- types will be varied over a series of tests. Locations of declaration
- -- and derivation for a particular test are marked with an asterisk (*).
- --
- -- Root type:
- --
- -- * Declared in package.
- -- Declared in generic package.
- --
- -- Extended types:
- --
- -- * Derived in parent location.
- -- Derived in a nested package.
- -- Derived in a nested subprogram.
- -- Derived in a nested generic package.
- -- Derived in a separate package.
- -- Derived in a separate visible child package.
- -- Derived in a separate private child package.
- --
- -- Primitive Operations:
- --
- -- * Procedures with same parameter profile.
- -- Procedures with different parameter profile.
- -- Functions with same parameter profile.
- -- Functions with different parameter profile.
- -- Mixture of Procedures and Functions.
- --
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F392A00.A
- --
- -- The following files comprise this test:
- --
- -- => C392A01.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F392A00; -- package Accounts
- with Report;
-
- procedure C392A01 is
-
- package Accounts renames F392A00;
-
- -- Declare account objects.
-
- B_Account : Accounts.Bank_Account;
- S_Account : Accounts.Savings_Account;
- P_Account : Accounts.Preferred_Account;
-
- -- Procedures to operate on accounts.
- -- Each uses a class-wide IN parameter, as well as a call to a
- -- dispatching operation.
-
- -- Procedure Tabulate_Account performs a dispatching call on a primitive
- -- operation that has been overridden for each of the extended types.
-
- procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Counters (Acct); -- Dispatch according to tag.
- end Tabulate_Account;
-
-
- -- Procedure Accumulate_Reserve performs a dispatching call on a
- -- primitive operation that has been defined for the root type and
- -- inherited by each derived type.
-
- procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Bank_Reserve (Acct); -- Dispatch according to tag.
- end Accumulate_Reserve;
-
-
- -- Procedure Resolve_Dispute performs a dispatching call on a primitive
- -- operation that has been defined in the root type, overridden in the
- -- first derived extended type, and inherited by the subsequent extended
- -- type.
-
- procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Assign_Representative (Acct); -- Dispatch according to tag.
- end Resolve_Dispute;
-
-
-
- begin -- Main test procedure.
-
- Report.Test ("C392A01", "Check that the use of a class-wide parameter " &
- "allows for proper dispatching where root type " &
- "and extended types are declared in the same " &
- "package" );
-
- Bank_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (B_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been defined for this specific type.
- Accumulate_Reserve (Acct => B_Account);
- Tabulate_Account (B_Account);
-
- if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or
- (Accounts.Number_Of_Accounts (Bank) /= 1) or
- (Accounts.Number_Of_Accounts (Total) /= 1)
- then
- Report.Failed ("Failed in Bank_Account_Subtest");
- end if;
-
- end Bank_Account_Subtest;
-
-
- Savings_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been inherited by this extended type.
- Accumulate_Reserve (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type.
- Resolve_Dispute (Acct => S_Account);
- Tabulate_Account (S_Account);
-
- if Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or
- Accounts.Daily_Representative /= Accounts.Manager or
- Accounts.Number_Of_Accounts (Savings) /= 1 or
- Accounts.Number_Of_Accounts (Total) /= 2
- then
- Report.Failed ("Failed in Savings_Account_Subtest");
- end if;
-
- end Savings_Account_Subtest;
-
-
- Preferred_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (P_Account);
-
- -- Verify that the correct implementation of Open (overridden) was
- -- used for the Preferred_Account object.
- if not Accounts.Verify_Open (P_Account) then
- Report.Failed ("Incorrect values for init. Preferred Acct object");
- end if;
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been twice inherited by this extended type.
- Accumulate_Reserve (Acct => P_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type (the
- -- operation was overridden by its parent type as well).
- Tabulate_Account (P_Account);
-
- if Accounts.Bank_Reserve /= 1300.00 or
- Accounts.Number_Of_Accounts (Preferred) /= 1 or
- Accounts.Number_Of_Accounts (Total) /= 3
- then
- Report.Failed ("Failed in Preferred_Account_Subtest");
- end if;
-
- end Preferred_Account_Subtest;
-
-
- Report.Result;
-
- end C392A01;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c05.a b/gcc/testsuite/ada/acats/tests/c3/c392c05.a
deleted file mode 100644
index 6bd3cec..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392c05.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- C392C05.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 for a call to a dispatching subprogram the subprogram
--- body which is executed is determined by the controlling tag for
--- the case where the call has statically tagged controlling operands
--- of the type T. Check this for various operands of tagged types:
--- objects (declared or allocated), formal parameters, view conversions,
--- function calls (both primitive and non-primitive).
---
--- TEST DESCRIPTION:
--- This test uses foundation F392C00 to test the usages of statically
--- tagged objects and values. The calls to Validate indicate the
--- expected sequence of procedure calls since the previous call to
--- Validate. Static tags can be determined at compile time, and
--- hence this is a test of correct overload resolution for tagged types.
--- A clever compiler which unrolls loops and does path analysis on
--- access values will be able to perform the same kind of determination
--- for all of the code in this test.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392C00.A (foundation code)
--- C392C05.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 24 Oct 95 SAIC Updated for ACVC 2.0.1
--- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are
--- evaluated in textual order.
---!
-
-with Report;
-with TCTouch;
-with F392C00_1;
-procedure C392C05 is -- Hardware_Store
-
- package Switch renames F392C00_1;
-
- subtype Switch_Class is Switch.Toggle'Class;
-
- type Reference is access all Switch_Class;
-
- A_Switch : aliased Switch.Toggle;
- A_Dimmer : aliased Switch.Dimmer;
- An_Autodim : aliased Switch.Auto_Dimmer;
-
- type Light_Bank is array(Positive range <>) of Reference;
-
- Lamps : Light_Bank(1..3);
-
-begin -- Main test procedure.
-
- Report.Test ("C392C05", "Check that a dispatching subprogram call is "
- & "determined by the controlling tag for statically "
- & "tagged controlling operands" );
-
--- Check use of static tagged declared objects,
--- and static tagged formal parameters
--- Must call correct version of flip based on type of controlling op.
-
--- Turn on the lights!
-
- Switch.Flip( A_Switch );
- TCTouch.Validate( "A", "Declared Toggle" );
-
- Switch.Flip( A_Dimmer );
- TCTouch.Validate( "GBA", "Declared Dimmer" );
-
- Switch.Flip( An_Autodim );
- TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" );
-
- Lamps(1) := new Switch.Toggle;
- Lamps(2) := new Switch.Dimmer;
- Lamps(3) := new Switch.Auto_Dimmer;
-
--- Check use of static tagged allocated objects,
--- and static tagged formal parameters in a loop which may dynamically
--- dispatch. If an optimizer unrolls the loop, it may then be statically
--- determined, and no dispatching will occur. Either interpretation is
--- correct.
- for Knob in Lamps'Range loop
- Switch.Flip( Lamps(Knob).all );
- end loop;
- TCTouch.Validate( "AGBAKGBA", "Allocated Objects" );
-
--- Check use of static tagged declared objects,
--- calling non-primitive functions.
- if not Switch.TC_Non_Disp( A_Switch ) then
- Report.Failed( "Bad Value 1" );
- end if;
- TCTouch.Validate( "X", "Nonprimitive Function" );
-
- if not Switch.TC_Non_Disp( A_Dimmer ) then
- Report.Failed( "Bad Value 2" );
- end if;
- TCTouch.Validate( "Y", "Nonprimitive Function" );
-
- if not Switch.TC_Non_Disp( An_Autodim ) then
- Report.Failed( "Bad Value 3" );
- end if;
- TCTouch.Validate( "Z", "Nonprimitive Function" );
-
- A_Switch := Switch.Create;
- A_Dimmer := Switch.Create;
- An_Autodim := Switch.Create;
- TCTouch.Validate( "123", "Primitive Function" );
-
--- View conversions
- Switch.Brighten( An_Autodim, 50 );
-
- Switch.Flip( Switch.Toggle( A_Switch ) );
- Switch.Flip( Switch.Toggle( A_Dimmer ) );
- Switch.Flip( Switch.Dimmer( An_Autodim ) );
- TCTouch.Validate( "DAAGBA", "View Conversions" );
-
--- statically tagged controlling operands (specific types) provided to
--- class-wide functions
- if Switch.On( A_Switch )
- or Switch.On( A_Dimmer )
- or Switch.On( An_Autodim ) then
- Report.Failed( "Bad Value 4" );
- end if;
- TCTouch.Validate( "BBB", "Class-wide" );
-
--- statically tagged controlling operands qualified expressions provided to
--- primitive functions, also using context to determine call to a
--- class-wide function.
- if Switch.Off( Switch.Toggle'( Switch.Create ) )
- or else Switch.Off( Switch.Dimmer'( Switch.Create ) )
- or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
- Report.Failed( "Bad Value 5" );
- end if;
- TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" );
-
- Report.Result;
-
-end C392C05;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c07.a b/gcc/testsuite/ada/acats/tests/c3/c392c07.a
deleted file mode 100644
index f13cc0b..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392c07.a
+++ /dev/null
@@ -1,190 +0,0 @@
--- C392C07.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 for a call to a dispatching subprogram the subprogram
--- body which is executed is determined by the controlling tag for
--- the case where the call has dynamic tagged controlling operands
--- of the type T. Check for calls to these same subprograms where
--- the operands are of specific statically tagged types:
--- objects (declared or allocated), formal parameters, view
--- conversions, and function calls (both primitive and non-primitive).
---
--- TEST DESCRIPTION:
--- This test uses foundation F392C00 to test the usages of statically
--- tagged objects and values. This test is derived in part from
--- C392C05.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Oct 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-with Report;
-with TCTouch;
-with F392C00_1;
-procedure C392C07 is -- Hardware_Store
- package Switch renames F392C00_1;
-
- subtype Switch_Class is Switch.Toggle'Class;
-
- type Reference is access all Switch_Class;
-
- A_Switch : aliased Switch.Toggle;
- A_Dimmer : aliased Switch.Dimmer;
- An_Autodim : aliased Switch.Auto_Dimmer;
-
- type Light_Bank is array(Positive range <>) of Reference;
-
- Lamps : Light_Bank(1..3);
-
--- dynamically tagged controlling operands : class wide formal parameters
- procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is
- begin
- if Switch.On( Device ) /= On then
- Switch.Flip( Device );
- end if;
- end Clamp;
- function Class_Item(Bank_Pos: Positive) return Switch_Class is
- begin
- return Lamps(Bank_Pos).all;
- end Class_Item;
-
-begin -- Main test procedure.
- Report.Test ("C392C07", "Check that a dispatching subprogram call is "
- & "determined by the controlling tag for "
- & "dynamically tagged controlling operands" );
-
- Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access );
-
--- dynamically tagged operands referring to
--- statically tagged declared objects
- for Knob in Lamps'Range loop
- Clamp( Lamps(Knob).all, On => True );
- end loop;
- TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" );
-
- Lamps(1) := new Switch.Toggle;
- Lamps(2) := new Switch.Dimmer;
- Lamps(3) := new Switch.Auto_Dimmer;
-
--- turn the full bank of switches ON
--- dynamically tagged allocated objects
- for Knob in Lamps'Range loop
- Clamp( Lamps(Knob).all, On => True );
- end loop;
- TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated");
-
--- Double check execution correctness
- if Switch.Off( Lamps(1).all )
- or Switch.Off( Lamps(2).all )
- or Switch.Off( Lamps(3).all ) then
- Report.Failed( "Bad Value" );
- end if;
- TCTouch.Validate( "CCC", "Class-wide");
-
--- turn the full bank of switches OFF
- for Knob in Lamps'Range loop
- Switch.Flip( Lamps(Knob).all );
- end loop;
- TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
-
--- check switches for OFF
--- a few function calls as operands
- for Knob in Lamps'Range loop
- if not Switch.Off( Class_Item(Knob) ) then
- Report.Failed("At function tests, Switch not OFF");
- end if;
- end loop;
- TCTouch.Validate( "CCC",
- "Using function returning class-wide type");
-
--- Switches are all OFF now.
--- dynamically tagged view conversion
- Clamp( Switch_Class( A_Switch ) );
- Clamp( Switch_Class( A_Dimmer ) );
- Clamp( Switch_Class( An_Autodim ) );
- TCTouch.Validate( "BABGBABKGBA", "View Conversions" );
-
--- dynamically tagged controlling operands : declared class wide objects
--- calling primitive functions
- declare
- Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' );
- begin
- Switch.Flip( Dine_O_Might );
- if Switch.On( Dine_O_Might ) then
- Report.Failed( "Exploded at Dine_O_Might" );
- end if;
- TCTouch.Validate( "WAB", "Dispatching function 1" );
- end;
-
- declare
- Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' );
- begin
- Switch.Flip( Dyne_A_Mite );
- if Switch.On( Dyne_A_Mite ) then
- Report.Failed( "Exploded at Dyne_A_Mite" );
- end if;
- TCTouch.Validate( "WGBAB", "Dispatching function 2" );
- end;
-
- declare
- Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' );
- begin
- Switch.Flip( Din_Um_Out );
- if Switch.Off( Din_Um_Out ) then
- Report.Failed( "Exploded at Din_Um_Out" );
- end if;
- TCTouch.Validate( "WKCC", "Dispatching function 3" );
-
--- Non-dispatching function calls.
- if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then
- Report.Failed( "Non primitive, via view conversion" );
- end if;
- TCTouch.Validate( "X", "View Conversion 1" );
-
- if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then
- Report.Failed( "Non primitive, via view conversion" );
- end if;
- TCTouch.Validate( "Y", "View Conversion 2" );
- end;
-
- -- a few more function calls as operands (oops)
- if not Switch.On( Switch.Toggle'( Switch.Create ) ) then
- Report.Failed("Toggle did not create ""On""");
- end if;
-
- if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then
- Report.Failed("Dimmer created ""Off""");
- end if;
-
- if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
- Report.Failed("Auto_Dimmer created ""Off""");
- end if;
-
- Report.Result;
-end C392C07;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc/testsuite/ada/acats/tests/c3/c392d01.a
deleted file mode 100644
index bb6e192..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d01.a
+++ /dev/null
@@ -1,324 +0,0 @@
--- C392D01.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, for an implicitly declared dispatching operation that is
--- overridden, the body executed is the body for the overriding
--- subprogram, even if the overriding occurs in a private part.
--- Check that, for an implicitly declared dispatching operation that is
--- NOT overridden, the body executed is the body of the corresponding
--- subprogram of the parent type.
---
--- Check for the case where the overriding (and non-overriding) operations
--- are declared for a private extension (and its full type) in a public
--- child unit of the package declaring the ancestor type, and the ancestor
--- type is a tagged private type whose full view is itself a derived type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type Root is tagged ...
--- procedure Vis_Op (P: Root);
--- private
--- procedure Pri_Op (P: Root); -- (A)
--- end Parent;
---
--- package Intermediate is
--- type Mid is tagged private;
--- private
--- type Mid is new Parent.Root with record ...
--- -- Implicit Vis_Op (P: Mid) declared here.
---
--- procedure Vis_Op (P: Mid); -- (B)
--- end Intermediate;
---
--- package Intermediate.Child is
--- type Derived is new Mid with private;
---
--- procedure Pri_Op (P: Derived); -- (C)
--- ...
---
--- private
--- type Derived is new Mid with record...
--- -- Implicit Vis_Op (P: Derived) declared here.
--- ...
--- end Intermediate.Child;
---
--- Type Derived inherits Vis_Op from the parent type Mid. Note, however,
--- that it is implicitly declared in the private part (inherited
--- subprograms for a derived_type_definition -- in this case, the full
--- type -- are implicitly declared at the earliest place within the
--- immediate scope of the type_declaration where the corresponding
--- declaration from the parent is visible).
---
--- Because Parent.Pri_Op is never visible within the immediate scope
--- of Mid, it is not implicitly declared for Mid. Thus, it is also not
--- implicitly declared for Derived. As a result, the version of Pri_Op
--- declared at (C) above does not override an inherited version of
--- Parent.Pri_Op and is totally unrelated to it.
---
--- Dispatching calls with tag Mid will execute (A) and (B). Dispatching
--- calls with tag Derived from Parent will execute the bodies of (B)
--- and (A). Dispatching calls with tag Derived from Parent.Child
--- will execute the bodies of (B) and (C).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D01_0 is
-
- type Zoom_Camera is tagged private;
-
- procedure Self_Test (C : in out Zoom_Camera'Class);
-
- -- ...Additional operations.
-
-
- function TC_Correct_Result (C : Zoom_Camera;
- D : F392D00.Depth_Of_Field;
- S : F392D00.Shutter_Speed) return Boolean;
-
-private
-
- type Magnification is (Low, Medium, High);
-
- type Zoom_Camera is new F392D00.Remote_Camera with record
- Mag : Magnification;
- end record;
-
- -- procedure Focus (C : in out Zoom_Camera; -- Implicitly
- -- Depth : in Depth_Of_Field) -- declared
- -- here.
-
- procedure Focus (C : in out Zoom_Camera; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- inherited op.
-
- -- For the remote zoom camera, perhaps the focusing algorithm is different
- -- in some way, so the original Focus operation is overridden here.
-
- -- Since the partial view is not an extension, the overriding operation
- -- must be declared after the full type. This version of Focus, although
- -- not visible for type Zoom_Camera from outside the package, can still be
- -- dispatched to.
-
-
- -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from
- -- F392D00.Remote_Camera, but since the operation never becomes visible
- -- within the immediate scope of Zoom_Camera, it is never implicitly
- -- declared.
-
-end C392D01_0;
-
-
- --==================================================================--
-
-
-package body C392D01_0 is
-
- procedure Focus (C : in out Zoom_Camera;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 83;
- end Focus;
-
- -----------------------------------------------------------
- -- Indirect call to F392D00.Self_Test since the main does not know
- -- that Zoom_Camera is a private extension of F392D00.Basic_Camera.
- procedure Self_Test (C : in out Zoom_Camera'Class) is
- begin
- F392D00.Self_Test (C);
- -- ...Additional self-testing.
- end Self_Test;
-
- -----------------------------------------------------------
- function TC_Correct_Result (C : Zoom_Camera;
- D : F392D00.Depth_Of_Field;
- S : F392D00.Shutter_Speed) return Boolean is
- use type F392D00.Depth_Of_Field;
- use type F392D00.Shutter_Speed;
- begin
- return (C.DOF = D and C.Shutter = S);
- end TC_Correct_Result;
-
-end C392D01_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-package C392D01_0.C392D01_1 is
-
- type Film_Speed is private;
-
- type Auto_Speed is new Zoom_Camera with private;
-
- -- Implicit function TC_Correct_Result (Auto_Speed) declared here.
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed);
-
- -- This version of Set_Shutter_Speed does NOT override the operation
- -- inherited from Zoom_Camera, because the inherited operation is never
- -- visible (and thus, is never implicitly declared) within the immediate
- -- scope of type Auto_Speed.
-
- procedure Self_Test (C : in out Auto_Speed'Class);
-
- -- ...Other operations.
-
-private
- type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
-
- type Auto_Speed is new Zoom_Camera with record
- ASA : Film_Speed;
- end record;
-
- -- procedure Focus (C : in out Auto_Speed; -- Implicitly
- -- Depth : in F392D00.Depth_Of_Field); -- declared
- -- here.
-
-end C392D01_0.C392D01_1;
-
-
- --==================================================================--
-
-
-package body C392D01_0.C392D01_1 is
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := F392D00.Two_Fifty;
- end Set_Shutter_Speed;
-
- -------------------------------------------------------
- procedure Self_Test (C : in out Auto_Speed'Class) is
- begin
- -- Artificial for testing purposes.
- Set_Shutter_Speed (C, F392D00.Thousand);
- Focus (C, 27);
- end Self_Test;
-
-end C392D01_0.C392D01_1;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D01_0.C392D01_1;
-
-with Report;
-
-procedure C392D01 is
- Zooming_Camera : C392D01_0.Zoom_Camera;
- Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed;
- Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed;
-
- TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Speed : constant F392D00.Shutter_Speed
- := F392D00.Two_Fifty;
-
- use type F392D00.Depth_Of_Field;
- use type F392D00.Shutter_Speed;
-
-begin
- Report.Test ("C392D01", "Dispatching for overridden and non-overridden " &
- "primitive subprograms: private extension declared in child " &
- "unit, parent is tagged private whose full view is derived " &
- "type");
-
-
-
--- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which
--- itself calls the class-wide operation for Remote_Camera'Class, which
--- in turn makes dispatching calls to Focus and Set_Shutter_Speed:
-
-
- -- For an object of type Zoom_Camera, the dispatching call to Focus should
- -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
- -- to Set_Shutter_Speed should dispatch to the body declared for
- -- Remote_Camera:
-
- C392D01_0.Self_Test(Zooming_Camera);
-
- if not C392D01_0.TC_Correct_Result (Zooming_Camera,
- TC_Expected_Zoom_Depth,
- TC_Expected_Zoom_Speed)
- then
- Report.Failed ("Calls dispatched incorrectly for tagged private type");
- end if;
-
- -- For an object of type Auto_Speed, the dispatching call to Focus should
- -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
- -- call to Set_Shutter_Speed should dispatch to the body explicitly declared
- -- for Remote_Camera:
-
- C392D01_0.Self_Test(Auto_Camera1);
-
- if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1,
- TC_Expected_Auto_Depth,
- TC_Expected_Auto_Speed)
- then
- Report.Failed ("Calls dispatched incorrectly for private extension");
- end if;
-
- -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call
- -- to Focus which should dispatch to the body explicitly declared for
- -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch
- -- to the body explicitly declared for Auto_Speed:
-
- C392D01_0.C392D01_1.Self_Test(Auto_Camera2);
-
- if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2,
- TC_Expected_Depth,
- TC_Expected_Speed)
- then
- Report.Failed ("Call to explicit subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392D01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d02.a b/gcc/testsuite/ada/acats/tests/c3/c392d02.a
deleted file mode 100644
index d8e012c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d02.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- C392D02.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 primitive procedure declared in a private part is not
--- overridden by a procedure explicitly declared at a place where the
--- primitive procedure in question is not visible.
---
--- Check for the case where the non-overriding operation is declared in a
--- separate (non-child) package from that declaring the parent type, and
--- the descendant type is a record extension.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Root is tagged ...
--- private
--- procedure Pri_Op (A: Root);
--- end P;
---
--- with P;
--- package Q is
--- type Derived is new P.Root with record...
--- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op.
--- ...
--- end Q;
---
--- Type Derived inherits Pri_Op from the parent type Root. However,
--- because P.Pri_Op is never visible within the immediate scope of
--- Derived, it is not implicitly declared for Derived. As a result,
--- the explicit Q.Pri_Op does not override P.Pri_Op and is totally
--- unrelated to it.
---
--- Dispatching calls to P.Pri_Op with operands of tag Derived will
--- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D02_0 is
-
- type Aperture is (Eight, Sixteen);
-
- type Auto_Speed is new F392D00.Remote_Camera with record
- -- ...
- FStop : Aperture;
- end record;
-
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed);
- -- Does NOT override.
-
- -- This version of Set_Shutter_Speed does NOT override the operation
- -- inherited from the parent, because the inherited operation is never
- -- visible (and thus, is never implicitly declared) within the immediate
- -- scope of type Auto_Speed.
-
- procedure Self_Test (C : in out Auto_Speed'Class);
-
- -- ...Other operations.
-
-end C392D02_0;
-
-
- --==================================================================--
-
-
-package body C392D02_0 is
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := F392D00.Four_Hundred;
- end Set_Shutter_Speed;
-
- ----------------------------------------------------
- procedure Self_Test (C : in out Auto_Speed'Class) is
- begin
- -- Should dispatch to the Set_Shutter_Speed explicitly declared
- -- for Auto_Speed.
- Set_Shutter_Speed (C, F392D00.Two_Fifty);
- end Self_Test;
-
-end C392D02_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D02_0;
-
-with Report;
-
-procedure C392D02 is
- Basic_Camera : F392D00.Remote_Camera;
- Auto_Camera1 : C392D02_0.Auto_Speed;
- Auto_Camera2 : C392D02_0.Auto_Speed;
-
- TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Speed : constant F392D00.Shutter_Speed
- := F392D00.Four_Hundred;
-
- use type F392D00.Shutter_Speed;
-
-begin
- Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
- "subprograms: record extension declared in non-child " &
- "package, parent is tagged record");
-
--- Call the class-wide operation for Remote_Camera'Class, which dispatches
--- to Set_Shutter_Speed:
-
- -- For an object of type Remote_Camera, the dispatching call should
- -- dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Basic_Camera);
-
- if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
- Report.Failed ("Call dispatched incorrectly for root type");
- end if;
-
-
- -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
- -- since C392D02_0.Set_Shutter_Speed does not override
- -- F392D00.Set_Shutter_Speed.
-
- -- For an object of type Auto_Speed, the dispatching call should
- -- also dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Auto_Camera1);
-
- if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
- Report.Failed ("Call dispatched incorrectly for derived type");
- end if;
-
- -- Call to Self_Test from C392D02_0 invokes the dispatching call to
- -- Set_Shutter_Speed which should dispatch to the body explicitly declared
- -- for Auto_Speed:
-
- C392D02_0.Self_Test(Auto_Camera2);
-
- if Auto_Camera2.Shutter /= TC_Expected_Speed then
- Report.Failed ("Call to explicit subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392D02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d03.a b/gcc/testsuite/ada/acats/tests/c3/c392d03.a
deleted file mode 100644
index 3a48895..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d03.a
+++ /dev/null
@@ -1,248 +0,0 @@
--- C392D03.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, for an inherited dispatching operation that is overridden,
--- the body executed is the body of the overriding subprogram, even if
--- the overriding occurs in a private part.
---
--- Check for the case where the overriding operation is declared in a
--- separate (non-child) package from that declaring the parent type, and
--- the descendant type is a record extension.
---
--- Check for both dispatching and nondispatching calls.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Root is tagged ...
--- procedure Op (A: Root);
--- end P;
---
--- with P;
--- package Q is
--- type Derived1 is new P.Root with record...
--- -- Implicit procedure Op (A: Derived1) declared here.
--- type Derived2 is new P.Root with private...
--- -- Implicit procedure Op (A: Derived2) declared here.
--- type New_Derived is new Derived1 with private...
--- -- Implicit procedure Op (A: New_Derived) declared here.
--- private
--- procedure Op (A: Derived1); -- Overrides parent's Op.
--- type Derived2 is new P.Root with record...
--- procedure Op (A: Derived2); -- Overrides parent's Op.
--- type New_Derived is new Derived1 with record...
--- ...
--- end Q;
---
--- Both type Derived1 and Derived2 inherit Op from the parent type Root.
--- Type New_Derived inherits (inherited) Op from Derived1. The inherited
--- operation is implicitly declared immediately after the type extension.
--- The inherited operation is overridden by an explicit declaration in
--- the private part. Even though the overriding operation is private,
--- calls to Op with an operand of tag Derived1, Derived2, or New_Derived
--- will execute the body of the overriding operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D03_0 is
-
- type Aperture is (Eight, Sixteen);
-
- type Auto_Focus is new F392D00.Remote_Camera with record
- -- ...
- FStop : Aperture;
- end record;
-
- -- Implicit procedure Focus (C : in out Auto_Focus;
- -- Depth : in Depth_Of_Field) declared here.
-
- type Auto_Flashing is new F392D00.Remote_Camera with private;
-
- -- Implicit procedure Focus (C : in out Auto_Flashing;
- -- Depth : in Depth_Of_Field) declared here.
-
- type Special_Focus is new Auto_Focus with private;
-
- -- Implicit procedure Focus (C : in out Special_Focus;
- -- Depth : in Depth_Of_Field) declared here.
-
- -- ...Other operations.
-
-private
-
- procedure Focus (C : in out Auto_Focus; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- parent's op.
-
- -- For the improved remote camera, focus is set automatically, so it is
- -- declared as a private operation.
-
- type Auto_Flashing is new F392D00.Remote_Camera with null record;
-
- procedure Focus (C : in out Auto_Flashing; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- parent's op.
-
- type Special_Focus is new Auto_Focus with null record;
-
-end C392D03_0;
-
-
- --==================================================================--
-
-
-package body C392D03_0 is
-
- procedure Focus (C : in out Auto_Focus;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 52;
- end Focus;
-
- -----------------------------------------------------------
- procedure Focus (C : in out Auto_Flashing;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 91;
- end Focus;
-
-end C392D03_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D03_0;
-
-with Report;
-
-procedure C392D03 is
-
- type Focus_Ptr is access procedure
- (P1 : in out C392D03_0.Auto_Focus;
- P2 : in F392D00.Depth_Of_Field);
-
- Basic_Camera : F392D00.Remote_Camera;
- Auto_Camera1 : C392D03_0.Auto_Focus;
- Auto_Camera2 : C392D03_0.Auto_Focus;
- Flash_Camera1 : C392D03_0.Auto_Flashing;
- Flash_Camera2 : C392D03_0.Auto_Flashing;
- Special_Camera : C392D03_0.Special_Focus;
- Auto_Depth : F392D00.Depth_Of_Field := 78;
-
- TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
- TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52;
- TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91;
-
- FP : Focus_Ptr := C392D03_0.Focus'Access;
-
- use type F392D00.Depth_Of_Field;
-
-begin
- Report.Test ("C392D03", "Dispatching for overridden primitive " &
- "subprograms: record extension declared in non-child " &
- "package, parent is tagged record");
-
-
--- Call the class-wide operation for Remote_Camera'Class, which itself makes
--- a dispatching call to Focus:
-
- -- For an object of type Remote_Camera, the dispatching call should
- -- dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Basic_Camera);
-
- if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
- Report.Failed ("Call dispatched incorrectly for root type");
- end if;
-
-
- -- For an object of type Auto_Focus, the dispatching call should
- -- dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Auto_Camera1);
-
- if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
- end if;
-
-
- -- For an object of type Auto_Flash, the dispatching call should
- -- also dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Flash_Camera1);
-
- if Flash_Camera1.DOF /= TC_Expected_Depth then
- Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
- end if;
-
- -- For an object of Auto_Flash type, a non-dispatching call to Focus should
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- C392D03_0.Focus (Flash_Camera2, Auto_Depth);
-
- if Flash_Camera2.DOF /= TC_Expected_Depth then
- Report.Failed ("Non-dispatching call to privately overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of Auto_Focus type, a non-dispatching call to Focus should
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- FP.all (Auto_Camera2, Auto_Depth);
-
- if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Non-dispatching call by using access to overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of type Special_Camera, the dispatching call should
- -- also dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Special_Camera);
-
- if Special_Camera.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Call dispatched incorrectly for Special_Camera type");
- end if;
-
- Report.Result;
-
-end C392D03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393001.a b/gcc/testsuite/ada/acats/tests/c3/c393001.a
deleted file mode 100644
index 9d6f85c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393001.a
+++ /dev/null
@@ -1,407 +0,0 @@
--- C393001.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 abstract type can be declared, and in turn concrete
--- types can be derived from it. Check that the definition of
--- actual subprograms associated with the derived types dispatch
--- correctly.
---
--- TEST DESCRIPTION:
--- This test declares an abstract type Breaker in a package, and
--- then derives from it. The type Basic_Breaker defines the least
--- possible in order to not be abstract. The type Ground_Fault is
--- defined to inherit as much as possible, whereas type Special_Breaker
--- overrides everything it can. The type Special_Breaker also includes
--- an embedded Basic_Breaker object. The main program then utilizes
--- each of the three types of breaker, and to ascertain that the
--- overloading and tagging resolution are correct, each "Create"
--- procedure is called with a unique value. The diagram below
--- illustrates the relationships. This test is derived from C3A2001.
---
--- Abstract type: Breaker
--- |
--- Basic_Breaker (Short)
--- / \
--- (Sharp) Ground_Fault Special_Breaker (Shock)
---
--- Test structure is an array of class-wide objects, modeling a circuit
--- as a list of components. The test then creates some values, and
--- traverses the list to determine correct operation.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Revised for 2.0.1
---
---!
-
------------------------------------------------------------------ C393001_1
-
-with Report;
-package C393001_1 is
-
- type Breaker is abstract tagged private;
- type Status is ( Power_Off, Power_On, Tripped, Failed );
-
- procedure Flip ( The_Breaker : in out Breaker ) is abstract;
- procedure Trip ( The_Breaker : in out Breaker ) is abstract;
- procedure Reset( The_Breaker : in out Breaker ) is abstract;
- procedure Fail ( The_Breaker : in out Breaker );
-
- procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
-
- function Status_Of( The_Breaker : Breaker ) return Status;
-
-private
- type Breaker is abstract tagged record
- State : Status := Power_Off;
- end record;
-end C393001_1;
-
-with TCTouch;
-package body C393001_1 is
- procedure Fail( The_Breaker : in out Breaker ) is ------------------- a
- begin
- TCTouch.Touch( 'a' );
- The_Breaker.State := Failed;
- end Fail;
-
- procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
- begin
- The_Breaker.State := To_State;
- end Set;
-
- function Status_Of( The_Breaker : Breaker ) return Status is ------- b
- begin
- TCTouch.Touch( 'b' );
- return The_Breaker.State;
- end Status_Of;
-end C393001_1;
-
------------------------------------------------------------------ C393001_2
-
-with C393001_1;
-package C393001_2 is
-
- type Basic_Breaker is new C393001_1.Breaker with private;
-
- type Voltages is ( V12, V110, V220, V440 );
- type Amps is ( A1, A5, A10, A25, A100 );
-
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker );
- procedure Trip ( The_Breaker : in out Basic_Breaker );
- procedure Reset( The_Breaker : in out Basic_Breaker );
-private
- type Basic_Breaker is new C393001_1.Breaker with record
- Voltage_Level : Voltages := V110;
- Amperage : Amps;
- end record;
-end C393001_2;
-
-with TCTouch;
-package body C393001_2 is
- function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c
- return Basic_Breaker is
- It : Basic_Breaker;
- begin
- TCTouch.Touch( 'c' );
- It.Amperage := Amperage;
- It.Voltage_Level := Voltage;
- C393001_1.Set( It, C393001_1.Power_Off );
- return It;
- end Construct;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d
- begin
- TCTouch.Touch( 'd' );
- case Status_Of( The_Breaker ) is
- when C393001_1.Power_Off =>
- C393001_1.Set( The_Breaker, C393001_1.Power_On );
- when C393001_1.Power_On =>
- C393001_1.Set( The_Breaker, C393001_1.Power_Off );
- when C393001_1.Tripped | C393001_1.Failed => null;
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e
- begin
- TCTouch.Touch( 'e' );
- C393001_1.Set( The_Breaker, C393001_1.Tripped );
- end Trip;
-
- procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f
- begin
- TCTouch.Touch( 'f' );
- case Status_Of( The_Breaker ) is
- when C393001_1.Power_Off | C393001_1.Tripped =>
- C393001_1.Set( The_Breaker, C393001_1.Power_On );
- when C393001_1.Power_On | C393001_1.Failed => null;
- end case;
- end Reset;
-
-end C393001_2;
-
-with C393001_1,C393001_2;
-package C393001_3 is
-
- type Ground_Fault is new C393001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps
-)
- return Ground_Fault;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer );
-
-private
- type Ground_Fault is new C393001_2.Basic_Breaker with record
- Capacitance : Integer;
- end record;
-end C393001_3;
-
------------------------------------------------------------------ C393001_3
-
-with TCTouch;
-package body C393001_3 is
-
- function Construct( Voltage : C393001_2.Voltages; ------------------ g
- Amperage : C393001_2.Amps )
- return Ground_Fault is
-
- It : Ground_Fault;
-
- procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
- begin
- It := C393001_2.Construct( Voltage, Amperage );
- end Set_Root;
-
- begin
- TCTouch.Touch( 'g' );
- Set_Root( C393001_2.Basic_Breaker( It ) );
- It.Capacitance := 0;
- return It;
- end Construct;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h
- Capacitance : in Integer ) is
- begin
- TCTouch.Touch( 'h' );
- The_Breaker.Capacitance := Capacitance;
- end Set_Trip;
-
-end C393001_3;
-
------------------------------------------------------------------ C393001_4
-
-with C393001_1, C393001_2;
-package C393001_4 is
-
- type Special_Breaker is new C393001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C393001_2.Voltages;
- Amperage : C393001_2.Amps )
- return Special_Breaker;
-
- procedure Flip ( The_Breaker : in out Special_Breaker );
- procedure Trip ( The_Breaker : in out Special_Breaker );
- procedure Reset( The_Breaker : in out Special_Breaker );
- procedure Fail ( The_Breaker : in out Special_Breaker );
-
- function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status;
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
-
-private
- type Special_Breaker is new C393001_2.Basic_Breaker with record
- Backup : C393001_2.Basic_Breaker;
- end record;
-end C393001_4;
-
-with TCTouch;
-package body C393001_4 is
-
- function Construct( Voltage : C393001_2.Voltages; --------------- i
- Amperage : C393001_2.Amps )
- return Special_Breaker is
- It: Special_Breaker;
- procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
- begin
- It := C393001_2.Construct( Voltage, Amperage );
- end Set_Root;
- begin
- TCTouch.Touch( 'i' );
- Set_Root( C393001_2.Basic_Breaker( It ) );
- Set_Root( It.Backup );
- return It;
- end Construct;
-
- function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status
- renames C393001_1.Status_Of;
-
- procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j
- begin
- TCTouch.Touch( 'j' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_Off | C393001_1.Power_On =>
- C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C393001_2.Flip( The_Breaker.Backup );
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k
- begin
- TCTouch.Touch( 'k' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_Off => null;
- when C393001_1.Power_On =>
- C393001_2.Reset( The_Breaker.Backup );
- C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C393001_2.Trip( The_Breaker.Backup );
- end case;
- end Trip;
-
- procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l
- begin
- TCTouch.Touch( 'l' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Tripped =>
- C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker ));
- when C393001_1.Failed =>
- C393001_2.Reset( The_Breaker.Backup );
- when C393001_1.Power_On | C393001_1.Power_Off =>
- null;
- end case;
- end Reset;
-
- procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m
- begin
- TCTouch.Touch( 'm' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Failed =>
- C393001_2.Fail( The_Breaker.Backup );
- when others =>
- C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker ));
- C393001_2.Reset( The_Breaker.Backup );
- end case;
- end Fail;
-
- function Status_Of( The_Breaker : Special_Breaker ) ----------------- n
- return C393001_1.Status is
- begin
- TCTouch.Touch( 'n' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_On => return C393001_1.Power_On;
- when C393001_1.Power_Off => return C393001_1.Power_Off;
- when others =>
- return C393001_2.Status_Of( The_Breaker.Backup );
- end case;
- end Status_Of;
-
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
- use C393001_2;
- use type C393001_1.Status;
- begin
- return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped
- or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed;
- end On_Backup;
-
-end C393001_4;
-
-------------------------------------------------------------------- C393001
-
-with Report, TCTouch;
-with C393001_1, C393001_2, C393001_3, C393001_4;
-procedure C393001 is
-
- procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Flip( The_Circuit );
- end Flipper;
-
- procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Trip( The_Circuit );
- end Tripper;
-
- procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Reset( The_Circuit );
- end Restore;
-
- procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Fail( The_Circuit );
- end Failure;
-
- Short : C393001_1.Breaker'Class -- Basic_Breaker
- := C393001_2.Construct( C393001_2.V440, C393001_2.A5 );
- Sharp : C393001_1.Breaker'Class -- Ground_Fault
- := C393001_3.Construct( C393001_2.V110, C393001_2.A1 );
- Shock : C393001_1.Breaker'Class -- Special_Breaker
- := C393001_4.Construct( C393001_2.V12, C393001_2.A100 );
-
-begin -- Main test procedure.
-
- Report.Test ("C393001", "Check that an abstract type can be declared " &
- "and used. Check actual subprograms dispatch correctly" );
-
- TCTouch.Validate( "cgcicc", "Declaration" );
-
- Flipper( Short );
- TCTouch.Validate( "db", "Flipping Short" );
- Flipper( Sharp );
- TCTouch.Validate( "db", "Flipping Sharp" );
- Flipper( Shock );
- TCTouch.Validate( "jbdb", "Flipping Shock" );
-
- Tripper( Short );
- TCTouch.Validate( "e", "Tripping Short" );
- Tripper( Sharp );
- TCTouch.Validate( "e", "Tripping Sharp" );
- Tripper( Shock );
- TCTouch.Validate( "kbfbe", "Tripping Shock" );
-
- Restore( Short );
- TCTouch.Validate( "fb", "Restoring Short" );
- Restore( Sharp );
- TCTouch.Validate( "fb", "Restoring Sharp" );
- Restore( Shock );
- TCTouch.Validate( "lbfb", "Restoring Shock" );
-
- Failure( Short );
- TCTouch.Validate( "a", "Shock Failing" );
- Failure( Sharp );
- TCTouch.Validate( "a", "Shock Failing" );
- Failure( Shock );
- TCTouch.Validate( "mbafb", "Shock Failing" );
-
- Report.Result;
-
-end C393001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393007.a b/gcc/testsuite/ada/acats/tests/c3/c393007.a
deleted file mode 100644
index 93458ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393007.a
+++ /dev/null
@@ -1,157 +0,0 @@
--- C393007.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 extended type can be derived from an abstract type,
--- where the abstract type is defined in a package, and the type derived
--- from it is defined in a distinct library package.
---
--- TEST DESCRIPTION:
--- Declare an private (abstract) type; declare two primitive operations
--- of the type that are explicitly abstract.
--- Derive an extended type from the (private) abstract type, overriding
--- both of the primitive operations.
--- This test also checks to see that name overloading between abstract
--- and non-abstract functions is resolved correctly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- package C393007_0 is
- -- Alert_System
-
- type DT_Type is new Integer;
-
- type Alert_Type is abstract tagged record
- Time_Of_Arrival : DT_Type;
- end record;
-
- type Log_File_Type is range 0 .. 100;
-
- Procedure Handle (A : in out Alert_type) is abstract;
-
- procedure Log (A : Alert_Type;
- L : in out Log_File_Type) is abstract;
-
- procedure Set_Time (A : in out Alert_Type);
-
- function Correct_Time_Stamp (A : Alert_Type) return Boolean;
-
- Day_Time : DT_Type := 100;
-
- end C393007_0;
- -- Alert_System;
-
- --=======================================================================--
-
- package body C393007_0 is
- -- Alert_System
-
- function Time_Stamp return DT_Type is
- begin
- Day_Time := Day_Time + 1;
- return Day_Time;
- end Time_Stamp;
-
- procedure Set_Time (A : in out Alert_Type) is
- begin
- A.Time_Of_Arrival := Time_Stamp;
- end Set_time;
-
- function Correct_Time_Stamp ( A : Alert_Type) return Boolean is
- begin
- return (A.Time_Of_Arrival = Day_Time);
- end Correct_Time_Stamp;
-
- end C393007_0;
- -- Alert_System;
-
- --=======================================================================--
-
- with Report;
- with C393007_0;
- -- Alert_system;
-
- package C393007_1 is
-
- type Normal_Alert_Type is
- new C393007_0.Alert_Type
- with null record;
-
- Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First;
-
- procedure Handle (A : in out Normal_Alert_Type); -- Override is required
-
- procedure Log (A : Normal_Alert_Type; -- Override is required
- L : in out C393007_0.Log_File_Type);
- end C393007_1;
-
- package body C393007_1 is
- use type C393007_0.Log_File_Type;
-
- procedure Handle (A : in out Normal_Alert_Type) is
- begin
- Set_Time (A);
- Log (A, Log_File);
- end Handle;
-
- procedure Log (A : Normal_Alert_Type;
- L : in out C393007_0.Log_File_Type) is
- begin
- L := C393007_0."+"(L, 1);
- end Log;
-
- end C393007_1;
-
- with Report;
- with C393007_0;
- with C393007_1;
- -- Alert_system;
-
- procedure C393007 is
- use C393007_0;
- use C393007_1;
-
- Alert_One : C393007_1.Normal_Alert_Type;
-
- begin
- Report.Test ("C393007", "Check that an extended type can be derived " &
- "from an abstract type");
-
- Handle (Alert_One);
- if not Correct_Time_Stamp (Alert_One) then
- Report.Failed ("Wrong results from procedure Handle");
- end if;
-
- if Log_File /=1 then
- Report.Failed ("Wrong results");
- end if;
-
- Report.Result;
-
- end C393007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393008.a b/gcc/testsuite/ada/acats/tests/c3/c393008.a
deleted file mode 100644
index d2d2aef..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393008.a
+++ /dev/null
@@ -1,204 +0,0 @@
--- C393008.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 extended type can be derived from an abstract type.
---
--- TEST DESCRIPTION:
--- Declare a tagged record; declare an abstract
--- primitive operation and a non-abstract primitive operation of the
--- type. Derive an extended type from it, including a new component.
--- Use the derived type, the overriding operation and the inherited
--- operation to instantiate a generic package. The overriding operation
--- calls a new primitive operation and an inherited operation [so the
--- instantiation must get this sorted out correctly].
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with TCTouch;
-procedure C393008 is
-
-package C393008_0 is
-
- type Status_Enum is (No_Status, Handled, Unhandled, Pending);
-
- type Alert_Type is abstract tagged record
- Status : Status_Enum;
- Reply : Boolean;
- Urgent : Boolean;
- end record;
-
- subtype Serial_Number is Integer range 0..Integer'last;
- Serial_Num : Serial_Number := 0;
-
- procedure Handle (A : in out Alert_Type) is abstract;
- -- abstract primitive operation
-
- -- the procedure Init would be _nice_ have this procedure be non_abstract
- -- and create a "base" object with a "null" constraint. The language
- -- will not allow this due to the restriction that an object of an
- -- abstract type cannot be created. Hence Init must be abstract,
- -- requiring any type derived directly from Alert_Type to declare
- -- an Init.
- --
- -- In light of this, I have changed init to a function to more closely
- -- model the typical usage of OO features...
-
- function Init return Alert_Type is abstract;
-
- procedure No_Reply (A : in out Alert_Type);
-
-end C393008_0;
-
---=======================================================================--
-
-package body C393008_0 is
-
- procedure No_Reply (A : in out Alert_Type) is
- begin -- primitive operation, not abstract
- TCTouch.Touch('A'); ------------------------------------------------- A
- if A.Status = Handled then
- A.Reply := False;
- end if;
- end No_Reply;
-
-end C393008_0;
-
---=======================================================================--
-
- generic
- -- pass in the Alert_Type object, including its
- -- operations
- type Data_Type is new C393008_0.Alert_Type with private;
- -- note that Alert_Type is abstract, so it may not be
- -- used as an actual parameter
- with procedure Update (P : in out Data_Type) is <>; -- generic formal
- with function Initialize return Data_Type is <>; -- generic formal
-
- package C393008_1 is
- -- Utilities
-
- procedure Modify (Item : in out Data_Type);
-
- end C393008_1;
- -- Utilities
-
---=======================================================================--
-
- package body C393008_1 is
- -- Utilities
-
- procedure Modify (Item : in out Data_Type) is
- begin
- TCTouch.Touch('B'); --------------------------------------------- B
- Item := Initialize;
- Update (Item);
- end Modify;
-
- end C393008_1;
-
---=======================================================================--
-
- package C393008_2 is
-
- type Low_Alert_Type is new C393008_0.Alert_Type with record
- Serial : C393008_0.Serial_Number;
- end record;
-
- procedure Serialize (LA : in out Low_Alert_Type);
-
- -- inherit No_Reply
-
- procedure Handle (LA : in out Low_Alert_Type);
-
- function Init return Low_Alert_Type;
- end C393008_2;
-
- package body C393008_2 is
- procedure Serialize (LA : in out Low_Alert_Type) is
- begin -- new primitive operation
- TCTouch.Touch('C'); ------------------------------------------------- C
- C393008_0.Serial_Num := C393008_0.Serial_Num + 1;
- LA.Serial := C393008_0.Serial_Num;
- end Serialize;
-
- -- inherit No_Reply
-
- function Init return Low_Alert_Type is
- TA: Low_Alert_Type;
- begin
- TCTouch.Touch('D'); ------------------------------------------------- D
- Serialize( TA );
- TA.Status := C393008_0.No_Status;
- return TA;
- end Init;
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin -- overrides abstract inherited Handle
- TCTouch.Touch('E'); ------------------------------------------------- E
- Serialize (LA);
- LA.Reply := False;
- LA.Status := C393008_0.Handled;
- No_Reply (LA);
- end Handle;
-
- end C393008_2;
-
- use C393008_2;
-
- package Alert_Utilities is new
- C393008_1 (Data_Type => Low_Alert_Type,
- Update => Handle, -- Low_Alert's Handle
- Initialize => Init); -- inherited from Alert
-
- Item : Low_Alert_Type;
-
- use type C393008_0.Status_Enum;
-
-begin
-
- Report.Test ("C393008", "Check that an extended type can be derived "&
- "from an abstract type");
-
- Item := Init;
- if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1) then
- Report.Failed ("Wrong initialization");
- end if;
- TCTouch.Validate("DC", "Initialization Call");
-
- Alert_Utilities.Modify (Item);
- if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then
- Report.Failed ("Wrong results from Modify");
- end if;
- TCTouch.Validate("BDCECA", "Generic Instance Call");
-
- Report.Result;
-
-end C393008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393009.a b/gcc/testsuite/ada/acats/tests/c3/c393009.a
deleted file mode 100644
index 1353f9c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393009.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- C393009.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 extended type can be derived from an abstract type.
---
--- TEST DESCRIPTION:
--- Declare an abstract type in the specification of a generic package.
--- Instantiate the package and derive an extended type from the abstract
--- (instantiated) type; override all abstract operations; use all
--- inherited operations;
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Oct 95 SAIC Fixed for ACVC 2.0.1
---
---!
-
-with Report;
-procedure C393009 is
-
- package Display_Devices is
-
- type Display_Device_Enum is (None, TTY, Console, Big_Screen);
- Display : Display_Device_Enum := None;
-
- end Display_Devices;
-
---=======================================================================--
-
- generic
-
- type Generic_Status is (<>);
-
- type Serial_Type is (<>);
-
- package Alert_System is
-
- type Alert_Type (Serial : Serial_Type) is abstract tagged record
- Status : Generic_Status;
- end record;
-
- Next_Serial_Number : Serial_Type := Serial_Type'First;
-
- procedure Handle (A : in out Alert_Type) is abstract;
- -- abstract operation - must be overridden after instantiation
-
- procedure Display ( A : Alert_Type;
- On : Display_Devices.Display_Device_Enum);
- -- primitive operation of Alert_Type
- -- not required to be overridden
-
- function Get_Serial_Number (A : Alert_Type) return Serial_Type;
- -- primitive operation of Alert_Type
- -- not required to be overridden
-
- end Alert_System;
-
---=======================================================================--
-
- package body Alert_System is
-
- procedure Display ( A : in Alert_Type;
- On : Display_Devices.Display_Device_Enum) is
- begin
- Display_Devices.Display := On;
- end Display;
-
- function Get_Serial_Number (A : Alert_Type)
- return Serial_Type is
- begin
- return A.Serial;
- end Get_Serial_Number;
-
- end Alert_System;
-
---=======================================================================--
-
- package NCC_1701 is
-
- type Status_Kind is (Green, Yellow, Red);
- type Serial_Number_Type is new Integer range 1..Integer'Last;
-
- subtype Msg_Str is String (1..16);
- Alert_Msg : Msg_Str := "C393009 passed.";
- -- 123456789A123456
-
- package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type);
-
- type New_Alert_Type(Serial : Serial_Number_Type) is
- new Alert_Pkg.Alert_Type(Serial) with record
- Message : Msg_Str;
- end record;
-
- -- procedure Display is inherited by New_Alert_Type
-
- -- function Get_Serial_Number is inherited by New_Alert_Type
- procedure Handle (NA : in out New_Alert_Type); -- must be overridden
- procedure Init (NA : in out New_Alert_Type); -- new primitive
-
- NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number);
- -- New_Alert_Type is not abstract, so an object of that
- -- type may be declared
-
- end NCC_1701;
-
- package body NCC_1701 is
-
- procedure Handle (NA : in out New_Alert_Type) is
- begin
- NA.Message := Alert_Msg;
- Display (NA, On => Display_Devices.TTY);
- end Handle;
-
- procedure Init (NA : in out New_Alert_Type) is -- new primitive operation
- begin -- for New_Alert_Type
- NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' '));
- end Init;
-
- end NCC_1701;
-
- use NCC_1701;
- use type Display_Devices.Display_Device_Enum;
-
-begin
-
- Report.Test ("C393009", "Check that an extended type can be derived " &
- "from an abstract type");
-
- Init (NA);
- if (Get_Serial_Number (NA) /= 1)
- or (NA.Status /= Green)
- or (Display_Devices.Display /= Display_Devices.None) then
- Report.Failed ("Wrong Initialization");
- end if;
-
- Handle (NA);
- if (Get_Serial_Number (NA) /= 1)
- or (NA.Status /= Green)
- or (NA.Message /= Alert_Msg)
- or (Display_Devices.Display /= Display_Devices.TTY) then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393009;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393010.a b/gcc/testsuite/ada/acats/tests/c3/c393010.a
deleted file mode 100644
index 6a52cf8..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393010.a
+++ /dev/null
@@ -1,306 +0,0 @@
--- C393010.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 extended type can be derived from an abstract type and
--- that a call on an abstract operation is a dispatching operation.
--- Check that such a call can dispatch to an overriding operation
--- declared in the private part of a package.
---
--- TEST DESCRIPTION:
--- Taking from a classroom example of a typical usage: declare a basic
--- abstract type containing data germane to the entire class structure,
--- derive from that a type with specific data, and derive from that
--- another type merely providing a "secret" override. The abstract type
--- provides a concrete procedure that itself "redispatches" to an
--- abstract procedure; the abstract procedure must be provided by one or
--- more of the concrete types derived from the abstract type, and hence
--- upon re-evaluating the actual type of the operand should dispatch
--- accordingly.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Mar 96 SAIC ACVC 2.1
---
---!
-
------------------------------------------------------------------ C393010_0
-
-package C393010_0 is
-
- type Ticket is abstract tagged record
- Flight : Natural;
- Serial_Number : Natural;
- end record;
-
- function Issue return Ticket is abstract;
- procedure Label( T: Ticket ) is abstract;
-
- procedure Print( T: Ticket );
-
-end C393010_0;
-
-with TCTouch;
-package body C393010_0 is
-
- procedure Print( T: Ticket ) is
- begin
- -- Check that a call on an abstract operation is a dispatching operation
- Label( Ticket'Class( T ) );
- -- Appropriate_IO.Put( T.Flight & T.Serial_Number );
- TCTouch.Touch('P'); -------------------------------------------------- P
- end Print;
-
-end C393010_0;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_0;
-package C393010_1 is
-
- type Service_Classes is (First, Business, Coach);
-
- type Menu is (Steak, Lobster, Fowl, Vegan);
-
- -- Check that an extended type can be derived from an abstract type.
- type Passenger_Ticket(Service : Service_Classes) is
- new C393010_0.Ticket with record
- Row_Seat : String(1..3);
- case Service is
- when First | Business => Meal : Menu;
- when Coach => null;
- end case;
- end record;
-
- function Issue return Passenger_Ticket;
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket;
-
- procedure Label( T: Passenger_Ticket );
-
- procedure Print( T: Passenger_Ticket );
-
-end C393010_1;
-
-with TCTouch;
-package body C393010_1 is
-
- procedure Label( T: Passenger_Ticket ) is
- begin
- -- Appropriate_IO.Put( T.Service );
- TCTouch.Touch('L'); -------------------------------------------------- L
- end Label;
-
- procedure Print( T: Passenger_Ticket ) is
- begin
- -- call parent print:
- C393010_0.Print( C393010_0.Ticket( T ) );
- case T.Service is
- when First => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('F'); ---------------------------------------------- F
- when Business => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('B'); ---------------------------------------------- B
- when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" );
- TCTouch.Touch('C'); ---------------------------------------------- C
- end case;
- end Print;
-
- Num : Natural := 1000;
-
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket is
- begin
- Num := Num +1;
- case Service is
- when First =>
- return Passenger_Ticket'(Service => First, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Business =>
- return Passenger_Ticket'(Service => Business, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Coach =>
- return Passenger_Ticket'(Service => Coach, Flight => Flight,
- Row_Seat => Seat, Serial_Number => Num );
- end case;
- end Issue;
-
- function Issue return Passenger_Ticket is
- begin
- return Issue( Coach, 0, "non" );
- end Issue;
-
-end C393010_1;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_1;
-package C393010_2 is
-
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with private;
-
- function Issue return Charter;
-
- -- procedure Print( T: Passenger_Ticket );
-
-private
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with null record;
-
- -- Check that the dispatching call to the abstract operation will dispatch
- -- to a procedure defined in the private part of a package.
- procedure Label( T: Charter );
-
- -- an example of a required function the users shouldn't see:
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter;
-
-end C393010_2;
-
-with TCTouch;
-package body C393010_2 is
-
- procedure Label( T: Charter ) is
- begin
- -- Appropriate_IO.Put( "Excursion Fare" );
- TCTouch.Touch('X'); -------------------------------------------------- X
- end Label;
-
- Num : Natural := 4000;
-
- function Issue return Charter is
- begin
- Num := Num +1;
- return Charter'(Service => C393010_1.Coach, Flight => 1001,
- Row_Seat => "OPN", Serial_Number => Num );
- end Issue;
-
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter is
- begin
- return Issue;
- end Issue;
-
-end C393010_2;
-
------------------------------------------------------------------ C393010_1
-
-with Report;
-with TCTouch;
-with C393010_0;
-with C393010_1;
-with C393010_2; -- Charter Tours
-
-procedure C393010 is
-
- type Agents_Handle is access all C393010_0.Ticket'Class;
-
- type Itinerary;
-
- type Next_Leg is access Itinerary;
-
- type Itinerary is record
- Leg : Agents_Handle;
- Next : Next_Leg;
- end record;
-
- function Travel_Agent_1 return Next_Leg is
- begin
- -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
- return new Itinerary'(
- -- ORL -> JFK 01 12 2A First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
- new Itinerary'(
- -- JFK -> LAX 02 18 2B First, Steak
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
- new Itinerary'(
- -- LAX -> SAN 03 5225 34H Coach
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
- new Itinerary'(
- -- SAN -> DFW 04 25 13A Business, Fowl
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Business, 25, "13A")),
- new Itinerary'(
- -- DFW -> ORL 05 15 1D First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
- null )))));
- end Travel_Agent_1;
-
- function Travel_Agent_2 return Next_Leg is
- begin
- -- LAX -> NRT -> SYD -> LAX
- return new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- null ))));
- end Travel_Agent_2;
-
- procedure Traveler( Pax_Tix : in Next_Leg ) is
- Fly_Me : Next_Leg := Pax_Tix;
- begin
- -- a particularly consumptive process...
- while Fly_Me /= null loop
- C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test.
- Fly_Me := Fly_Me.Next;
- end loop;
- end Traveler;
-
-begin
-
- Report.Test ("C393010", "Check that an extended type can be derived from "
- & "an abstract type and that a call on an abstract "
- & "operation is a dispatching operation. Check "
- & "that such a call can dispatch to an overriding "
- & "operation declared in the private part of a "
- & "package" );
-
- Traveler( Travel_Agent_1 );
- TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
-
- Traveler( Travel_Agent_2 );
- TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
-
- Report.Result;
-
-end C393010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393011.a b/gcc/testsuite/ada/acats/tests/c3/c393011.a
deleted file mode 100644
index 8741e87..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393011.a
+++ /dev/null
@@ -1,220 +0,0 @@
--- C393011.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 abstract extended type can be derived from an abstract
--- type, and that a a non-abstract type may then be derived from the
--- second abstract type.
---
--- TEST DESCRIPTION:
--- Define an abstract type with three primitive operations, two of them
--- abstract. Derive an extended type from it, inheriting the non-
--- abstract operation, overriding one of the abstract operations with
--- a non-abstract operation, and overriding the other abstract operation
--- with an abstract operation. The extended type is therefore abstract;
--- derive an extended type from it. Override the abstract operation with
--- a non-abstract operation; inherit one operation from the original
--- abstract type, and inherit one operation from the intermediate
--- abstract type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- Package C393011_0 is
- -- Definitions
-
- type Status_Enum is (None, Unhandled, Pending, Handled);
- type Serial_Type is new Integer range 0 .. Integer'Last;
- subtype Priority_Type is Integer range 0..10;
-
- type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen);
-
- Next : Serial_Type := 1;
- Display_Device : Display_Enum := Bit_Bucket;
-
- end C393011_0;
- -- Definitions;
-
- --=======================================================================--
-
- with C393011_0;
- -- Definitions
-
- Package C393011_1 is
- -- Alert
-
- package Definitions renames C393011_0;
-
- type Alert_Type is abstract tagged record
- Status : Definitions.Status_Enum := Definitions.None;
- Serial_Num : Definitions.Serial_Type := 0;
- Priority : Definitions.Priority_Type;
- end record;
- -- Alert_Type is an abstract type with
- -- two operations to be overridden
-
- procedure Set_Status ( A : in out Alert_Type; -- not abstract
- To : Definitions.Status_Enum);
-
- procedure Set_Serial ( A : in out Alert_Type) is abstract;
- procedure Display ( A : Alert_Type) is abstract;
-
- end C393011_1;
- -- Alert
-
- --=======================================================================--
-
- with C393011_0;
- package body C393011_1 is
- -- Alert
- procedure Set_Status ( A : in out Alert_Type;
- To : Definitions.Status_Enum) is
- begin
- A.Status := To;
- end Set_Status;
-
- end C393011_1;
- -- Alert;
-
- --=======================================================================--
-
- with C393011_0,
- -- Definitions,
- C393011_1,
- -- Alert,
- Calendar;
-
- Package C393011_3 is
- -- New_Alert
-
- type New_Alert_Type is abstract new C393011_1.Alert_Type with record
- Display_Dev : C393011_0.Display_Enum := C393011_0.TTY;
- end record;
-
- -- procedure Set_Status is inherited
-
- procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body
-
- procedure Display ( A : New_Alert_Type) is abstract;
- -- override is abstract
- -- still can't declare objects of New_Alert_Type
-
- end C393011_3;
- -- New_Alert
-
- --=======================================================================--
-
- with C393011_0;
- Package Body C393011_3 is
- -- New_Alert
-
- package Definitions renames C393011_0;
-
- procedure Set_Serial (A : in out New_Alert_Type) is
- use type Definitions.Serial_Type;
- begin
- A.Serial_Num := Definitions.Next;
- Definitions.Next := Definitions."+"( Definitions.Next, 1);
- end Set_Serial;
-
- End C393011_3;
- -- New_Alert;
-
- --=======================================================================--
-
- with C393011_0,
- -- Definitions
- C393011_3;
- -- New_Alert -- package Alert is not visible
- package C393011_4 is
-
- package New_Alert renames C393011_3;
- package Definitions renames C393011_0;
-
- type Final_Alert_Type is new New_Alert.New_Alert_Type with null record;
- -- inherits Set_Status including body
- -- inherits Set_Serial including body
- -- must override Display since inherited Display is abstract
- procedure Display(FA : in Final_Alert_Type);
- procedure Handle (FA : in out Final_Alert_Type);
-
- end C393011_4;
-
- package body C393011_4 is
-
- procedure Display (FA : in Final_Alert_Type) is
- begin
- Definitions.Display_Device := FA.Display_Dev;
- end Display;
-
- procedure Handle (FA : in out Final_Alert_Type) is
- begin
- Set_Status (FA, Definitions.Handled);
- Set_Serial (FA);
- Display (FA);
- end Handle;
- end C393011_4;
-
- with C393011_0,
- -- Definitions
- C393011_3;
- -- New_Alert -- package Alert is not visible
- with C393011_4;
- with Report;
- procedure C393011 is
- use C393011_4;
- use Definitions;
-
- FA : Final_Alert_Type;
-
- begin
-
- Report.Test ("C393011", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if (Definitions.Display_Device /= Definitions.Bit_Bucket)
- or (Definitions.Next /= 1)
- or (FA.Status /= Definitions.None)
- or (FA.Serial_Num /= 0)
- or (FA.Display_Dev /= TTY) then
- Report.Failed ("Incorrect initial conditions");
- end if;
-
- Handle (FA);
- if (Definitions.Display_Device /= Definitions.TTY)
- or (Definitions.Next /= 2)
- or (FA.Status /= Definitions.Handled)
- or (FA.Serial_Num /= 1)
- or (FA.Display_Dev /= TTY) then
- Report.Failed ("Incorrect results from Handle");
- end if;
-
- Report.Result;
-
- end C393011;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc/testsuite/ada/acats/tests/c3/c393012.a
deleted file mode 100644
index 16bf6dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393012.a
+++ /dev/null
@@ -1,221 +0,0 @@
--- C393012.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 non-abstract subprogram of an abstract type can be
--- called with a controlling operand that is a type conversion to
--- the abstract type.
---
--- Check that converting to the class-wide type of an abstract type
--- inside an operation of that type causes a "redispatch" of the
--- called operation.
---
--- TEST DESCRIPTION:
--- This test defines an abstract type, and further derives types from it.
--- The key feature of this test is in the "Display" procedures where
--- the bodies of these procedures convert an object to the class-wide
--- type of the root abstract type, causing a "redispatch".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Add allocation to the object initializations
---
---!
-
-package C393012_0 is
-
- subtype Row_Number is Positive range 1..120;
- subtype Seat_Letter is Character range 'A'..'M';
-
- type Ticket is abstract tagged
- record
- Flight : Natural;
- Row : Row_Number;
- Seat : Seat_Letter;
- end record;
-
- function Display( T: Ticket ) return String;
- function Service( T: Ticket ) return String is abstract;
-
-end C393012_0;
-
-with TCTouch;
-package body C393012_0 is
- function Display( T: Ticket ) return String is
- begin
- TCTouch.Touch('T'); --------------------------------------------------- T
- return "Fl:" & Natural'Image(T.Flight)
- & Service( Ticket'Class( T ) )
- & " Seat:" & Row_Number'Image(T.Row) & T.Seat;
- end Display;
-end C393012_0;
-
-with C393012_0;
-package C393012_1 is
- type Economy is new C393012_0.Ticket with null record;
- function Display( T: Economy ) return String;
- function Service( T: Economy ) return String;
-
- type Meal_Designator is ( B, L, D, V, SN );
-
- type First is new C393012_0.Ticket with
- record
- Meal : Meal_Designator;
- end record;
- function Display( T: First ) return String;
- function Service( T: First ) return String;
- procedure Set_Meal( T: in out First; To_Meal : Meal_Designator );
-
-end C393012_1;
-
-with TCTouch;
-package body C393012_1 is
- function Display( T: Economy ) return String is
- begin
- TCTouch.Touch('E'); --------------------------------------------------- E
- return C393012_0.Display( C393012_0.Ticket( T ) );
- end Display; -- conversion to abstract type
-
- function Service( T: Economy ) return String is
- begin
- TCTouch.Touch('e'); --------------------------------------------------- e
- return " K";
- end Service;
-
- function Display( T: First ) return String is
- begin
- TCTouch.Touch('F'); --------------------------------------------------- F
- return C393012_0.Display( C393012_0.Ticket( T ) );
- end Display; -- conversion to abstract type
-
- function Service( T: First ) return String is
- begin
- TCTouch.Touch('f'); --------------------------------------------------- f
- return " F" & Meal_Designator'Image(T.Meal);
- end Service;
-
- procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is
- begin
- T.Meal := To_Meal;
- end Set_Meal;
-
-end C393012_1;
-
-with Report;
-with TCTouch;
-with C393012_0;
-with C393012_1;
-procedure C393012 is
-
- package Rt renames C393012_0;
- package Tx renames C393012_1;
-
- type Tix is access Rt.Ticket'Class;
- type Itinerary is array(Positive range 1..3) of Tix;
-
--- Outbound and Inbound itineraries provide different orderings of mixtures
--- of Economy and First_Class. Not that that should make any difference...
-
- Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ),
- 2 => new Tx.First' ( 67, 1, 'J', Tx.L ),
- 3 => new Tx.Economy'( 345, 37, 'C' ) );
-
- Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ),
- 2 => new Tx.Economy'( 68, 12, 'D' ),
- 3 => new Tx.Economy'( 5336, 6, 'A' ) );
-
--- Each call to Display uses a parameter that is a type conversion
--- to the abstract type Ticket.
-
- procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is
- begin
- if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then
- Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 );
- end if;
- if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then
- Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 );
- end if;
- if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then
- Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 );
- end if;
- end TC_Convert;
-
--- Each call to Display uses a parameter that is not a type conversion
-
- procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is
- begin
- if Rt.Display( I(1).all ) /= Leg1 then
- Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 );
- end if;
- if Rt.Display( I(2).all ) /= Leg2 then
- Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 );
- end if;
- if Rt.Display( I(3).all ) /= Leg3 then
- Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 );
- end if;
- end TC_Match;
-
-begin -- Main test procedure.
-
- Report.Test ("C393012", "Check that a non-abstract subprogram of an "
- & "abstract type can be called with a "
- & "controlling operand that is a type "
- & "conversion to the abstract type. "
- & "Check that converting to the class-wide type "
- & "of an abstract type inside an operation of "
- & "that type causes a redispatch" );
-
- -- Test conversions to abstract type
-
- TC_Convert( Outbound, "Fl: 5335 K Seat: 5B",
- "Fl: 67 FL Seat: 1J",
- "Fl: 345 K Seat: 37C" );
-
- TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" );
-
- TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F",
- "Fl: 68 K Seat: 12D",
- "Fl: 5336 K Seat: 6A" );
-
- TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" );
-
- -- Test without conversions to abstract type
-
- TC_Match( Outbound, "Fl: 5335 K Seat: 5B",
- "Fl: 67 FL Seat: 1J",
- "Fl: 345 K Seat: 37C" );
-
- TCTouch.Validate( "ETeFTfETe", "Outbound flight" );
-
- TC_Match( Inbound, "Fl: 456 FSN Seat: 4F",
- "Fl: 68 K Seat: 12D",
- "Fl: 5336 K Seat: 6A" );
-
- TCTouch.Validate( "FTfETeETe", "Inbound flight" );
-
- Report.Result;
-
-end C393012;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a02.a b/gcc/testsuite/ada/acats/tests/c3/c393a02.a
deleted file mode 100644
index 177bd34..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a02.a
+++ /dev/null
@@ -1,213 +0,0 @@
--- C393A02.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 dispatching call to an abstract subprogram invokes
--- the correct subprogram body of a descendant type according to
--- the controlling tag.
--- Check that a subprogram can be declared with formal parameters
--- and result that are of an abstract type's associated class-wide
--- type and that such subprograms can be called. 3.4.1(4)
---
--- TEST DESCRIPTION:
--- This test declares several objects of types derived from the
--- abstract type as defined in the foundation F393A00. It then calls
--- various dispatching and class-wide subprograms using those objects.
--- The packages in F393A00 are instrumented to trace the flow of
--- execution.
--- The test checks for the correct order of execution, as expected
--- by the various calls.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 05 APR 96 SAIC Update RM references for 2.1
---
---!
-
-with Report;
-with F393A00_0;
-with F393A00_1;
-with F393A00_2;
-with F393A00_3;
-with F393A00_4;
-procedure C393A02 is
-
- A_Windmill : F393A00_2.Windmill;
- A_Pump : F393A00_3.Pump;
- A_Mill : F393A00_4.Mill;
-
- A_Windmill_2 : F393A00_2.Windmill;
- A_Pump_2 : F393A00_3.Pump;
- A_Mill_2 : F393A00_4.Mill;
-
- B_Windmill : F393A00_2.Windmill;
- B_Pump : F393A00_3.Pump;
- B_Mill : F393A00_4.Mill;
-
- procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is
- begin
- F393A00_0.TC_Touch('x');
- F393A00_2.Swap( A,B );
- end Swapem;
-
- function Zephyr( A: F393A00_2.Windmill'Class )
- return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := A;
- begin
- F393A00_0.TC_Touch('y');
- if not F393A00_1.Initialized( Item ) then -- b
- F393A00_2.Initialize( Item ); -- a
- end if;
- F393A00_2.Stop( Item ); -- f / mff
- F393A00_2.Add_Spin( Item, 10 ); -- e
- return Item;
- end Zephyr;
-
- function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- f
- F393A00_2.Add_Spin( Item, 40 ); -- e
- return Item;
- end Gale;
-
- function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- f
- F393A00_2.Add_Spin( Item, 50 ); -- e
- return Item;
- end Gale;
-
- function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- mff
- F393A00_2.Add_Spin( Item, 60 ); -- e
- return Item;
- end Gale;
-
-begin -- Main test procedure.
-
- Report.Test ("C393A02", "Check that a dispatching call to an abstract "
- & "subprogram invokes the correct subprogram body. "
- & "Check that a subprogram declared with formal "
- & "parameters/result of an abstract type's "
- & "associated class-wide can be called" );
-
- F393A00_0.TC_Validate( "hhh", "Mill declarations" );
- A_Windmill := F393A00_2.Create;
- F393A00_0.TC_Validate( "d", "Create A_Windmill" );
-
- A_Pump := F393A00_3.Create;
- F393A00_0.TC_Validate( "h", "Create A_Pump" );
-
- A_Mill := F393A00_4.Create;
- F393A00_0.TC_Validate( "hl", "Create A_Mill" );
-
- --------------
-
- Swapem( A_Windmill, A_Windmill_2 );
- F393A00_0.TC_Validate( "xc", "Windmill Swap" );
-
- Swapem( A_Pump, A_Pump_2 );
- F393A00_0.TC_Validate( "xc", "Pump Swap" );
-
- Swapem( A_Mill, A_Mill_2 );
- F393A00_0.TC_Validate( "xk", "Pump Swap" );
-
- F393A00_2.Initialize( A_Windmill_2 );
- F393A00_3.Initialize( A_Pump_2 );
- F393A00_4.Initialize( A_Mill_2 );
- B_Windmill := A_Windmill_2;
- B_Pump := A_Pump_2;
- B_Mill := A_Mill_2;
- F393A00_2.Add_Spin( B_Windmill, 123 );
- F393A00_3.Set_Rate( B_Pump, 12.34 );
- F393A00_4.Add_Spin( B_Mill, 321 );
- F393A00_0.TC_Validate( "aaaeie", "Setting Values" );
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe
- XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 40 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" );
- end;
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe
- XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Bad copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 50 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" );
- end;
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe
- XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Bad copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 60 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" );
- end;
-
- Report.Result;
-
-end C393A02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a03.a b/gcc/testsuite/ada/acats/tests/c3/c393a03.a
deleted file mode 100644
index 90106f4..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a03.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- C393A03.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 non-abstract primitive subprogram of an abstract
--- type can be called as a dispatching operation and that the body
--- of this subprogram can make a dispatching call to an abstract
--- operation of the corresponding abstract type.
---
--- TEST DESCRIPTION:
--- This test expands on the class family defined in foundation F393A00
--- by deriving a new abstract type from the root abstract type "Object".
--- The subprograms defined for the new abstract type are then
--- appropriately overridden, and the test ultimately calls various
--- mixtures of these subprograms to check that the dispatching occurs
--- correctly.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed ARM references from objective text.
--- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-------------------------------------------------------------------- C393A03_0
-
-with F393A00_1;
-package C393A03_0 is
-
- type Counting_Object is abstract new F393A00_1.Object with private;
- -- inherits Initialize, Swap (abstract) and Create (abstract)
-
- procedure Bump ( A_Counter: in out Counting_Object );
- procedure Clear( A_Counter: in out Counting_Object ) is abstract;
- procedure Zero ( A_Counter: in out Counting_Object );
- function Value( A_Counter: Counting_Object'Class ) return Natural;
-
-private
-
- type Counting_Object is abstract new F393A00_1.Object with
- record
- Tally : Natural :=0;
- end record;
-
-end C393A03_0;
-
------------------------------------------------------------------------------
-
-with F393A00_0;
-package body C393A03_0 is
-
- procedure Bump ( A_Counter: in out Counting_Object ) is
- begin
- F393A00_0.TC_Touch('A');
- A_Counter.Tally := A_Counter.Tally +1;
- end Bump;
-
- procedure Zero ( A_Counter: in out Counting_Object ) is
- begin
- F393A00_0.TC_Touch('B');
-
- -- dispatching call to abstract operation of Counting_Object
- Clear( Counting_Object'Class(A_Counter) );
-
- A_Counter.Tally := 0;
-
- end Zero;
-
- function Value( A_Counter: Counting_Object'Class ) return Natural is
- begin
- F393A00_0.TC_Touch('C');
- return A_Counter.Tally;
- end Value;
-
-end C393A03_0;
-
-------------------------------------------------------------------- C393A03_1
-
-with C393A03_0;
-package C393A03_1 is
-
- type Modular_Object is new C393A03_0.Counting_Object with private;
- -- inherits Initialize, Bump, Zero and Value,
- -- inherits abstract Swap, Create and Clear
-
- procedure Swap( A,B: in out Modular_Object );
- procedure Clear( It: in out Modular_Object );
- procedure Set_Max( It : in out Modular_Object; Value : Natural );
- function Create return Modular_Object;
-
-private
-
- type Modular_Object is new C393A03_0.Counting_Object with
- record
- Max_Value : Natural;
- end record;
-
-end C393A03_1;
-
------------------------------------------------------------------------------
-
-with F393A00_0;
-package body C393A03_1 is
-
- procedure Swap( A,B: in out Modular_Object ) is
- T : constant Modular_Object := B;
- begin
- F393A00_0.TC_Touch('1');
- B := A;
- A := T;
- end Swap;
-
- procedure Clear( It: in out Modular_Object ) is
- begin
- F393A00_0.TC_Touch('2');
- null;
- end Clear;
-
- procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
- begin
- F393A00_0.TC_Touch('3');
- It.Max_Value := Value;
- end Set_Max;
-
- function Create return Modular_Object is
- AMO : Modular_Object;
- begin
- F393A00_0.TC_Touch('4');
- AMO.Max_Value := Natural'Last;
- return AMO;
- end Create;
-
-end C393A03_1;
-
---------------------------------------------------------------------- C393A03
-
-with Report;
-with F393A00_0;
-with F393A00_1;
-with C393A03_0;
-with C393A03_1;
-procedure C393A03 is
-
- A_Thing : C393A03_1.Modular_Object;
- Another_Thing : C393A03_1.Modular_Object;
-
- procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Initialize( It ); -- dispatch to inherited procedure
- end Initialize;
-
- procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
- end Bump;
-
- procedure Set_Max( It : in out C393A03_1.Modular_Object'Class;
- Val : Natural) is
- begin
- C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
- end Set_Max;
-
- procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
- end Swap;
-
- procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
- end Zero;
-
-begin -- Main test procedure.
-
- Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
- & "of an abstract type can be called as a "
- & "dispatching operation and that the body of this "
- & "subprogram can make a dispatching call to an "
- & "abstract operation of the corresponding "
- & "abstract type" );
-
- A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
- F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
-
- Initialize( A_Thing );
- Initialize( Another_Thing );
- F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
-
- Bump( A_Thing ); -- Tally = 1
- F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
-
- Set_Max( A_Thing, 42 ); -- Max_Value = 42
- F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
-
- if not F393A00_1.Initialized( A_Thing ) then
- Report.Failed("Initialize didn't");
- end if;
- F393A00_0.TC_Validate( "b", "Class-wide layer 0");
-
- Swap( A_Thing, Another_Thing );
- F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
-
- Zero( A_Thing );
- F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
-
- if C393A03_0.Value( A_Thing ) /= 0 then
- Report.Failed("Zero didn't");
- end if;
- F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
-
- Report.Result;
-
-end C393A03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a05.a b/gcc/testsuite/ada/acats/tests/c3/c393a05.a
deleted file mode 100644
index b404559..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a05.a
+++ /dev/null
@@ -1,166 +0,0 @@
--- C393A05.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 for a nonabstract private extension, any inherited
- -- abstract subprograms can be overridden in the private part of
- -- the immediately enclosing package and that calls can be made to
- -- private dispatching operations.
- --
- -- TEST DESCRIPTION:
- -- This test builds an additional layer upon the foundation code to
- -- provide the required "hidden" dispatching operation. The procedure
- -- Swap, a private subprogram, should be called by dispatch.
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- F393A00.A (foundation code)
- -- C393A05.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F393A00_4;
- package C393A05_0 is
- type Grinder is new F393A00_4.Mill with private;
- type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso);
-
- procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness );
- function Grind( It: Grinder ) return Coarseness;
-
- function Create return Grinder;
- private
- procedure Swap( A,B: in out Grinder );
- type Grinder is new F393A00_4.Mill with
- record
- Grind : Coarseness := Whole_Bean;
- end record;
- end C393A05_0;
-
- with F393A00_0;
- package body C393A05_0 is
- procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is
- begin
- F393A00_0.TC_Touch( 'A' );
- It.Grind := The_Grind;
- end Set_Grind;
-
- function Grind( It: Grinder ) return Coarseness is
- begin
- F393A00_0.TC_Touch( 'B' );
- return It.Grind;
- end Grind;
-
- procedure Swap( A,B: in out Grinder ) is
- T : constant Grinder := A;
- begin
- F393A00_0.TC_Touch( 'C' );
- A := B;
- B := T;
- end Swap;
-
- function Create return Grinder is
- One: Grinder;
- begin
- F393A00_0.TC_Touch( 'D' );
- F393A00_4.Initialize( F393A00_4.Mill( One ) );
- One.Grind := Fine;
- return One;
- end Create;
- end C393A05_0;
-
- with Report;
- with F393A00_0;
- with C393A05_0;
- procedure C393A05 is
-
- package Tracer renames F393A00_0;
- package Coffee renames C393A05_0;
- use type Coffee.Coarseness;
-
- Morning : Coffee.Grinder;
- Afternoon : Coffee.Grinder;
-
- Gritty : Coffee.Coarseness;
-
- procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is
- begin
- Coffee.Swap( A, B ); -- dispatch
- end Class_Swap;
-
- begin -- Main test procedure.
-
- Report.Test ("C393A05", "Check that nonabstract private extensions, "
- & "inherited abstract subprograms overridden "
- & "in the private part can be dispatched from "
- & "outside the package" );
-
- Tracer.TC_Validate( "hh", "Declarations" );
-
- Morning := Coffee.Create;
- Tracer.TC_Validate( "hDa", "Creating Morning Coffee" );
- Gritty := Coffee.Grind( Morning );
- Tracer.TC_Validate( "B", "Finding Morning Grind" );
-
- Afternoon := Coffee.Create;
- Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" );
- Coffee.Set_Grind( Afternoon, Coffee.Medium );
- Tracer.TC_Validate( "A", "Setting Afternoon Grind" );
-
- Coffee.Swap( Morning, Afternoon );
- Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" );
-
- if Gritty /= Coffee.Grind( Afternoon )
- or Coffee.Grind ( Afternoon ) /= Coffee.Fine then
- Report.Failed ("Result of Swap");
- end if;
- Tracer.TC_Validate( "BB", "Finding Afternoon Grind" );
-
- Sunset: declare
- Evening : Coffee.Grinder'Class := Coffee.Create;
- begin
- Tracer.TC_Validate( "hDa", "Creating Evening Coffee" );
-
- Coffee.Set_Grind( Evening, Coffee.Espresso );
- Tracer.TC_Validate( "A", "Setting Evening Grind" );
-
- Morning := Coffee.Grinder( Evening );
- Class_Swap( Morning, Evening );
- Tracer.TC_Validate( "C", "Swapping Coffees" );
- if Coffee.Grind( Morning ) /= Coffee.Espresso then
- Report.Failed ("Result of Assignment");
- end if;
- end Sunset;
-
- Report.Result;
-
- end C393A05;
-
-
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a06.a b/gcc/testsuite/ada/acats/tests/c3/c393a06.a
deleted file mode 100644
index c257d5f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a06.a
+++ /dev/null
@@ -1,201 +0,0 @@
--- C393A06.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 type that inherits abstract operations but
--- overrides each of these operations is not required to be
--- abstract, and that objects of the type and its class-wide type
--- may be declared and passed in calls to the overriding
--- subprograms.
---
--- TEST DESCRIPTION:
--- This test derives a type from the root abstract type available
--- in foundation F393A00. It declares subprograms as required by
--- the language to override the abstract subprograms, allowing the
--- derived type itself to be not abstract. It also declares
--- operations on the new type, as well as on the associated class-
--- wide type. The main program then uses two objects of the type
--- and two objects of the class-wide type as parameters for each of
--- the subprograms. Correct execution is determined by path
--- analysis and value checking.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A06.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
-
- with F393A00_1;
- package C393A06_0 is
- type Organism is new F393A00_1.Object with private;
- type Kingdoms is ( Animal, Vegetable, Unspecified );
-
- procedure Swap( A,B: in out Organism );
- function Create return Organism;
-
- procedure Initialize( The_Entity : in out Organism;
- In_The_Kingdom : Kingdoms );
- function Kingdom( Of_The_Entity : Organism ) return Kingdoms;
-
- procedure TC_Check( An_Entity : Organism'Class;
- In_Kingdom : Kingdoms;
- Initialized : Boolean );
-
- Incompatible : exception;
-
- private
- type Organism is new F393A00_1.Object with
- record
- In_Kingdom : Kingdoms;
- end record;
- end C393A06_0;
-
- with F393A00_0;
- package body C393A06_0 is
-
- procedure Swap( A,B: in out Organism ) is
- begin
- F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A
- if A.In_Kingdom /= B.In_Kingdom then
- F393A00_0.TC_Touch( 'X' );
- raise Incompatible;
- else
- declare
- T: constant Organism := A;
- begin
- A := B;
- B := T;
- end;
- end if;
- end Swap;
-
- function Create return Organism is
- Widget : Organism;
- begin
- F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B
- Initialize( Widget );
- Widget.In_Kingdom := Unspecified;
- return Widget;
- end Create;
-
- procedure Initialize( The_Entity : in out Organism;
- In_The_Kingdom : Kingdoms ) is
- begin
- F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C
- F393A00_1.Initialize( F393A00_1.Object( The_Entity ) );
- The_Entity.In_Kingdom := In_The_Kingdom;
- end Initialize;
-
- function Kingdom( Of_The_Entity : Organism ) return Kingdoms is
- begin
- F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D
- return Of_The_Entity.In_Kingdom;
- end Kingdom;
-
- procedure TC_Check( An_Entity : Organism'Class;
- In_Kingdom : Kingdoms;
- Initialized : Boolean ) is
- begin
- if F393A00_1.Initialized( An_Entity ) /= Initialized then
- F393A00_0.TC_Touch( '-' ); ------------------------------------------- -
- elsif An_Entity.In_Kingdom /= In_Kingdom then
- F393A00_0.TC_Touch( '!' ); ------------------------------------------- !
- else
- F393A00_0.TC_Touch( '+' ); ------------------------------------------- +
- end if;
- end TC_Check;
-
- end C393A06_0;
-
- with Report;
-
- with C393A06_0;
- with F393A00_0;
- with F393A00_1;
- procedure C393A06 is
-
- package Darwin renames C393A06_0;
- package Tagger renames F393A00_0;
- package Objects renames F393A00_1;
-
- Lion : Darwin.Organism;
- Tigerlily : Darwin.Organism;
- Bear : Darwin.Organism'Class := Darwin.Create;
- Sunflower : Darwin.Organism'Class := Darwin.Create;
-
- use type Darwin.Kingdoms;
-
- begin -- Main test procedure.
-
- Report.Test ("C393A06", "Check that a type that inherits abstract "
- & "operations but overrides each of these "
- & "operations is not required to be abstract. "
- & "Check that objects of the type and its "
- & "class-wide type may be declared and passed "
- & "in calls to the overriding subprograms" );
-
- Tagger.TC_Validate( "BaBa", "Declaration Initializations" );
-
- Darwin.Initialize( Lion, Darwin.Animal );
- Darwin.Initialize( Tigerlily, Darwin.Vegetable );
- Darwin.Initialize( Bear, Darwin.Animal );
- Darwin.Initialize( Sunflower, Darwin.Vegetable );
-
- Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" );
-
- Oh_My: begin
- Darwin.Swap( Lion, Darwin.Organism( Bear ) );
- Darwin.Swap( Lion, Tigerlily );
- Report.Failed("Exception not raised");
- exception
- when Darwin.Incompatible => null;
- end Oh_My;
-
- Tagger.TC_Validate( "AAX", "Swap sequence" );
-
- if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then
- Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) );
- end if;
-
- Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" );
-
- Darwin.TC_Check( Lion, Darwin.Animal, True );
- Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True );
- Darwin.TC_Check( Bear, Darwin.Animal, True );
- Darwin.TC_Check( Sunflower, Darwin.Vegetable, True );
-
- Tagger.TC_Validate( "b+b+b+b+", "Final sequence" );
-
- Report.Result;
-
- end C393A06;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b12.a b/gcc/testsuite/ada/acats/tests/c3/c393b12.a
deleted file mode 100644
index 5d1b46d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b12.a
+++ /dev/null
@@ -1,131 +0,0 @@
--- C393B12.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 extended type can be derived in the specification of a
--- generic package when the parent is an abstract type in a library
--- package.
---
--- TEST DESCRIPTION:
--- Extend an abstract type in the visible part of a generic package.
--- Make all of the procedures which override abstract procedures
--- available as part of the generic interface. Instantiate the generic.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Oct 95 SAIC Update and repair for ACVC 2.0.1
--- 27 Feb 97 PWB.CTA Add pragma Elaborate for C393B12_0.
---!
-
------------------------------------------------------------------ C393B12_0
-
-with F393B00;
- -- Alert_Foundation
-generic
- type Generic_Status_Enum is (<>);
-
-package C393B12_0 is
- -- Alert_Functions
-
- type Generic_Alert_Type is new F393B00.Alert with record
- Status : Generic_Status_Enum := Generic_Status_Enum'First;
- end record;
- -- extension of an abstract type
-
- procedure Handle (GA : in out Generic_Alert_Type);
- -- override of abstract procedure
-
- function Query_Status (GA : Generic_Alert_Type)
- return Generic_Status_Enum; -- new primitive operation for
- -- Generic_Alert_Type
-end C393B12_0;
- -- Alert_Functions
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C393B12_0 is
- -- Alert_Functions
-
- procedure Handle (GA : in out Generic_Alert_Type) is
- begin
- GA.Status := Generic_Status_Enum'Last;
- end Handle;
-
- function Query_Status (GA : Generic_Alert_Type)
- return Generic_Status_Enum is
- begin
- return GA.Status;
- end Query_Status;
-
-end C393B12_0;
-
------------------------------------------------------------------ C393B12_1
-
-package C393B12_1 is
- type Status is (Low, Medium, High);
-end C393B12_1;
-
-------------------------------------------------------- C393B12_1.C393B12_2
-
-with C393B12_0;
-pragma Elaborate (C393B12_0);
-package C393B12_1.C393B12_2 is new C393B12_0
- -- Alert_Functions
- (Generic_Status_Enum => Status);
-
-------------------------------------------------------------------- C393B12
-
-with C393B12_1.C393B12_2;
-with Report;
-procedure C393B12 is
-
- use type C393B12_1.Status;
-
- package Alt_Alert renames C393B12_1.C393B12_2;
-
- GA : Alt_Alert.Generic_Alert_Type;
-
-begin
- Report.Test ("C393B12", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then
- Report.Failed ("Wrong initialization");
- end if;
-
- Alt_Alert.Handle (GA);
- if Alt_Alert.Query_Status (GA) /= C393B12_1.High then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393B12;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b13.a b/gcc/testsuite/ada/acats/tests/c3/c393b13.a
deleted file mode 100644
index c533bad..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b13.a
+++ /dev/null
@@ -1,105 +0,0 @@
--- C393B13.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 extended type can be derived from an abstract type
--- when that derivation is declared in a child package.
---
--- TEST DESCRIPTION:
--- Add a visible child to Alert_Foundation. Using the abstract type
--- Alert as parent, declare an extended type with discriminant and new
--- record components. Override the Handle procedure.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package F393B00.C393B13_0 is
- -- Alert_Foundation.Public_Child
-
- subtype Msg_Length_Range is integer range 0 .. 240;
- Max_Msg_Length : constant Msg_Length_Range := 80;
- Message : String := "Test Passed";
-
- type Child_Alert (Length : Msg_Length_Range)
- is new Alert with record -- abstract type is in parent package
- Times_Handled : Natural := 0;
- Msg : String (1..Length);
- end record;
-
- procedure Handle (CA : in out Child_Alert); -- required override
-
-end F393B00.C393B13_0;
- -- Alert_Foundation.Public_Child;
-
---=======================================================================--
-
-package body F393B00.C393B13_0 is
- -- Alert_Foundation.Public_Child
-
- procedure Handle (CA : in out Child_Alert) is
- begin
- CA.Msg(1..Message'Length) := Message;
- CA.Times_Handled := CA.Times_Handled + 1;
- end;
-
-end F393B00.C393B13_0;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with Report;
-with F393B00.C393B13_0;
- -- Alert_foundation.Public_Child;
-procedure C393B13 is
- package Child renames F393B00.C393B13_0;
- CA : Child.Child_Alert(Child.Message'Length);
-
-begin
-
- Report.Test ("C393B13", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if CA.Times_Handled /= 0 then
- Report.Failed ("Wrong initialization");
- end if;
-
- Child.Handle (CA);
- if (CA.Times_Handled /= 1)
- or (CA.Msg /= Child.Message) then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393B13;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b14.a b/gcc/testsuite/ada/acats/tests/c3/c393b14.a
deleted file mode 100644
index f100377..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b14.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C393B14.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 extended type can be derived in a private child package
--- from an abstract type defined in a library package.
---
--- TEST DESCRIPTION:
--- Add a private child package to Alert_Foundation. Using Private_Alert
--- as parent type, declare an extended type adding a new record component.
--- Override procedure Handle. Declare an object of the new type in the
--- child specification. Use type definitions from the private part of the
--- parent in the body of the child.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-private package F393B00.C393B14_0 is
- -- Alert_Foundation.Private_Child
-
- type Implementation_Specific_Alert_Type is new Private_Alert with record
- New_Private_Field : Implementation_Detail
- := Implementation_Detail'Last;
- end record;
-
- procedure Handle (PA : in out Implementation_Specific_Alert_Type);
- -- overrides abstract Handle, as required
- PA : Implementation_Specific_Alert_Type;
-
-end F393B00.C393B14_0;
- -- Alert_Foundation.Private_Child
-
---=======================================================================--
-
-package body F393B00.C393B14_0 is
- -- Alert_Foundation.Private_Child
-
- procedure Handle (PA : in out Implementation_Specific_Alert_Type) is
- begin
- PA.Private_Field := 1;
- PA.New_Private_Field := PA.Private_Field + 1;
- end;
-
-end F393B00.C393B14_0;
- -- Alert_Foundation.Private_Child
-
---=======================================================================--
-
-package F393B00.C393B14_1 is
- -- Alert_Foundation.Public_Child
-
- type Timing is (Before, After);
- procedure Init;
- procedure Modify;
- function Check_Before return Boolean;
- function Check_After return Boolean;
-
-end F393B00.C393B14_1;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with F393B00.C393B14_0; -- private sibling is visible in the
- -- Alert_Foundation.Private_Child -- body of a public sibling
-package body F393B00.C393B14_1 is
- -- Alert_Foundation.Public_Child
- package Priv renames F393B00.C393B14_0;
-
- procedure Init is
- begin
- Priv.PA.Private_Field := 5;
- Priv.PA.New_Private_Field := 10;
- end Init;
-
- procedure Modify is
- begin
- Priv.Handle (Priv.PA);
- end Modify;
-
- function Check_Before return Boolean is
- begin
- return ((Priv.PA.Private_Field = 5)
- and (Priv.PA.New_Private_Field =10));
- end Check_Before;
-
- function Check_After return Boolean is
- begin
- return ((Priv.PA.Private_Field = 1)
- and (Priv.PA.New_Private_Field = 2));
- end Check_After;
-
-end F393B00.C393B14_1;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with Report;
-with F393B00.C393B14_1;
-procedure C393B14 is
- -- Alert_Foundation.Public_Child;
-
-begin
- Report.Test ("C393B14", "Check that an extended type can be derived " &
- "from an abstract type");
-
- F393B00.C393B14_1.Init;
- if not F393B00.C393B14_1.Check_Before then
- Report.Failed ("Wrong initialization");
- end if;
-
- F393B00.C393B14_1.Modify;
- if not F393B00.C393B14_1.Check_After then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-end C393B14;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a b/gcc/testsuite/ada/acats/tests/c3/c3a0001.a
deleted file mode 100644
index f8a0681..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3A0001.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 access to subprogram type can be used to select and
--- invoke functions with appropriate arguments dynamically.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare three different sine functions that can be referred to by
--- the access to function type.
---
--- In the main program, call each function indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0001_0 is
-
- TC_Call_Tag : Natural := 0;
-
- -- Type accesses to any sine function
- type Sine_Function_Ptr is access function
- (Angle : in Float) return Float;
-
--- Three 'Sine' functions that model an application situation in which
--- one function might be chosen when speed is important, another (using
--- a different algorithm) might be chosen when accuracy is important,
--- and so on.
-
- function Sine_Calc_Fast (Angle : in Float) return Float;
-
- function Sine_Calc_Acc (Angle : in Float) return Float;
-
- function Sine_Calc_Table (Angle : in Float) return Float;
-
-end C3A0001_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0001_0 is
-
- function Sine_Calc_Fast (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 1;
- return 1.0;
- end Sine_Calc_Fast;
-
-
- function Sine_Calc_Acc (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 2;
- return 0.0;
- end Sine_Calc_Acc;
-
-
- function Sine_Calc_Table (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 3;
- return -1.0;
- end Sine_Calc_Table;
-
-end C3A0001_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0001_0;
-
-procedure C3A0001 is
-
- Sine_Access : C3A0001_0.Sine_Function_Ptr;
- X, Theta : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0001", "Check that access to subprogram can be " &
- "used to select and invoke an operation with " &
- "appropriate arguments dynamically");
-
- Sine_Access := C3A0001_0.Sine_Calc_Fast'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 1 then
- Report.Failed ("Incorrect Sine_Calc_Fast result");
- end if;
-
- Sine_Access := C3A0001_0.Sine_Calc_Acc'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 2 then
- Report.Failed ("Incorrect Sine_Calc_Acc result");
- end if;
-
- Sine_Access := C3A0001_0.Sine_Calc_Table'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 3 then
- Report.Failed ("Incorrect Sine_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a b/gcc/testsuite/ada/acats/tests/c3/c3a0002.a
deleted file mode 100644
index 5c05d43..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a
+++ /dev/null
@@ -1,142 +0,0 @@
--- C3A0002.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 access to subprogram type can be used to select and
--- invoke procedures with appropriate arguments dynamically.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare three different log procedures that can be referred to by
--- the access to procedure type.
---
--- In the main program, call each procedure indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 APR 96 SAIC RM reference change for 2.1
---
---
---!
-
-
-package C3A0002_0 is
-
- TC_Call_Tag : Natural := 0;
-
- Return_Num : Float := 0.0;
-
- -- Type accesses to any log procedure
- type Log_Procedure_Ptr is access procedure
- (Angle : in Float);
-
- procedure Log_Calc_Fast (Angle : in Float);
-
- procedure Log_Calc_Acc (Angle : in Float);
-
- procedure Log_Calc_Table (Angle : in Float);
-
-end C3A0002_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0002_0 is
-
- procedure Log_Calc_Fast (Angle : in Float) is
- begin
- TC_Call_Tag := 1;
- Return_Num := Angle;
- end Log_Calc_Fast;
-
-
- procedure Log_Calc_Acc (Angle : in Float) is
- begin
- TC_Call_Tag := 2;
- Return_Num := Angle;
- end Log_Calc_Acc;
-
-
- procedure Log_Calc_Table (Angle : in Float) is
- begin
- TC_Call_Tag := 3;
- Return_Num := Angle;
- end Log_Calc_Table;
-
-end C3A0002_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0002_0;
-
-procedure C3A0002 is
-
- Log_Access : C3A0002_0.Log_Procedure_Ptr;
- Theta : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0002", "Check that access to subprogram type can be "
- & "used to select and invoke procedures with "
- & "appropriate arguments dynamically" );
-
- Log_Access := C3A0002_0.Log_Calc_Fast'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 1 or C3A0002_0.Return_Num /= 0.0 then
- Report.Failed ("Incorrect Log_Calc_Fast result");
- end if;
-
- Theta := 1.0;
-
- Log_Access := C3A0002_0.Log_Calc_Acc'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 2 or C3A0002_0.Return_Num /= 1.0 then
- Report.Failed ("Incorrect Log_Calc_Acc result");
- end if;
-
- Theta := -1.0;
-
- Log_Access := C3A0002_0.Log_Calc_Table'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 3 or C3A0002_0.Return_Num /= -1.0 then
- Report.Failed ("Incorrect Log_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a b/gcc/testsuite/ada/acats/tests/c3/c3a0003.a
deleted file mode 100644
index 4f9fdbe..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- C3A0003.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 function in a generic instance can be called using
--- an access-to-subprogram value.
---
--- TEST DESCRIPTION:
--- Declare a numeric type in the visible part of a generic package.
--- Declare an access to function type. Declare three different sine
--- functions that can be referred to by the access to function type.
---
--- In the main program, instantiate the generic. Call each function
--- indirectly by dereferencing the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Real_Num is digits <>;
-
-package C3A0003_0 is
-
- TC_Call_Tag : Natural := 0;
-
- -- Type accesses to any sine function
- type Sine_Function_Ptr is access function
- (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Table (Angle : in Real_Num) return Real_Num;
-
-end C3A0003_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0003_0 is
-
- function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := 1.0;
- begin
- TC_Call_Tag := 1;
- return Sine_Num;
- end Sine_Calc_Fast;
-
-
- function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := 0.0;
- begin
- TC_Call_Tag := 2;
- return Sine_Num;
- end Sine_Calc_Acc;
-
-
- function Sine_Calc_Table (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := -1.0;
- begin
- TC_Call_Tag := 3;
- return Sine_Num;
- end Sine_Calc_Table;
-
-end C3A0003_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0003_0;
-
-procedure C3A0003 is
-
- type Real is digits 5;
-
- Subtype Trig_Float is Real range -1.0 .. 1.0;
-
- package Trig is new C3A0003_0 (Real_Num => Trig_Float);
-
- Sine_Access : Trig.Sine_Function_Ptr;
- X, Theta : Trig_Float := 0.0;
-
-begin
-
- Report.Test ("C3A0003", "Check that a function in a generic instance can "
- & "be called using an access-to-subprogram value");
-
- Sine_Access := Trig.Sine_Calc_Fast'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 1 then
- Report.Failed ("Incorrect Sine_Calc_Fast result");
- end if;
-
- Sine_Access := Trig.Sine_Calc_Acc'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 2 then
- Report.Failed ("Incorrect Sine_Calc_Acc result");
- end if;
-
- Sine_Access := Trig.Sine_Calc_Table'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 3 then
- Report.Failed ("Incorrect Sine_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a b/gcc/testsuite/ada/acats/tests/c3/c3a0004.a
deleted file mode 100644
index 2557546..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a
+++ /dev/null
@@ -1,115 +0,0 @@
--- C3A0004.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 access to subprogram may be stored within array
- -- objects, and that the access to subprogram can subsequently
- -- be called.
- --
- -- TEST DESCRIPTION:
- -- Declare an access to procedure type in a package specification.
- -- Declare an array of the access type. Declare three different
- -- procedures that can be referred to by the access to procedure type.
- --
- -- In the main program, build the array by dereferencing the access
- -- value.
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with Report;
-
- procedure C3A0004 is
-
- Left_Turn : Integer := 1;
-
- Right_Turn : Integer := 1;
-
- Center_Turn : Integer := 1;
-
- -- Type accesses to any procedure
- type Action_Ptr is access procedure;
-
- -- Array of access to procedure
- type Action_Array is array (Integer range <>) of Action_Ptr;
-
-
- procedure Rotate_Left is
- begin
- Left_Turn := 2;
- end Rotate_Left;
-
-
- procedure Rotate_Right is
- begin
- Right_Turn := 3;
- end Rotate_Right;
-
-
- procedure Center is
- begin
- Center_Turn := 0;
- end Center;
-
-
- begin
-
- Report.Test ("C3A0004", "Check that access to subprogram may be "
- & "stored within data structures, and that the "
- & "access to subprogram can subsequently be called");
-
- ------------------------------------------------------------------------
-
- declare
- Total_Actions : constant := 3;
- Action_Sequence : Action_Array (1 .. Total_Actions);
-
- begin
-
- -- Build the action sequence
- Action_Sequence := (Rotate_Left'Access, Center'Access,
- Rotate_Right'Access);
-
- -- Assign actions by invoking subprogram designated by access value
- for I in Action_Sequence'Range loop
- Action_Sequence(I).all;
- end loop;
-
- If Left_Turn /= 2 or Right_Turn /= 3
- or Center_Turn /= 0 then
- Report.Failed ("Incorrect Action sequence result");
- end if;
-
- end;
-
- ------------------------------------------------------------------------
-
- Report.Result;
-
- end C3A0004;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a b/gcc/testsuite/ada/acats/tests/c3/c3a0005.a
deleted file mode 100644
index 1f23689..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C3A0005.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 access to subprogram may be stored within record
--- objects, and that the access to subprogram can subsequently
--- be called.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare two different procedures that can be referred to by the
--- access to procedure type. Declare a record with the access to
--- procedure type as a component. Use the access to procedure type to
--- initialize the component of a record.
---
--- In the main program, declare an operation. An access value
--- designating this operation is passed as a parameter to be
--- stored in the record.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0005_0 is
-
- Default_Call : Boolean := False;
-
- type Button;
-
-
- -- Type accesses to procedures Push and Default_Response
- type Button_Response_Ptr is access procedure
- (B : access Button);
-
- procedure Push (B : access Button);
-
- procedure Set_Response (B : access Button;
- R : in Button_Response_Ptr);
-
- procedure Default_Response (B : access Button);
-
- Emergency_Call : Boolean := False;
-
- procedure Emergency (B : access C3A0005_0.Button);
-
- type Button is
- record
- Response : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-
-end C3A0005_0;
-
-
------------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A0005_0 is
-
- procedure Push (B : access Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Response (B);
- end Push;
-
-
- procedure Set_Response (B : access Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Response := R;
- end Set_Response;
-
-
- procedure Default_Response (B : access Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- Default_Call := True;
- end Default_Response;
-
-
- procedure Emergency (B : access C3A0005_0.Button) is
- begin
- TCTouch.Touch( 'E' ); --------------------------------------------- E
- Emergency_Call := True;
- end Emergency;
-
-end C3A0005_0;
-
-
------------------------------------------------------------------------------
-
-with TCTouch;
-with Report;
-
-with C3A0005_0;
-
-procedure C3A0005 is
-
- Big_Red_Button : aliased C3A0005_0.Button;
-
-begin
-
- Report.Test ("C3A0005", "Check that access to subprogram may be "
- & "stored within data structures, and that the "
- & "access to subprogram can subsequently be called");
-
- C3A0005_0.Push (Big_Red_Button'Access);
- TCTouch.Validate("PD", "Using default value");
- TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" );
-
- -- set Emergency value in Button.Response
- C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access);
-
- C3A0005_0.Push (Big_Red_Button'Access);
- TCTouch.Validate("SPE", "After set to Emergency value");
- TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call");
-
- Report.Result;
-
-end C3A0005;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a b/gcc/testsuite/ada/acats/tests/c3/c3a0006.a
deleted file mode 100644
index effab346..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a
+++ /dev/null
@@ -1,163 +0,0 @@
--- C3A0006.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 access to subprogram may be stored within data
--- structures, and that the access to subprogram can subsequently
--- be called.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare an array of the access type. Declare three different
--- functions that can be referred to by the access to function type.
---
--- In the main program, declare a key function that builds the array
--- by calling each function indirectly through the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C3A0006_0 is
-
- TC_Sine_Call : Integer := 0;
- TC_Cos_Call : Integer := 0;
- TC_Tan_Call : Integer := 0;
-
- Sine_Value : Float := 4.0;
- Cos_Value : Float := 8.0;
- Tan_Value : Float := 10.0;
-
- -- Type accesses to any function
- type Trig_Function_Ptr is access function
- (Angle : in Float) return Float;
-
- function Sine (Angle : in Float) return Float;
-
- function Cos (Angle : in Float) return Float;
-
- function Tan (Angle : in Float) return Float;
-
-end C3A0006_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0006_0 is
-
- function Sine (Angle : in Float) return Float is
- begin
- TC_Sine_Call := TC_Sine_Call + 1;
- Sine_Value := Sine_Value + Angle;
- return Sine_Value;
- end Sine;
-
-
- function Cos (Angle: in Float) return Float is
- begin
- TC_Cos_Call := TC_Cos_Call + 1;
- Cos_Value := Cos_Value - Angle;
- return Cos_Value;
- end Cos;
-
-
- function Tan (Angle : in Float) return Float is
- begin
- TC_Tan_Call := TC_Tan_Call + 1;
- Tan_Value := (Tan_Value + (Tan_Value * Angle));
- return Tan_Value;
- end Tan;
-
-
-end C3A0006_0;
-
------------------------------------------------------------------------------
-
-
-with Report;
-
-with C3A0006_0;
-
-procedure C3A0006 is
-
- Trig_Value, Theta : Float := 0.0;
-
- Total_Routines : constant := 3;
-
- Sine_Total : constant := 7.0;
- Cos_Total : constant := 5.0;
- Tan_Total : constant := 75.0;
-
- Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr;
-
-
- -- Key function to build the table
- function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr;
- Operand : Float) return Float is
- begin
- return (Func(Operand));
- end Call_Trig_Func;
-
-
-begin
-
- Report.Test ("C3A0006", "Check that access to subprogram may be " &
- "stored within data structures, and that the access " &
- "to subprogram can subsequently be called");
-
- Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access,
- C3A0006_0.Tan'Access);
-
- -- increase the value of Theta to build the table
- for I in 1 .. Total_Routines loop
- Theta := Theta + 0.5;
- for J in 1 .. Total_Routines loop
- Trig_Value := Call_Trig_Func (Trig_Table(J), Theta);
- end loop;
- end loop;
-
- if C3A0006_0.TC_Sine_Call /= Total_Routines
- or C3A0006_0.TC_Cos_Call /= Total_Routines
- or C3A0006_0.TC_Tan_Call /= Total_Routines then
- Report.Failed ("Incorrect subprograms result");
- end if;
-
- if C3A0006_0.Sine_Value /= Sine_Total
- or C3A0006_0.Cos_Value /= Cos_Total
- or C3A0006_0.Tan_Value /= Tan_Total then
- Report.Failed ("Incorrect values returned from subprograms");
- end if;
-
- if Trig_Value /= Tan_Total then
- Report.Failed ("Incorrect call order.");
- end if;
-
- Report.Result;
-
-end C3A0006;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a b/gcc/testsuite/ada/acats/tests/c3/c3a0007.a
deleted file mode 100644
index ff18d2f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a
+++ /dev/null
@@ -1,234 +0,0 @@
--- C3A0007.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 subprogram via an access-to-subprogram value
--- stored in a data structure will correctly dispatch according to the
--- tag of the class-wide parameter passed via that call.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare a root tagged type with the access to procedure type as a
--- component. Declare three primitive procedures for the type that
--- can be referred to by the access to procedure type. Use the access
--- to procedure type to initialize the component of a record.
---
--- Extend the root type with a record extension in another package
--- specification. Declare a new primitive procedure for the extension
--- (in addition to its three inherited subprograms).
---
--- In the main program, declare an operation for the root tagged type
--- which can be passed as an access value to change the initial value
--- of the component. Call the inherited operation indirectly by
--- dereferencing the access value to check on the initial value of the
--- extension. Call inherited operations indirectly by dereferencing
--- the access value to replace the initial value. Call the primitive
--- procedure indirectly by dereferencing the access value to modify the
--- extension.
---
--- type Button
--- procedure Push(Button)
--- procedure Set_Response(Button,Button_Response_Ptr)
--- procedure Default_Response(Button)
---
--- type Priority_Button (new Button)
--- procedures Push, Set_Response inherited
--- procedure Default_Response
--- procedure Set_Priority
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0007_0 is
-
- Default_Call : Boolean := False;
-
- type Button is tagged private;
-
- type Button_Response_Ptr is access procedure
- (B : in out Button'Class);
-
- procedure Push (B : in out Button); -- to be inherited
-
- procedure Set_Response (B : in out Button; -- to be inherited
- R : in Button_Response_Ptr);
-
- procedure Response (B : in out Button); -- to be inherited
-
-private
- procedure Default_Response(B: in out Button'Class);
- type Button is tagged -- root tagged type
- record
- Action : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-end C3A0007_0;
-
-with C3A0007_0;
-package C3A0007_1 is
-
- type Priority_Button is new C3A0007_0.Button
- with record
- Priority : Integer := 0;
- end record;
-
- -- Inherits procedure Push from Button
- -- Inherits procedure Set_Response from Button
-
- -- Override procedure Response from Button
- procedure Response (B : in out Priority_Button);
-
- -- Primitive operation of the extension
- procedure Set_Priority (B : in out Priority_Button);
-
-end C3A0007_1;
-
-with C3A0007_0;
-package C3A0007_2 is
-
- Emergency_Call : Boolean := False;
-
- procedure Emergency (B : in out C3A0007_0.Button'Class);
-end C3A0007_2;
-
------------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A0007_0 is
-
- procedure Push (B : in out Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Action (B);
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Action := R;
- end Set_Response;
-
-
- procedure Response (B : in out Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- Default_Call := True;
- end Response;
-
- procedure Default_Response (B : in out Button'Class) is
- begin
- TCTouch.Touch( 'C' ); --------------------------------------------- C
- Response(B);
- end Default_Response;
-
-end C3A0007_0;
-
-with TCTouch;
-package body C3A0007_1 is
-
- procedure Set_Priority (B : in out Priority_Button) is
- begin
- TCTouch.Touch( 's' ); --------------------------------------------- s
- B.Priority := 1;
- end Set_Priority;
-
- procedure Response (B : in out Priority_Button) is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- end Response;
-
-end C3A0007_1;
-
-with TCTouch;
-package body C3A0007_2 is
- procedure Emergency (B : in out C3A0007_0.Button'Class) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------- E
- Emergency_Call := True;
- end Emergency;
-end C3A0007_2;
-
------------------------------------------------------------------------------
-
-with Report;
-with TCTouch;
-
-with C3A0007_0;
-with C3A0007_1;
-with C3A0007_2;
-procedure C3A0007 is
-
- Pink_Button : C3A0007_0.Button;
- Green_Button : C3A0007_1.Priority_Button;
-
-begin
-
- Report.Test ("C3A0007", "Check that a call to a subprogram via an "
- & "access-to-subprogram value stored in a data "
- & "structure will correctly dispatch according to "
- & "the tag of the class-wide parameter passed "
- & "via that call" );
-
- -- Call inherited operation Push to set Default_Response value
- -- in the extension.
-
- C3A0007_1.Push (Green_Button);
- TCTouch.Validate("PCd", "First Green Button Push");
-
- TCTouch.Assert_Not(C3A0007_0.Default_Call,
- "Incorrect Green Default_Response");
-
- C3A0007_0.Push (Pink_Button);
- TCTouch.Validate("PCD", "First Pink Button Push");
-
- -- Call inherited operations Set_Response and Push to set
- -- Emergency value in the extension.
- C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
- C3A0007_1.Push (Green_Button);
- TCTouch.Validate("SPE", "Second Green Button Push");
-
- TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
-
- C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
- C3A0007_0.Push (Pink_Button);
- TCTouch.Validate("SPE", "Second Pink Button Push");
-
- -- Call primitive operation to set priority value
- -- in the extension.
- C3A0007_1.Set_Priority (Green_Button);
- TCTouch.Validate("s", "Green Button Priority");
-
- TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
-
- Report.Result;
-
-end C3A0007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a b/gcc/testsuite/ada/acats/tests/c3/c3a0008.a
deleted file mode 100644
index 6cd9ce3..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a
+++ /dev/null
@@ -1,150 +0,0 @@
--- C3A0008.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 subprogram references may be passed as parameters using
--- access-to-subprogram types. Check that the passed subprograms may
--- be invoked from within the called subprogram.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare three different trig functions that can be referred to by
--- the access to function type.
---
--- In the main program, call each function indirectly by passing the
--- access to subprogram value as parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package Integrate_Lookup is
-
- TC_Log_Call : Boolean := False;
-
- TC_Cos_Call : Boolean := False;
-
- TC_Sine_Call : Boolean := False;
-
- -- Type accesses to functions Log, Sine, or Cos
- type Integrand_Ptr is access function
- (Angle : Float) return Float;
-
- function Log (Angle : in Float) return Float;
-
- function Sine (Angle : in Float) return Float;
-
- function Cos (Angle : in Float) return Float;
-
- function Integrate (Func : Integrand_Ptr; From, To: Float)
- return Float;
-
-end Integrate_Lookup;
-
-
------------------------------------------------------------------------------
-
-
-package body Integrate_Lookup is
-
-
- function Log (Angle : in Float) return Float is
- begin
- TC_Log_Call := True;
- return 0.1;
- end Log;
-
-
- function Sine (Angle : in Float) return Float is
- begin
- TC_Sine_Call := True;
- return 0.0;
- end Sine;
-
-
- function Cos (Angle : in Float) return Float is
- begin
- TC_Cos_Call := True;
- return 1.0;
- end Cos;
-
-
- function Integrate (Func : Integrand_Ptr; From, To: Float)
- return Float is
- Theta : Float;
- begin
- -- calls the actual subprogram passed as parameter
- Theta := Func (From) + Func (To);
- return Theta;
- end Integrate;
-
-end Integrate_Lookup;
-
-
------------------------------------------------------------------------------
-
-
-with Report;
-
-with Integrate_Lookup;
-
-procedure C3A0008 is
-
- Area : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0008", "Check that subprogram references may be passed "
- & "as parameters using access-to-subprogram types. "
- & "Check that the passed subprograms may be invoked "
- & "from within the called subprogram");
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Log'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Log_Call or Area /= 0.2 then
- Report.Failed ("Incorrect Log result");
- end if;
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Sine'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Sine_Call or Area /= 0.0 then
- Report.Failed ("Incorrect Sine result");
- end if;
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Cos'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Cos_Call or Area /= 2.0 then
- Report.Failed ("Incorrect Cos result");
- end if;
-
- Report.Result;
-
-end C3A0008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
deleted file mode 100644
index ba3f2f6..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
+++ /dev/null
@@ -1,219 +0,0 @@
--- C3A0009.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 subprogram references may be passed as parameters using
--- access-to-subprogram types. Check that the passed subprograms may
--- be invoked from within the called subprogram.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare a root tagged type with the access to procedure type as a
--- component. Declare three primitive procedures for the type that
--- can be referred to by the access to procedure type. Use the access
--- to procedure type to initialize the component of a record.
---
--- Extend the root type with a private extension in the same package
--- specification. Declare two new primitive subprograms for the extension
--- (in addition to its three inherited subprograms).
---
--- In the main program, declare an operation for the root tagged type
--- which can be passed as an access value to change the initial value
--- of the component. Call the inherited operations indirectly by
--- de-referencing the access value to set value in the extension.
--- Call the primitive function to modify the extension by passing
--- the access value designating the primitive procedure as a parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0009_0 is -- Push_Buttons
-
- type Button is tagged private;
-
- -- Type accesses to procedures Push and Default_Response
- type Button_Response_Ptr is access procedure
- (B : in out Button);
-
- procedure Push (B : in out Button); -- to be inherited
-
- procedure Set_Response (B : in out Button; -- to be inherited
- R : in Button_Response_Ptr);
-
- procedure Default_Response (B : in out Button); -- to be inherited
-
- type Alert_Button is new Button with private; -- private extension of
- -- root tagged type
- -- Inherits procedure Push from Button
- -- Inherits procedure Set_Response from Button
- -- Inherits procedure Default_Response from Button
-
- procedure Replace_Action( B: in out Alert_Button );
-
- -- type accesses to procedure Default_Action
- type Button_Action_Ptr is access procedure;
-
- -- The following function is needed to set value in the
- -- extension's private component.
- function Alert (B : in Alert_Button) return Button_Action_Ptr;
-
-private
-
- type Button is tagged -- root tagged type
- record
- Response : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-
- procedure Default_Action;
-
- type Alert_Button is new Button with record
- Action : Button_Action_Ptr
- := Default_Action'Access;
- end record;
-
-end C3A0009_0;
-
-
------------------------------------------------------------------------------
-
-
-with TCTouch;
-package body C3A0009_0 is
-
- procedure Push (B : in out Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Response (B);
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Response := R;
- end Set_Response;
-
-
- procedure Default_Response (B : in out Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- end Default_Response;
-
-
- procedure Default_Action is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- end Default_Action;
-
- procedure Replacement_Action is
- begin
- TCTouch.Touch( 'r' ); --------------------------------------------- r
- end Replacement_Action;
-
- procedure Replace_Action( B: in out Alert_Button ) is
- begin
- TCTouch.Touch( 'R' ); --------------------------------------------- R
- B.Action := Replacement_Action'Access;
- end Replace_Action;
-
- function Alert (B : in Alert_Button) return Button_Action_Ptr is
- begin
- TCTouch.Touch( 'A' ); --------------------------------------------- A
- return (B.Action);
- end Alert;
-
-end C3A0009_0;
-
------------------------------------------------------------------------------
-
-with C3A0009_0;
-package C3A0009_1 is -- Emergency_Items
- package Push_Buttons renames C3A0009_0;
-
- procedure Emergency (B : in out Push_Buttons.Button);
-end C3A0009_1;
-
-with TCTouch;
-package body C3A0009_1 is -- Emergency_Items
- procedure Emergency (B : in out Push_Buttons.Button) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------- E
- end Emergency;
-end C3A0009_1;
------------------------------------------------------------------------------
-
-with Report;
-
-with C3A0009_0, C3A0009_1;
-with TCTouch;
-procedure C3A0009 is
-
- package Push_Buttons renames C3A0009_0;
- package Emergency_Items renames C3A0009_1;
-
- Black_Button : Push_Buttons.Alert_Button;
- Alert_Ptr : Push_Buttons.Button_Action_Ptr;
-
-begin
-
- Report.Test ("C3A0009", "Check that subprogram references may be passed "
- & "as parameters using access-to-subprogram types. "
- & "Check that the passed subprograms may be "
- & "invoked from within the called subprogram");
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "PDAd", "Default operation set" );
-
- -- Call inherited operations Set_Response and Push to set
- -- Emergency value in the extension.
- Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access);
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "SPEAd", "Altered Response set" );
-
- -- Call primitive operation to set action value in the extension.
- Push_Buttons.Replace_Action( Black_Button );
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "RPEAr", "Altered Action set" );
-
- Report.Result;
-end C3A0009;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a b/gcc/testsuite/ada/acats/tests/c3/c3a0010.a
deleted file mode 100644
index 5628c95..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- C3A0010.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 access-to-subprogram type in a generic instance may be
--- used to declare access-to-subprogram objects which invoke subprograms
--- in the instance.
---
--- TEST DESCRIPTION:
--- Declare a numeric type in the visible part of a generic package.
--- Declare two different math procedures that can be referred to by
--- the access to procedure type.
---
--- In the main program, instantiate the generic. Declare an access
--- to procedure type. Call each procedure indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 APR 96 SAIC Header correction for 2.1
---
---!
-
-generic
- type Real_Num is digits <>;
-
-package C3A0010_0 is
-
- -- Type accesses to any math procedure
- type Math_Procedure_Ptr is access procedure
- (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
- procedure Add (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
- procedure Subtract (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
-end C3A0010_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0010_0 is
-
- procedure Add (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num) is
- begin
- Result_Num := First_Num + Second_Num;
- end Add;
-
-
- procedure Subtract (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num) is
- begin
- Result_Num := First_Num - Second_Num;
- end Subtract;
-
-end C3A0010_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0010_0;
-
-procedure C3A0010 is
-
- type Real is digits 2;
-
- subtype Math_Float is Real range -10.0 .. 10.0;
-
- package Math_Pk is new C3A0010_0 (Real_Num => Math_Float);
-
- Math_Access : Math_Pk.Math_Procedure_Ptr;
-
- Total_Num : Math_Float := 0.0;
- First_Num : Math_Float := 1.0;
- Second_Num : Math_Float := 2.0;
-
- procedure Max( A_Num, B_Num: in Math_Float; Result : out Math_Float ) is
- begin
- if A_Num > B_Num then
- Result := A_Num;
- else
- Result := B_Num;
- end if;
- end Max;
-
- procedure Due_Process( Process: Math_Pk.Math_Procedure_Ptr ) is
- begin
- Process(First_Num, Second_Num, Total_Num);
- end Due_Process;
-
-begin
-
- Report.Test ("C3A0010", "Check that an access-to-subprogram type in a "
- & "generic instance may be used to declare "
- & "access-to-subprogram objects which invoke "
- & "subprograms in the instance");
-
--- Check for correct defaulting
- if Math_Pk."/="( Math_Access, null) then
- Report.Failed("subprogram access type object not initialized to null");
- end if;
-
- Math_Access := Math_Pk.Add'Access;
-
- -- Invoking Add procedure designated by access value
- Due_Process( Math_Access );
-
- If Total_Num /= 3.0 then
- Report.Failed ("Incorrect Add result");
- end if;
-
- Math_Access := Math_Pk.Subtract'Access;
-
- Due_Process( Math_Access );
-
- If Total_Num /= -1.0 then
- Report.Failed ("Incorrect Subtract result");
- end if;
-
- Math_Access := Max'Access;
-
- Due_Process( Math_Access );
-
- If Total_Num /= 2.0 then
- Report.Failed ("Incorrect Max result");
- end if;
-
- Report.Result;
-
-end C3A0010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a b/gcc/testsuite/ada/acats/tests/c3/c3a0011.a
deleted file mode 100644
index 9850806..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- C3A0011.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 access-to-subprogram object whose type is declared in a
--- parent package, may be used to invoke subprograms in a child package.
--- Check that such access objects may be stored in a data structure and
--- that subprograms may be called by walking the data structure.
---
--- TEST DESCRIPTION:
--- In the package, declare an access to procedure type. Declare an
--- array of the access type. Declare three different procedures that
--- can be referred to by the access to procedure type.
---
--- In the visible child package, declare two procedures that can be
--- referred to by the access to procedure type of the parent. Build
--- the array by calling each procedure indirectly through the access
--- value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Improved visibility of "/=" in main body
---
---!
-
-package C3A0011_0 is -- Interpreter
-
- type Compass_Point is mod 360;
-
- function Heading return Compass_Point;
-
- -- Type accesses to any procedure
- type Action_Ptr is access procedure;
-
- -- Array of access to procedure
- type Action_Array is array (Natural range <>) of Action_Ptr;
-
- procedure Rotate_Left;
-
- procedure Rotate_Right;
-
- procedure Center;
-
-private
- The_Heading : Compass_Point := Compass_Point'First;
-
-end C3A0011_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0011_0 is
-
- function Heading return Compass_Point is
- begin
- return The_Heading;
- end Heading;
-
- procedure Rotate_Left is
- begin
- The_Heading := The_Heading - 90;
- end Rotate_Left;
-
-
- procedure Rotate_Right is
- begin
- The_Heading := The_Heading + 90;
- end Rotate_Right;
-
-
- procedure Center is
- begin
- The_Heading := 0;
- end Center;
-
-end C3A0011_0;
-
-
------------------------------------------------------------------------------
-
-
-package C3A0011_0.Action is
-
- procedure Rotate_Front;
-
- procedure Rotate_Back;
-
-end C3A0011_0.Action;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0011_0.Action is
-
- procedure Rotate_Front is
- begin
- The_Heading := The_Heading + 5;
- end Rotate_Front;
-
-
- procedure Rotate_Back is
- begin
- The_Heading := The_Heading - 5;
- end Rotate_Back;
-
-end C3A0011_0.Action;
-
-
------------------------------------------------------------------------------
-
-
-with C3A0011_0.Action;
-
-with Report;
-
-procedure C3A0011 is
-
- Total_Actions : constant := 6;
-
- Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions);
-
- type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point;
-
- Action_Results : Result_Array(1 .. Total_Actions);
-
- package IA renames C3A0011_0.Action;
-
-begin
-
- Report.Test ("C3A0011", "Check that an access-to-subprogram object whose "
- & "type is declared in a parent package, may be "
- & "used to invoke subprograms in a child package. "
- & "Check that such access objects may be stored in "
- & "a data structure and that subprograms may be "
- & "called by walking the data structure");
-
- -- Build the action sequence
- Action_Sequence := (C3A0011_0.Rotate_Left'Access,
- C3A0011_0.Center'Access,
- C3A0011_0.Rotate_Right'Access,
- IA.Rotate_Front'Access,
- C3A0011_0.Center'Access,
- IA.Rotate_Back'Access);
-
- -- Build the expected result
- Action_Results := ( 270, 0, 90, 95, 0, 355 );
-
- -- Assign actions by invoking subprogram designated by access value
- for I in Action_Sequence'Range loop
- Action_Sequence(I).all;
- if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then
- Report.Failed ("Expecting "
- & C3A0011_0.Compass_Point'Image(Action_Results(I))
- & " Got"
- & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading));
- end if;
- end loop;
-
- Report.Result;
-
-end C3A0011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a b/gcc/testsuite/ada/acats/tests/c3/c3a00120.a
deleted file mode 100644
index 5ce7b61..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a
+++ /dev/null
@@ -1,83 +0,0 @@
--- C3A00120.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:
- -- See file C3A00122.AM
- --
- -- TEST DESCRIPTION:
- -- See file C3A00122.AM
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- => C3A00120.A
- -- C3A00121.A
- -- C3A00122.AM
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- package C3A0012_0 is
-
- type Call_Kind is (No_Call_Made, Fast_Call, Accurate_Call,
- Table_Lookup_Call);
-
- Log_Result : Float := 0.0;
-
- -- Type accesses to any log procedure
- type Log_Procedure_Ptr is access procedure
- (Angle : in Float; Log_Call : out Call_Kind);
-
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind);
-
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind);
-
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind);
-
- end C3A0012_0;
-
-
- --=======================================================================--
-
-
- package body C3A0012_0 is
-
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- end C3A0012_0;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a b/gcc/testsuite/ada/acats/tests/c3/c3a00121.a
deleted file mode 100644
index acb1dab..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- C3A00121.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:
- -- See file C3A00122.AM
- --
- -- TEST DESCRIPTION:
- -- See file C3A00122.AM
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- C3A00120.A
- -- => C3A00121.A
- -- C3A00122.AM
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- Separate (C3A0012_0)
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Fast_Call;
- end Log_Calc_Fast;
-
-
- --=======================================================================--
-
-
- Separate (C3A0012_0)
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Accurate_Call;
- end Log_Calc_Acc;
-
-
- --=======================================================================--
-
-
- Separate (C3A0012_0)
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Table_Lookup_Call;
- end Log_Calc_Table;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00122.am b/gcc/testsuite/ada/acats/tests/c3/c3a00122.am
deleted file mode 100644
index 7af03c2..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a00122.am
+++ /dev/null
@@ -1,113 +0,0 @@
--- C3A00122.AM
---
--- 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 access-to-subprogram object can be used to invoke a
--- subprogram when the subprogram body had been declared and implemented
--- as a subunit.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a main program. Declare
--- three different log subprogram body stubs that can be referred to by
--- the access to procedure type.
---
--- Complete bodies of the log procedures.
---
--- In the main program, each procedure will be called indirectly by
--- dereferencing the access value.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- C3A00120.A
--- C3A00121.A
--- => C3A00122.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- with Report;
-
- with C3A0012_0;
-
- procedure C3A00122 is
-
- function "="( A,B: C3A0012_0.Call_Kind ) return Boolean
- renames C3A0012_0."=";
-
- Log_Access : C3A0012_0.Log_Procedure_Ptr;
- Theta : Float := 0.0;
- Method : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made;
-
-
-
- function Due_Process( LA: C3A0012_0.Log_Procedure_Ptr )
- return C3A0012_0.Call_Kind is
- Result : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made;
- begin
- LA( Theta, Result );
- return Result;
- end Due_Process;
-
- begin
-
- Report.Test ("C3A0012", "Check that an access to a subprogram object " &
- "can be used to select and invoke an operation with " &
- "appropriate arguments");
-
- Log_Access := C3A0012_0.Log_Calc_Fast'Access;
-
- -- Invoking Log procedure designated by access value
- Method := Due_Process( Log_Access );
-
- If Method /= C3A0012_0.Fast_Call then
- Report.Failed ("Incorrect Log_Calc_Fast result");
- end if;
-
- Log_Access := C3A0012_0.Log_Calc_Acc'Access;
-
- -- Invoking Log procedure designated by access value
- Method := Due_Process( Log_Access );
-
- If Method /= C3A0012_0.Accurate_Call then
- Report.Failed ("Incorrect Log_Calc_Acc result");
- end if;
-
- Log_Access := C3A0012_0.Log_Calc_Table'Access;
-
- -- Invoking Log procedure designated by access value
- Method := Due_Process( Log_Access );
-
- If Method /= C3A0012_0.Table_Lookup_Call then
- Report.Failed ("Incorrect Log_Calc_Table result");
- end if;
-
- Report.Result;
-
- end C3A00122;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a b/gcc/testsuite/ada/acats/tests/c3/c3a0013.a
deleted file mode 100644
index b23d4ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a
+++ /dev/null
@@ -1,347 +0,0 @@
--- C3A0013.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 general access type object may reference allocated
--- pool objects as well as aliased objects. (3,4)
--- Check that formal parameters of tagged types are implicitly
--- defined as aliased; check that the 'Access of these formal
--- parameters designates the correct object with the correct
--- tag. (5)
--- Check that the current instance of a limited type is defined as
--- aliased. (5)
---
--- TEST DESCRIPTION:
--- This test takes from the hierarchy defined in C390003; making
--- the root type Vehicle limited private. It also shifts the
--- abstraction to include the notion of a transmission, an object
--- which is contained within any vehicle. Using an access
--- discriminant, any subprogram which operates on a transmission
--- may also reference the vehicle in which it is installed.
---
--- Class Hierarchy:
--- Vehicle Transmission
--- / \
--- Truck Car
---
--- Contains:
--- Vehicle( Transmission )
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Fixed accessibility problems
---
---!
-
-package C3A0013_1 is
- type Vehicle is tagged limited private;
- type Vehicle_ID is access all Vehicle'Class;
-
- -- Constructors
- procedure Create ( It : in out Vehicle;
- Wheels : Natural := 4 );
- -- Modifiers
- procedure Accelerate ( It : in out Vehicle );
- procedure Decelerate ( It : in out Vehicle );
- procedure Up_Shift ( It : in out Vehicle );
- procedure Stop ( It : in out Vehicle );
-
- -- Selectors
- function Speed ( It : Vehicle ) return Natural;
- function Wheels ( It : Vehicle ) return Natural;
- function Gear_Factor( It : Vehicle ) return Natural;
-
- -- TC_Ops
- procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
-
- -- dispatching procedure used to check tag correctness
- procedure TC_Validate( It : Vehicle;
- TC_ID : Character);
-
-private
-
- type Transmission(Within: access Vehicle'Class) is limited record
- Engaged : Boolean := False;
- Gear : Integer range -1..5 := 0;
- end record;
-
- -- Current instance of a limited type is defined as aliased
-
- type Vehicle is tagged limited record
- Wheels: Natural;
- Speed : Natural;
- Power_Train: Transmission( Vehicle'Access );
- end record;
-end C3A0013_1;
-
-with C3A0013_1;
-package C3A0013_2 is
- type Car is new C3A0013_1.Vehicle with private;
- procedure TC_Validate( It : Car;
- TC_ID : Character);
- function Gear_Factor( It : Car ) return Natural;
-private
- type Car is new C3A0013_1.Vehicle with record
- Displacement : Natural;
- end record;
-end C3A0013_2;
-
-with C3A0013_1;
-package C3A0013_3 is
- type Truck is new C3A0013_1.Vehicle with private;
- procedure TC_Validate( It : Truck;
- TC_ID : Character);
- function Gear_Factor( It : Truck ) return Natural;
-private
- type Truck is new C3A0013_1.Vehicle with record
- Displacement : Natural;
- end record;
-end C3A0013_3;
-
-with Report;
-package body C3A0013_1 is
-
- procedure Create ( It : in out Vehicle;
- Wheels : Natural := 4 ) is
- begin
- It.Wheels := Wheels;
- It.Speed := 0;
- end Create;
-
- procedure Accelerate( It : in out Vehicle ) is
- begin
- It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
- end Accelerate;
-
- procedure Decelerate( It : in out Vehicle ) is
- begin
- It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
- end Decelerate;
-
- procedure Stop ( It : in out Vehicle ) is
- begin
- It.Speed := 0;
- It.Power_Train.Engaged := False;
- end Stop;
-
- function Gear_Factor( It : Vehicle ) return Natural is
- begin
- return It.Power_Train.Gear;
- end Gear_Factor;
-
- function Speed ( It : Vehicle ) return Natural is
- begin
- return It.Speed;
- end Speed;
-
- function Wheels ( It : Vehicle ) return Natural is
- begin
- return It.Wheels;
- end Wheels;
-
- -- formal tagged parameters are implicitly aliased
-
- procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
- License: Vehicle_ID := It'Unchecked_Access;
- begin
- if Speed( License.all ) /= Speed_Trap then
- Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It : Vehicle;
- TC_ID : Character) is
- begin
- if TC_ID /= 'V' then
- Report.Failed("Dispatched to Vehicle");
- end if;
- if Wheels( It ) /= 1 then
- Report.Failed("Not a Vehicle");
- end if;
- end TC_Validate;
-
- procedure Up_Shift( It: in out Vehicle ) is
- begin
- It.Power_Train.Gear := It.Power_Train.Gear +1;
- It.Power_Train.Engaged := True;
- Accelerate( It );
- end Up_Shift;
-end C3A0013_1;
-
-with Report;
-package body C3A0013_2 is
-
- procedure TC_Validate( It : Car;
- TC_ID : Character ) is
- begin
- if TC_ID /= 'C' then
- Report.Failed("Dispatched to Car");
- end if;
- if Wheels( It ) /= 4 then
- Report.Failed("Not a Car");
- end if;
- end TC_Validate;
-
- function Gear_Factor( It : Car ) return Natural is
- begin
- return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
- end Gear_Factor;
-
-end C3A0013_2;
-
-with Report;
-package body C3A0013_3 is
-
- procedure TC_Validate( It : Truck;
- TC_ID : Character) is
- begin
- if TC_ID /= 'T' then
- Report.Failed("Dispatched to Truck");
- end if;
- if Wheels( It ) /= 3 then
- Report.Failed("Not a Truck");
- end if;
- end TC_Validate;
-
- function Gear_Factor( It : Truck ) return Natural is
- begin
- return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
- end Gear_Factor;
-
-end C3A0013_3;
-
-package C3A0013_4 is
- procedure Perform_Tests;
-end C3A0013_4;
-
-with Report;
-with C3A0013_1;
-with C3A0013_2;
-with C3A0013_3;
-package body C3A0013_4 is
- package Root renames C3A0013_1;
- package Cars renames C3A0013_2;
- package Trucks renames C3A0013_3;
-
- type Car_Pool is array(1..4) of aliased Cars.Car;
- Commuters : Car_Pool;
-
- My_Car : aliased Cars.Car;
- Company_Car : Root.Vehicle_ID;
- Repair_Shop : Root.Vehicle_ID;
-
- The_Vehicle : Root.Vehicle;
- The_Car : Cars.Car;
- The_Truck : Trucks.Truck;
-
- procedure TC_Dispatch( Ptr : Root.Vehicle_ID;
- Char : Character ) is
- begin
- Root.TC_Validate( Ptr.all, Char );
- end TC_Dispatch;
-
- procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
- Char: Character) is
- begin
- TC_Dispatch( Item'Unchecked_Access, Char );
- end TC_Check_Formal_Access;
-
- procedure Perform_Tests is
- begin -- Main test procedure.
-
- for Lane in Commuters'Range loop
- Cars.Create( Commuters(Lane) );
- for Excitement in 1..Lane loop
- Cars.Up_Shift( Commuters(Lane) );
- end loop;
- end loop;
-
- Cars.Create( My_Car );
- Cars.Up_Shift( My_Car );
- Cars.TC_Validate( My_Car, 2 );
-
- Root.Create( The_Vehicle, 1 );
- Cars.Create( The_Car , 4 );
- Trucks.Create( The_Truck, 3 );
-
- TC_Check_Formal_Access( The_Vehicle, 'V' );
- TC_Check_Formal_Access( The_Car, 'C' );
- TC_Check_Formal_Access( The_Truck, 'T' );
-
- Root.Up_Shift( The_Vehicle );
- Cars.Up_Shift( The_Car );
- Trucks.Up_Shift( The_Truck );
-
- Root.TC_Validate( The_Vehicle, 1 );
- Cars.TC_Validate( The_Car, 2 );
- Trucks.TC_Validate( The_Truck, 3 );
-
- -- general access type may reference allocated objects
-
- Company_Car := new Cars.Car;
- Root.Create( Company_Car.all );
- Root.Up_Shift( Company_Car.all );
- Root.Up_Shift( Company_Car.all );
- Root.TC_Validate( Company_Car.all, 6 );
-
- -- general access type may reference aliased objects
-
- Repair_Shop := My_Car'Access;
- Root.TC_Validate( Repair_Shop.all, 2 );
-
- -- general access type may reference aliased objects
-
- Construction: declare
- type Speed_List is array(Commuters'Range) of Natural;
- Accelerations : constant Speed_List := (2, 6, 12, 20);
- begin
- for Rotation in Commuters'Range loop
- Repair_Shop := Commuters(Rotation)'Access;
- Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
- end loop;
- end Construction;
-
-end Perform_Tests;
-
-end C3A0013_4;
-
-with C3A0013_4;
-with Report;
-procedure C3A0013 is
-begin
-
- Report.Test ("C3A0013", "Check general access types. Check aliased "
- & "nature of formal tagged type parameters. "
- & "Check aliased nature of the current "
- & "instance of a limited type. Check the "
- & "constraining of actual subtypes for "
- & "discriminated objects" );
-
- C3A0013_4.Perform_Tests;
-
- Report.Result;
-end C3A0013;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
deleted file mode 100644
index c83ab4f..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
+++ /dev/null
@@ -1,453 +0,0 @@
--- C3A0014.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 view defined by an object declaration is aliased,
--- and the type of the object has discriminants, then the object is
--- constrained by its initial value even if its nominal subtype is
--- unconstrained.
---
--- Check that the attribute A'Constrained returns True if A is a formal
--- out or in out parameter, or dereference thereof, and A denotes an
--- aliased view of an object.
---
--- TEST DESCRIPTION:
--- These rules apply to objects of a record type with defaulted
--- discriminants, which may be unconstrained variables. If such a
--- variable is declared to be aliased, then it is constrained by its
--- initial value, and the value of the discriminant cannot be changed
--- for the life of the variable.
---
--- The rules do not apply to aliased component types because if such
--- types are discriminated they must be constrained.
---
--- A'Constrained returns True if A denotes a constant, value, or
--- constrained variable. Since aliased objects are constrained, it must
--- return True if the actual parameter corresponding to a formal
--- parameter A is an aliased object. The objective only mentions formal
--- parameters of mode out and in out, since parameters of mode in are
--- by definition constant, and would result in True anyway.
---
--- This test declares aliased objects of a nominally unconstrained
--- record subtype, both with and without initialization expressions.
--- It also declares access values which point to such objects. It then
--- checks that Constraint_Error is raised if an attempt is made to
--- change the discriminant value of an aliased object, either directly
--- or via a dereference of an access value. For aliased objects, this
--- check is also performed for subprogram parameters of mode out.
---
--- The test also passes aliased objects and access values which point
--- to such objects as actuals to subprograms and verifies, for parameter
--- modes out and in out, that P'Constrained returns true if P is the
--- corresponding formal parameter or a dereference thereof.
---
--- Additionally, the test declares a generic package which declares a
--- an aliased object of a formal derived unconstrained type, which is
--- is initialized with the value of a formal object of that type.
--- procedure declared within the generic assigns a value to the object
--- which has the same discriminant value as the formal derived type's
--- ancestor type. The generic is instantiated with various actuals
--- for the formal object, and the procedure is called. The test verifies
--- that Constraint_Error is raised if the discriminant values of the
--- actual corresponding to the formal object and the value assigned
--- by the procedure are not equal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors.
---
---!
-
-package C3A0014_0 is
-
- subtype Reasonable is Integer range 1..10;
- -- Unconstrained (sub)type.
- type UC (D: Reasonable := 2) is record -- Discriminant default.
- S: String (1 .. D) := "Hi"; -- Default value.
- end record;
-
- type AUC is access all UC;
-
- -- Nominal subtype is unconstrained for the following:
-
- Obj0 : UC; -- An unconstrained object.
-
- Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization,
- -- an unconstrained object.
-
- Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization,
- -- a constrained object.
-
- Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view),
- -- a constrained object.
- Obj4 : aliased UC; -- Aliased without initialization, Obj4
- -- constrained here to initial value
- -- taken from default for type.
-
- Ptr1 : AUC := new UC'(Obj1);
- Ptr2 : AUC := new UC;
- Ptr3 : AUC := Obj3'Access;
- Ptr4 : AUC := Obj4'Access;
-
-
- procedure NP_Proc (A: out UC);
- procedure NP_Cons (A: in out UC; B: out Boolean);
- procedure P_Cons (A: out AUC; B: out Boolean);
-
-
- generic
- type FT is new UC;
- FObj : in out FT;
- package Gen is
- F : aliased FT := FObj; -- Constrained if FT has discriminants.
- procedure Proc;
- end Gen;
-
-
- procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
-
-
-end C3A0014_0;
-
-
- --=======================================================================--
-
-with Report;
-
-package body C3A0014_0 is
-
- procedure NP_Proc (A: out UC) is
- begin
- A := (3, "Bye");
- end NP_Proc;
-
- procedure NP_Cons (A: in out UC; B: out Boolean) is
- begin
- B := A'Constrained;
- end NP_Cons;
-
- procedure P_Cons (A: out AUC; B: out Boolean) is
- begin
- B := A.all'Constrained;
- end P_Cons;
-
-
- package body Gen is
-
- procedure Proc is
- begin
- F := (2, "Fi");
- end Proc;
-
- end Gen;
-
-
- procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
- Default : UC := (1, "!"); -- Unique value.
- begin
- if P = Default then -- Both If branches can't do the same thing.
- Report.Failed (Msg & ": Constraint_Error not raised");
- else -- Subtests should always select this path.
- Report.Failed ("Constraint_Error not raised " & Msg);
- end if;
- end Avoid_Optimization_and_Fail;
-
-
-end C3A0014_0;
-
-
- --=======================================================================--
-
-
-with C3A0014_0; use C3A0014_0;
-with Report;
-
-procedure C3A0014 is
-begin
-
- Report.Test("C3A0014", "Check that if the view defined by an object " &
- "declaration is aliased, and the type of the " &
- "object has discriminants, then the object is " &
- "constrained by its initial value even if its " &
- "nominal subtype is unconstrained. Check that " &
- "the attribute A'Constrained returns True if A " &
- "is a formal out or in out parameter, or " &
- "dereference thereof, and A denotes an aliased " &
- "view of an object");
-
- Non_Pointer_Block:
- begin
-
- begin
- Obj0 := (3, "Bye"); -- OK: Obj0 not constrained.
- if Obj0 /= (3, "Bye") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 1");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 1");
- end;
-
-
- begin
- Obj1 := (3, "Bye"); -- OK: Obj1 not constrained.
- if Obj1 /= (3, "Bye") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 2");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 2");
- end;
-
-
- begin
- Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2).
- Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
- exception
- when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
- end Non_Pointer_Block;
-
-
- Pointer_Block:
- begin
-
- begin
- Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5).
- Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2).
- Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5).
- Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2).
- Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
- exception
- when others => Report.Failed("Unexpected exception: Pointer_Block");
- end Pointer_Block;
-
-
- Subprogram_Block:
- declare
- Is_Constrained : Boolean;
- begin
-
- begin
- NP_Proc (Obj0); -- OK: Obj0 not constrained, can
- if Obj0 /= (3, "Bye") then -- change discriminant value.
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 10");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 10");
- end;
-
-
- begin
- NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2).
- Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
-
- begin
- Is_Constrained := True;
- NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1
- if Is_Constrained then -- is not constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 14");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 14");
- end;
-
-
- begin
- Is_Constrained := False;
- NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is
- if not Is_Constrained then -- constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 15");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 15");
- end;
-
-
-
-
- begin
- Is_Constrained := False;
- P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all
- if not Is_Constrained then -- is constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 16");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 16");
- end;
-
-
- begin
- Is_Constrained := False;
- P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all
- if not Is_Constrained then -- is constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 17");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 17");
- end;
-
-
- exception
- when others => Report.Failed("Exception raised in Subprogram_Block");
- end Subprogram_Block;
-
-
- Generic_Block:
- declare
-
- type NUC is new UC;
-
- Obj : NUC;
-
-
- package Instance_A is new Gen (NUC, Obj);
- package Instance_B is new Gen (UC, Obj2);
- package Instance_C is new Gen (UC, Obj3);
- package Instance_D is new Gen (UC, Obj4);
-
- begin
-
- begin
- Instance_A.Proc; -- OK: Obj.D = 2.
- if Instance_A.F /= (2, "Fi") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 18");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 18");
- end;
-
-
- begin
- Instance_B.Proc; -- C_E: Obj2.D = 5.
- Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Instance_C.Proc; -- C_E: Obj3.D = 5.
- Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Instance_D.Proc; -- OK: Obj4.D = 2.
- if Instance_D.F /= (2, "Fi") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 21");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 21");
- end;
-
- exception
- when others => Report.Failed("Exception raised in Generic_Block");
- end Generic_Block;
-
-
- Report.Result;
-
-end C3A0014;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a b/gcc/testsuite/ada/acats/tests/c3/c3a0015.a
deleted file mode 100644
index 856c910..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- C3A0015.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 derived access type has the same storage pool as its
--- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)).
---
--- CHANGE HISTORY:
--- 24 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-with System.Storage_Elements;
-use System.Storage_Elements;
-with System.Storage_Pools;
-use System.Storage_Pools;
-package C3A0015_0 is
-
- type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with
- record
- First_Free : Storage_Count := 1;
- Contents : Storage_Array (1 .. Storage_Size);
- end record;
-
- procedure Allocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count);
-
- procedure Deallocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count);
-
- function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count;
-
-end C3A0015_0;
-
-package body C3A0015_0 is
-
- use System;
-
- procedure Allocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count) is
- Unaligned_Address : constant System.Address :=
- Pool.Contents (Pool.First_Free)'Address;
- Unalignment : Storage_Count;
- begin
- Unalignment := Unaligned_Address mod Alignment;
- if Unalignment = 0 then
- Storage_Address := Unaligned_Address;
- Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements;
- else
- Storage_Address :=
- Pool.Contents (Pool.First_Free + Alignment - Unalignment)'
- Address;
- Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements +
- Alignment - Unalignment;
- end if;
- end Allocate;
-
- procedure Deallocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count) is
- begin
- if Storage_Address + Size_In_Storage_Elements =
- Pool.Contents (Pool.First_Free)'Address then
- -- Only deallocate if the block is at the end.
- Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements;
- end if;
- end Deallocate;
-
- function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is
- begin
- return Pool.Storage_Size;
- end Storage_Size;
-
-end C3A0015_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Unchecked_Deallocation;
-with Report;
-use Report;
-with System.Storage_Elements;
-use System.Storage_Elements;
-with C3A0015_0;
-procedure C3A0015 is
-
- type Standard_Pool is access Float;
- type Derived_Standard_Pool is new Standard_Pool;
- type Derived_Derived_Standard_Pool is new Derived_Standard_Pool;
-
- type User_Defined_Pool is access Integer;
- type Derived_User_Defined_Pool is new User_Defined_Pool;
- type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool;
-
- My_Pool : C3A0015_0.Pool (1024);
- for User_Defined_Pool'Storage_Pool use My_Pool;
-
- generic
- type Designated is private;
- Value : Designated;
- type Acc is access Designated;
- type Derived_Acc is new Acc;
- procedure Check (Subtest : String; User_Defined_Pool : Boolean);
-
- procedure Check (Subtest : String; User_Defined_Pool : Boolean) is
-
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Object => Designated,
- Name => Acc);
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Object => Designated,
- Name => Derived_Acc);
-
- First_Free : Storage_Count;
- X : Acc;
- Y : Derived_Acc;
- begin
- if User_Defined_Pool then
- First_Free := My_Pool.First_Free;
- end if;
- X := new Designated'(Value);
- if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
- Failed (Subtest &
- " - Allocation didn't consume storage in the pool - 1");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- Y := Derived_Acc (X);
- if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
- Failed (Subtest &
- " - Conversion did consume storage in the pool - 1");
- end if;
- if Y.all /= Value then
- Failed (Subtest &
- " - Incorrect allocation/conversion of access values - 1");
- end if;
-
- Deallocate (Y);
- if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
- Failed (Subtest &
- " - Deallocation didn't release storage from the pool - 1");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- Y := new Designated'(Value);
- if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
- Failed (Subtest &
- " - Allocation didn't consume storage in the pool - 2");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- X := Acc (Y);
- if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
- Failed (Subtest &
- " - Conversion did consume storage in the pool - 2");
- end if;
- if X.all /= Value then
- Failed (Subtest &
- " - Incorrect allocation/conversion of access values - 2");
- end if;
-
- Deallocate (X);
- if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
- Failed (Subtest &
- " - Deallocation didn't release storage from the pool - 2");
- end if;
- exception
- when E: others =>
- Failed (Subtest & " - Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E));
- end Check;
-
-
-begin
- Test ("C3A0015", "Check that a dervied access type has the same " &
- "storage pool as its parent");
-
- Comment ("Access types using the standard storage pool");
-
- Std:
- declare
- procedure Check1 is
- new Check (Designated => Float,
- Value => 3.0,
- Acc => Standard_Pool,
- Derived_Acc => Derived_Standard_Pool);
- procedure Check2 is
- new Check (Designated => Float,
- Value => 4.0,
- Acc => Standard_Pool,
- Derived_Acc => Derived_Derived_Standard_Pool);
- procedure Check3 is
- new Check (Designated => Float,
- Value => 5.0,
- Acc => Derived_Standard_Pool,
- Derived_Acc => Derived_Derived_Standard_Pool);
- begin
- Check1 ("Standard_Pool/Derived_Standard_Pool",
- User_Defined_Pool => False);
- Check2 ("Standard_Pool/Derived_Derived_Standard_Pool",
- User_Defined_Pool => False);
- Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool",
- User_Defined_Pool => False);
- end Std;
-
- Comment ("Access types using a user-defined storage pool");
-
- User:
- declare
- procedure Check1 is
- new Check (Designated => Integer,
- Value => 17,
- Acc => User_Defined_Pool,
- Derived_Acc => Derived_User_Defined_Pool);
- procedure Check2 is
- new Check (Designated => Integer,
- Value => 18,
- Acc => User_Defined_Pool,
- Derived_Acc => Derived_Derived_User_Defined_Pool);
- procedure Check3 is
- new Check (Designated => Integer,
- Value => 19,
- Acc => Derived_User_Defined_Pool,
- Derived_Acc => Derived_Derived_User_Defined_Pool);
- begin
- Check1 ("User_Defined_Pool/Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- Check3
- ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- end User;
-
- Result;
-end C3A0015;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a b/gcc/testsuite/ada/acats/tests/c3/c3a1001.a
deleted file mode 100644
index 9b05b5d..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a
+++ /dev/null
@@ -1,315 +0,0 @@
--- C3A1001.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 full type completing a type with no discriminant part
--- or an unknown discriminant part may have explicitly declared or
--- inherited discriminants.
--- Check for cases where the types are records and protected types.
---
--- TEST DESCRIPTION:
--- Declare two groups of incomplete types: one group with no discriminant
--- part and one group with unknown discriminant part. Both groups of
--- incomplete types are completed with both explicit and inherited
--- discriminants. Discriminants for record and protected types are
--- declared with default and non default values.
--- In the main program, verify that objects of both groups of incomplete
--- types can be created by default values or by assignments.
---
---
--- CHANGE HISTORY:
--- 11 Oct 95 SAIC Initial prerelease version.
--- 11 Nov 96 SAIC Revised for version 2.1.
---
---!
-
-package C3A1001_0 is
-
- type Incomplete1 (<>); -- unknown discriminant
-
- type Incomplete2; -- no discriminant
-
- type Incomplete3 (<>); -- unknown discriminant
-
- type Incomplete4; -- no discriminant
-
- type Incomplete5 (<>); -- unknown discriminant
-
- type Incomplete6; -- no discriminant
-
- type Incomplete8; -- no discriminant
-
- subtype Small_Int is Integer range 1 .. 10;
-
- type Enu_Type is (M, F);
-
- type Incomplete1 (Disc : Enu_Type) is -- unknown discriminant/
- record -- explicit discriminant
- case Disc is
- when M => MInteger : Small_Int := 3;
- when F => FInteger : Small_Int := 8;
- end case;
- end record;
-
- type Incomplete2 (Disc : Small_Int := 8) is -- no discriminant/
- record -- explicit discriminant
- ID : String (1 .. Disc) := "Plymouth";
- end record;
-
- type Incomplete3 is new Incomplete2; -- unknown discriminant/
- -- inherited discriminant
-
- type Incomplete4 is new Incomplete2; -- no discriminant/
- -- inherited discriminant
-
- protected type Incomplete5 -- unknown discriminant/
- (Disc : Enu_Type) is -- explicit discriminant
- function Get_Priv_Val return Enu_Type;
- private
- Enu_Obj : Enu_Type := Disc;
- end Incomplete5;
-
- protected type Incomplete6 -- no discriminant/
- (Disc : Small_Int := 1) is -- explicit discriminant
- function Get_Priv_Val return Small_Int; -- with default
- private
- Num : Small_Int := Disc;
- end Incomplete6;
-
- type Incomplete8 (Disc : Small_Int) is -- no discriminant/
- record -- explicit discriminant
- Str : String (1 .. Disc); -- no default
- end record;
-
- type Incomplete9 is new Incomplete8;
-
- function Return_String (S : String) return String;
-
-end C3A1001_0;
-
- --==================================================================--
-
-with Report;
-
-package body C3A1001_0 is
-
- protected body Incomplete5 is
-
- function Get_Priv_Val return Enu_Type is
- begin
- return Enu_Obj;
- end Get_Priv_Val;
-
- end Incomplete5;
-
- ----------------------------------------------------------------------
- protected body Incomplete6 is
-
- function Get_Priv_Val return Small_Int is
- begin
- return Num;
- end Get_Priv_Val;
-
- end Incomplete6;
-
- ----------------------------------------------------------------------
- function Return_String (S : String) return String is
- begin
- if Report.Ident_Bool(True) = True then
- return S;
- end if;
-
- return S;
- end Return_String;
-
-end C3A1001_0;
-
- --==================================================================--
-
-with Report;
-
-with C3A1001_0;
-use C3A1001_0;
-
-procedure C3A1001 is
-
- -- Discriminant value comes from default.
-
- Incomplete2_Obj_1 : Incomplete2;
-
- Incomplete4_Obj_1 : Incomplete4;
-
- Incomplete6_Obj_1 : Incomplete6;
-
- -- Discriminant value comes from explicit constraint.
-
- Incomplete1_Obj_1 : Incomplete1 (F);
-
- Incomplete5_Obj_1 : Incomplete5 (M);
-
- Incomplete6_Obj_2 : Incomplete6 (2);
-
- -- Discriminant value comes from assignment.
-
- Incomplete3_Obj_1 : Incomplete3 := (Disc => 6, ID => "Sentra");
-
- Incomplete1_Obj_2 : Incomplete1 := (Disc => M, MInteger => 9);
-
- Incomplete2_Obj_2 : Incomplete2 := (Disc => 5, ID => "Buick");
-
-begin
-
- Report.Test ("C3A1001", "Check that the full type completing a type " &
- "with no discriminant part or an unknown discriminant " &
- "part may have explicitly declared or inherited " &
- "discriminants. Check for cases where the types are " &
- "records and protected types");
-
- -- Check the initial values.
-
- if (Incomplete2_Obj_1.Disc /= 8) or
- (Incomplete2_Obj_1.ID /= "Plymouth") then
- Report.Failed ("Wrong initial values for Incomplete2_Obj_1");
- end if;
-
- if (Incomplete4_Obj_1.Disc /= 8) or
- (Incomplete4_Obj_1.ID /= "Plymouth") then
- Report.Failed ("Wrong initial values for Incomplete4_Obj_1");
- end if;
-
- if (Incomplete6_Obj_1.Disc /= 1) or
- (Incomplete6_Obj_1.Get_Priv_Val /= 1) then
- Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
- end if;
-
- -- Check the explicit values.
-
- if (Incomplete1_Obj_1.Disc /= F) or
- (Incomplete1_Obj_1.FInteger /= 8) then
- Report.Failed ("Wrong values for Incomplete1_Obj_1");
- end if;
-
- if (Incomplete5_Obj_1.Disc /= M) or
- (Incomplete5_Obj_1.Get_Priv_Val /= M) then
- Report.Failed ("Wrong value for Incomplete5_Obj_1");
- end if;
-
- if (Incomplete6_Obj_2.Disc /= 2) or
- (Incomplete6_Obj_2.Get_Priv_Val /= 2) then
- Report.Failed ("Wrong value for Incomplete6_Obj_2");
- end if;
-
- -- Check the assigned values.
-
- if (Incomplete3_Obj_1.Disc /= 6) or
- (Incomplete3_Obj_1.ID /= "Sentra") then
- Report.Failed ("Wrong values for Incomplete3_Obj_1");
- end if;
-
- if (Incomplete1_Obj_2.Disc /= M) or
- (Incomplete1_Obj_2.MInteger /= 9) then
- Report.Failed ("Wrong values for Incomplete1_Obj_2");
- end if;
-
- if (Incomplete2_Obj_2.Disc /= 5) or
- (Incomplete2_Obj_2.ID /= "Buick") then
- Report.Failed ("Wrong values for Incomplete2_Obj_2");
- end if;
-
- -- Make sure that assignments work without problems.
-
- Incomplete1_Obj_1.FInteger := 1;
-
- -- Avoid optimization (dead variable removal of FInteger):
-
- if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1)
- then
- Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger");
- end if;
-
- Incomplete2_Obj_1.ID := Return_String ("12345678");
-
- -- Avoid optimization (dead variable removal of ID)
-
- if Incomplete2_Obj_1.ID /= Return_String ("12345678")
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.ID");
- end if;
-
- Incomplete4_Obj_1.ID := Return_String ("87654321");
-
- -- Avoid optimization (dead variable removal of ID)
-
- if Incomplete4_Obj_1.ID /= Return_String ("87654321")
- then
- Report.Failed ("Wrong values for Incomplete4_Obj_1.ID");
- end if;
-
-
- Test1:
- declare
-
- Incomplete8_Obj_1 : Incomplete8 (10);
-
- begin
- Incomplete8_Obj_1.Str := "Merry Xmas";
-
- -- Avoid optimization (dead variable removal of Str):
-
- if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas"
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1");
-
- end Test1;
-
- Test2:
- declare
-
- Incomplete8_Obj_2 : Incomplete8 (5);
-
- begin
- Incomplete8_Obj_2.Str := "Happy";
-
- -- Avoid optimization (dead variable removal of Str):
-
- if Return_String (Incomplete8_Obj_2.Str) /= "Happy"
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2");
-
- end Test2;
-
- Report.Result;
-
-end C3A1001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a b/gcc/testsuite/ada/acats/tests/c3/c3a1002.a
deleted file mode 100644
index 27d1f84..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a
+++ /dev/null
@@ -1,251 +0,0 @@
--- C3A1002.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 full type completing a type with no discriminant part
--- or an unknown discriminant part may have explicitly declared or
--- inherited discriminants.
--- Check for cases where the types are tagged records and task types.
---
--- TEST DESCRIPTION:
--- Declare two groups of incomplete types: one group with no discriminant
--- part and one group with unknown discriminant part. Both groups of
--- incomplete types are completed with both explicit and inherited
--- discriminants. Discriminants for task types are declared with both
--- default and non default values. Discriminants for tagged types are
--- only declared without default values.
--- In the main program, verify that objects of both groups of incomplete
--- types can be created by default values or by assignments.
---
---
--- CHANGE HISTORY:
--- 23 Oct 95 SAIC Initial prerelease version.
--- 19 Oct 96 SAIC ACVC 2.1: modified test description. Initialized
--- Int_Val.
---
---!
-
-package C3A1002_0 is
-
- subtype Small_Int is Integer range 1 .. 15;
-
- type Enu_Type is (M, F);
-
- type Tag_Type is tagged
- record
- I : Small_Int := 1;
- end record;
-
- type NTag_Type (D : Small_Int) is new Tag_Type with
- record
- S : String (1 .. D) := "Aloha";
- end record;
-
- type Incomplete1; -- no discriminant
-
- type Incomplete2 (<>); -- unknown discriminant
-
- type Incomplete3; -- no discriminant
-
- type Incomplete4 (<>); -- unknown discriminant
-
- type Incomplete5; -- no discriminant
-
- type Incomplete6 (<>); -- unknown discriminant
-
- type Incomplete1 (D1 : Enu_Type) is tagged -- no discriminant/
- record -- explicit discriminant
- case D1 is
- when M => MInteger : Small_Int := 9;
- when F => FInteger : Small_Int := 8;
- end case;
- end record;
-
- type Incomplete2 (D2 : Small_Int) is new -- unknown discriminant/
- Incomplete1 (D1 => F) with record -- explicit discriminant
- ID : String (1 .. D2) := "ACVC95";
- end record;
-
- type Incomplete3 is new -- no discriminant/
- NTag_Type with record -- inherited discriminant
- E : Enu_Type := M;
- end record;
-
- type Incomplete4 is new -- unknown discriminant/
- NTag_Type (D => 3) with record -- inherited discriminant
- E : Enu_Type := F;
- end record;
-
- task type Incomplete5 (D5 : Enu_Type) is -- no discriminant/
- entry Read_Disc (P : out Enu_Type); -- explicit discriminant
- end Incomplete5;
-
- task type Incomplete6
- (D6 : Small_Int := 4) is -- unknown discriminant/
- entry Read_Int (P : out Small_Int); -- explicit discriminant
- end Incomplete6;
-
-end C3A1002_0;
-
- --==================================================================--
-
-package body C3A1002_0 is
-
- task body Incomplete5 is
- begin
- select
- accept Read_Disc (P : out Enu_Type) do
- P := D5;
- end Read_Disc;
- or
- terminate;
- end select;
-
- end Incomplete5;
-
- ----------------------------------------------------------------------
- task body Incomplete6 is
- begin
- select
- accept Read_Int (P : out Small_Int) do
- P := D6;
- end Read_Int;
- or
- terminate;
- end select;
-
- end Incomplete6;
-
-end C3A1002_0;
-
- --==================================================================--
-
-with Report;
-
-with C3A1002_0;
-use C3A1002_0;
-
-procedure C3A1002 is
-
- Enum_Val : Enu_Type := M;
-
- Int_Val : Small_Int := 15;
-
- -- Discriminant value comes from default.
-
- Incomplete6_Obj_1 : Incomplete6;
-
- -- Discriminant value comes from explicit constraint.
-
- Incomplete1_Obj_1 : Incomplete1 (M);
-
- Incomplete2_Obj_1 : Incomplete2 (6);
-
- Incomplete5_Obj_1 : Incomplete5 (F);
-
- Incomplete6_Obj_2 : Incomplete6 (7);
-
- -- Discriminant value comes from assignment.
-
- Incomplete1_Obj_2 : Incomplete1
- := (F, 12);
-
- Incomplete3_Obj_1 : Incomplete3
- := (D => 2, S => "Hi", I => 10, E => F);
-
- Incomplete4_Obj_1 : Incomplete4
- := (E => M, D => 3, S => "Bye", I => 14);
-
-begin
-
- Report.Test ("C3A1002", "Check that the full type completing a type " &
- "with no discriminant part or an unknown discriminant " &
- "part may have explicitly declared or inherited " &
- "discriminants. Check for cases where the types are " &
- "tagged records and task types");
-
- -- Check the initial values.
-
- if (Incomplete6_Obj_1.D6 /= 4) then
- Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
- end if;
-
- -- Check the explicit values.
-
- if (Incomplete1_Obj_1.D1 /= M) or
- (Incomplete1_Obj_1.MInteger /= 9) then
- Report.Failed ("Wrong values for Incomplete1_Obj_1");
- end if;
-
- if (Incomplete2_Obj_1.D2 /= 6) or
- (Incomplete2_Obj_1.FInteger /= 8) or
- (Incomplete2_Obj_1.ID /= "ACVC95") then
- Report.Failed ("Wrong values for Incomplete2_Obj_1");
- end if;
-
- if (Incomplete5_Obj_1.D5 /= F) then
- Report.Failed ("Wrong value for Incomplete5_Obj_1");
- end if;
-
- Incomplete5_Obj_1.Read_Disc (Enum_Val);
-
- if (Enum_Val /= F) then
- Report.Failed ("Wrong value for Enum_Val");
- end if;
-
- if (Incomplete6_Obj_2.D6 /= 7) then
- Report.Failed ("Wrong value for Incomplete6_Obj_2");
- end if;
-
- Incomplete6_Obj_1.Read_Int (Int_Val);
-
- if (Int_Val /= 4) then
- Report.Failed ("Wrong value for Int_Val");
- end if;
-
- -- Check the assigned values.
-
- if (Incomplete1_Obj_2.D1 /= F) or
- (Incomplete1_Obj_2.FInteger /= 12) then
- Report.Failed ("Wrong values for Incomplete1_Obj_2");
- end if;
-
- if (Incomplete3_Obj_1.D /= 2 ) or
- (Incomplete3_Obj_1.I /= 10) or
- (Incomplete3_Obj_1.E /= F ) or
- (Incomplete3_Obj_1.S /= "Hi") then
- Report.Failed ("Wrong values for Incomplete3_Obj_1");
- end if;
-
- if (Incomplete4_Obj_1.E /= M ) or
- (Incomplete4_Obj_1.D /= 3) or
- (Incomplete4_Obj_1.S /= "Bye") or
- (Incomplete4_Obj_1.I /= 14) then
- Report.Failed ("Wrong values for Incomplete4_Obj_1");
- end if;
-
- Report.Result;
-
-end C3A1002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a b/gcc/testsuite/ada/acats/tests/c3/c3a2001.a
deleted file mode 100644
index c3c7f44..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a
+++ /dev/null
@@ -1,460 +0,0 @@
--- C3A2001.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 access type may be defined to designate the
--- class-wide type of an abstract type. Check that the access type
--- may then be used subsequently with types derived from the abstract
--- type. Check that dispatching operations dispatch correctly, when
--- called using values designated by objects of the access type.
---
--- TEST DESCRIPTION:
--- This test declares an abstract type Breaker in a package, and
--- then derives from it. The type Basic_Breaker defines the least
--- possible in order to not be abstract. The type Ground_Fault is
--- defined to inherit as much as possible, whereas type Special_Breaker
--- overrides everything it can. The type Special_Breaker also includes
--- an embedded Basic_Breaker object. The main program then utilizes
--- each of the three types of breaker, and to ascertain that the
--- overloading and tagging resolution are correct, each "Create"
--- procedure is called with a unique value. The diagram below
--- illustrates the relationships.
---
--- Abstract type: Breaker(1)
--- |
--- Basic_Breaker(2)
--- / \
--- Ground_Fault(3) Special_Breaker(4)
---
--- Test structure is a polymorphic linked list, modeling a circuit
--- as a list of components. The type component is the access type
--- defined to designate Breaker'Class values. The test then creates
--- some values, and traverses the list to determine correct operation.
--- This test is instrumented with a the trace facility found in
--- foundation F392C00 to simplify the verification process.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1
--- 23 APR 96 SAIC Added pragma Elaborate_All
--- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All
---
---!
-
-with Report;
-with TCTouch;
-package C3A2001_1 is
-
- type Breaker is abstract tagged private;
- type Status is ( Power_Off, Power_On, Tripped, Failed );
-
- procedure Flip ( The_Breaker : in out Breaker ) is abstract;
- procedure Trip ( The_Breaker : in out Breaker ) is abstract;
- procedure Reset( The_Breaker : in out Breaker ) is abstract;
- procedure Fail ( The_Breaker : in out Breaker );
-
- procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
-
- function Status_Of( The_Breaker : Breaker ) return Status;
-
-private
- type Breaker is abstract tagged record
- State : Status := Power_Off;
- end record;
-end C3A2001_1;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_1 is
- procedure Fail( The_Breaker : in out Breaker ) is
- begin
- TCTouch.Touch( 'a' ); --------------------------------------------- a
- The_Breaker.State := Failed;
- end Fail;
-
- procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
- begin
- The_Breaker.State := To_State;
- end Set;
-
- function Status_Of( The_Breaker : Breaker ) return Status is
- begin
- TCTouch.Touch( 'b' ); --------------------------------------------- b
- return The_Breaker.State;
- end Status_Of;
-end C3A2001_1;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1;
-package C3A2001_2 is
-
- type Basic_Breaker is new C3A2001_1.Breaker with private;
-
- type Voltages is ( V12, V110, V220, V440 );
- type Amps is ( A1, A5, A10, A25, A100 );
-
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker );
- procedure Trip ( The_Breaker : in out Basic_Breaker );
- procedure Reset( The_Breaker : in out Basic_Breaker );
-private
- type Basic_Breaker is new C3A2001_1.Breaker with record
- Voltage_Level : Voltages := V110;
- Amperage : Amps;
- end record;
-end C3A2001_2;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_2 is
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker is
- It : Basic_Breaker;
- begin
- TCTouch.Touch( 'c' ); --------------------------------------------- c
- It.Amperage := Amperage;
- It.Voltage_Level := Voltage;
- C3A2001_1.Set( It, C3A2001_1.Power_Off );
- return It;
- end Construct;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- case Status_Of( The_Breaker ) is
- when C3A2001_1.Power_Off =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
- when C3A2001_1.Power_On =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off );
- when C3A2001_1.Tripped | C3A2001_1.Failed => null;
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'e' ); --------------------------------------------- e
- C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped );
- end Trip;
-
- procedure Reset( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'f' ); --------------------------------------------- f
- case Status_Of( The_Breaker ) is
- when C3A2001_1.Power_Off | C3A2001_1.Tripped =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
- when C3A2001_1.Power_On | C3A2001_1.Failed => null;
- end case;
- end Reset;
-
-end C3A2001_2;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1,C3A2001_2;
-package C3A2001_3 is
- use type C3A2001_1.Status;
-
- type Ground_Fault is new C3A2001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Ground_Fault;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer );
-
-private
- type Ground_Fault is new C3A2001_2.Basic_Breaker with record
- Capacitance : Integer;
- end record;
-end C3A2001_3;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_3 is
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Ground_Fault is
- begin
- TCTouch.Touch( 'g' ); --------------------------------------------- g
- return ( C3A2001_2.Construct( Voltage, Amperage )
- with Capacitance => 0 );
- end Construct;
-
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer ) is
- begin
- TCTouch.Touch( 'h' ); --------------------------------------------- h
- The_Breaker.Capacitance := Capacitance;
- end Set_Trip;
-
-end C3A2001_3;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1, C3A2001_2;
-package C3A2001_4 is
-
- type Special_Breaker is new C3A2001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Special_Breaker;
-
- procedure Flip ( The_Breaker : in out Special_Breaker );
- procedure Trip ( The_Breaker : in out Special_Breaker );
- procedure Reset( The_Breaker : in out Special_Breaker );
- procedure Fail ( The_Breaker : in out Special_Breaker );
-
- function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status;
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
-
-private
- type Special_Breaker is new C3A2001_2.Basic_Breaker with record
- Backup : C3A2001_2.Basic_Breaker;
- end record;
-end C3A2001_4;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_4 is
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Special_Breaker is
- It: Special_Breaker;
- procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is
- begin
- It := C3A2001_2.Construct( Voltage, Amperage );
- end Set_Root;
- begin
- TCTouch.Touch( 'i' ); --------------------------------------------- i
- Set_Root( C3A2001_2.Basic_Breaker( It ) );
- Set_Root( It.Backup );
- return It;
- end Construct;
-
- function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status
- renames C3A2001_1.Status_Of;
-
- procedure Flip ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'j' ); --------------------------------------------- j
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_Off | C3A2001_1.Power_On =>
- C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C3A2001_2.Flip( The_Breaker.Backup );
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'k' ); --------------------------------------------- k
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_Off => null;
- when C3A2001_1.Power_On =>
- C3A2001_2.Reset( The_Breaker.Backup );
- C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C3A2001_2.Trip( The_Breaker.Backup );
- end case;
- end Trip;
-
- procedure Reset( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'l' ); --------------------------------------------- l
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Tripped =>
- C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker ));
- when C3A2001_1.Failed =>
- C3A2001_2.Reset( The_Breaker.Backup );
- when C3A2001_1.Power_On | C3A2001_1.Power_Off =>
- null;
- end case;
- end Reset;
-
- procedure Fail ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'm' ); --------------------------------------------- m
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Failed =>
- C3A2001_2.Fail( The_Breaker.Backup );
- when others =>
- C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker ));
- C3A2001_2.Reset( The_Breaker.Backup );
- end case;
- end Fail;
-
- function Status_Of( The_Breaker : Special_Breaker )
- return C3A2001_1.Status is
- begin
- TCTouch.Touch( 'n' ); --------------------------------------------- n
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_On => return C3A2001_1.Power_On;
- when C3A2001_1.Power_Off => return C3A2001_1.Power_Off;
- when others =>
- return C3A2001_2.Status_Of( The_Breaker.Backup );
- end case;
- end Status_Of;
-
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
- use C3A2001_2;
- use type C3A2001_1.Status;
- begin
- return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped
- or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed;
- end On_Backup;
-
-end C3A2001_4;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1;
-package C3A2001_5 is
-
- type Component is access C3A2001_1.Breaker'Class;
-
- type Circuit;
- type Connection is access Circuit;
-
- type Circuit is record
- The_Gadget : Component;
- Next : Connection;
- end record;
-
- procedure Flipper( The_Circuit : Connection );
- procedure Tripper( The_Circuit : Connection );
- procedure Restore( The_Circuit : Connection );
- procedure Failure( The_Circuit : Connection );
-
- Short : Connection := null;
-
-end C3A2001_5;
-
-----------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4;
-
-pragma Elaborate_All( Report, TCTouch,
- C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 );
-
-package body C3A2001_5 is
-
- function Neww( Breaker: in C3A2001_1.Breaker'Class )
- return Component is
- begin
- return new C3A2001_1.Breaker'Class'( Breaker );
- end Neww;
-
- procedure Add( Gadget : in Component;
- To_Circuit : in out Connection) is
- begin
- To_Circuit := new Circuit'(Gadget,To_Circuit);
- end Add;
-
- procedure Flipper( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Flip( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Flipper;
-
- procedure Tripper( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Trip( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Tripper;
-
- procedure Restore( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Reset( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Restore;
-
- procedure Failure( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Fail( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Failure;
-
-begin
- Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short );
- Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short );
- Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short );
-end C3A2001_5;
-
-----------------------------------------------------------------------------
-
-with Report;
-with TCTouch;
-with C3A2001_5;
-procedure C3A2001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C3A2001", "Check that an abstract type can be declared " &
- "and used. Check actual subprograms dispatch correctly" );
-
- -- This Validate call must be _after_ the call to Report.Test
- TCTouch.Validate( "cgcicc", "Adding" );
-
- C3A2001_5.Flipper( C3A2001_5.Short );
- TCTouch.Validate( "jbdbdbdb", "Flipping" );
-
- C3A2001_5.Tripper( C3A2001_5.Short );
- TCTouch.Validate( "kbfbeee", "Tripping" );
-
- C3A2001_5.Restore( C3A2001_5.Short );
- TCTouch.Validate( "lbfbfbfb", "Restoring" );
-
- C3A2001_5.Failure( C3A2001_5.Short );
- TCTouch.Validate( "mbafbaa", "Circuits Failing" );
-
- Report.Result;
-
-end C3A2001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a b/gcc/testsuite/ada/acats/tests/c3/c3a2002.a
deleted file mode 100644
index 63ea700..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- C3A2002.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, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for the case where X denotes a view that is a dereference of an
--- access parameter, or a rename thereof.
---
--- Check for cases where the actual corresponding to X is:
--- (a) An allocator.
--- (b) An expression of a named access type.
--- (c) Obj'Access.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- 'Access is attempted on a dereference of the access parameter, and
--- assigned to an access object whose type A is declared at some nesting
--- level. The test verifies that Program_Error is raised if the actual
--- corresponding to the access parameter is:
---
--- (1) an allocator, and the accessibility level of the execution
--- of the called subprogram is deeper than that of the access
--- type A.
---
--- (2) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (3) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the type A -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := X.all'Access; -- Check should never fail.
--- begin null; end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- P (Actual'Access);
--- end;
---
--- For the execution of P, the accessibility level of type A will
--- always be deeper than that of Actual, so there is no danger of a
--- dangling reference arising from the assignment to Acc. Thus,
--- X.all'Access is safe, even though the static nesting level of
--- Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A2002_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig; -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind);
- procedure Never_Fails (X: access Desig; R : out Result_Kind);
-
-end C3A2002_0;
-
-
- --==================================================================--
-
-package body C3A2002_0 is
-
- procedure A_Is_Level_0 (X : access Desig;
- R : out Result_Kind) is
- begin
- -- The accessibility level of the type of A0 is 0.
- A0 := X.all'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end A_Is_Level_0;
-
- -----------------------------------------------
- procedure Never_Fails (X: access Desig;
- R : out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- X.all'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of the
- -- type of AL will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AL := X.all'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Never_Fails;
-
-end C3A2002_0;
-
-
- --==================================================================--
-
-
-with C3A2002_0;
-with Report;
-
-procedure C3A2002 is
-
- X1 : aliased C3A2002_0.Desig; -- Level = 1.
-
- type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1.
- A1 : Acc_L1;
-
- Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access;
- Expr_L1 : Acc_L1 := X1'Access;
-
- Res : C3A2002_0.Result_Kind;
-
- use type C3A2002_0.Result_Kind;
-
- -----------------------------------------------
- procedure A_Is_Level_1 (X : access C3A2002_0.Desig;
- R : out C3A2002_0.Result_Kind) is
- -- Dereference of an access_to_object value is aliased.
- Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- The accessibility level of the type of A1 is 1.
- A1 := Ren'Access;
- R := C3A2002_0.OK;
- exception
- when Program_Error =>
- R := C3A2002_0.P_E;
- when others =>
- R := C3A2002_0.O_E;
- end A_Is_Level_1;
-
- -----------------------------------------------
- procedure Display_Results (Result : in C3A2002_0.Result_Kind;
- Expected: in C3A2002_0.Result_Kind;
- Message : in String) is
- begin
- if Result /= Expected then
- case Result is
- when C3A2002_0.OK => Report.Failed ("No exception raised: " &
- Message);
- when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " &
- Message);
- when C3A2002_0.O_E => Report.Failed ("Unexpected exception " &
- "raised: " & Message);
- end case;
- end if;
- end Display_Results;
-
-begin -- C3A2002
-
- Report.Test ("C3A2002", "Check that, for X'Access of general access " &
- "type A, Program_Error is raised if the accessibility " &
- "level of X is deeper than that of A: X is an access " &
- "parameter; corresponding actual is an allocator, " &
- "expression of a named access type, Obj'Access, or a " &
- "rename thereof");
-
-
- -- Actual is X'Access:
-
- C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type");
-
- C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type");
-
- C3A2002_0.A_Is_Level_0 (X1'Access, Res);
- Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type");
-
- A_Is_Level_1 (X1'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type");
-
-
- -- Actual is expression of a named access type:
-
- C3A2002_0.Never_Fails (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type");
-
- C3A2002_0.A_Is_Level_0 (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type");
-
- A_Is_Level_1 (Expr_L0, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type");
-
- A_Is_Level_1 (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type");
-
- -- Actual is allocator (level of execution = 2):
-
- C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " &
- "local access type");
-
- -- Since actual is an allocator, its accessibility level is that of
- -- the execution of the called subprogram, i.e., level 2.
-
- C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " &
- "level 0 access type");
-
- A_Is_Level_1 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " &
- "level 1 access type");
-
-
- Block_L2:
- declare
- X2 : aliased C3A2002_0.Desig; -- Level = 2.
- type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X1'Access;
- begin
-
- -- Actual is X'Access:
-
- C3A2002_0.Never_Fails (X2'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type");
-
- C3A2002_0.A_Is_Level_0 (X2'Access, Res);
- Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type");
-
-
- -- Actual is expression of a named access type:
-
- A_Is_Level_1 (Expr_L2, Res);
- Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type");
-
-
- -- Actual is allocator (level of execution = 3):
-
- C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " &
- "local access type");
-
- A_Is_Level_1 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " &
- "level 1 access type");
-
- end Block_L2;
-
- Report.Result;
-
-end C3A2002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a b/gcc/testsuite/ada/acats/tests/c3/c3a2003.a
deleted file mode 100644
index deb92f1..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- C3A2003.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, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for the case where X denotes a view that is a dereference of an
--- access parameter, or a rename thereof. Check for the case where X is
--- an access parameter and the corresponding actual is another access
--- parameter.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- 'Access is attempted on a dereference of an access parameter, and
--- assigned to an access object whose type A is declared at some nesting
--- level. The test verifies that Program_Error is raised if the actual
--- corresponding to the access parameter is another access parameter,
--- and the actual corresponding to this second access parameter is:
---
--- (1) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (2) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the type A -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := X.all'Access; -- Check should never fail.
--- begin null; end;
--- . . .
--- procedure Q (Y: access T) is
--- begin
--- P(Y);
--- end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- Q (Actual'Access);
--- end;
---
--- For the execution of Q (and hence P), the accessibility level of
--- type A will always be deeper than that of Actual, so there is no
--- danger of a dangling reference arising from the assignment to
--- Acc. Thus, X.all'Access is safe, even though the static nesting
--- level of Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Jul 98 EDS Avoid optimization.
--- 28 Jun 02 RLB Added pragma Elaborate_All (Report);.
---!
-
-with report; use report; pragma Elaborate_All (report);
-package C3A2003_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig := (Desig'Range => Ident_Int(3)); -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind);
-
-end C3A2003_0;
-
-
- --==================================================================--
-
-
-package body C3A2003_0 is
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
-
-
- -- This procedure utilizes 'Access on a dereference of an access
- -- parameter, and assigned to an access object whose type A is
- -- declared at some nesting level. Program_Error is raised if
- -- the accessibility level of the operand type is deeper than that
- -- of the target type.
-
- procedure Nested (X: access Desig; R: out Result_Kind) is
- -- Dereference of an access_to_object value is aliased.
- Ren : Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- The accessibility level of type A0 is 0.
- A0 := Ren'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Nested;
-
- begin -- Target_Is_Level_0_Nest
- Nested (Y, S);
- end Target_Is_Level_0_Nest;
-
- ------------------------------------------------------------------
-
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
-
- type Acc_Deeper is access all Desig;
- AD : Acc_Deeper;
-
- function Nested (X: access Desig) return Result_Kind is
- begin
- -- X.all'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of the
- -- type of AD will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AD := X.all'Access;
- if Ident_Int (AD(4)) /= 3 then --Avoid Optimization of AD
- FAILED ("Initial Values not correct.");
- end if;
- return OK;
- exception
- when Program_Error =>
- return P_E;
- when others =>
- return O_E;
- end Nested;
-
- begin -- Never_Fails_Nest
- S := Nested (Y);
- end Never_Fails_Nest;
-
- ------------------------------------------------------------------
-
- procedure Called_By_Never_Fails_Same
- (X: access Desig; R: out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
-
- -- Dereference of an access_to_object value is aliased.
- Ren : Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- Ren'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of
- -- type of AL will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AL := Ren'Access;
- if Ident_Int (AL(4)) /= 3 then --Avoid Optimization of AL
- FAILED ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Never_Fails_Same;
-
- ------------------------------------------------------------------
-
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
- begin
- Called_By_Never_Fails_Same (Y, S);
- end Never_Fails_Same;
-
-end C3A2003_0;
-
-
- --==================================================================--
-
-
-with C3A2003_0;
-use C3A2003_0;
-
-with Report; use report;
-
-procedure C3A2003 is
-
- type Acc_L1 is access all Desig; -- Level = 1.
- A1 : Acc_L1;
- X1 : aliased Desig := (Desig'Range => Ident_Int(3));
- Res : Result_Kind;
-
-
- procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
- begin
- -- The accessibility level of the type of A1 is 1.
- A1 := X.all'Access;
- if IDENT_INT (A1(4)) /= 3 then --Avoid optimization of A1
- FAILED ("Initial values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Target_L1;
-
- ------------------------------------------------------------------
-
- function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
- S : Result_Kind;
- begin
- Called_By_Target_L1 (Y, S);
- return S;
- end Target_Is_Level_1_Same;
-
- ------------------------------------------------------------------
-
- procedure Display_Results (Result : in Result_Kind;
- Expected: in Result_Kind;
- Msg : in String) is
- begin
- if Result /= Expected then
- case Result is
- when OK => Report.Failed ("No exception raised: " & Msg);
- when P_E => Report.Failed ("Program_Error raised: " & Msg);
- when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
- end case;
- end if;
- end Display_Results;
-
-begin -- C3A2003
-
- Report.Test ("C3A2003", "Check that, for X'Access of general access " &
- "type A, Program_Error is raised if the accessibility " &
- "level of X is deeper than that of A: X is an access " &
- "parameter; corresponding actual is another access " &
- "parameter");
-
-
- -- Accessibility level of actual is 0 (actual is X'Access):
-
- Never_Fails_Same (X0'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 0 actual");
-
- Never_Fails_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 0 actual");
-
- Target_Is_Level_0_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L0_Nest, level 0 actual");
-
- Res := Target_Is_Level_1_Same (X0'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 0 actual");
-
-
- -- Accessibility level of actual is 1 (actual is X'Access):
-
- Never_Fails_Same (X1'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 1 actual");
-
- Never_Fails_Nest (X1'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 1 actual");
-
- Target_Is_Level_0_Nest (X1'Access, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual");
-
- Res := Target_Is_Level_1_Same (X1'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 1 actual");
-
-
- Block_L2:
- declare
- X2 : aliased Desig := (Desig'Range => Ident_Int(3));
- type Acc_L2 is access all Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X2'Access;
- begin
-
- -- Accessibility level of actual is 2 (actual is expression of named
- -- access type):
-
- Never_Fails_Same (Expr_L2, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 2 actual");
-
- Never_Fails_Nest (Expr_L2, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 2 actual");
-
- Target_Is_Level_0_Nest (Expr_L2, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual");
-
- Res := Target_Is_Level_1_Same (Expr_L2);
- Display_Results (Res, P_E, "Target_L1_Same, level 2 actual");
-
- end Block_L2;
-
- Report.Result;
-
-end C3A2003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a
deleted file mode 100644
index 8271d48..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- C3A2A01.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, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for cases where X'Access occurs in an instance body, and A
--- is passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares three generic units, each of which has a formal
--- general access type:
---
--- (1) A generic package, in which X is declared in the specification,
--- and X'Access occurs within the declarative part of the body.
---
--- (2) A generic package, in which X is a formal in out object of a
--- tagged formal derived type, and X'Access occurs in the sequence
--- of statements of a nested subprogram.
---
--- (3) A generic procedure, in which X is a dereference of an access
--- parameter, and X'Access occurs in the sequence of statements.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised upon instantiation if the generic
--- package is instantiated at a deeper level than that of the general
--- access type passed as an actual. The exception is propagated to the
--- innermost enclosing master.
---
--- For (2), Program_Error is raised when the nested subprogram is
--- called if the object passed as an actual during instantiation of
--- the generic package has an accessibility level deeper than that of
--- the general access type passed as an actual. The exception is
--- handled within the nested subprogram. Also, check that
--- Program_Error is not raised if the level of the actual access type
--- is deeper than that of the actual object.
---
--- For (3), Program_Error is raised when the instance subprogram is
--- called if the object pointed to by the actual corresponding to
--- the access parameter has an accessibility level deeper than that of
--- the general access type passed as an actual during instantiation.
--- The exception is handled within the instance subprogram. Also,
--- check that Program_Error is not raised if the level of the actual
--- access type is deeper than that of the actual corresponding to the
--- access parameter.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F3A2A00.A
--- -> C3A2A01.A
---
---
--- CHANGE HISTORY:
--- 12 May 95 SAIC Initial prerelease version.
--- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
---
---!
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- type FAF is access all FD;
-package C3A2A01_0 is
- X : aliased FD;
-
- procedure Dummy; -- Needed to allow package body.
-end C3A2A01_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A01_0 is
- Ptr : FAF := X'Access;
- Index : Integer := F3A2A00.Array_Type'First;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A01_0 instance");
- end if;
-end C3A2A01_0;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Tagged_Type with private;
- type FAF is access all FD;
- FObj : in out FD;
-package C3A2A01_1 is
- procedure Handle (R: out F3A2A00.TC_Result_Kind);
-end C3A2A01_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A01_1 is
-
- procedure Handle (R: out F3A2A00.TC_Result_Kind) is
- Ptr : FAF;
- begin
- Ptr := FObj'Access;
- R := F3A2A00.OK;
-
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in Handle");
- end if;
- exception
- when Program_Error => R := F3A2A00.P_E;
- when others => R := F3A2A00.O_E;
- end Handle;
-
-end C3A2A01_1;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- type FAF is access all FD;
-procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind);
-
-
- --==================================================================--
-
-
-with Report;
-procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is
- Ptr : FAF;
- Index : Integer := F3A2A00.Array_Type'First;
-begin
- Ptr := P.all'Access;
- R := F3A2A00.OK;
-
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A01_2 instance");
- end if;
-exception
- when Program_Error => R := F3A2A00.P_E;
- when others => R := F3A2A00.O_E;
-end C3A2A01_2;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-with C3A2A01_0;
-with C3A2A01_1;
-with C3A2A01_2;
-
-with Report;
-procedure C3A2A01 is
-begin -- C3A2A01. -- [ Level = 1 ]
-
- Report.Test ("C3A2A01", "Run-time accessibility checks: instance " &
- "bodies. Type of X'Access is passed as actual to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- type AccArr_L3 is access all F3A2A00.Array_Type;
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of Pack.X is that of the instantiation
- -- (4). The accessibility level of the actual access type used to
- -- instantiate Pack is 3. Therefore, the X'Access in Pack
- -- propagates Program_Error when the instance body is elaborated:
-
- package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3);
- begin
- Result := F3A2A00.OK;
- end;
- exception
- when Program_Error => Result := F3A2A00.P_E; -- Expected result.
- when others => Result := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1");
-
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_1 should NOT result in any
- -- exceptions.
-
- type AccTag_L3 is access all F3A2A00.Tagged_Type;
-
- package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type,
- AccTag_L3,
- F3A2A00.X_L0);
- begin
- -- The accessibility level of the actual object used to instantiate
- -- Pack_OK is 0. The accessibility level of the actual access type
- -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in
- -- Pack_OK.Handle does not raise an exception when the subprogram is
- -- called. If an exception is (incorrectly) raised, however, it is
- -- handled within the subprogram:
-
- Pack_OK.Handle (Result);
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_1 should NOT result in any
- -- exceptions.
-
- X_L3: F3A2A00.Tagged_Type;
-
- package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type,
- F3A2A00.AccTag_L0,
- X_L3);
- begin
- -- The accessibility level of the actual object used to instantiate
- -- Pack_PE is 3. The accessibility level of the actual access type
- -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in
- -- Pack_OK.Handle raises Program_Error when the subprogram is
- -- called. The exception is handled within the subprogram:
-
- Pack_PE.Handle (Result);
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_2 should NOT result in any
- -- exceptions.
-
- X_L3: aliased F3A2A00.Array_Type;
- type AccArr_L3 is access all F3A2A00.Array_Type;
-
- procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3);
- begin
- -- The accessibility level of Proc.P.all is that of the corresponding
- -- actual during the call (in this case 3). The accessibility level of
- -- the access type used to instantiate Proc is also 3. Therefore, the
- -- P.all'Access in Proc does not raise an exception when the
- -- subprogram is called. If an exception is (incorrectly) raised,
- -- however, it is handled within the subprogram:
-
- Proc (X_L3'Access, Result1);
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #4: same levels");
-
- declare -- [ Level = 4 ]
- X_L4: aliased F3A2A00.Array_Type;
- begin
- -- Within this block, the accessibility level of the actual
- -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access
- -- in Proc raises Program_Error when the subprogram is called. The
- -- exception is handled within the subprogram:
-
- Proc (X_L4'Access, Result2);
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
- "SUBTEST #4: object at deeper level");
- end;
-
- end;
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST4;
-
-
- Report.Result;
-
-end C3A2A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
deleted file mode 100644
index 23b2c1c..0000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
+++ /dev/null
@@ -1,396 +0,0 @@
--- C3A2A02.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, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for cases where X'Access occurs in an instance body, and A
--- is a type either declared inside the instance, or declared outside
--- the instance but not passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares three generic packages:
---
--- (1) One in which X is of a formal tagged derived type and declared
--- in the body, A is a type declared outside the instance, and
--- X'Access occurs in the declarative part of a nested subprogram.
---
--- (2) One in which X is a formal object of a tagged type, A is a
--- type declared outside the instance, and X'Access occurs in the
--- declarative part of the body.
---
--- (3) One in which there are two X's and two A's. In the first pair,
--- X is a formal in object of a tagged type, A is declared in the
--- specification, and X'Access occurs in the declarative part of
--- the body. In the second pair, X is of a formal derived type,
--- X and A are declared in the specification, and X'Access occurs
--- in the sequence of statements of the body.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised when the nested subprogram is
--- called, if the generic package is instantiated at a deeper level
--- than that of A. The exception is propagated to the innermost
--- enclosing master. Also, check that Program_Error is not raised
--- if the instantiation is at the same level as that of A.
---
--- For (2), Program_Error is raised upon instantiation if the object
--- passed as an actual during instantiation has an accessibility level
--- deeper than that of A. The exception is propagated to the innermost
--- enclosing master. Also, check that Program_Error is not raised if
--- the level of the actual object is not deeper than that of A.
---
--- For (3), Program_Error is not raised, for actual objects at
--- various accessibility levels (since A will have at least the same
--- accessibility level as X in all cases, no exception should ever
--- be raised).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F3A2A00.A
--- -> C3A2A02.A
---
---
--- CHANGE HISTORY:
--- 12 May 95 SAIC Initial prerelease version.
--- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
--- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package
--- package C3A2A02_3, in order to avoid possible
--- instantiation error.
---!
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Tagged_Type with private;
-package C3A2A02_0 is
- procedure Proc;
-end C3A2A02_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_0 is
- X : aliased FD;
-
- procedure Proc is
- Ptr : F3A2A00.AccTagClass_L0 := X'Access;
- begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in Proc");
- end if;
- end Proc;
-end C3A2A02_0;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- FObj : in out F3A2A00.Tagged_Type;
-package C3A2A02_1 is
- procedure Dummy; -- Needed to allow package body.
-end C3A2A02_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_1 is
- Ptr : F3A2A00.AccTag_L0 := FObj'Access;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_1 instance");
- end if;
-end C3A2A02_1;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- FObj : in F3A2A00.Tagged_Type;
-package C3A2A02_2 is
- type GAF is access all FD;
- type GAO is access constant F3A2A00.Tagged_Type;
- XG : aliased FD;
- PtrF : GAF;
- Index : Integer := FD'First;
-
- procedure Dummy; -- Needed to allow package body.
-end C3A2A02_2;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_2 is
- PtrO : GAO := FObj'Access;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- PtrF := XG'Access;
-
- -- Avoid optimization (dead variable removal of PtrO and/or PtrF):
-
- if not Report.Equal (PtrO.C, PtrO.C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO");
- end if;
-
- if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF");
- end if;
-end C3A2A02_2;
-
-
- --==================================================================--
-
-
--- The instantiation of C3A2A02_0 should NOT result in any exceptions.
-
-with F3A2A00;
-with C3A2A02_0;
-pragma Elaborate (C3A2A02_0);
-package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type);
-
-
- --==================================================================--
-
-
-with F3A2A00;
-with C3A2A02_0;
-with C3A2A02_1;
-with C3A2A02_2;
-with C3A2A02_3;
-
-with Report;
-procedure C3A2A02 is
-begin -- C3A2A02. -- [ Level = 1 ]
-
- Report.Test ("C3A2A02", "Run-time accessibility checks: instance " &
- "bodies. Type of X'Access is local or global to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- package Pack_Same_Level renames C3A2A02_3;
- begin
- -- The accessibility level of Pack_Same_Level.X is that of the
- -- instance (0), not that of the renaming declaration. The level of
- -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is
- -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise
- -- an exception when the subprogram is called. The level of execution
- -- of the subprogram is irrelevant:
-
- Pack_Same_Level.Proc;
- Result1 := F3A2A00.OK; -- Expected result.
- exception
- when Program_Error => Result1 := F3A2A00.P_E;
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #1 (same level)");
-
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A02_0 should NOT result in any
- -- exceptions.
-
- package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type);
- begin
- -- The accessibility level of Pack_Deeper_Level.X is that of the
- -- instance (3). The level of the type of Pack_Deeper_Level.X'Access
- -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in
- -- Pack_Deeper_Level.Proc propagates Program_Error when the
- -- subprogram is called:
-
- Pack_Deeper_Level.Proc;
- Result2 := F3A2A00.OK;
- exception
- when Program_Error => Result2 := F3A2A00.P_E; -- Expected result.
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
- "SUBTEST #1: deeper level");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- X_L3 : F3A2A00.Tagged_Type;
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual object corresponding to
- -- FObj in Pack_PE is 3. The level of the type of FObj'Access
- -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE
- -- propagates Program_Error when the instance body is elaborated:
-
- package Pack_PE is new C3A2A02_1 (X_L3);
- begin
- Result1 := F3A2A00.OK;
- end;
- exception
- when Program_Error => Result1 := F3A2A00.P_E; -- Expected result.
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E,
- "SUBTEST #2: deeper level");
-
-
- begin -- [ Level = 3 ]
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual object corresponding to
- -- FObj in Pack_OK is 0. The level of the type of FObj'Access
- -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in
- -- Pack_OK does not raise an exception when the instance body is
- -- elaborated:
-
- package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0);
- begin
- Result2 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result2 := F3A2A00.P_E;
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
- "SUBTEST #2: same level");
-
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- X_L3 : F3A2A00.Tagged_Type;
- begin
- declare -- [ Level = 4 ]
- -- Since the accessibility level of the type of X'Access in
- -- both cases within Pack_OK1 is that of the instance, and since
- -- X is either passed as an actual (in which case its level will
- -- not be deeper than that of the instance) or is declared within
- -- the instance (in which case its level is the same as that of
- -- the instance), no exception should be raised when the instance
- -- body is elaborated:
-
- package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3);
- begin
- Result1 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result1 := F3A2A00.P_E;
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #3: 1st okay case");
-
-
- declare -- [ Level = 3 ]
- type My_Array is new F3A2A00.Array_Type;
- begin
- declare -- [ Level = 4 ]
- -- Since the accessibility level of the type of X'Access in
- -- both cases within Pack_OK2 is that of the instance, and since
- -- X is either passed as an actual (in which case its level will
- -- not be deeper than that of the instance) or is declared within
- -- the instance (in which case its level is the same as that of
- -- the instance), no exception should be raised when the instance
- -- body is elaborated:
-
- package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0);
- begin
- Result2 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result2 := F3A2A00.P_E;
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
- "SUBTEST #3: 2nd okay case");
-
-
- end SUBTEST3;
-
-
-
- Report.Result;
-
-end C3A2A02;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc/testsuite/ada/acats/tests/c4/c410001.a
deleted file mode 100644
index 2655553..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c410001.a
+++ /dev/null
@@ -1,303 +0,0 @@
--- C410001.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 evaluating an access to subprogram variable containing
--- the value null causes the exception Constraint_Error.
--- Check that the default value for objects of access to subprogram
--- types is null.
---
--- TEST DESCRIPTION:
--- This test defines a few simple access_to_subprogram types, and
--- objects of those types. It checks that the default values for
--- these objects is null, and that an attempt to make a subprogram
--- call via one of this objects containing a null value causes the
--- predefined exception Constraint_Error. The check is performed
---- both with the default null value, and with an explicitly assigned
--- null value, after the object has been used to successfully designate
--- and call a subprogram.
---
---
--- CHANGE HISTORY:
--- 05 APR 96 SAIC Initial version
--- 04 NOV 96 SAIC Revised for 2.1 release
--- 26 FEB 97 PWB.CTA Initialized variable before passing to function
---!
-
------------------------------------------------------------------ C410001_0
-
-package C410001_0 is
-
- -- used to "switch state" in the software
- Expect_Exception : Boolean;
-
- -- define a minimal mixture of access_to_subprogram types
-
- type Proc_Ref is access procedure;
-
- type Func_Ref is access function(I:Integer) return Integer;
-
- type Proc_Para_Ref is access procedure(P:Proc_Ref);
-
- type Func_Para_Ref is access function(F:Func_Ref) return Integer;
-
- type Prot_Proc_Ref is access protected procedure;
-
- type Prot_Func_Ref is access protected function return Boolean;
-
- -- define some subprograms for them to reference
-
- procedure Proc;
-
- function Func(I:Integer) return Integer;
-
- procedure Proc_Para( Param : Proc_Ref );
-
- function Func_Para( Param : Func_Ref ) return Integer;
-
- protected Prot_Obj is
- procedure Prot_Proc;
- function Prot_Func return Boolean;
- end Prot_Obj;
-
-end C410001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C410001_0 is
-
- -- Note that some failing cases will cause duplicate failure messages;
- -- rather than have the procedure/function bodies be null, the error
- -- checking code makes for a reasonable anti-optimization feature.
-
- procedure Proc is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Proc");
- end if;
- end Proc;
-
- function Func(I:Integer) return Integer is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Func");
- end if;
- return Report.Ident_Int(I);
- end Func;
-
- procedure Proc_Para( Param : Proc_Ref ) is
- begin
-
- Param.all; -- call by explicit dereference
-
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Proc_Para");
- end if;
-
- exception
- when Constraint_Error =>
- if not Expect_Exception then
- Report.Failed("Unexpected Constraint_Error: Proc_Para");
- end if; -- else null; expected the exception
- when others => Report.Failed("Unexpected exception: Proc_Para");
- end Proc_Para;
-
- function Func_Para( Param : Func_Ref ) return Integer is
- begin
-
- return Param(1); -- call by implicit dereference
-
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Func_Para");
- end if;
- return 1; -- really just to avoid warnings
-
- exception
- when Constraint_Error =>
- if not Expect_Exception then
- Report.Failed("Unexpected Constraint_Error: Func_Para");
- return 0;
- else
- return 1995; -- any value other than this is unexpected
- end if;
- when others => Report.Failed("Unexpected exception: Func_Para");
- return -42;
- end Func_Para;
-
- protected body Prot_Obj is
-
- procedure Prot_Proc is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Prot_Proc");
- end if;
- end Prot_Proc;
-
- function Prot_Func return Boolean is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Prot_Func");
- end if;
- return Report.Ident_Bool( True );
- end Prot_Func;
-
- end Prot_Obj;
-
-end C410001_0;
-
-------------------------------------------------------------------- C410001
-
-with Report;
-with TCTouch;
-with C410001_0;
-procedure C410001 is
-
- Proc_Ref_Var : C410001_0.Proc_Ref;
-
- Func_Ref_Var : C410001_0.Func_Ref;
-
- Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref;
-
- Func_Para_Ref_Var : C410001_0.Func_Para_Ref;
-
- type Enclosure is record
- Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref;
- Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref;
- end record;
-
- Enclosed : Enclosure;
-
- Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access;
-
- Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access;
-
- procedure Make_Calls( Expecting_Exceptions : Boolean ) is
- type Case_Numbers is range 1..6;
- Some_Integer : Integer := 0;
- begin
- for Cases in Case_Numbers loop
- Catch_Exception : begin
- case Cases is
- when 1 => Proc_Ref_Var.all;
- when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer );
- when 3 => Proc_Para_Ref_Var( Valid_Proc );
- when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func );
- when 5 => Enclosed.Prot_Proc_Ref_Var.all;
- when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all
- /= Expecting_Exceptions,
- "Case 6");
- end case;
- if Expecting_Exceptions then
- Report.Failed("Exception expected: Case"
- & Case_Numbers'Image(Cases) );
- end if;
- exception
- when Constraint_Error =>
- if not Expecting_Exceptions then
- Report.Failed("Constraint_Error not expected: Case"
- & Case_Numbers'Image(Cases) );
- end if;
- when others =>
- Report.Failed("Wrong/Bad Exception: Case"
- & Case_Numbers'Image(Cases) );
- end Catch_Exception;
- end loop;
- end Make_Calls;
-
-begin -- Main test procedure.
-
- Report.Test ("C410001", "Check that evaluating an access to subprogram " &
- "variable containing the value null causes the " &
- "exception Constraint_Error. Check that the " &
- "default value for objects of access to " &
- "subprogram types is null" );
-
- -- check that the default values are null
- declare
- use C410001_0; -- make all "="'s visible for all types
- begin
- TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" );
-
- TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" );
-
- TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" );
-
- TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" );
-
- TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null,
- "Enclosed.Prot_Proc_Ref_Var = null" );
-
- TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null,
- "Enclosed.Prot_Func_Ref_Var = null" );
- end;
-
- -- check that calls via the default values cause Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Make_Calls( Expecting_Exceptions => True );
-
- -- assign non-null values to the objects
-
- Proc_Ref_Var := C410001_0.Proc'Access;
- Func_Ref_Var := C410001_0.Func'Access;
- Proc_Para_Ref_Var := C410001_0.Proc_Para'Access;
- Func_Para_Ref_Var := C410001_0.Func_Para'Access;
- Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access,
- C410001_0.Prot_Obj.Prot_Func'Access);
-
- -- check that the calls perform normally
-
- C410001_0.Expect_Exception := False;
-
- Make_Calls( Expecting_Exceptions => False );
-
- -- check that a passed null value causes Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Proc_Para_Ref_Var( null );
-
- TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995,
- "Func_Para_Ref_Var( null )");
-
- -- assign the null value to the objects
-
- Proc_Ref_Var := null;
- Func_Ref_Var := null;
- Proc_Para_Ref_Var := null;
- Func_Para_Ref_Var := null;
- Enclosed := (null,null);
-
- -- check that calls now again cause Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Make_Calls( Expecting_Exceptions => True );
-
- Report.Result;
-
-end C410001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41101d.ada b/gcc/testsuite/ada/acats/tests/c4/c41101d.ada
deleted file mode 100644
index c826a22..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41101d.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C41101D.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.
---*
--- FOR INDEXED COMPONENTS OF THE FORM F(...), CHECK THAT
--- THE NUMBER OF INDEX VALUES, THE TYPE OF THE INDEX
--- VALUES, AND THE REQUIRED TYPE OF THE INDEXED COMPONENT
--- ARE USED TO RESOLVE AN OVERLOADING OF F.
-
--- WKB 8/12/81
--- JBG 10/12/81
--- SPS 11/1/82
-
-WITH REPORT;
-PROCEDURE C41101D IS
-
- USE REPORT;
-
- TYPE T1 IS ARRAY (1..10) OF INTEGER;
- TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER;
- I : INTEGER;
-
- TYPE U1 IS (MON,TUE,WED,THU,FRI);
- TYPE U2 IS ARRAY (U1 RANGE MON..THU) OF INTEGER;
-
- TYPE V1 IS ARRAY (1..10) OF BOOLEAN;
- B : BOOLEAN;
-
- FUNCTION F RETURN T1 IS
- BEGIN
- RETURN (1..10 => 1);
- END F;
-
- FUNCTION F RETURN T2 IS
- BEGIN
- RETURN (1..10 => (1..10 => 2));
- END F;
-
- FUNCTION G RETURN U2 IS
- BEGIN
- RETURN (MON..THU => 3);
- END G;
-
- FUNCTION G RETURN T1 IS
- BEGIN
- RETURN (1..10 => 4);
- END G;
-
- FUNCTION H RETURN T1 IS
- BEGIN
- RETURN (1..10 => 5);
- END H;
-
- FUNCTION H RETURN V1 IS
- BEGIN
- RETURN (1..10 => FALSE);
- END H;
-
-BEGIN
-
- TEST ("C41101D", "WHEN INDEXING FUNCTION RESULTS, INDEX TYPE, " &
- "NUMBER OF INDICES, AND COMPONENT TYPE ARE " &
- "USED FOR OVERLOADING RESOLUTION");
-
- I := F(7); -- NUMBER OF INDEX VALUES.
- IF I /= IDENT_INT(1) THEN
- FAILED ("WRONG VALUE - 1");
- END IF;
-
- I := G(3); -- INDEX TYPE.
- IF I /= IDENT_INT(4) THEN
- FAILED ("WRONG VALUE - 2");
- END IF;
-
- B := H(5); -- COMPONENT TYPE.
- IF B /= IDENT_BOOL(FALSE) THEN
- FAILED ("WRONG VALUE - 3");
- END IF;
-
- RESULT;
-
-END C41101D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41103a.ada b/gcc/testsuite/ada/acats/tests/c4/c41103a.ada
deleted file mode 100644
index 21feafb..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41103a.ada
+++ /dev/null
@@ -1,239 +0,0 @@
--- C41103A.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 NAME IN AN INDEXED_COMPONENT MAY BE:
--- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1;
--- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE
--- DESIGNATES AN ARRAY OBJECT - N2;
--- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING
--- A PREDEFINED FUNCTION - &,
--- A USER-DEFINED FUNCTION - F1;
--- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT
--- DESIGNATES AN ARRAY - F2;
--- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3;
--- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT
--- (ARRAY OF ARRAYS) - N4;
--- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT
--- ENCLOSING ITS DECLARATION - C41103A.N1;
--- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE
--- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5.
--- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR
--- STATIC INDICES).
-
--- WKB 7/27/81
--- JRK 7/28/81
--- SPS 10/26/82
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41103A IS
-
- TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER;
- N1 : A1 := (1,2,3,4);
-
-BEGIN
- TEST ("C41103A", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " &
- "CERTAIN FORMS AND THAT THE APPROPRIATE " &
- "COMPONENT IS ACCESSED (FOR STATIC INDICES)");
-
- DECLARE
-
- TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN;
- TYPE A3 IS ACCESS A1;
- TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1;
- TYPE R (LENGTH : INTEGER) IS
- RECORD
- S : STRING (1..LENGTH);
- END RECORD;
-
- N2 : A3 := NEW A1' (1,2,3,4);
- N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7);
- N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8),
- 3 => (9,10,11,12), 4 => (13,14,15,16));
- N5 : R(4) := (LENGTH => 4, S => "ABCD");
-
- FUNCTION F1 RETURN A2 IS
- BEGIN
- RETURN (FALSE,FALSE,TRUE,FALSE);
- END F1;
-
- FUNCTION F2 RETURN A3 IS
- BEGIN
- RETURN N2;
- END F2;
-
- PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER;
- Z : OUT INTEGER; W : IN STRING) IS
- BEGIN
- IF X /= 2 THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= 3 THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := 8;
- Z := 9;
- END P1;
-
- PROCEDURE P2 (X : CHARACTER) IS
- BEGIN
- IF X /= 'C' THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - '&'");
- END IF;
- END P2;
-
- PROCEDURE P3 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - F1");
- END IF;
- END P3;
-
- PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER;
- Z : OUT CHARACTER) IS
- BEGIN
- IF X /= 'A' THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - N5");
- END IF;
- IF Y /= 'D' THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5");
- END IF;
- Y := 'Y';
- Z := 'Z';
- END P5;
-
- BEGIN
-
- IF N1(2) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N1");
- END IF;
- N1(2) := 7;
- IF N1 /= (1,7,3,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N1");
- END IF;
- N1 := (1,2,3,4);
- P1 (N1(2), N1(3), N1(1), "N1");
- IF N1 /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1");
- END IF;
-
- IF N2(3) /= 3 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N2");
- END IF;
- N2(3) := 7;
- IF N2.ALL /= (1,2,7,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N2");
- END IF;
- N2.ALL := (2,1,4,3);
- P1 (N2(1), N2(4), N2(2), "N2");
- IF N2.ALL /= (2,9,4,8) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2");
- END IF;
-
- IF "&" (STRING'("AB"), STRING'("CDEF"))(5) /= CHARACTER'('E') THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - '&'");
- END IF;
- P2 ("&" ("AB", "CD")(3));
-
- IF F1(3) /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F1");
- END IF;
- P3 (F1(3));
-
- N2 := NEW A1' (1,2,3,4);
- IF F2(2) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F2");
- END IF;
- F2(3) := 7;
- IF N2.ALL /= (1,2,7,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - F2");
- END IF;
- N2.ALL := (1,2,3,4);
- P1 (F2(2), F2(3), F2(1), "F2");
- IF N2.ALL /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2");
- END IF;
-
- IF N3(2..5)(5) /= 5 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N3");
- END IF;
- N3(2..5)(2) := 8;
- IF N3 /= (1,8,3,4,5,6,7) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N3");
- END IF;
- N3 := (5,3,4,2,1,6,7);
- P1 (N3(2..5)(4), N3(2..5)(2), N3(2..5)(5), "N3");
- IF N3 /= (5,8,4,2,9,6,7) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3");
- END IF;
-
- IF N4(1)(2) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N4");
- END IF;
- N4(3)(1) := 20;
- IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12),
- (13,14,15,16)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N4");
- END IF;
- N4 := (1 => (0,6,4,2), 2 => (10,11,12,13),
- 3 => (14,15,16,17), 4 => (7,5,3,1));
- P1 (N4(1)(4), N4(4)(3), N4(2)(1), "N4");
- IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17),
- (7,5,8,1)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4");
- END IF;
-
- N1 := (1,2,3,4);
- IF C41103A.N1(2) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C41103A.N1");
- END IF;
- C41103A.N1(2) := 7;
- IF N1 /= (1,7,3,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103A.N1");
- END IF;
- N1 := (1,2,3,4);
- P1 (C41103A.N1(2), C41103A.N1(3), C41103A.N1(1),
- "C41103A.N1");
- IF N1 /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " &
- "- C41103A.N1");
- END IF;
-
- IF N5.S(3) /= 'C' THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N5");
- END IF;
- N5.S(4) := 'X';
- IF N5.S /= "ABCX" THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N5");
- END IF;
- N5.S := "ABCD";
- P5 (N5.S(1), N5.S(4), N5.S(2));
- IF N5.S /= "AZCY" THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5");
- END IF;
- END;
-
- RESULT;
-END C41103A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41103b.ada b/gcc/testsuite/ada/acats/tests/c4/c41103b.ada
deleted file mode 100644
index 7fbab71..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41103b.ada
+++ /dev/null
@@ -1,366 +0,0 @@
--- C41103B.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 NAME IN AN INDEXED_COMPONENT MAY BE:
--- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1;
--- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE
--- DESIGNATES AN ARRAY OBJECT - N2;
--- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING
--- PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS
--- A USER-DEFINED FUNCTION - F1;
--- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT
--- DESIGNATES AN ARRAY - F2;
--- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3;
--- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT
--- (ARRAY OF ARRAYS) - N4;
--- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT
--- ENCLOSING ITS DECLARATION - C41103B.N1;
--- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE
--- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5.
--- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR
--- DYNAMIC INDICES).
-
--- HISTORY:
--- WKB 08/05/81 CREATED ORIGINAL TEST.
--- SPS 10/26/82
--- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE
--- LOGICAL OPERATORS.
--- BCB 04/16/90 MODIFIED SLICE TEST TO INCLUDE A READING OF THE
--- COMPONENT DESIGNATED BY THE LOWER BOUND OF THE
--- SLICE. ADDED TEST FOR PREFIX OF INDEXED COMPONENT
--- HAVING A LIMITED TYPE.
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41103B IS
-
- TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER;
- N1 : A1 := (1,2,3,4);
-
-BEGIN
- TEST ("C41103B", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " &
- "CERTAIN FORMS AND THAT THE APPROPRIATE " &
- "COMPONENT IS ACCESSED (FOR DYNAMIC INDICES)");
-
- DECLARE
-
- TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN;
- TYPE A3 IS ACCESS A1;
- TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1;
- TYPE R (LENGTH : INTEGER) IS
- RECORD
- S : STRING (1..LENGTH);
- END RECORD;
-
- N2 : A3 := NEW A1' (1,2,3,4);
- N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7);
- N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8),
- 3 => (9,10,11,12), 4 => (13,14,15,16));
- N5 : R(4) := (LENGTH => 4, S => "ABCD");
-
- M2A : A2 := (TRUE,FALSE,TRUE,FALSE);
- M2B : A2 := (TRUE,TRUE,FALSE,FALSE);
-
- FUNCTION F1 RETURN A2 IS
- BEGIN
- RETURN (FALSE,FALSE,TRUE,FALSE);
- END F1;
-
- FUNCTION F2 RETURN A3 IS
- BEGIN
- RETURN N2;
- END F2;
-
- PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER;
- Z : OUT INTEGER; W : IN STRING) IS
- BEGIN
- IF X /= 2 THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= 3 THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := 8;
- Z := 9;
- END P1;
-
- PROCEDURE P2 (X : CHARACTER) IS
- BEGIN
- IF X /= 'C' THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - '&'");
- END IF;
- END P2;
-
- PROCEDURE P3 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - F1");
- END IF;
- END P3;
-
- PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER;
- Z : OUT CHARACTER) IS
- BEGIN
- IF X /= 'A' THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - N5");
- END IF;
- IF Y /= 'D' THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5");
- END IF;
- Y := 'Y';
- Z := 'Z';
- END P5;
-
- PROCEDURE P6 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - NOT");
- END IF;
- END P6;
-
- PROCEDURE P7 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - AND");
- END IF;
- END P7;
-
- PROCEDURE P8 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - OR");
- END IF;
- END P8;
-
- PROCEDURE P9 (X : BOOLEAN) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - XOR");
- END IF;
- END P9;
-
- BEGIN
-
- IF N1(IDENT_INT(2)) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N1");
- END IF;
- N1(IDENT_INT(2)) := 7;
- IF N1 /= (1,7,3,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N1");
- END IF;
- N1 := (1,2,3,4);
- P1 (N1(IDENT_INT(2)), N1(IDENT_INT(3)),
- N1(IDENT_INT(1)), "N1");
- IF N1 /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1");
- END IF;
-
- IF N2(IDENT_INT(3)) /= 3 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N2");
- END IF;
- N2(IDENT_INT(3)) := 7;
- IF N2.ALL /= (1,2,7,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N2");
- END IF;
- N2.ALL := (2,1,4,3);
- P1 (N2(IDENT_INT(1)), N2(IDENT_INT(4)),
- N2(IDENT_INT(2)), "N2");
- IF N2.ALL /= (2,9,4,8) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2");
- END IF;
-
- IF "&" (STRING'("AB"), STRING'("CDEF"))(IDENT_INT(5))
- /= CHARACTER'('E') THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - '&'");
- END IF;
- P2 ("&" ("AB", "CD")(IDENT_INT(3)));
-
- IF "NOT" (M2A)(IDENT_INT(4)) /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'");
- END IF;
- P6 ("NOT" (M2A)(IDENT_INT(4)));
-
- IF "AND" (M2A,M2B)(IDENT_INT(3)) /= FALSE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'");
- END IF;
- P7 ("AND" (M2A,M2B)(IDENT_INT(1)));
-
- IF "OR" (M2A,M2B)(IDENT_INT(3)) /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'");
- END IF;
- P8 ("OR" (M2A,M2B)(IDENT_INT(3)));
-
- IF "XOR" (M2A,M2B)(IDENT_INT(1)) /= FALSE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'");
- END IF;
- P9 ("XOR" (M2A,M2B)(IDENT_INT(3)));
-
- IF F1(IDENT_INT(3)) /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F1");
- END IF;
- P3 (F1(IDENT_INT(3)));
-
- N2 := NEW A1'(1,2,3,4);
- IF F2(IDENT_INT(2)) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F2");
- END IF;
- F2(IDENT_INT(3)) := 7;
- IF N2.ALL /= (1,2,7,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - F2");
- END IF;
- N2.ALL := (1,2,3,4);
- P1 (F2(IDENT_INT(2)), F2(IDENT_INT(3)),
- F2(IDENT_INT(1)), "F2");
- IF N2.ALL /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2");
- END IF;
-
- IF N3(2..5)(IDENT_INT(2)) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION (LOWER BOUND) - N3");
- END IF;
- IF N3(2..5)(IDENT_INT(5)) /= 5 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION (UPPER BOUND) - N3");
- END IF;
- N3(2..5)(IDENT_INT(2)) := 8;
- IF N3 /= (1,8,3,4,5,6,7) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N3");
- END IF;
- N3 := (5,3,4,2,1,6,7);
- P1 (N3(2..5)(IDENT_INT(4)), N3(2..5)(IDENT_INT(2)),
- N3(2..5)(IDENT_INT(5)), "N3");
- IF N3 /= (5,8,4,2,9,6,7) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3");
- END IF;
-
- IF N4(1)(IDENT_INT(2)) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N4");
- END IF;
- N4(3)(IDENT_INT(1)) := 20;
- IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12),
- (13,14,15,16)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N4");
- END IF;
- N4 := (1 => (0,6,4,2), 2 => (10,11,12,13),
- 3 => (14,15,16,17), 4 => (7,5,3,1));
- P1 (N4(1)(IDENT_INT(4)), N4(4)(IDENT_INT(3)),
- N4(2)(IDENT_INT(1)), "N4");
- IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17),
- (7,5,8,1)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4");
- END IF;
-
- N1 := (1,2,3,4);
- IF C41103B.N1(IDENT_INT(2)) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C41103B.N1");
- END IF;
- C41103B.N1(IDENT_INT(2)) := 7;
- IF N1 /= (1,7,3,4) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103B.N1");
- END IF;
- N1 := (1,2,3,4);
- P1 (C41103B.N1(IDENT_INT(2)), C41103B.N1(IDENT_INT(3)),
- C41103B.N1(IDENT_INT(1)), "C41103B.N1");
- IF N1 /= (9,2,8,4) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " &
- "- C41103B.N1");
- END IF;
-
- IF N5.S(IDENT_INT(3)) /= 'C' THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N5");
- END IF;
- N5.S(IDENT_INT(4)) := 'X';
- IF N5.S /= "ABCX" THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N5");
- END IF;
- N5.S := "ABCD";
- P5 (N5.S(IDENT_INT(1)), N5.S(IDENT_INT(4)),
- N5.S(IDENT_INT(2)));
- IF N5.S /= "AZCY" THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5");
- END IF;
-
- DECLARE
- PACKAGE P IS
- TYPE LIM IS LIMITED PRIVATE;
- PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER);
- PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM);
- FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN;
- PRIVATE
- TYPE LIM IS ARRAY(1..3) OF INTEGER;
- END P;
-
- USE P;
-
- TYPE A IS ARRAY(1..3) OF LIM;
-
- H : A;
-
- N6 : LIM;
-
- PACKAGE BODY P IS
- PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS
- BEGIN
- V := (X,Y,Z);
- END INIT;
-
- PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS
- BEGIN
- ONE := TWO;
- END ASSIGN;
-
- FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN IS
- BEGIN
- IF ONE(1) = TWO(1) AND ONE(2) = TWO(2) AND
- ONE(3) = TWO(3) THEN
- RETURN TRUE;
- ELSE
- RETURN FALSE;
- END IF;
- END "=";
- END P;
-
- FUNCTION FR RETURN A IS
- BEGIN
- RETURN H;
- END FR;
-
- BEGIN
- INIT (H(1),1,2,3);
- INIT (H(2),4,5,6);
- INIT (H(3),7,8,9);
- INIT (N6,0,0,0);
-
- ASSIGN (N6,FR(2));
-
- IF N6 /= FR(2) THEN
- FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE");
- END IF;
-
- END;
- END;
-
- RESULT;
-END C41103B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41104a.ada b/gcc/testsuite/ada/acats/tests/c4/c41104a.ada
deleted file mode 100644
index 5407028..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41104a.ada
+++ /dev/null
@@ -1,240 +0,0 @@
--- C41104A.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 IF AN EXPRESSION GIVES AN INDEX
--- VALUE OUTSIDE THE RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND ACCESS
--- TYPES.
-
--- TBN 9/12/86
--- EDS 8/03/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41104A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 5;
- SUBTYPE BOOL IS BOOLEAN RANGE TRUE .. TRUE;
- SUBTYPE CHAR IS CHARACTER RANGE 'W' .. 'Z';
- TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER;
- TYPE ARRAY2 IS ARRAY (3 .. 1) OF INTEGER;
- TYPE ARRAY3 IS ARRAY (BOOL RANGE <>) OF INTEGER;
- TYPE ARRAY4 IS ARRAY (CHAR RANGE <>) OF INTEGER;
-
- TYPE REC (D : INT) IS
- RECORD
- A : ARRAY1 (1 .. D);
- END RECORD;
-
- TYPE B_REC (D : BOOL) IS
- RECORD
- A : ARRAY3 (TRUE .. D);
- END RECORD;
-
- TYPE NULL_REC (D : INT) IS
- RECORD
- A : ARRAY1 (D .. 1);
- END RECORD;
-
- TYPE NULL_CREC (D : CHAR) IS
- RECORD
- A : ARRAY4 (D .. 'W');
- END RECORD;
-
-BEGIN
- TEST ("C41104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF AN " &
- "EXPRESSION GIVES AN INDEX VALUE OUTSIDE THE " &
- "RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND " &
- "ACCESS TYPES");
-
- DECLARE
- ARA1 : ARRAY1 (1 .. 5) := (1, 2, 3, 4, 5);
- BEGIN
- ARA1 (IDENT_INT(0)) := 1;
-
- BEGIN
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " &
- INTEGER'IMAGE(ARA1 (1)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-------------------------------------------------------------------------
- DECLARE
- TYPE ACC_ARRAY IS ACCESS ARRAY3 (TRUE .. TRUE);
- ACC_ARA : ACC_ARRAY := NEW ARRAY3'(TRUE => 2);
- BEGIN
- ACC_ARA (IDENT_BOOL(FALSE)) := 2;
-
- BEGIN
-
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " &
- INTEGER'IMAGE(ACC_ARA (TRUE)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-------------------------------------------------------------------------
- DECLARE
- ARA2 : ARRAY4 ('Z' .. 'Y');
- BEGIN
- ARA2 (IDENT_CHAR('Y')) := 3;
-
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3");
-
- BEGIN
- COMMENT ("ARA2 (Y) IS " & INTEGER'IMAGE(ARA2 ('Y')));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-------------------------------------------------------------------------
- DECLARE
- TYPE ACC_ARRAY IS ACCESS ARRAY2;
- ACC_ARA : ACC_ARRAY := NEW ARRAY2;
- BEGIN
- ACC_ARA (IDENT_INT(4)) := 4;
-
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4");
-
- BEGIN
- COMMENT ("ACC_ARA (4) IS " & INTEGER'IMAGE(ACC_ARA (4)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 4");
- END;
-------------------------------------------------------------------------
- DECLARE
- REC1 : B_REC (TRUE) := (TRUE, A => (TRUE => 5));
- BEGIN
- REC1.A (IDENT_BOOL (FALSE)) := 1;
-
- BEGIN
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " &
- INTEGER'IMAGE(REC1.A (TRUE)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 5");
- END;
-------------------------------------------------------------------------
- DECLARE
- TYPE ACC_REC IS ACCESS REC (3);
- ACC_REC1 : ACC_REC := NEW REC'(3, (4, 5, 6));
- BEGIN
- ACC_REC1.A (IDENT_INT(4)) := 4;
-
- BEGIN
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " &
- INTEGER'IMAGE(ACC_REC1.A (3)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 6");
- END;
-------------------------------------------------------------------------
- DECLARE
- REC1 : NULL_REC (2);
- BEGIN
- REC1.A (IDENT_INT(2)) := 1;
-
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7");
-
- BEGIN
- COMMENT ("REC1.A (2) IS " & INTEGER'IMAGE(REC1.A (2)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 7");
- END;
-------------------------------------------------------------------------
- DECLARE
- TYPE ACC_REC IS ACCESS NULL_CREC ('Z');
- ACC_REC1 : ACC_REC := NEW NULL_CREC ('Z');
- BEGIN
- ACC_REC1.A (IDENT_CHAR('A')) := 4;
-
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8");
- BEGIN
- COMMENT ("ACC_REC1.A (A) IS " &
- INTEGER'IMAGE(ACC_REC1.A ('A')));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 8");
- END;
-------------------------------------------------------------------------
-
- RESULT;
-END C41104A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41105a.ada b/gcc/testsuite/ada/acats/tests/c4/c41105a.ada
deleted file mode 100644
index 1b5ad40..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41105a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C41105A.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 CONSTRAINT_ERROR IS RAISED IF THE NAME PART OF AN
--- INDEXED COMPONENT DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL,
--- AND ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL.
-
--- HISTORY:
--- WKB 07/29/81 CREATED ORIGINAL TEST.
--- SPS 10/26/82
--- JET 01/05/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
--- OPTIMIZATION.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41105A IS
-
-BEGIN
- TEST ("C41105A", "CONSTRAINT_ERROR FROM NAMES DENOTING A NULL " &
- "ACCESS OBJECT AND A FUNCTION CALL DELIVERING " &
- "NULL");
-
- DECLARE
-
- TYPE T1 IS ARRAY (1..2) OF INTEGER;
- TYPE A1 IS ACCESS T1;
- B : A1 := NEW T1' (1,2);
- I : INTEGER;
-
- BEGIN
-
- IF EQUAL (3,3) THEN
- B := NULL;
- END IF;
-
- I := B(1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
-
- IF EQUAL (I,I) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1");
-
- END;
-
-
- DECLARE
-
- TYPE T2 IS ARRAY (1..2) OF INTEGER;
- TYPE A2 IS ACCESS T2;
- I : INTEGER;
-
- FUNCTION F RETURN A2 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN NULL;
- END IF;
- RETURN NEW T2' (1,2);
- END F;
-
- BEGIN
-
- I := F(1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
-
- IF EQUAL (I,I) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2");
-
- END;
-
- RESULT;
-END C41105A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41107a.ada b/gcc/testsuite/ada/acats/tests/c4/c41107a.ada
deleted file mode 100644
index 13781fb..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41107a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C41107A.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 AN ARRAY HAVING BOTH POSITIVE AND NEGATIVE
--- INDEX VALUES, THE PROPER COMPONENT IS SELECTED - A.
--- CHECK THAT FOR AN ARRAY INDEXED WITH AN ENUMERATION TYPE,
--- APPROPRIATE COMPONENTS CAN BE SELECTED - B.
--- CHECK THAT SUBSCRIPT EXPRESSIONS CAN BE OF COMPLEXITY GREATER
--- THAN VARIABLE + - CONSTANT - C.
--- CHECK THAT MULTIPLY DIMENSIONED ARRAYS ARE PROPERLY INDEXED - D.
-
--- WKB 7/29/81
--- JBG 8/21/83
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41107A IS
-
- TYPE T1 IS ARRAY (INTEGER RANGE -2..2) OF INTEGER;
- A : T1 := (1,2,3,4,5);
-
- TYPE COLOR IS (RED,ORANGE,YELLOW,GREEN,BLUE);
- TYPE T2 IS ARRAY (COLOR RANGE RED..BLUE) OF INTEGER;
- B : T2 := (5,4,3,2,1);
-
- C : STRING (1..7) := "ABCDEFG";
-
- TYPE T4 IS ARRAY (1..4,1..3) OF INTEGER;
- D : T4 := (1 => (1,2,3), 2 => (4,5,6), 3 => (7,8,9),
- 4 => (0,-1,-2));
-
- V1 : INTEGER := IDENT_INT (1);
- V2 : INTEGER := IDENT_INT (2);
- V3 : INTEGER := IDENT_INT (3);
-
- PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER;
- Z : OUT INTEGER; W : STRING) IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= 4 THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := 11;
- Z := 12;
- END P1;
-
- PROCEDURE P2 (X : IN CHARACTER; Y : IN OUT CHARACTER;
- Z : OUT CHARACTER) IS
- BEGIN
- IF X /= 'D' THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - C");
- END IF;
- IF Y /= 'F' THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - C");
- END IF;
- Y := 'Y';
- Z := 'Z';
- END P2;
-
-BEGIN
- TEST ("C41107A", "CHECK THAT THE PROPER COMPONENT IS SELECTED " &
- "FOR ARRAYS WITH POS AND NEG INDICES, " &
- "ENUMERATION INDICES, COMPLEX SUBSCRIPT " &
- "EXPRESSIONS, AND MULTIPLE DIMENSIONS");
-
- IF A(IDENT_INT(1)) /= 4 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - A");
- END IF;
- A(IDENT_INT(-2)) := 10;
- IF A /= (10,2,3,4,5) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - A");
- END IF;
- A := (2,1,0,3,4);
- P1 (A(-1), A(2), A(-2), "A");
- IF A /= (12,1,0,3,11) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - A");
- END IF;
-
- IF B(GREEN) /= 2 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - B");
- END IF;
- B(YELLOW) := 10;
- IF B /= (5,4,10,2,1) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - B");
- END IF;
- B := (1,4,2,3,5);
- P1 (B(RED), B(ORANGE), B(BLUE), "B");
- IF B /= (1,11,2,3,12) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - B");
- END IF;
-
- IF C(3..6)(3**2 / 3 * (2-1) - 6 / 3 + 2) /= 'C' THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C");
- END IF;
- C(3..6)(V3**2 / V1 * (V3-V2) + IDENT_INT(4) - V3 * V2 - V1) := 'W';
- IF C /= "ABCDEWG" THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C");
- END IF;
- C := "ABCDEFG";
- P2 (C(3..6)(V3+V1), C(3..6)(V3*V2), C(3..6)((V1+V2)*V1));
- IF C /= "ABZDEYG" THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - C");
- END IF;
-
- IF D(IDENT_INT(1),IDENT_INT(3)) /= 3 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - D");
- END IF;
- D(IDENT_INT(4),IDENT_INT(2)) := 10;
- IF D /= ((1,2,3),(4,5,6),(7,8,9),(0,10,-2)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - D");
- END IF;
- D := (1 => (0,2,3), 2 => (4,5,6), 3 => (7,8,9), 4 => (1,-1,-2));
- P1 (D(4,1), D(2,1), D(3,2), "D");
- IF D /= ((0,2,3),(11,5,6),(7,12,9),(1,-1,-2)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - D");
- END IF;
-
- RESULT;
-END C41107A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41201d.ada b/gcc/testsuite/ada/acats/tests/c4/c41201d.ada
deleted file mode 100644
index a589ba7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41201d.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C41201D.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.
---*
--- FOR SLICED COMPONENTS OF THE FORM F(...), CHECK THAT
--- THE REQUIREMENT FOR A ONE-DIMENSIONAL ARRAY AND THE
--- TYPE OF THE INDEX ARE USED TO RESOLVE AN OVERLOADING OF F.
-
--- WKB 8/11/81
--- JBG 10/12/81
--- SPS 11/1/82
-
-WITH REPORT;
-PROCEDURE C41201D IS
-
- USE REPORT;
-
- TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- SUBTYPE T1 IS T(1..10);
- TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER;
- TT : T(1..3);
-
- SUBTYPE U1 IS T(1..10);
- TYPE U2 IS (MON,TUE,WED,THU,FRI);
- SUBTYPE SU2 IS U2 RANGE MON .. THU;
- TYPE U3 IS ARRAY (SU2) OF INTEGER;
- UU : T(1..3);
-
- TYPE V IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN;
- SUBTYPE V1 IS V(1..10);
- SUBTYPE V2 IS T(1..10);
- VV : V(2..5);
-
- FUNCTION F RETURN T1 IS
- BEGIN
- RETURN (1,1,1,1,5,6,7,8,9,10);
- END F;
-
- FUNCTION F RETURN T2 IS
- BEGIN
- RETURN (1..10 => (1,2,3,4,5,6,7,8,9,10));
- END F;
-
- FUNCTION G RETURN U1 IS
- BEGIN
- RETURN (3,3,3,3,5,6,7,8,9,10);
- END G;
-
- FUNCTION G RETURN U3 IS
- BEGIN
- RETURN (0,1,2,3);
- END G;
-
- FUNCTION H RETURN V1 IS
- BEGIN
- RETURN (1|3..10 => FALSE, 2 => IDENT_BOOL(TRUE));
- END H;
-
- FUNCTION H RETURN V2 IS
- BEGIN
- RETURN (1..10 => 5);
- END H;
-
-BEGIN
-
- TEST ("C41201D", "WHEN SLICING FUNCTION RESULTS, TYPE OF " &
- "RESULT IS USED FOR OVERLOADING RESOLUTION");
-
- IF F(1..3) /=
- F(IDENT_INT(2)..IDENT_INT(4)) THEN -- NUMBER OF DIMENSIONS.
- FAILED ("WRONG VALUE - 1");
- END IF;
-
- IF G(1..3) /=
- G(IDENT_INT(2)..IDENT_INT(4)) THEN -- INDEX TYPE.
- FAILED ("WRONG VALUE - 2");
- END IF;
-
- IF NOT IDENT_BOOL(H(2..3)(2)) THEN -- COMPONENT TYPE.
- FAILED ("WRONG VALUE - 3");
- END IF;
-
- RESULT;
-
-END C41201D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41203a.ada b/gcc/testsuite/ada/acats/tests/c4/c41203a.ada
deleted file mode 100644
index 7e75165..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41203a.ada
+++ /dev/null
@@ -1,241 +0,0 @@
--- C41203A.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 NAME PART OF A SLICE MAY BE:
--- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1;
--- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE
--- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2;
--- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT USING
--- A PREDEFINED FUNCTION - &,
--- A USER-DEFINED FUNCTION - F1;
--- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT
--- DESIGNATES A ONE DIMENSIONAL ARRAY - F2;
--- A SLICE - N3;
--- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT
--- (ARRAY OF ARRAYS) - N4;
--- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT
--- ENCLOSING ITS DECLARATION - C41203A.N1;
--- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE
--- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5.
--- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR
--- STATIC INDICES).
-
--- WKB 8/5/81
--- SPS 11/1/82
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41203A IS
-
- TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- SUBTYPE A1 IS T1 (1..6);
- N1 : A1 := (1,2,3,4,5,6);
-
-BEGIN
- TEST ("C41203A", "CHECK THAT THE NAME PART OF A SLICE MAY BE " &
- "OF CERTAIN FORMS AND THAT THE APPROPRIATE " &
- "SLICE IS ACCESSED (FOR STATIC INDICES)");
-
- DECLARE
-
- TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN;
- SUBTYPE A2 IS T2 (1..6);
- TYPE A3 IS ACCESS A1;
- SUBTYPE SI IS INTEGER RANGE 1 .. 3;
- TYPE A4 IS ARRAY (SI) OF A1;
- TYPE R (LENGTH : INTEGER) IS
- RECORD
- S : STRING (1..LENGTH);
- END RECORD;
-
- N2 : A3 := NEW A1' (1,2,3,4,5,6);
- N3 : T1 (1..7) := (1,2,3,4,5,6,7);
- N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12),
- 3 => (13,14,15,16,17,18));
- N5 : R(6) := (LENGTH => 6, S => "ABCDEF");
-
- FUNCTION F1 RETURN A2 IS
- BEGIN
- RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE);
- END F1;
-
- FUNCTION F2 RETURN A3 IS
- BEGIN
- RETURN N2;
- END F2;
-
- PROCEDURE P1 (X : IN T1; Y : IN OUT T1;
- Z : OUT T1; W : IN STRING) IS
- BEGIN
- IF X /= (1,2) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= (3,4) THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := (10,11);
- Z := (12,13);
- END P1;
-
- PROCEDURE P2 (X : STRING) IS
- BEGIN
- IF X /= "BC" THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - '&'");
- END IF;
- END P2;
-
- PROCEDURE P3 (X : T2) IS
- BEGIN
- IF X /= (FALSE,TRUE,FALSE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - F1");
- END IF;
- END P3;
-
- PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING;
- Z : OUT STRING) IS
- BEGIN
- IF X /= "EF" THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - N5");
- END IF;
- IF Y /= "CD" THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5");
- END IF;
- Y := "XY";
- Z := "WZ";
- END P5;
-
- BEGIN
-
- IF N1(1..2) /= (1,2) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N1");
- END IF;
- N1(1..2) := (7,8);
- IF N1 /= (7,8,3,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N1");
- END IF;
- N1 := (1,2,3,4,5,6);
- P1 (N1(1..2), N1(3..4), N1(5..6), "N1");
- IF N1 /= (1,2,10,11,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1");
- END IF;
-
- IF N2(4..6) /= (4,5,6) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N2");
- END IF;
- N2(4..6) := (7,8,9);
- IF N2.ALL /= (1,2,3,7,8,9) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N2");
- END IF;
- N2.ALL := (1,2,5,6,3,4);
- P1 (N2(1..2), N2(5..6), N2(3..4), "N2");
- IF N2.ALL /= (1,2,12,13,10,11) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2");
- END IF;
-
- IF "&" (STRING'("AB"), STRING'("CDEF"))(4..6) /= STRING'("DEF") THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - '&'");
- END IF;
- P2 ("&" ("AB", "CD")(2..3));
-
- IF F1(1..2) /= (FALSE,FALSE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F1");
- END IF;
- P3 (F1(2..4));
-
- N2 := NEW A1' (1,2,3,4,5,6);
- IF F2(2..6) /= (2,3,4,5,6) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F2");
- END IF;
- F2(3..3) := (5 => 7);
- IF N2.ALL /= (1,2,7,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - F2");
- END IF;
- N2.ALL := (5,6,1,2,3,4);
- P1 (F2(3..4), F2(5..6), F2(1..2), "F2");
- IF N2.ALL /= (12,13,1,2,10,11) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2");
- END IF;
-
- IF N3(2..7)(2..4) /= (2,3,4) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N3");
- END IF;
- N3(2..7)(4..5) := (8,9);
- IF N3 /= (1,2,3,8,9,6,7) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N3");
- END IF;
- N3 := (5,3,4,1,2,6,7);
- P1 (N3(2..7)(4..5), N3(2..7)(2..3), N3(2..7)(6..7), "N3");
- IF N3 /= (5,10,11,1,2,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3");
- END IF;
-
- IF N4(1)(3..5) /= (3,4,5) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N4");
- END IF;
- N4(2)(1..3) := (21,22,23);
- IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12),
- (13,14,15,16,17,18)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N4");
- END IF;
- N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14),
- 3 => (7,3,4,5,6,8));
- P1 (N4(2)(4..5), N4(3)(2..3), N4(1)(5..6), "N4");
- IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14),
- (7,10,11,5,6,8)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4");
- END IF;
-
- N1 := (1,2,3,4,5,6);
- IF C41203A.N1(1..2) /= (1,2) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C41203A.N1");
- END IF;
- C41203A.N1(1..2) := (7,8);
- IF N1 /= (7,8,3,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203A.N1");
- END IF;
- N1 := (1,2,3,4,5,6);
- P1 (C41203A.N1(1..2), C41203A.N1(3..4), C41203A.N1(5..6),
- "C41203A.N1");
- IF N1 /= (1,2,10,11,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " &
- "- C41203A.N1");
- END IF;
-
- IF N5.S(1..5) /= "ABCDE" THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N5");
- END IF;
- N5.S(4..6) := "PQR";
- IF N5.S /= "ABCPQR" THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N5");
- END IF;
- N5.S := "ABCDEF";
- P5 (N5.S(5..6), N5.S(3..4), N5.S(1..2));
- IF N5.S /= "WZXYEF" THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5");
- END IF;
- END;
-
- RESULT;
-END C41203A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41203b.ada b/gcc/testsuite/ada/acats/tests/c4/c41203b.ada
deleted file mode 100644
index 2bfb095..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41203b.ada
+++ /dev/null
@@ -1,378 +0,0 @@
--- C41203B.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 NAME PART OF A SLICE MAY BE:
--- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1;
--- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE
--- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2;
--- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT
--- USING PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS
--- A USER-DEFINED FUNCTION - F1;
--- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT
--- DESIGNATES A ONE DIMENSIONAL ARRAY - F2;
--- A SLICE - N3;
--- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT
--- (ARRAY OF ARRAYS) - N4;
--- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT
--- ENCLOSING ITS DECLARATION - C41203B.N1;
--- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE
--- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5.
--- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR
--- DYNAMIC INDICES).
-
--- HISTORY:
--- WKB 08/05/81 CREATED ORIGINAL TEST.
--- SPS 02/04/83
--- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE
--- LOGICAL OPERATORS.
--- BCB 04/16/90 ADDED TEST FOR PREFIX OF INDEXED COMPONENT HAVING
--- A LIMITED TYPE.
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41203B IS
-
- TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- SUBTYPE A1 IS T1 (1..6);
- N1 : A1 := (1,2,3,4,5,6);
-
-BEGIN
- TEST ("C41203B", "CHECK THAT THE NAME PART OF A SLICE MAY BE " &
- "OF CERTAIN FORMS AND THAT THE APPROPRIATE " &
- "SLICE IS ACCESSED (FOR DYNAMIC INDICES)");
-
- DECLARE
-
- TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN;
- SUBTYPE A2 IS T2 (1..6);
- TYPE A3 IS ACCESS A1;
- TYPE A4 IS ARRAY (INTEGER RANGE 1..3 ) OF A1;
- TYPE R (LENGTH : INTEGER) IS
- RECORD
- S : STRING (1..LENGTH);
- END RECORD;
-
- N2 : A3 := NEW A1'(1,2,3,4,5,6);
- N3 : T1(1..7) := (1,2,3,4,5,6,7);
- N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12),
- 3 => (13,14,15,16,17,18));
- N5 : R(6) := (LENGTH => 6, S => "ABCDEF");
-
- M2A : A2 := (TRUE,TRUE,TRUE,FALSE,FALSE,FALSE);
- M2B : A2 := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE);
-
- FUNCTION F1 RETURN A2 IS
- BEGIN
- RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE);
- END F1;
-
- FUNCTION F2 RETURN A3 IS
- BEGIN
- RETURN N2;
- END F2;
-
- PROCEDURE P1 (X : IN T1; Y : IN OUT T1;
- Z : OUT T1; W : IN STRING) IS
- BEGIN
- IF X /= (1,2) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= (3,4) THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := (10,11);
- Z := (12,13);
- END P1;
-
- PROCEDURE P2 (X : STRING) IS
- BEGIN
- IF X /= "BC" THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - '&'");
- END IF;
- END P2;
-
- PROCEDURE P3 (X : T2) IS
- BEGIN
- IF X /= (FALSE,TRUE,FALSE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - F1");
- END IF;
- END P3;
-
- PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING;
- Z : OUT STRING) IS
- BEGIN
- IF X /= "EF" THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - N5");
- END IF;
- IF Y /= "CD" THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5");
- END IF;
- Y := "XY";
- Z := "WZ";
- END P5;
-
- PROCEDURE P6 (X : T2) IS
- BEGIN
- IF X /= (FALSE,FALSE,TRUE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - NOT");
- END IF;
- END P6;
-
- PROCEDURE P7 (X : T2) IS
- BEGIN
- IF X /= (FALSE,TRUE,FALSE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - AND");
- END IF;
- END P7;
-
- PROCEDURE P8 (X : T2) IS
- BEGIN
- IF X /= (FALSE,TRUE,FALSE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - OR");
- END IF;
- END P8;
-
- PROCEDURE P9 (X : T2) IS
- BEGIN
- IF X /= (FALSE,TRUE,FALSE) THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - XOR");
- END IF;
- END P9;
-
- BEGIN
-
- IF N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N1");
- END IF;
- N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8);
- IF N1 /= (7,8,3,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N1");
- END IF;
- N1 := (1,2,3,4,5,6);
- P1 (N1(IDENT_INT(1)..IDENT_INT(2)),
- N1(IDENT_INT(3)..IDENT_INT(4)),
- N1(IDENT_INT(5)..IDENT_INT(6)), "N1");
- IF N1 /= (1,2,10,11,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1");
- END IF;
-
- IF N2(IDENT_INT(4)..IDENT_INT(6)) /= (4,5,6) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N2");
- END IF;
- N2(IDENT_INT(4)..IDENT_INT(6)) := (7,8,9);
- IF N2.ALL /= (1,2,3,7,8,9) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N2");
- END IF;
- N2.ALL := (1,2,5,6,3,4);
- P1 (N2(IDENT_INT(1)..IDENT_INT(2)),
- N2(IDENT_INT(5)..IDENT_INT(6)),
- N2(IDENT_INT(3)..IDENT_INT(4)), "N2");
- IF N2.ALL /= (1,2,12,13,10,11) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2");
- END IF;
-
- IF "&" (STRING'("AB"),STRING'("CDEF"))(IDENT_INT(4)..IDENT_INT(6))
- /= STRING'("DEF") THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - '&'");
- END IF;
- P2 ("&" ("AB","CD")(IDENT_INT(2)..IDENT_INT(3)));
-
- IF "NOT" (M2A)(IDENT_INT(3)..IDENT_INT(5)) /=
- (FALSE,TRUE,TRUE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'");
- END IF;
- P6 ("NOT" (M2A)(IDENT_INT(2)..IDENT_INT(4)));
-
- IF "AND" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /=
- (TRUE,FALSE,FALSE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'");
- END IF;
- P7 ("AND" (M2A,M2B)(IDENT_INT(2)..IDENT_INT(4)));
-
- IF "OR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /=
- (TRUE,FALSE,TRUE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'");
- END IF;
- P8 ("OR" (M2A,M2B)(IDENT_INT(4)..IDENT_INT(6)));
-
- IF "XOR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /=
- (FALSE,FALSE,TRUE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'");
- END IF;
- P9 ("XOR" (M2A,M2B)(IDENT_INT(1)..IDENT_INT(3)));
-
- IF F1(IDENT_INT(1)..IDENT_INT(2)) /= (FALSE,FALSE) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F1");
- END IF;
- P3 (F1(IDENT_INT(2)..IDENT_INT(4)));
-
- N2 := NEW A1'(1,2,3,4,5,6);
- IF F2(IDENT_INT(2)..IDENT_INT(6)) /= (2,3,4,5,6) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F2");
- END IF;
- F2(IDENT_INT(3)..IDENT_INT(3)) := (5 => 7);
- IF N2.ALL /= (1,2,7,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - F2");
- END IF;
- N2.ALL := (5,6,1,2,3,4);
- P1 (F2(IDENT_INT(3)..IDENT_INT(4)),
- F2(IDENT_INT(5)..IDENT_INT(6)),
- F2(IDENT_INT(1)..IDENT_INT(2)), "F2");
- IF N2.ALL /= (12,13,1,2,10,11) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2");
- END IF;
-
- IF N3(2..7)(IDENT_INT(2)..IDENT_INT(4)) /= (2,3,4) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N3");
- END IF;
- N3(2..7)(IDENT_INT(4)..IDENT_INT(5)) := (8,9);
- IF N3 /= (1,2,3,8,9,6,7) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N3");
- END IF;
- N3 := (5,3,4,1,2,6,7);
- P1 (N3(2..7)(IDENT_INT(4)..IDENT_INT(5)),
- N3(2..7)(IDENT_INT(2)..IDENT_INT(3)),
- N3(2..7)(IDENT_INT(6)..IDENT_INT(7)), "N3");
- IF N3 /= (5,10,11,1,2,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3");
- END IF;
-
- IF N4(1)(IDENT_INT(3)..IDENT_INT(5)) /= (3,4,5) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N4");
- END IF;
- N4(2)(IDENT_INT(1)..IDENT_INT(3)) := (21,22,23);
- IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12),
- (13,14,15,16,17,18)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N4");
- END IF;
- N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14),
- 3 => (7,3,4,5,6,8));
- P1 (N4(2)(IDENT_INT(4)..IDENT_INT(5)),
- N4(3)(IDENT_INT(2)..IDENT_INT(3)),
- N4(1)(IDENT_INT(5)..IDENT_INT(6)), "N4");
- IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14),
- (7,10,11,5,6,8)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4");
- END IF;
-
- N1 := (1,2,3,4,5,6);
- IF C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C41203B.N1");
- END IF;
- C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8);
- IF N1 /= (7,8,3,4,5,6) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203B.N1");
- END IF;
- N1 := (1,2,3,4,5,6);
- P1 (C41203B.N1(IDENT_INT(1)..IDENT_INT(2)),
- C41203B.N1(IDENT_INT(3)..IDENT_INT(4)),
- C41203B.N1(IDENT_INT(5)..IDENT_INT(6)), "C41203B.N1");
- IF N1 /= (1,2,10,11,12,13) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " &
- "- C41203B.N1");
- END IF;
-
- IF N5.S(IDENT_INT(1)..IDENT_INT(5)) /= "ABCDE" THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - N5");
- END IF;
- N5.S(IDENT_INT(4)..IDENT_INT(6)) := "PQR";
- IF N5.S /= "ABCPQR" THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - N5");
- END IF;
- N5.S := "ABCDEF";
- P5 (N5.S(IDENT_INT(5)..IDENT_INT(6)),
- N5.S(IDENT_INT(3)..IDENT_INT(4)),
- N5.S(IDENT_INT(1)..IDENT_INT(2)));
- IF N5.S /= "WZXYEF" THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5");
- END IF;
-
- DECLARE
- PACKAGE P IS
- TYPE LIM IS LIMITED PRIVATE;
- TYPE A IS ARRAY(INTEGER RANGE <>) OF LIM;
- PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER);
- PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM);
- FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN;
- PRIVATE
- TYPE LIM IS ARRAY(1..3) OF INTEGER;
- END P;
-
- USE P;
-
- H : A(1..5);
-
- N6 : A(1..3);
-
- PACKAGE BODY P IS
- PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS
- BEGIN
- V := (X,Y,Z);
- END INIT;
-
- PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS
- BEGIN
- ONE := TWO;
- END ASSIGN;
-
- FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN IS
- BEGIN
- IF ONE(1) = TWO(2) AND ONE(2) = TWO(3) AND
- ONE(3) = TWO(4) THEN
- RETURN TRUE;
- ELSE
- RETURN FALSE;
- END IF;
- END "=";
- END P;
-
- FUNCTION FR RETURN A IS
- BEGIN
- RETURN H;
- END FR;
-
- BEGIN
- INIT (H(1),1,2,3);
- INIT (H(2),4,5,6);
- INIT (H(3),7,8,9);
- INIT (H(4),10,11,12);
- INIT (H(5),13,14,15);
- INIT (N6(1),0,0,0);
- INIT (N6(2),0,0,0);
- INIT (N6(3),0,0,0);
-
- ASSIGN (N6(1),H(2));
- ASSIGN (N6(2),H(3));
- ASSIGN (N6(3),H(4));
-
- IF N6 /= FR(2..4) THEN
- FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE");
- END IF;
- END;
- END;
-
- RESULT;
-END C41203B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41204a.ada b/gcc/testsuite/ada/acats/tests/c4/c41204a.ada
deleted file mode 100644
index 0ad8439..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41204a.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C41204A.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 IF A SLICE'S DISCRETE
--- RANGE IS NOT NULL, AND ITS LOWER OR UPPER BOUND IS NOT A
--- POSSIBLE INDEX FOR THE NAMED ARRAY.
-
--- WKB 8/4/81
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41204A IS
-
-BEGIN
- TEST ("C41204A", "ILLEGAL UPPER OR LOWER BOUNDS FOR A " &
- "SLICE RAISES CONSTRAINT_ERROR");
-
- DECLARE
-
- TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- A : T (10..15) := (10,11,12,13,14,15);
- B : T (-20..30);
-
- BEGIN
-
- BEGIN
- B (IDENT_INT(9)..12) := A (IDENT_INT(9)..12);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1" &
- INTEGER'IMAGE(B(10)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1");
- END;
-
- BEGIN
- B (IDENT_INT(-12)..14) := A (IDENT_INT(-12)..14);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2" &
- INTEGER'IMAGE(B(10)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2");
- END;
-
- BEGIN
- B (11..IDENT_INT(16)) := A (11..IDENT_INT(16));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 3" &
- INTEGER'IMAGE(B(15)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 3");
- END;
-
- BEGIN
- B (17..20) := A (IDENT_INT(17)..IDENT_INT(20));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 4" &
- INTEGER'IMAGE(B(17)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 4");
- END;
- END;
-
- RESULT;
-END C41204A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41205a.ada b/gcc/testsuite/ada/acats/tests/c4/c41205a.ada
deleted file mode 100644
index 220ae33..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41205a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C41205A.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 IF THE NAME PART OF A
--- SLICE DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL, AND
--- ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL.
-
--- WKB 8/6/81
--- SPS 10/26/82
--- EDS 07/14/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41205A IS
-
-BEGIN
- TEST ("C41205A", "CONSTRAINT_ERROR WHEN THE NAME PART OF A " &
- "SLICE DENOTES A NULL ACCESS OBJECT OR A " &
- "FUNCTION CALL DELIVERING NULL");
-
- DECLARE
-
- TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- SUBTYPE T1 IS T (1..5);
- TYPE A1 IS ACCESS T1;
- B : A1 := NEW T1' (1,2,3,4,5);
- I : T (2..3);
-
- BEGIN
-
- IF EQUAL (3,3) THEN
- B := NULL;
- END IF;
-
- I := B(2..3);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & INTEGER'IMAGE(I(2)));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1");
-
- END;
-
- DECLARE
-
- TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER;
- SUBTYPE T2 IS T (1..5);
- TYPE A2 IS ACCESS T2;
- I : T (2..5);
-
- FUNCTION F RETURN A2 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN NULL;
- END IF;
- RETURN NEW T2' (1,2,3,4,5);
- END F;
-
- BEGIN
-
- I := F(2..5);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " & INTEGER'IMAGE(I(2)));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2");
-
- END;
-
- RESULT;
-END C41205A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41206a.ada b/gcc/testsuite/ada/acats/tests/c4/c41206a.ada
deleted file mode 100644
index b12e43d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41206a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C41206A.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 RANGE L..R, WHERE L=SUCC(R) CAN BE USED TO FORM
--- A NULL SLICE FROM AN ARRAY WHEN:
--- BOTH L AND R SATISFY THE INDEX CONSTRAINT;
--- L SATISFIES THE INDEX CONSTRAINT, R DOES NOT (BUT IT
--- BELONGS TO THE BASE TYPE OF THE INDEX);
--- L SATISFIES THE CONSTRAINT IMPOSED BY THE TYPE MARK OF
--- THE INDEX, BUT NOT THE CONSTRAINT ASSOCIATED WITH
--- THE INDEX;
--- THE ARRAY IS NULL, AND L IS IN THE RANGE OF THE INDEX SUBTYPE.
-
--- WKB 8/10/81
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41206A IS
-
- TYPE SMALL IS RANGE 1..100;
- TYPE T IS ARRAY (SMALL RANGE <> ) OF INTEGER;
- SUBTYPE T1 IS T(5..10);
- A : T1 := (5,6,7,8,9,10);
- B : T(8..7) := (8..7 => 1);
-
-BEGIN
- TEST ("C41206A", "USING A RANGE L..R, WHERE L=SUCC(R), " &
- "TO FORM A NULL SLICE FROM AN ARRAY");
-
- BEGIN
- IF A (7..6) /= B OR A (SMALL(IDENT_INT(7))..6) /= B THEN
- FAILED ("SLICE NOT NULL - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- IF A (5..4) /= B OR A (SMALL(IDENT_INT(5))..4) /= B THEN
- FAILED ("SLICE NOT NULL - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- IF A (50..49) /= B OR A (SMALL(IDENT_INT(50))..49) /= B THEN
- FAILED ("SLICE NOT NULL - 3");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- IF B (50..49) /= B OR B (SMALL(IDENT_INT(50))..49) /= B THEN
- FAILED ("SLICE NOT NULL - 4");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("EXCEPTION RAISED - 4");
- END;
-
- RESULT;
-END C41206A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41207a.ada b/gcc/testsuite/ada/acats/tests/c4/c41207a.ada
deleted file mode 100644
index 6f1807f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41207a.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C41207A.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 DISCRETE RANGE IN A SLICE CAN HAVE THE FORM
--- A'RANGE, WHERE A IS A CONSTRAINED ARRAY SUBTYPE OR AN ARRAY
--- OBJECT.
-
--- HISTORY:
--- BCB 07/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C41207A IS
-
- TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
-
- SUBTYPE A1 IS ARR(1..5);
-
- ARR_VAR : ARR(1..10) := (90,91,92,93,94,95,96,97,98,99);
-
- A2 : ARRAY(1..5) OF INTEGER := (80,81,82,83,84);
-
-BEGIN
- TEST ("C41207A", "CHECK THAT THE DISCRETE RANGE IN A SLICE CAN " &
- "HAVE THE FORM A'RANGE, WHERE A IS A " &
- "CONSTRAINED ARRAY SUBTYPE OR AN ARRAY OBJECT");
-
- ARR_VAR (A1'RANGE) := (1,2,3,4,5);
-
- IF NOT (EQUAL(ARR_VAR(1),1) AND EQUAL(ARR_VAR(2),2) AND
- EQUAL(ARR_VAR(3),3) AND EQUAL(ARR_VAR(4),4) AND
- EQUAL(ARR_VAR(5),5)) THEN
- FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " &
- "RANGE OF A CONSTRAINED ARRAY SUBTYPE");
- END IF;
-
- ARR_VAR (A2'RANGE) := (6,7,8,9,10);
-
- IF (NOT EQUAL(ARR_VAR(1),6) OR NOT EQUAL(ARR_VAR(2),7) OR
- NOT EQUAL(ARR_VAR(3),8) OR NOT EQUAL(ARR_VAR(4),9) OR
- NOT EQUAL(ARR_VAR(5),10)) THEN
- FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " &
- "RANGE OF AN ARRAY OBJECT");
- END IF;
-
- RESULT;
-END C41207A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41301a.ada b/gcc/testsuite/ada/acats/tests/c4/c41301a.ada
deleted file mode 100644
index 78017f5..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41301a.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- C41301A.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 NOTATION L.R MAY BE USED TO DENOTE A RECORD COMPONENT,
--- WHERE R IS THE IDENTIFIER OF SUCH COMPONENT, AND L MAY BE ANY OF
--- THE FOLLOWING:
--- AN IDENTIFIER DENOTING A RECORD OBJECT - X2;
--- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE DESIGNATES
--- A RECORD OBJECT - X3;
--- A FUNCTION CALL DELIVERING A RECORD VALUE - F1;
--- A FUNCTION CALL DELIVERING AN ACCESS VALUE DESIGNATING A
--- RECORD OBJECT - F2;
--- AN INDEXED COMPONENT - X4;
--- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT
--- ENCLOSING THE IDENTIFIER'S DECLARATION - C41301A.X1;
--- A SELECTED COMPONENT DENOTING A RECORD (WHICH IS A COMPONENT
--- OF ANOTHER RECORD) - X5.
-
--- WKB 8/13/81
--- JRK 8/17/81
--- SPS 10/26/82
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41301A IS
-
- TYPE T1 IS
- RECORD
- A : INTEGER;
- B : BOOLEAN;
- C : BOOLEAN;
- END RECORD;
- X1 : T1 := (A=>1, B=>TRUE, C=>FALSE);
-
-BEGIN
- TEST ("C41301A", "CHECK THAT THE NOTATION L.R MAY BE USED TO " &
- "DENOTE A RECORD COMPONENT, WHERE R IS THE " &
- "IDENTIFIER AND L MAY BE OF CERTAIN FORMS");
-
- DECLARE
-
- TYPE T2 (DISC : INTEGER := 0) IS
- RECORD
- D : BOOLEAN;
- E : INTEGER;
- F : BOOLEAN;
- CASE DISC IS
- WHEN 1 =>
- G : BOOLEAN;
- WHEN 2 =>
- H : INTEGER;
- WHEN OTHERS =>
- NULL;
- END CASE;
- END RECORD;
- X2 : T2(2) := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1);
-
- TYPE T3 IS ACCESS T1;
- X3 : T3 := NEW T1' (A=>1, B=>TRUE, C=>FALSE);
-
- TYPE T4 IS ARRAY (1..3) OF T1;
- X4 : T4 := (1 => (1, TRUE, FALSE),
- 2 => (2, FALSE, TRUE),
- 3 => (3, TRUE, FALSE));
-
- TYPE T5 IS
- RECORD
- I : INTEGER;
- J : T1;
- END RECORD;
- X5 : T5 := (I => 5, J => (6, FALSE, TRUE));
-
- FUNCTION F1 RETURN T2 IS
- BEGIN
- RETURN (DISC=>1, D=>FALSE, E=>3, F=>TRUE, G=>FALSE);
- END F1;
-
- FUNCTION F2 RETURN T3 IS
- BEGIN
- RETURN X3;
- END F2;
-
- PROCEDURE P1 (X : IN BOOLEAN; Y : IN OUT INTEGER;
- Z : OUT BOOLEAN; W : STRING) IS
- BEGIN
- IF X /= TRUE THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - " & W);
- END IF;
- IF Y /= 1 THEN
- FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W);
- END IF;
- Y := 10;
- Z := TRUE;
- END P1;
-
- PROCEDURE P2 (X : IN INTEGER) IS
- BEGIN
- IF X /= 1 THEN
- FAILED ("WRONG VALUE FOR IN PARAMETER - F1");
- END IF;
- END P2;
-
- BEGIN
-
- IF X2.E /= 3 THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - X2");
- END IF;
- X2.E := 5;
- IF X2 /= (2, TRUE, 5, FALSE, 1) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - X2");
- END IF;
- X2 := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1);
- P1 (X2.D, X2.H, X2.F, "X2");
- IF X2 /= (2, TRUE, 3, TRUE, 10) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X2");
- END IF;
-
- IF X3.C /= FALSE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - X3");
- END IF;
- X3.A := 5;
- IF X3.ALL /= (5, TRUE, FALSE) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - X3");
- END IF;
- X3 := NEW T1 '(A=>1, B=>TRUE, C=>FALSE);
- P1 (X3.B, X3.A, X3.C, "X3");
- IF X3.ALL /= (10, TRUE, TRUE) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X3");
- END IF;
-
- IF F1.G /= FALSE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F1");
- END IF;
- P2 (F1.DISC);
-
- X3 := NEW T1' (A=>3, B=>FALSE, C=>TRUE);
- IF F2.B /= FALSE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - F2");
- END IF;
- F2.A := 4;
- IF X3.ALL /= (4, FALSE, TRUE) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - F2");
- END IF;
- X3 := NEW T1' (A=>1, B=>FALSE, C=>TRUE);
- P1 (F2.C, F2.A, F2.B, "F2");
- IF X3.ALL /= (10, TRUE, TRUE) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2");
- END IF;
-
- IF X4(2).C /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - X4");
- END IF;
- X4(3).A := 4;
- IF X4 /= ((1,TRUE,FALSE), (2,FALSE,TRUE), (4,TRUE,FALSE)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - X4");
- END IF;
- X4 := (1 => (2,TRUE,FALSE), 2 => (1,FALSE,TRUE),
- 3 => (3,TRUE,FALSE));
- P1 (X4(3).B, X4(2).A, X4(1).C, "X4");
- IF X4 /= ((2,TRUE,TRUE), (10,FALSE,TRUE), (3,TRUE,FALSE)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X4");
- END IF;
-
- X1 := (A=>1, B=>FALSE, C=>TRUE);
- IF C41301A.X1.C /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - C41301A.X1");
- END IF;
- C41301A.X1.B := TRUE;
- IF X1 /= (1, TRUE, TRUE) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - C41301A.X1");
- END IF;
- X1 := (A=>1, B=>FALSE, C=>TRUE);
- P1 (C41301A.X1.C, C41301A.X1.A, C41301A.X1.B, "C41301A.X1");
- IF X1 /= (10, TRUE, TRUE) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - " &
- "C41301A.X1");
- END IF;
-
- IF X5.J.C /= TRUE THEN
- FAILED ("WRONG VALUE FOR EXPRESSION - X5");
- END IF;
- X5.J.C := FALSE;
- IF X5 /= (5, (6, FALSE, FALSE)) THEN
- FAILED ("WRONG TARGET FOR ASSIGNMENT - X5");
- END IF;
- X5 := (I => 5, J => (A=>1, B=>TRUE, C=>FALSE));
- P1 (X5.J.B, X5.J.A, X5.J.C, "X5");
- IF X5 /= (5, (10, TRUE, TRUE)) THEN
- FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X5");
- END IF;
-
- END;
-
- RESULT;
-END C41301A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303a.ada b/gcc/testsuite/ada/acats/tests/c4/c41303a.ada
deleted file mode 100644
index 4224eff..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C41303A.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || XXXXXXXXX |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303A IS
-
-
-BEGIN
-
- TEST ( "C41303A" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR");
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO RECORD ---------------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
- REC_CONST : REC := ( 7 , 8 , 9 );
- REC_VAR : REC := REC_CONST ;
-
- TYPE ACC_REC IS ACCESS REC ;
-
- ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 );
-
- BEGIN
-
- REC_VAR := ACC_REC_VAR.ALL ;
-
- IF REC_VAR /= ( 17 , 18 , 19 )
- THEN
- FAILED( "ACC. RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL.");
- END IF;
-
-
- ACC_REC_VAR.ALL := REC_CONST ;
-
- IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 )
- THEN
- FAILED( "ACC. RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303b.ada b/gcc/testsuite/ada/acats/tests/c4/c41303b.ada
deleted file mode 100644
index cb6c1ab..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303b.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C41303B.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || XXXXXXXXX |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303B IS
-
-
-BEGIN
-
- TEST ( "C41303B" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR");
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO ARRAY ----------------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
-
- ARR_CONST : ARR := ( TRUE , FALSE );
- ARR_VAR : ARR := ARR_CONST ;
-
- TYPE ACC_ARR IS ACCESS ARR ;
-
- ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE );
-
- BEGIN
-
- ARR_VAR := ACC_ARR_VAR.ALL ;
-
- IF ARR_VAR /= ( FALSE , TRUE )
- THEN
- FAILED( "ACC. ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- ACC_ARR_VAR.ALL := ARR_CONST ;
-
- IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE )
- THEN
- FAILED( "ACC. ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." );
- END IF;
-
-
- END ;
-
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303c.ada b/gcc/testsuite/ada/acats/tests/c4/c41303c.ada
deleted file mode 100644
index d688725..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303c.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C41303C.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || XXXXXXXXX |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303C IS
-
-
-BEGIN
-
- TEST ( "C41303C" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR");
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO SCALAR ---------------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- NEWINT_CONST : NEWINT := 813 ;
- NEWINT_VAR : NEWINT := NEWINT_CONST ;
-
- TYPE ACC_NEWINT IS ACCESS NEWINT ;
-
- ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 );
-
- BEGIN
-
- NEWINT_VAR := ACC_NEWINT_VAR.ALL ;
-
- IF NEWINT_VAR /= ( 707 )
- THEN
- FAILED( "ACC. NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL.");
- END IF;
-
-
- ACC_NEWINT_VAR.ALL := NEWINT_CONST ;
-
- IF ACC_NEWINT_VAR.ALL /= 813
- THEN
- FAILED( "ACC. NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303e.ada b/gcc/testsuite/ada/acats/tests/c4/c41303e.ada
deleted file mode 100644
index f49dae2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303e.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C41303E.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || XXXXXXXXX |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303E IS
-
-
-BEGIN
-
- TEST ( "C41303E" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO RECORD ----------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
-
- TYPE ACCREC IS ACCESS REC ;
-
- ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 );
- ACCREC_VAR : ACCREC := ACCREC_CONST ;
- ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 );
-
- TYPE ACC_ACCREC IS ACCESS ACCREC ;
-
- ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2);
-
- BEGIN
-
- ACCREC_VAR := ACC_ACCREC_VAR.ALL ;
-
- IF ACCREC_VAR /= ACCREC_CONST2
- THEN
- FAILED( "ACC2 RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL.");
- END IF;
-
-
- ACC_ACCREC_VAR.ALL := ACCREC_CONST ;
-
- IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL
- THEN
- FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303f.ada b/gcc/testsuite/ada/acats/tests/c4/c41303f.ada
deleted file mode 100644
index aa474cd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303f.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C41303F.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || XXXXXXXXX |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303F IS
-
-BEGIN
-
- TEST ( "C41303F" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO ARRAY -----------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
- TYPE ACCARR IS ACCESS ARR ;
-
- ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE );
- ACCARR_VAR : ACCARR := ACCARR_CONST ;
- ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE );
-
- TYPE ACC_ACCARR IS ACCESS ACCARR ;
-
- ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2);
-
- BEGIN
-
- ACCARR_VAR := ACC_ACCARR_VAR.ALL ;
-
- IF ACCARR_VAR /= ACCARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- ACC_ACCARR_VAR.ALL := ACCARR_CONST ;
-
- IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL
- THEN
- FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303g.ada b/gcc/testsuite/ada/acats/tests/c4/c41303g.ada
deleted file mode 100644
index 39a6aa3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303g.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- C41303G.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || XXXXXXXXX |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303G IS
-
-
-BEGIN
-
- TEST ( "C41303G" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO SCALAR ----------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- TYPE ACCNEWINT IS ACCESS NEWINT ;
-
- ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 );
- ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ;
- ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 );
-
- TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ;
-
- ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'(
- ACCNEWINT_CONST2
- );
-
- BEGIN
-
- ACCNEWINT_VAR := ACC_ACCNEWINT_VAR.ALL ;
-
- IF ACCNEWINT_VAR /= ACCNEWINT_CONST2
- THEN
- FAILED( "ACC2 NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL.");
- END IF;
-
-
- ACC_ACCNEWINT_VAR.ALL := ACCNEWINT_CONST ;
-
- IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL
- THEN
- FAILED( "ACC2 NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303i.ada b/gcc/testsuite/ada/acats/tests/c4/c41303i.ada
deleted file mode 100644
index 1c0aff2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303i.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- C41303I.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || XXXXXXXXX |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303I IS
-
-
-BEGIN
-
- TEST ( "C41303I" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO RECORD ----------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
-
- REC_CONST : REC := ( 7 , 8 , 9 );
- REC_VAR : REC := REC_CONST ;
- REC_CONST2 : REC := ( 17 , 18 , 19 );
-
- TYPE ACCREC IS ACCESS REC ;
-
- TYPE ACC_ACCREC IS ACCESS ACCREC ;
-
- ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(
- NEW REC'( REC_CONST2 )
- );
-
- BEGIN
-
- REC_VAR := ACC_ACCREC_VAR.ALL.ALL ;
-
- IF REC_VAR /= REC_CONST2
- THEN
- FAILED( "ACC2 RECORD,RIGHT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- ACC_ACCREC_VAR.ALL.ALL := REC_CONST ;
-
- IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303j.ada b/gcc/testsuite/ada/acats/tests/c4/c41303j.ada
deleted file mode 100644
index fad2a39..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303j.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- C41303J.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || XXXXXXXXX |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303J IS
-
-
-BEGIN
-
- TEST ( "C41303J" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO ARRAY -----------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
-
- ARR_CONST : ARR := ( TRUE , FALSE );
- ARR_VAR : ARR := ARR_CONST ;
- ARR_CONST2 : ARR := ( FALSE , TRUE );
-
- TYPE ACCARR IS ACCESS ARR ;
-
- TYPE ACC_ACCARR IS ACCESS ACCARR ;
-
- ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(
- NEW ARR'( ARR_CONST2 )
- );
-
- BEGIN
-
- ARR_VAR := ACC_ACCARR_VAR.ALL.ALL ;
-
- IF ARR_VAR /= ARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- ACC_ACCARR_VAR.ALL.ALL := ARR_CONST ;
-
- IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303J;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303k.ada b/gcc/testsuite/ada/acats/tests/c4/c41303k.ada
deleted file mode 100644
index bb6f2a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303k.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C41303K.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || XXXXXXXXX |
--- ============================================================
-
-
--- RM 1/20/82
--- RM 1/25/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303K IS
-
-
-BEGIN
-
- TEST ( "C41303K" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO SCALAR ----------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- NEWINT_CONST : NEWINT := ( 813 );
- NEWINT_VAR : NEWINT := NEWINT_CONST ;
- NEWINT_CONST2 : NEWINT := ( 707 );
-
- TYPE ACCNEWINT IS ACCESS NEWINT ;
-
- TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ;
-
- ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'(
- NEW NEWINT' (
- NEWINT_CONST2
- )
- );
-
- BEGIN
-
- NEWINT_VAR := ACC_ACCNEWINT_VAR.ALL.ALL ;
-
- IF NEWINT_VAR /= NEWINT_CONST2
- THEN
- FAILED( "ACC2 NEWINT,RIGHT SIDE OF ASSIGN., WRONG VAL.");
- END IF;
-
-
- ACC_ACCNEWINT_VAR.ALL.ALL := NEWINT_CONST ;
-
- IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 NEWINT,LEFT SIDE OF ASSIGN., WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303K;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303m.ada b/gcc/testsuite/ada/acats/tests/c4/c41303m.ada
deleted file mode 100644
index f0c13d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303m.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C41303M.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || | XXXXXXXXX
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/22/82
--- RM 1/26/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303M IS
-
-
-BEGIN
-
- TEST ( "C41303M" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF"
- & " AN ACCESS OBJECT DESIGNATING A RECORD, AN"
- & " ARRAY, OR A SCALAR, IS ALLOWED AS"
- & " ACTUAL PARAMETER OF ANY MODE" );
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO RECORD ---------------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
- REC_CONST : REC := ( 7 , 8 , 9 );
- REC_VAR : REC := REC_CONST ;
- REC_VAR0 : REC := REC_CONST ;
-
- TYPE ACC_REC IS ACCESS REC ;
-
- ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 );
- ACC_REC_VAR0 : ACC_REC := NEW REC'( 17 , 18 , 19 );
-
-
- PROCEDURE R_ASSIGN( R_IN : IN REC ;
- R_INOUT : IN OUT REC ) IS
- BEGIN
- REC_VAR := R_IN ;
- REC_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT REC ;
- L_INOUT : IN OUT REC ) IS
- BEGIN
- L_OUT := REC_CONST ;
- L_INOUT := REC_CONST ;
- END ;
-
- BEGIN
-
- R_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL );
-
- IF REC_VAR /= ( 17 , 18 , 19 )
- THEN
- FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL.");
- END IF;
-
- IF REC_VAR0 /= ( 17 , 18 , 19 )
- THEN
- FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL.");
- END IF;
-
-
- L_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL );
-
- IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 )
- THEN
- FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
-
- IF ACC_REC_VAR0.ALL /= ( 7 , 8 , 9 )
- THEN
- FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303M;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303n.ada b/gcc/testsuite/ada/acats/tests/c4/c41303n.ada
deleted file mode 100644
index 431d01e..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303n.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- C41303N.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || | XXXXXXXXX
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/22/82
--- RM 1/26/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303N IS
-
-
-BEGIN
-
- TEST ( "C41303N" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF"
- & " AN ACCESS OBJECT DESIGNATING A RECORD, AN"
- & " ARRAY, OR A SCALAR, IS ALLOWED AS"
- & " ACTUAL PARAMETER OF ANY MODE" );
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO ARRAY ----------------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
-
- ARR_CONST : ARR := ( TRUE , FALSE );
- ARR_VAR : ARR := ARR_CONST ;
- ARR_VAR0 : ARR := ARR_CONST ;
-
- TYPE ACC_ARR IS ACCESS ARR ;
-
- ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE );
- ACC_ARR_VAR0 : ACC_ARR := NEW ARR'( FALSE , TRUE );
-
-
- PROCEDURE R_ASSIGN( R_IN : IN ARR ;
- R_INOUT : IN OUT ARR ) IS
- BEGIN
- ARR_VAR := R_IN ;
- ARR_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT ARR ;
- L_INOUT : IN OUT ARR ) IS
- BEGIN
- L_OUT := ARR_CONST ;
- L_INOUT := ARR_CONST ;
- END ;
-
- BEGIN
-
-
- R_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL );
-
- IF ARR_VAR /= ( FALSE , TRUE )
- THEN
- FAILED( "ACC. ARRAY, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ARR_VAR0 /= ( FALSE , TRUE )
- THEN
- FAILED( "ACC. ARRAY, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL );
-
- IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE )
- THEN
- FAILED( "ACC. ARRAY, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
-
- IF ACC_ARR_VAR0.ALL /= ( TRUE , FALSE )
- THEN
- FAILED( "ACC. ARRAY, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303N;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303o.ada b/gcc/testsuite/ada/acats/tests/c4/c41303o.ada
deleted file mode 100644
index 8f488bd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303o.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C41303O.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || | XXXXXXXXX
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/27/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303O IS
-
-
-BEGIN
-
- TEST ( "C41303O" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF"
- & " AN ACCESS OBJECT DESIGNATING A RECORD, AN"
- & " ARRAY, OR A SCALAR, IS ALLOWED AS"
- & " ACTUAL PARAMETER OF ANY MODE" );
-
-
- -------------------------------------------------------------------
- -------------------- ACCESS TO SCALAR ---------------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- NEWINT_CONST : NEWINT := 813 ;
- NEWINT_VAR : NEWINT := NEWINT_CONST ;
- NEWINT_VAR0 : NEWINT := NEWINT_CONST ;
-
- TYPE ACC_NEWINT IS ACCESS NEWINT ;
-
- ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 );
- ACC_NEWINT_VAR0 : ACC_NEWINT := NEW NEWINT'( 707 );
-
-
- PROCEDURE R_ASSIGN( R_IN : IN NEWINT ;
- R_INOUT : IN OUT NEWINT ) IS
- BEGIN
- NEWINT_VAR := R_IN ;
- NEWINT_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ;
- L_INOUT : IN OUT NEWINT ) IS
- BEGIN
- L_OUT := NEWINT_CONST ;
- L_INOUT := NEWINT_CONST ;
- END ;
-
-
- BEGIN
-
- R_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL );
-
- IF NEWINT_VAR /= ( 707 )
- THEN
- FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF NEWINT_VAR0 /= ( 707 )
- THEN
- FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL );
-
- IF ACC_NEWINT_VAR.ALL /= 813
- THEN
- FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACC_NEWINT_VAR0.ALL /= 813
- THEN
- FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303O;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303q.ada b/gcc/testsuite/ada/acats/tests/c4/c41303q.ada
deleted file mode 100644
index bf87562..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303q.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C41303Q.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || | XXXXXXXXX
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/28/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303Q IS
-
-
-BEGIN
-
- TEST ( "C41303Q" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO RECORD ----------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
-
- TYPE ACCREC IS ACCESS REC ;
-
- ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 );
- ACCREC_VAR : ACCREC := ACCREC_CONST ;
- ACCREC_VAR0 : ACCREC := ACCREC_CONST ;
- ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 );
-
- TYPE ACC_ACCREC IS ACCESS ACCREC ;
-
- ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2);
- ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2);
-
- PROCEDURE R_ASSIGN( R_IN : IN ACCREC ;
- R_INOUT : IN OUT ACCREC ) IS
- BEGIN
- ACCREC_VAR := R_IN ;
- ACCREC_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT ACCREC ;
- L_INOUT : IN OUT ACCREC ) IS
- BEGIN
- L_OUT := ACCREC_CONST ;
- L_INOUT := ACCREC_CONST ;
- END ;
-
-
- BEGIN
-
-
- R_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL );
-
- IF ACCREC_VAR /= ACCREC_CONST2
- THEN
- FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL.");
- END IF;
-
- IF ACCREC_VAR0 /= ACCREC_CONST2
- THEN
- FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL.");
- END IF;
-
-
- L_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL );
-
- IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL
- THEN
- FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACCREC_CONST /= ACC_ACCREC_VAR0.ALL
- THEN
- FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303Q;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303r.ada b/gcc/testsuite/ada/acats/tests/c4/c41303r.ada
deleted file mode 100644
index b219e3c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303r.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C41303R.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || | XXXXXXXXX
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/28/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303R IS
-
-BEGIN
-
- TEST ( "C41303R" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO ARRAY -----------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
- TYPE ACCARR IS ACCESS ARR ;
-
- ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE );
- ACCARR_VAR : ACCARR := ACCARR_CONST ;
- ACCARR_VAR0 : ACCARR := ACCARR_CONST ;
- ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE );
-
- TYPE ACC_ACCARR IS ACCESS ACCARR ;
-
- ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2);
- ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2);
-
-
- PROCEDURE R_ASSIGN( R_IN : IN ACCARR ;
- R_INOUT : IN OUT ACCARR ) IS
- BEGIN
- ACCARR_VAR := R_IN ;
- ACCARR_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT ACCARR ;
- L_INOUT : IN OUT ACCARR ) IS
- BEGIN
- L_OUT := ACCARR_CONST ;
- L_INOUT := ACCARR_CONST ;
- END ;
-
-
- BEGIN
-
- R_ASSIGN( ACC_ACCARR_VAR.ALL, ACC_ACCARR_VAR0.ALL );
-
- IF ACCARR_VAR /= ACCARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACCARR_VAR0 /= ACCARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ACCARR_VAR.ALL , ACC_ACCARR_VAR0.ALL );
-
- IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL
- THEN
- FAILED( "ACC2. ARRAY, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACCARR_CONST /= ACC_ACCARR_VAR0.ALL
- THEN
- FAILED( "ACC2. ARRAY, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303R;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303s.ada b/gcc/testsuite/ada/acats/tests/c4/c41303s.ada
deleted file mode 100644
index 09ce2f4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303s.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- C41303S.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || | XXXXXXXXX
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/28/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303S IS
-
-
-BEGIN
-
- TEST ( "C41303S" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF"
- & " L IS THE NAME OF AN ACCESS OBJECT"
- & " DESIGNATING ANOTHER ACCESS OBJECT" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO SCALAR ----------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- TYPE ACCNEWINT IS ACCESS NEWINT ;
-
- ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 );
- ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ;
- ACCNEWINT_VAR0 : ACCNEWINT := ACCNEWINT_CONST ;
- ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 );
-
- TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ;
-
- ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'(
- ACCNEWINT_CONST2
- );
-
- ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'(
- ACCNEWINT_CONST2
- );
-
- PROCEDURE R_ASSIGN( R_IN : IN ACCNEWINT ;
- R_INOUT : IN OUT ACCNEWINT ) IS
- BEGIN
- ACCNEWINT_VAR := R_IN ;
- ACCNEWINT_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT ACCNEWINT ;
- L_INOUT : IN OUT ACCNEWINT ) IS
- BEGIN
- L_OUT := ACCNEWINT_CONST ;
- L_INOUT := ACCNEWINT_CONST ;
- END ;
-
-
- BEGIN
-
- R_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL );
-
- IF ACCNEWINT_VAR /= ACCNEWINT_CONST2
- THEN
- FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACCNEWINT_VAR0 /= ACCNEWINT_CONST2
- THEN
- FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL );
-
- IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL
- THEN
- FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL
- THEN
- FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303S;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303u.ada b/gcc/testsuite/ada/acats/tests/c4/c41303u.ada
deleted file mode 100644
index 92a7601..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303u.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C41303U.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || | XXXXXXXXX
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/29/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303U IS
-
-
-BEGIN
-
- TEST ( "C41303U" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO RECORD ----------------------
-
- DECLARE
-
- TYPE REC IS
-
- RECORD
- A , B , C : INTEGER ;
- END RECORD ;
-
-
- REC_CONST : REC := ( 7 , 8 , 9 );
- REC_VAR : REC := REC_CONST ;
- REC_VAR0 : REC := REC_CONST ;
- REC_CONST2 : REC := ( 17 , 18 , 19 );
-
- TYPE ACCREC IS ACCESS REC ;
-
- TYPE ACC_ACCREC IS ACCESS ACCREC ;
-
- ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(
- NEW REC'( REC_CONST2 )
- );
-
- ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'(
- NEW REC'( REC_CONST2 )
- );
-
-
- PROCEDURE R_ASSIGN( R_IN : IN REC ;
- R_INOUT : IN OUT REC ) IS
- BEGIN
- REC_VAR := R_IN ;
- REC_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT REC ;
- L_INOUT : IN OUT REC ) IS
- BEGIN
- L_OUT := REC_CONST ;
- L_INOUT := REC_CONST ;
- END ;
-
-
- BEGIN
-
- R_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL );
-
- IF REC_VAR /= REC_CONST2
- THEN
- FAILED( "ACC2 RECORD, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF REC_VAR0 /= REC_CONST2
- THEN
- FAILED( "ACC2 RECORD, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL );
-
- IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 RECORD, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR0.ALL.ALL
- THEN
- FAILED( "ACC2 RECORD, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303U;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303v.ada b/gcc/testsuite/ada/acats/tests/c4/c41303v.ada
deleted file mode 100644
index e6a6259..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303v.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- C41303V.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || | XXXXXXXXX
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ============================================================
-
-
--- RM 1/29/82
--- SPS 12/2/82
-
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303V IS
-
-
-BEGIN
-
- TEST ( "C41303V" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO ARRAY -----------------------
-
- DECLARE
-
- TYPE ARR IS ARRAY(1..2) OF BOOLEAN ;
-
- ARR_CONST : ARR := ( TRUE , FALSE );
- ARR_VAR : ARR := ARR_CONST ;
- ARR_VAR0 : ARR := ARR_CONST ;
- ARR_CONST2 : ARR := ( FALSE , TRUE );
-
- TYPE ACCARR IS ACCESS ARR ;
-
- TYPE ACC_ACCARR IS ACCESS ACCARR ;
-
- ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(
- NEW ARR'( ARR_CONST2 )
- );
-
- ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'(
- NEW ARR'( ARR_CONST2 )
- );
-
-
- PROCEDURE R_ASSIGN( R_IN : IN ARR ;
- R_INOUT : IN OUT ARR ) IS
- BEGIN
- ARR_VAR := R_IN ;
- ARR_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT ARR ;
- L_INOUT : IN OUT ARR ) IS
- BEGIN
- L_OUT := ARR_CONST ;
- L_INOUT := ARR_CONST ;
- END ;
-
-
- BEGIN
-
-
- R_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL );
-
- IF ARR_VAR /= ARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ARR_VAR0 /= ARR_CONST2
- THEN
- FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL );
-
- IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 ARRAY, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR0.ALL.ALL
- THEN
- FAILED( "ACC2 ARRAY, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303V;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303w.ada b/gcc/testsuite/ada/acats/tests/c4/c41303w.ada
deleted file mode 100644
index a1bf580..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41303w.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- C41303W.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 NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN
--- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR
--- ANOTHER ACCESS OBJECT.
--- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH
--- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS
--- ACCEPTED.
-
-
--- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM,
--- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' .
-
-
--- || ASSIGNMT | PROC. PARAMETERS
--- || ():= :=() | IN OUT IN OUT
--- ========================||=============|====================
--- ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ARR || |
--- --------------||-------------|--------------------
--- ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 1 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || |
--- ========================||=============|====================
--- ACC ACC REC || |
--- --------------||-------------|--------------------
--- 2 '.ALL' ACC ACC ARR || |
--- --------------||-------------|--------------------
--- ACC ACC SCLR || | XXXXXXXXX
--- ============================================================
-
-
--- RM 1/29/82
--- SPS 12/2/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41303W IS
-
-
-BEGIN
-
- TEST ( "C41303W" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" &
- " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" &
- " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" &
- " ACCEPTED" );
-
-
- -------------------------------------------------------------------
- --------------- ACCESS TO ACCESS TO SCALAR ----------------------
-
- DECLARE
-
- TYPE NEWINT IS NEW INTEGER ;
-
- NEWINT_CONST : NEWINT := ( 813 );
- NEWINT_VAR : NEWINT := NEWINT_CONST ;
- NEWINT_VAR0 : NEWINT := NEWINT_CONST ;
- NEWINT_CONST2 : NEWINT := ( 707 );
-
- TYPE ACCNEWINT IS ACCESS NEWINT ;
-
- TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ;
-
- ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'(
- NEW NEWINT' (
- NEWINT_CONST2
- )
- );
-
- ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'(
- NEW NEWINT' (
- NEWINT_CONST2
- )
- );
-
- PROCEDURE R_ASSIGN( R_IN : IN NEWINT ;
- R_INOUT : IN OUT NEWINT ) IS
- BEGIN
- NEWINT_VAR := R_IN ;
- NEWINT_VAR0 := R_INOUT ;
- END ;
-
-
- PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ;
- L_INOUT : IN OUT NEWINT ) IS
- BEGIN
- L_OUT := NEWINT_CONST ;
- L_INOUT := NEWINT_CONST ;
- END ;
-
-
- BEGIN
-
-
- R_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL ,
- ACC_ACCNEWINT_VAR0.ALL.ALL );
-
- IF NEWINT_VAR /= NEWINT_CONST2
- THEN
- FAILED( "ACC2 NEWINT, RIGHT SIDE (1), WRONG VAL." );
- END IF;
-
- IF NEWINT_VAR0 /= NEWINT_CONST2
- THEN
- FAILED( "ACC2 NEWINT, RIGHT SIDE (2), WRONG VAL." );
- END IF;
-
-
- L_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL ,
- ACC_ACCNEWINT_VAR0.ALL.ALL );
-
- IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL
- THEN
- FAILED( "ACC2 NEWINT, LEFT SIDE (1), WRONG VAL." );
- END IF;
-
- IF NEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL.ALL
- THEN
- FAILED( "ACC2 NEWINT, LEFT SIDE (2), WRONG VAL." );
- END IF;
-
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41303W;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41304a.ada b/gcc/testsuite/ada/acats/tests/c4/c41304a.ada
deleted file mode 100644
index 124d527..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41304a.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- C41304A.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 L.R RAISES CONSTRAINT_ERROR WHEN:
--- L DENOTES AN ACCESS OBJECT HAVING THE VALUE NULL.
--- L IS A FUNCTION CALL DELIVERING THE ACCESS VALUE NULL.
-
--- HISTORY:
--- WKB 08/14/81
--- JRK 08/17/81
--- SPS 10/26/82
--- TBN 03/26/86 PUT THE NON-EXISTENT COMPONENT CASES INTO C41304B.
--- JET 01/05/88 MODIFIED HEADER FORMAT AND ADDED CODE TO PREVENT
--- OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41304A IS
-
- TYPE R IS
- RECORD
- I : INTEGER;
- END RECORD;
-
- TYPE T IS ACCESS R;
-
-BEGIN
- TEST ("C41304A", "CONSTRAINT_ERROR WHEN L IN L.R DENOTES A NULL " &
- "ACCESS OBJECT OR A FUNCTION CALL DELIVERING " &
- "NULL");
-
- --------------------------------------------------
-
- DECLARE
-
- A : T := NEW R' (I => 1);
- J : INTEGER;
-
- BEGIN
-
- IF EQUAL (4, 4) THEN
- A := NULL;
- END IF;
-
- J := A.I;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A NULL ACCESS " &
- "OBJECT");
-
- IF EQUAL (J,J) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR A NULL ACCESS " &
- "OBJECT");
-
- END;
-
- --------------------------------------------------
-
- DECLARE
-
- J : INTEGER;
-
- FUNCTION F RETURN T IS
- BEGIN
- IF EQUAL (4, 4) THEN
- RETURN NULL;
- END IF;
- RETURN NEW R' (I => 2);
- END F;
-
- BEGIN
-
- J := F.I;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
- "DELIVERING A NULL ACCESS VALUE");
-
- IF EQUAL (J,J) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
- "DELIVERING A NULL ACCESS VALUE");
-
- END;
-
- RESULT;
-END C41304A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41304b.ada b/gcc/testsuite/ada/acats/tests/c4/c41304b.ada
deleted file mode 100644
index c6dec9c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41304b.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- C41304B.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 L.R RAISES CONSTRAINT_ERROR WHEN:
--- L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING
--- DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES
--- NOT EXIST.
--- L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT,
--- FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT
--- DENOTED BY R DOES NOT EXIST.
--- L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS
--- VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE
--- OBJECT'S CURRENT DISCRIMINANT VALUES.
--- L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT
--- DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R
--- DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT
--- VALUES.
-
--- HISTORY:
--- TBN 05/23/86 CREATED ORIGINAL TEST.
--- JET 01/08/88 MODIFIED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41304B IS
-
- TYPE V (DISC : INTEGER := 0) IS
- RECORD
- CASE DISC IS
- WHEN 1 =>
- X : INTEGER;
- WHEN OTHERS =>
- Y : INTEGER;
- END CASE;
- END RECORD;
-
- TYPE T IS ACCESS V;
-
-BEGIN
- TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " &
- "THE COMPONENT DENOTED BY R DOES NOT EXIST");
-
- DECLARE
-
- VR : V := (DISC => 0, Y => 4);
- J : INTEGER;
-
- BEGIN
-
- IF EQUAL (4, 4) THEN
- VR := (DISC => 1, X => 3);
- END IF;
-
- J := VR.Y;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT");
-
- -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
-
- IF EQUAL (J,3) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT");
-
- END;
-
- --------------------------------------------------
-
- DECLARE
-
- J : INTEGER;
-
- FUNCTION F RETURN V IS
- BEGIN
- IF EQUAL (4, 4) THEN
- RETURN (DISC => 2, Y => 3);
- END IF;
- RETURN (DISC => 1, X => 4);
- END F;
-
- BEGIN
-
- J := F.X;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
- "DELIVERING A RECORD VALUE");
-
- -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
-
- IF EQUAL (J,3) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
- "DELIVERING A RECORD VALUE");
-
- END;
-
- --------------------------------------------------
-
- DECLARE
-
- A : T := NEW V' (DISC => 0, Y => 4);
- J : INTEGER;
-
- BEGIN
-
- IF EQUAL (4, 4) THEN
- A := NEW V' (DISC => 1, X => 3);
- END IF;
-
- J := A.Y;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT");
-
- -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
-
- IF EQUAL (J,3) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT");
-
- END;
-
- --------------------------------------------------
-
- DECLARE
-
- J : INTEGER;
-
- FUNCTION F RETURN T IS
- BEGIN
- IF EQUAL (4, 4) THEN
- RETURN NEW V' (DISC => 2, Y => 3);
- END IF;
- RETURN NEW V' (DISC => 1, X => 4);
- END F;
-
- BEGIN
-
- J := F.X;
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
- "DELIVERING AN ACCESS VALUE");
-
- -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J.
-
- IF EQUAL (J,3) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
- "DELIVERING AN ACCESS VALUE");
-
- END;
-
- RESULT;
-END C41304B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306a.ada b/gcc/testsuite/ada/acats/tests/c4/c41306a.ada
deleted file mode 100644
index 2521d7b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41306a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C41306A.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 F IS A FUNCTION RETURNING A TASK OF A TYPE HAVING
--- AN ENTRY E , AN ENTRY CALL OF THE FORM
---
--- F.E
---
--- IS PERMITTED.
-
-
--- RM 2/2/82
--- ABW 7/16/82
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C41306A IS
-
-
-BEGIN
-
- TEST ( "C41306A" , "CHECK THAT IF F IS A FUNCTION RETURNING" &
- " A TASK OF A TYPE HAVING AN ENTRY E , AN" &
- " ENTRY CALL OF THE FORM F.E IS PERMITTED");
-
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- T1 : T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- ACCEPT E DO
- X := IDENT_INT(16) ;
- END E ;
- END T ;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- RETURN T1 ;
- END F1 ;
-
- FUNCTION F2 (A,B : BOOLEAN) RETURN T IS
- BEGIN
- IF A AND B THEN NULL; END IF;
- RETURN T1;
- END F2;
-
- BEGIN
-
- F1.E ; -- X SET TO 17.
-
- IF X /= 17 THEN
- FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 1");
- END IF;
-
- X := 0;
- F2(TRUE,TRUE).E; -- X SET TO 16.
- -- X TO BE SET TO 16.
-
- IF X /= 16 THEN
- FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 2");
- END IF;
-
- END ;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-
-END C41306A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306b.ada b/gcc/testsuite/ada/acats/tests/c4/c41306b.ada
deleted file mode 100644
index 390f978..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41306b.ada
+++ /dev/null
@@ -1,217 +0,0 @@
--- C41306B.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 F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING
--- A TASK OF A TYPE HAVING
--- AN ENTRY E , AN ENTRY CALL OF THE FORM
---
--- F.ALL.E
---
--- IS PERMITTED.
-
--- RM 02/02/82
--- ABW 07/16/82
--- EG 05/28/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C41306B IS
-
-BEGIN
-
- TEST ( "C41306B" , "CHECK THAT IF F IS A FUNCTION RETURNING" &
- " AN ACCESS VALUE DESIGNATING" &
- " A TASK OF A TYPE HAVING AN ENTRY E , AN" &
- " ENTRY CALL OF THE FORM F.ALL.E IS" &
- " PERMITTED" );
-
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- FUNCTION F1 RETURN A_T IS
- A_T_VAR1 : A_T := NEW T ;
- BEGIN
- RETURN A_T_VAR1 ;
- END F1 ;
-
- FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS
- A_T_VAR2 : A_T := NEW T;
- BEGIN
- IF A AND B THEN
- NULL;
- END IF;
- RETURN A_T_VAR2;
- END F2;
-
- BEGIN
-
- F1.ALL.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK,
- -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO
- -- BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17
- THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" );
- END IF;
-
- X := 0;
- F2(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F2 (BODY)
- -- ACTIVATES THE TASK, WHICH
- -- PROCEEDS TO WAIT FOR THE
- -- ENTRY E TO BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE
- -- SET TO 17.
-
- IF X /= 17 THEN
- FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)");
- END IF;
-
- END ;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- FUNCTION F3 RETURN A_T IS
- BEGIN
- RETURN NEW T ;
- END F3;
-
- FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS
- BEGIN
- IF C AND D THEN
- NULL;
- END IF;
- RETURN NEW T;
- END F4;
-
- BEGIN
-
- F3.ALL.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK,
- -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO
- -- BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17
- THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" );
- END IF;
-
- X := 0;
- F4(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F4 (BODY)
- -- ACTIVATES THE TASK, WHICH
- -- PROCEEDS TO WAIT FOR THE
- -- ENTRY E TO BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE
- -- SET TO 17.
-
- IF X /= 17 THEN
- FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)");
- END IF;
-
- END ;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- BEGIN
-
- DECLARE
-
- F3 : A_T := NEW T;
-
- BEGIN
-
- F3.ALL.E;
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17 THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" );
- END IF;
-
- END;
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C41306B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306c.ada b/gcc/testsuite/ada/acats/tests/c4/c41306c.ada
deleted file mode 100644
index dc715c8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41306c.ada
+++ /dev/null
@@ -1,215 +0,0 @@
--- C41306C.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 F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING
--- A TASK OF A TYPE HAVING
--- AN ENTRY E , AN ENTRY CALL OF THE FORM
---
--- F.E
---
--- IS PERMITTED.
-
-
--- RM 02/02/82
--- ABW 07/16/82
--- EG 05/28/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C41306C IS
-
-BEGIN
-
- TEST ( "C41306C" , "CHECK THAT IF F IS A FUNCTION RETURNING" &
- " AN ACCESS VALUE DESIGNATING" &
- " A TASK OF A TYPE HAVING AN ENTRY E , AN" &
- " ENTRY CALL OF THE FORM F.E IS PERMITTED" );
-
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- FUNCTION F1 RETURN A_T IS
- A_T_VAR1 : A_T := NEW T ;
- BEGIN
- RETURN A_T_VAR1 ;
- END F1 ;
-
- FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS
- A_T_VAR2 : A_T := NEW T;
- BEGIN
- IF A AND B THEN
- NULL;
- END IF;
- RETURN A_T_VAR2;
- END F2;
-
- BEGIN
-
- F1.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK,
- -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO
- -- BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17
- THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" );
- END IF;
-
- X := 0;
- F2(TRUE, TRUE).E; -- THE ELABORATION OF F2 (BODY) ACTIVATES
- -- THE TASK, WHICH PROCEEDS TO WAIT FOR
- -- ENTRY E TO BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO
- -- 17.
-
- IF X /= 17 THEN
- FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)");
- END IF;
-
- END ;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- FUNCTION F3 RETURN A_T IS
- BEGIN
- RETURN NEW T ;
- END F3;
-
- FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS
- BEGIN
- IF C AND D THEN
- NULL;
- END IF;
- RETURN NEW T;
- END F4;
-
- BEGIN
-
- F3.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK,
- -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO
- -- BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17
- THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" );
- END IF;
-
- X := 0;
- F4(TRUE, TRUE).E; -- THE ELABORATION OF F4 (BODY) ACTIVATES
- -- THE TASK WHICH PROCEEDS TO WAIT FOR
- -- ENTRY E TO BE CALLED.
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO
- -- 17.
-
- IF X /= 17 THEN
- FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)");
- END IF;
-
- END ;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- X : INTEGER := 0 ;
-
- TASK TYPE T IS
- ENTRY E ;
- END T ;
-
- TYPE A_T IS ACCESS T ;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E DO
- X := IDENT_INT(17) ;
- END E ;
- END T ;
-
- BEGIN
-
- DECLARE
-
- F3 : A_T := NEW T;
-
- BEGIN
-
- F3.E;
-
- -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 .
-
- IF X /= 17 THEN
- FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" );
- END IF;
-
- END;
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C41306C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41307d.ada b/gcc/testsuite/ada/acats/tests/c4/c41307d.ada
deleted file mode 100644
index e65e79f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41307d.ada
+++ /dev/null
@@ -1,255 +0,0 @@
--- C41307D.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 L.R IS ALLOWED INSIDE A PACKAGE, GENERIC PACKAGE,
--- SUBPROGRAM, GENERIC SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT
--- STATEMENT NAMED L, IF R IS DECLARED INSIDE THE UNIT.
-
--- TBN 12/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41307D IS
-
-BEGIN
- TEST ("C41307D", "CHECK THAT L.R IS ALLOWED INSIDE A PACKAGE, " &
- "GENERIC PACKAGE, SUBPROGRAM, GENERIC " &
- "SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT " &
- "STATEMENT NAMED L, IF R IS DECLARED INSIDE " &
- "THE UNIT");
- DECLARE
- PACKAGE L IS
- R : INTEGER := 5;
- A : INTEGER := L.R;
- END L;
-
- PACKAGE BODY L IS
- B : INTEGER := L.R + 1;
- BEGIN
- IF IDENT_INT(A) /= 5 OR IDENT_INT(B) /= 6 THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
- END L;
-
- GENERIC
- S : INTEGER;
- PACKAGE M IS
- X : INTEGER := M.S;
- END M;
-
- PACKAGE BODY M IS
- Y : INTEGER := M.S + 1;
- BEGIN
- IF IDENT_INT(X) /= 2 OR
- IDENT_INT(Y) /= 3 OR
- IDENT_INT(M.X) /= 2 THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
- END M;
-
- PACKAGE Q IS NEW M(2);
- BEGIN
- IF IDENT_INT(Q.X) /= 2 THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- CH : CHARACTER := '6';
-
- PROCEDURE L (R : IN OUT CHARACTER) IS
- A : CHARACTER := L.R;
- BEGIN
- IF IDENT_CHAR(L.A) /= '6' THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
- L.R := IDENT_CHAR('7');
- END L;
-
- GENERIC
- S : CHARACTER;
- PROCEDURE M;
-
- PROCEDURE M IS
- T : CHARACTER := M.S;
- BEGIN
- IF IDENT_CHAR(T) /= '3' OR IDENT_CHAR(M.S) /= '3' THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
- END M;
-
- PROCEDURE P1 IS NEW M('3');
-
- BEGIN
- L (CH);
- IF CH /= IDENT_CHAR('7') THEN
- FAILED ("INCORRECT RESULTS RETURNED FROM PROCEDURE - 6");
- END IF;
- P1;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- INT : INTEGER := 3;
-
- FUNCTION L (R : INTEGER) RETURN INTEGER IS
- A : INTEGER := L.R;
- BEGIN
- IF IDENT_INT(L.A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
- RETURN IDENT_INT(4);
- END L;
-
- GENERIC
- S : INTEGER;
- FUNCTION M RETURN INTEGER;
-
- FUNCTION M RETURN INTEGER IS
- T : INTEGER := M.S;
- BEGIN
- IF IDENT_INT(M.T) /= 4 OR M.S /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
- RETURN IDENT_INT(1);
- END M;
-
- FUNCTION F1 IS NEW M(4);
-
- BEGIN
- IF L(INT) /= 4 OR F1 /= 1 THEN
- FAILED ("INCORRECT RESULTS RETURNED FROM FUNCTION - 9");
- END IF;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- TASK L IS
- ENTRY E (A : INTEGER);
- END L;
-
- TASK TYPE M IS
- ENTRY E1 (A : INTEGER);
- END M;
-
- T1 : M;
-
- TASK BODY L IS
- X : INTEGER := IDENT_INT(1);
- R : INTEGER RENAMES X;
- Y : INTEGER := L.R;
- BEGIN
- X := X + L.R;
- IF X /= IDENT_INT(2) OR Y /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " &
- "10");
- END IF;
- END L;
-
- TASK BODY M IS
- X : INTEGER := IDENT_INT(2);
- R : INTEGER RENAMES X;
- Y : INTEGER := M.R;
- BEGIN
- ACCEPT E1 (A : INTEGER) DO
- X := X + M.R;
- IF X /= IDENT_INT(4) OR Y /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED " &
- "NAME - 11");
- END IF;
- IF E1.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED " &
- "NAME - 12");
- END IF;
- END E1;
- END M;
- BEGIN
- T1.E1 (3);
- END;
- -------------------------------------------------------------------
-
- DECLARE
- TASK T IS
- ENTRY G (1..2) (A : INTEGER);
- END T;
-
- TASK BODY T IS
- BEGIN
- ACCEPT G (1) (A : INTEGER) DO
- IF G.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED " &
- "NAME - 13");
- END IF;
- BLK:
- DECLARE
- B : INTEGER := 7;
- BEGIN
- IF T.BLK.B /= IDENT_INT(7) THEN
- FAILED ("INCORRECT RESULTS FROM " &
- "EXPANDED NAME - 14");
- END IF;
- END BLK;
- END G;
- ACCEPT G (2) (A : INTEGER) DO
- IF G.A /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED " &
- "NAME - 15");
- END IF;
- END G;
- END T;
- BEGIN
- T.G (1) (2);
- T.G (2) (1);
- END;
- -------------------------------------------------------------------
-
- SWAP:
- DECLARE
- VAR : CHARACTER := '*';
- RENAME_VAR : CHARACTER RENAMES VAR;
- NEW_VAR : CHARACTER;
- BEGIN
- IF EQUAL (3, 3) THEN
- NEW_VAR := SWAP.RENAME_VAR;
- END IF;
- IF NEW_VAR /= IDENT_CHAR('*') THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " &
- "16");
- END IF;
- LP: FOR I IN 1..2 LOOP
- IF SWAP.LP.I = IDENT_INT(2) OR
- LP.I = IDENT_INT(1) THEN
- GOTO SWAP.LAB1;
- END IF;
- NEW_VAR := IDENT_CHAR('+');
- <<LAB1>>
- NEW_VAR := IDENT_CHAR('-');
- END LOOP LP;
- IF NEW_VAR /= IDENT_CHAR('-') THEN
- FAILED ("INCORRECT RESULTS FROM FOR LOOP - 17");
- END IF;
- END SWAP;
-
- RESULT;
-END C41307D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41309a.ada b/gcc/testsuite/ada/acats/tests/c4/c41309a.ada
deleted file mode 100644
index a1dc917..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41309a.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C41309A.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 EXPANDED NAME IS ALLOWED EVEN IF A USE CLAUSE MAKES THE
--- EXPANDED NAME UNNECESSARY.
-
--- TBN 12/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41309A IS
-
-BEGIN
- TEST ("C41309A", "CHECK THAT AN EXPANDED NAME IS ALLOWED EVEN " &
- "IF A USE CLAUSE MAKES THE EXPANDED NAME " &
- "UNNECESSARY");
- DECLARE
- PACKAGE P IS
- PACKAGE Q IS
- PACKAGE R IS
- TYPE REC IS
- RECORD
- A : INTEGER := 5;
- B : BOOLEAN := TRUE;
- END RECORD;
- REC1 : REC;
- END R;
-
- USE R;
-
- REC2 : R.REC := R.REC1;
- END Q;
-
- USE Q; USE R;
-
- REC3 : Q.R.REC := Q.REC2;
- END P;
-
- USE P; USE Q; USE R;
-
- REC4 : P.Q.R.REC := P.REC3;
- BEGIN
- IF REC4 /= (IDENT_INT(5), IDENT_BOOL(TRUE)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME");
- END IF;
- END;
-
- RESULT;
-END C41309A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41320a.ada b/gcc/testsuite/ada/acats/tests/c4/c41320a.ada
deleted file mode 100644
index 011174a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41320a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- C41320A.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 IMPLICITLY DECLARED ENUMERATION LITERALS, CHARACTER
--- LITERALS, AND THE RELATIONAL OPERATORS CAN BE SELECTED FROM
--- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR ENUMERATION TYPES.
-
--- HISTORY:
--- TBN 07/15/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 ADDED TEST FOR OVERLOADED VARIABLES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41320A IS
-
- PACKAGE P IS
- TYPE FLAG IS (RED, WHITE, BLUE);
- TYPE ROMAN_DIGITS IS ('I', 'V', 'X', 'C', 'M');
- TYPE TRAFFIC_LIGHT IS (RED, YELLOW, GREEN);
- TYPE HEX IS ('A', 'B', 'C', 'D', 'E', 'F');
- FLAG_COLOR_1 : FLAG := RED;
- FLAG_COLOR_2 : FLAG := WHITE;
- TRAFFIC_LIGHT_COLOR_1 : FLAG := RED;
- HEX_3 : HEX := 'C';
- ROMAN_1 : ROMAN_DIGITS := 'I';
- END P;
-
- USA_FLAG_1 : P.FLAG := P.RED;
- USA_FLAG_3 : P.FLAG := P.BLUE;
- HEX_CHAR_3 : P.HEX := P.'C';
- ROMAN_DIGITS_4 : P.ROMAN_DIGITS := P.'C';
- TRAFFIC_LIGHT_1 : P.TRAFFIC_LIGHT := P.RED;
-
-BEGIN
- TEST ("C41320A", "CHECK THAT IMPLICITLY DECLARED ENUMERATION " &
- "LITERALS, CHARACTER LITERALS, AND THE " &
- "RELATIONAL OPERATORS CAN BE SELECTED FROM " &
- "OUTSIDE THE PACKAGE USING AN EXPANDED NAME " &
- "FOR ENUMERATION TYPES");
-
- IF P."/=" (USA_FLAG_1, P.FLAG_COLOR_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."=" (USA_FLAG_3, P.FLAG_COLOR_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."<" (HEX_CHAR_3, P.HEX_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P.">" (P.ROMAN_1, ROMAN_DIGITS_4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P.">=" (TRAFFIC_LIGHT_1, P.TRAFFIC_LIGHT'PRED (P.GREEN)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- FOR J IN P.FLAG'(P.WHITE) .. P.FLAG'(P.WHITE) LOOP
- IF P."<=" (P.FLAG'SUCC (P.WHITE), J) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
- END LOOP;
-
- IF P.">=" (P.RED, P.GREEN) THEN
- FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 1");
- END IF;
-
- IF P."<=" (P.BLUE, P.RED) THEN
- FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 2");
- END IF;
-
- RESULT;
-END C41320A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41321a.ada b/gcc/testsuite/ada/acats/tests/c4/c41321a.ada
deleted file mode 100644
index 8064c12..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41321a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- C41321A.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 IMPLICITLY DECLARED RELATIONAL OPERATORS, LOGICAL
--- OPERATORS, AND THE "NOT" OPERATOR MAY BE SELECTED FROM OUTSIDE
--- THE PACKAGE USING AN EXPANDED NAME, FOR A DERIVED BOOLEAN TYPE.
-
--- TBN 7/16/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41321A IS
-
- PACKAGE P IS
- TYPE DERIVED_BOOLEAN IS NEW BOOLEAN RANGE FALSE .. TRUE;
- DERIVED_FALSE : DERIVED_BOOLEAN := FALSE;
- DERIVED_TRUE : DERIVED_BOOLEAN := TRUE;
- END P;
-
- DBOOL_FALSE : P.DERIVED_BOOLEAN := P.FALSE;
- DBOOL_TRUE : P.DERIVED_BOOLEAN := P.TRUE;
-
-BEGIN
- TEST ("C41321A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " &
- "OPERATORS, LOGICAL OPERATORS, AND THE 'NOT' " &
- "OPERATOR MAY BE SELECTED FROM OUTSIDE THE " &
- "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " &
- "BOOLEAN TYPE");
-
- IF P."=" (DBOOL_FALSE, P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (DBOOL_TRUE, P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."<" (P.DERIVED_TRUE, P.DERIVED_FALSE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P.">" (DBOOL_TRUE, P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P."<=" (P.DERIVED_TRUE, DBOOL_FALSE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- IF P."<=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
-
- IF P.">=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
-
- FOR J IN P.DERIVED_BOOLEAN'(P.TRUE) .. P.DERIVED_BOOLEAN'(P.TRUE)
- LOOP
- IF P.">=" (DBOOL_FALSE, J) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
- END LOOP;
-
- IF P."AND" (DBOOL_FALSE, P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9");
- END IF;
-
- IF P."OR" (DBOOL_FALSE, P.DERIVED_FALSE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10");
- END IF;
-
- IF P."XOR" (DBOOL_TRUE, P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11");
- END IF;
-
- IF P."NOT" (P.DERIVED_TRUE) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12");
- END IF;
-
- RESULT;
-END C41321A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41322a.ada b/gcc/testsuite/ada/acats/tests/c4/c41322a.ada
deleted file mode 100644
index eaf3a6f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41322a.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C41322A.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 IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC
--- OPERATORS (+, -, *, /, **, ABS, MOD, REM) MAY BE SELECTED FROM
--- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN INTEGER TYPE.
-
--- TBN 7/16/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41322A IS
-
- PACKAGE P IS
- TYPE INT IS RANGE -10 .. 10;
- OBJ_INT_1 : INT := -10;
- OBJ_INT_2 : INT := 1;
- OBJ_INT_3 : INT := 10;
- END P;
-
- INT_VAR : P.INT;
- INT_VAR_1 : P.INT := P."-"(P.INT'(10));
- INT_VAR_2 : P.INT := P.INT'(1);
- INT_VAR_3 : P.INT := P.INT'(10);
-
-BEGIN
- TEST ("C41322A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " &
- "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " &
- "/, **, ABS, MOD, REM) MAY BE SELECTED FROM " &
- "OUTSIDE THE PACKAGE USING AN EXPANDED NAME, " &
- "FOR AN INTEGER TYPE");
-
- IF P."=" (INT_VAR_1, P.INT'(2)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (INT_VAR_1, P.OBJ_INT_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."<" (INT_VAR_2, 0) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P.">" (INT_VAR_2, P.OBJ_INT_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P."<=" (INT_VAR_3, P.INT'(9)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- FOR J IN P.INT'(4) .. P.INT'(4) LOOP
- IF P.">=" (J, INT_VAR_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
- END LOOP;
-
- INT_VAR := P."+" (INT_VAR_1, P.INT'(2));
- IF P."/=" (INT_VAR, P."-"(P.INT'(8))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
-
- INT_VAR := P."+" (P.INT'(2));
- IF P."/=" (INT_VAR, P.INT'(2)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
-
- INT_VAR := P."-" (INT_VAR_2, P.INT'(0));
- IF P."/=" (INT_VAR, P.OBJ_INT_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9");
- END IF;
-
- INT_VAR := P."*" (INT_VAR_2, P.INT'(5));
- IF P."/=" (INT_VAR, P.INT'(5)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10");
- END IF;
-
- INT_VAR := P."/" (INT_VAR_3, P.INT'(2));
- IF P."/=" (INT_VAR, P.INT'(5)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11");
- END IF;
-
- INT_VAR := P."**" (P.INT'(2), 3);
- IF P."/=" (INT_VAR, P.INT'(8)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12");
- END IF;
-
- INT_VAR := P."ABS" (INT_VAR_1);
- IF P."/=" (INT_VAR, P.OBJ_INT_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13");
- END IF;
-
- INT_VAR := P."MOD" (INT_VAR_1, P.INT'(3));
- IF P."/=" (INT_VAR, P.INT'(2)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14");
- END IF;
-
- INT_VAR := P."REM" (INT_VAR_1, P.INT'(3));
- IF P."/=" (INT_VAR, P."-" (INT_VAR_2)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15");
- END IF;
-
- RESULT;
-END C41322A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41323a.ada b/gcc/testsuite/ada/acats/tests/c4/c41323a.ada
deleted file mode 100644
index f82a97a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41323a.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C41323A.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 IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC
--- OPERATORS (+, -, *, /, **, ABS) MAY BE SELECTED FROM OUTSIDE THE
--- PACKAGE USING AN EXPANDED NAME, FOR A FLOATING POINT TYPE.
-
--- TBN 7/16/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41323A IS
-
- PACKAGE P IS
- TYPE FLOAT IS DIGITS 5 RANGE -1.0E1 .. 1.0E1;
- OBJ_FLO_1 : FLOAT := -5.5;
- OBJ_FLO_2 : FLOAT := 1.5;
- OBJ_FLO_3 : FLOAT := 10.0;
- END P;
-
- FLO_VAR : P.FLOAT;
- FLO_VAR_1 : P.FLOAT := P."-"(P.FLOAT'(5.5));
- FLO_VAR_2 : P.FLOAT := P.FLOAT'(1.5);
- FLO_VAR_3 : P.FLOAT := P.FLOAT'(1.0E1);
-
-BEGIN
- TEST ("C41323A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " &
- "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " &
- "/, **, ABS) MAY BE SELECTED FROM OUTSIDE THE " &
- "PACKAGE USING AN EXPANDED NAME, FOR A " &
- "FLOATING POINT TYPE");
-
- IF P."=" (FLO_VAR_1, P."-"(P.FLOAT'(5.55))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (FLO_VAR_1, P.OBJ_FLO_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."<" (FLO_VAR_2, P.OBJ_FLO_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P.">" (FLO_VAR_2, P.OBJ_FLO_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P."<=" (FLO_VAR_3, P.FLOAT'(9.9)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- IF P."<=" (FLO_VAR_3, P.FLOAT'(10.0)) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
-
- IF P.">=" (P.OBJ_FLO_2, FLO_VAR_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
-
- IF P.">=" (P.OBJ_FLO_3, FLO_VAR_3) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
-
- FLO_VAR := P."+" (FLO_VAR_1, P.OBJ_FLO_2);
- IF P."/=" (FLO_VAR, P."-"(P.FLOAT'(4.0))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9");
- END IF;
-
- FLO_VAR := P."+" (FLO_VAR_1);
- IF P."/=" (FLO_VAR, P.OBJ_FLO_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10");
- END IF;
-
- FLO_VAR := P."-" (FLO_VAR_2, P.OBJ_FLO_1);
- IF P."/=" (FLO_VAR, P.FLOAT'(7.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11");
- END IF;
-
- FLO_VAR := P."*" (FLO_VAR_2, P.FLOAT'(2.0));
- IF P."/=" (FLO_VAR, P.FLOAT'(3.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12");
- END IF;
-
- FLO_VAR := P."/" (FLO_VAR_3, P.FLOAT'(2.0));
- IF P."/=" (FLO_VAR, P.FLOAT'(5.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13");
- END IF;
-
- FLO_VAR := P."**" (P.FLOAT'(2.0), 3);
- IF P."/=" (FLO_VAR, P.FLOAT'(8.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14");
- END IF;
-
- FLO_VAR := P."ABS" (FLO_VAR_1);
- IF P."/=" (FLO_VAR, P.FLOAT'(5.5)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15");
- END IF;
-
- RESULT;
-END C41323A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41324a.ada b/gcc/testsuite/ada/acats/tests/c4/c41324a.ada
deleted file mode 100644
index 19992a2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41324a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C41324A.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 IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC
--- OPERATORS (+, -, *, /, ABS) MAY BE SELECTED FROM OUTSIDE THE
--- PACKAGE USING AN EXPANDED NAME, FOR A FIXED POINT TYPE.
-
--- TBN 7/16/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41324A IS
-
- PACKAGE P IS
- TYPE FIXED IS DELTA 0.125 RANGE -1.0E1 .. 1.0E1;
- OBJ_FIX_1 : FIXED := -5.5;
- OBJ_FIX_2 : FIXED := 1.5;
- OBJ_FIX_3 : FIXED := 10.0;
- END P;
-
- FIX_VAR : P.FIXED;
- FIX_VAR_1 : P.FIXED := P."-"(P.FIXED'(5.5));
- FIX_VAR_2 : P.FIXED := P.FIXED'(1.5);
- FIX_VAR_3 : P.FIXED := P.FIXED'(1.0E1);
-
-BEGIN
- TEST ("C41324A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " &
- "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " &
- "/, ABS) MAY BE SELECTED FROM OUTSIDE THE " &
- "PACKAGE USING AN EXPANDED NAME, FOR A FIXED " &
- "POINT TYPE");
-
- IF P."=" (FIX_VAR_1, P."-"(P.FIXED'(6.0))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (FIX_VAR_1, P.OBJ_FIX_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."<" (FIX_VAR_2, P.OBJ_FIX_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P.">" (FIX_VAR_2, P.OBJ_FIX_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P."<=" (FIX_VAR_3, P.FIXED'(9.9)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- IF P."<=" (FIX_VAR_3, P.FIXED'(10.0)) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
-
- IF P.">=" (P.OBJ_FIX_2, FIX_VAR_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
-
- IF P.">=" (P.OBJ_FIX_2, FIX_VAR_2) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
-
- FIX_VAR := P."+" (FIX_VAR_1, P.OBJ_FIX_2);
- IF P."/=" (FIX_VAR, P."-"(P.FIXED'(4.0))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9");
- END IF;
-
- FIX_VAR := P."-" (FIX_VAR_2, P.OBJ_FIX_1);
- IF P."/=" (FIX_VAR, P.FIXED'(7.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10");
- END IF;
-
- FIX_VAR := P."*" (FIX_VAR_2, 2);
- IF P."/=" (FIX_VAR, P.FIXED'(3.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11");
- END IF;
-
- FIX_VAR := P."*" (3, FIX_VAR_2);
- IF P."/=" (FIX_VAR, P.FIXED'(4.5)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12");
- END IF;
-
- FIX_VAR := P."/" (FIX_VAR_3, 2);
- IF P."/=" (FIX_VAR, P.FIXED'(5.0)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13");
- END IF;
-
- FIX_VAR := P."ABS" (FIX_VAR_1);
- IF P."/=" (FIX_VAR, P.FIXED'(5.5)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14");
- END IF;
-
- RESULT;
-END C41324A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41325a.ada b/gcc/testsuite/ada/acats/tests/c4/c41325a.ada
deleted file mode 100644
index 95437ab..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41325a.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- C41325A.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 FOLLOWING IMPLICITLY DECLARED ENTITIES CAN BE SELECTED
--- FROM OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN ARRAY TYPE.
--- CASE 1: CHECK EQUALITY AND INEQUALITY WHEN COMPONENT TYPE IS
--- NON-LIMITED, FOR MULTIDIMENSIONAL ARRAYS.
--- CASE 2: FOR ONE DIMENSIONAL ARRAYS:
--- A) CHECK CATENATION, EQUALITY, AND INEQUALITY WHEN
--- COMPONENT TYPE IS NON-LIMITED.
--- B) CHECK RELATIONAL OPERATORS WHEN COMPONENT TYPE IS
--- DISCRETE.
--- C) CHECK THE "NOT" OPERATOR AND THE LOGICAL OPERATORS
--- WHEN COMPONENT TYPE IS BOOLEAN.
-
--- TBN 7/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41325A IS
-
- PACKAGE P IS
- TYPE CATARRAY IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE ARRAY_1 IS ARRAY (1..10) OF INTEGER;
- TYPE ARRAY_2 IS ARRAY (1..4, 1..4) OF INTEGER;
- TYPE ARRAY_3 IS ARRAY (1..2, 1..3, 1..4) OF INTEGER;
- TYPE ARRAY_4 IS ARRAY (1..10) OF BOOLEAN;
- TYPE ARRAY_5 IS ARRAY (1..4, 1..4) OF BOOLEAN;
- TYPE ARRAY_6 IS ARRAY (1..2, 1..3, 1..4) OF BOOLEAN;
-
- OBJ_ARA_1 : ARRAY_1 := (1..10 => IDENT_INT(0));
- OBJ_ARA_2 : ARRAY_2 := (1..4 => (1..4 => IDENT_INT(0)));
- OBJ_ARA_3 : ARRAY_3 := (1..2 => (1..3 =>
- (1..4 => IDENT_INT(0))));
- OBJ_ARA_4 : ARRAY_4 := (1..10 => IDENT_BOOL(FALSE));
- OBJ_ARA_5 : ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(FALSE)));
- OBJ_ARA_6 : ARRAY_6 := (1..2 => (1..3 =>
- (1..4 => IDENT_BOOL(FALSE))));
- OBJ_ARA_7 : CATARRAY (1..10) := (1..10 => IDENT_INT(0));
- OBJ_ARA_20 : CATARRAY (1..20) := (1..10 => 1,
- 11..20 => IDENT_INT(0));
- END P;
-
- VAR_ARA_1 : P.ARRAY_1 := (1..10 => IDENT_INT(1));
- VAR_ARA_2 : P.ARRAY_2 := (1..4 => (1..4 => IDENT_INT(1)));
- VAR_ARA_3 : P.ARRAY_3 := (1..2 => (1..3 =>
- (1..4 => IDENT_INT(1))));
- VAR_ARA_4 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE));
- VAR_ARA_5 : P.ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(TRUE)));
- VAR_ARA_6 : P.ARRAY_6 := (1..2 => (1..3 =>
- (1..4 => IDENT_BOOL(TRUE))));
- VAR_ARA_7 : P.CATARRAY (1..10) := (1..10 => IDENT_INT(1));
- VAR_ARA_8 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE));
- VAR_ARA_20 : P.CATARRAY (1..20) := (1..20 => IDENT_INT(0));
-
-BEGIN
- TEST ("C41325A", "CHECK THAT IMPLICITLY DECLARED ENTITIES CAN " &
- "BE SELECTED FROM OUTSIDE THE PACKAGE USING AN " &
- "EXPANDED NAME, FOR AN ARRAY TYPE");
-
- -- CASE 1: MULTIDIMENSIONAL ARRAYS.
-
- IF P."=" (VAR_ARA_2, P.OBJ_ARA_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."=" (VAR_ARA_5, P.OBJ_ARA_5) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."/=" (VAR_ARA_2, P.ARRAY_2'(1..4 => (1..4 => 1))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- IF P."/=" (VAR_ARA_5, P.ARRAY_5'(1..4 => (1..4 => TRUE))) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- IF P."=" (VAR_ARA_3, P.OBJ_ARA_3) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5");
- END IF;
-
- IF P."/=" (VAR_ARA_6, P.ARRAY_6'(1..2 =>(1..3 =>(1..4 => TRUE))))
- THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6");
- END IF;
-
- -- CASE 2: ONE DIMENSIONAL ARRAYS.
-
- IF P."=" (VAR_ARA_1, P.OBJ_ARA_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7");
- END IF;
-
- IF P."/=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8");
- END IF;
-
- VAR_ARA_20 := P."&" (VAR_ARA_7, P.OBJ_ARA_7);
- IF P."/=" (VAR_ARA_20, P.OBJ_ARA_20) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9");
- END IF;
-
- IF P."<" (VAR_ARA_1, P.OBJ_ARA_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10");
- END IF;
-
- IF P.">" (P.OBJ_ARA_1, VAR_ARA_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11");
- END IF;
-
- IF P."<=" (VAR_ARA_1, P.OBJ_ARA_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12");
- END IF;
-
- IF P."<=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13");
- END IF;
-
- IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 2)) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14");
- END IF;
-
- IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15");
- END IF;
-
- VAR_ARA_8 := P."NOT" (VAR_ARA_4);
- IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 16");
- END IF;
-
- VAR_ARA_8 := P."OR" (VAR_ARA_4, P.OBJ_ARA_4);
- IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 17");
- END IF;
-
- VAR_ARA_8 := P."AND" (VAR_ARA_4, P.OBJ_ARA_4);
- IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 18");
- END IF;
-
- VAR_ARA_8 := P."XOR" (VAR_ARA_4, P.OBJ_ARA_4);
- IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 19");
- END IF;
-
- RESULT;
-END C41325A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41326a.ada b/gcc/testsuite/ada/acats/tests/c4/c41326a.ada
deleted file mode 100644
index 9ef3c65..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41326a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- C41326A.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 IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS
--- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR
--- AN ACCESS TYPE.
-
--- TBN 7/18/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41326A IS
-
- PACKAGE P IS
- TYPE CELL IS
- RECORD
- VALUE : INTEGER;
- END RECORD;
- TYPE LINK IS ACCESS CELL;
-
- OBJ_LINK_1 : LINK := NEW CELL'(VALUE => 1);
- OBJ_LINK_2 : LINK := OBJ_LINK_1;
- END P;
-
- VAR_LINK_1 : P.LINK := NEW P.CELL'(VALUE => 1);
- VAR_LINK_2 : P.LINK := NEW P.CELL'(VALUE => 2);
-
-BEGIN
- TEST ("C41326A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " &
- "INEQUALITY OPERATORS MAY BE SELECTED FROM " &
- "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " &
- "FOR AN ACCESS TYPE");
-
- IF P."=" (VAR_LINK_1, P.OBJ_LINK_1) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (P.OBJ_LINK_1, P.OBJ_LINK_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- IF P."=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3");
- END IF;
-
- VAR_LINK_2.VALUE := 1;
- IF P."/=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4");
- END IF;
-
- RESULT;
-END C41326A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41327a.ada b/gcc/testsuite/ada/acats/tests/c4/c41327a.ada
deleted file mode 100644
index 4d5d852..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41327a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C41327A.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 IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS
--- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR
--- A PRIVATE TYPE.
-
--- TBN 7/18/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41327A IS
-
- PACKAGE P IS
- TYPE KEY IS PRIVATE;
- TYPE CHAR IS PRIVATE;
- FUNCTION INIT_KEY (X : NATURAL) RETURN KEY;
- FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR;
- PRIVATE
- TYPE KEY IS NEW NATURAL;
- TYPE CHAR IS NEW CHARACTER;
- END P;
-
- VAR_KEY_1 : P.KEY;
- VAR_KEY_2 : P.KEY;
- VAR_CHAR_1 : P.CHAR;
- VAR_CHAR_2 : P.CHAR;
-
- PACKAGE BODY P IS
-
- FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS
- BEGIN
- RETURN (KEY (X));
- END INIT_KEY;
-
- FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR IS
- BEGIN
- RETURN (CHAR (X));
- END INIT_CHAR;
-
- BEGIN
- NULL;
- END P;
-
-BEGIN
- TEST ("C41327A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " &
- "INEQUALITY OPERATORS MAY BE SELECTED FROM " &
- "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " &
- "FOR A PRIVATE TYPE");
-
- VAR_KEY_1 := P.INIT_KEY (1);
- VAR_KEY_2 := P.INIT_KEY (2);
- VAR_CHAR_1 := P.INIT_CHAR ('A');
- VAR_CHAR_2 := P.INIT_CHAR ('A');
- IF P."=" (VAR_KEY_1, VAR_KEY_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1");
- END IF;
-
- IF P."/=" (VAR_CHAR_1, VAR_CHAR_2) THEN
- FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2");
- END IF;
-
- RESULT;
-END C41327A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41328a.ada b/gcc/testsuite/ada/acats/tests/c4/c41328a.ada
deleted file mode 100644
index 3c6ea5b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41328a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C41328A.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 IMPLICITLY DECLARED DERIVED SUBPROGRAMS CAN BE SELECTED
--- FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR A DERIVED TYPE.
-
--- TBN 7/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41328A IS
-
- PACKAGE P IS
- PACKAGE Q IS
- TYPE PAIR IS ARRAY (1..2) OF INTEGER;
- FUNCTION INIT (INT : INTEGER) RETURN PAIR;
- PROCEDURE SWAP (TWO : IN OUT PAIR);
- END Q;
- TYPE COUPLE IS NEW Q.PAIR;
- END P;
-
- VAR_1 : P.COUPLE;
- VAR_2 : P.COUPLE;
-
- PACKAGE BODY P IS
-
- PACKAGE BODY Q IS
-
- FUNCTION INIT (INT : INTEGER) RETURN PAIR IS
- A : PAIR;
- BEGIN
- A (1) := INT;
- A (2) := INT + 1;
- RETURN (A);
- END INIT;
-
- PROCEDURE SWAP (TWO : IN OUT PAIR) IS
- TEMP : INTEGER;
- BEGIN
- TEMP := TWO (1);
- TWO (1) := TWO (2);
- TWO (2) := TEMP;
- END SWAP;
-
- BEGIN
- NULL;
- END Q;
-
- BEGIN
- NULL;
- END P;
-
-BEGIN
- TEST ("C41328A", "CHECK THAT IMPLICITLY DECLARED DERIVED " &
- "SUBPROGRAMS CAN BE SELECTED FROM OUTSIDE A " &
- "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " &
- "TYPE");
-
- VAR_1 := P.INIT (IDENT_INT(1));
- IF P."/=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN
- FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 1");
- END IF;
-
- VAR_2 := P.INIT (IDENT_INT(2));
- IF P."=" (VAR_2, P.COUPLE'(1 => 1, 2 => 2)) THEN
- FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 2");
- END IF;
-
- P.SWAP (VAR_1);
- IF P."=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN
- FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 3");
- END IF;
-
- P.SWAP (VAR_2);
- IF P."/=" (VAR_2, P.COUPLE'(1 => 3, 2 => 2)) THEN
- FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 4");
- END IF;
-
- RESULT;
-END C41328A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41401a.ada b/gcc/testsuite/ada/acats/tests/c4/c41401a.ada
deleted file mode 100644
index f58a8a4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41401a.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- C41401A.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 IF THE PREFIX OF THE FOLLOWING
--- ATTRIBUTES HAS THE VALUE NULL:
--- A) 'CALLABLE AND 'TERMINATED FOR A TASK TYPE.
--- B) 'FIRST, 'FIRST(N), 'LAST, 'LAST(N), 'LENGTH, 'LENGTH(N),
--- 'RANGE, AND 'RANGE(N) FOR AN ARRAY TYPE.
-
--- TBN 10/2/86
--- EDS 07/14/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41401A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
-
- TASK TYPE TT IS
- ENTRY E;
- END TT;
-
- TYPE ACC_TT IS ACCESS TT;
-
- TYPE NULL_ARR1 IS ARRAY (2 .. 1) OF INTEGER;
- TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER;
- TYPE NULL_ARR2 IS ARRAY (3 .. 1, 2 .. 1) OF INTEGER;
- TYPE ARRAY2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER;
- TYPE ACC_NULL1 IS ACCESS NULL_ARR1;
- TYPE ACC_ARR1 IS ACCESS ARRAY1;
- TYPE ACC_NULL2 IS ACCESS NULL_ARR2;
- TYPE ACC_ARR2 IS ACCESS ARRAY2;
-
- PTR_TT : ACC_TT;
- PTR_ARA1: ACC_NULL1;
- PTR_ARA2 : ACC_ARR1 (1 .. 4);
- PTR_ARA3 : ACC_NULL2;
- PTR_ARA4 : ACC_ARR2 (1 .. 2, 2 .. 4);
- BOOL_VAR : BOOLEAN := FALSE;
- INT_VAR : INTEGER := 1;
-
- TASK BODY TT IS
- BEGIN
- ACCEPT E;
- END TT;
-
-BEGIN
- TEST ("C41401A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " &
- "PREFIX HAS A VALUE OF NULL FOR THE FOLLOWING " &
- "ATTRIBUTES: 'CALLABLE, 'TERMINATED, 'FIRST, " &
- "'LAST, 'LENGTH, AND 'RANGE");
-
- BEGIN
- IF EQUAL (3, 2) THEN
- PTR_TT := NEW TT;
- END IF;
- BOOL_VAR := IDENT_BOOL(PTR_TT'CALLABLE);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & BOOLEAN'IMAGE(BOOL_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- IF EQUAL (1, 3) THEN
- PTR_TT := NEW TT;
- END IF;
- BOOL_VAR := IDENT_BOOL(PTR_TT'TERMINATED);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & BOOLEAN'IMAGE(BOOL_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA1'FIRST);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 5 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA2'LAST);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 7 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 8");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA1'LENGTH);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 9 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 10");
- END;
-
- BEGIN
- DECLARE
- A : ARRAY1 (PTR_ARA2'RANGE);
- BEGIN
- A (1) := IDENT_INT(1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 " &
- INTEGER'IMAGE(A(1)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 ");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 12");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA3'FIRST(2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 13 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 14");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA4'LAST(2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 15 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 16");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 17 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 18");
- END;
-
- BEGIN
- DECLARE
- A : ARRAY1 (PTR_ARA4'RANGE(2));
- BEGIN
- A (1) := IDENT_INT(1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 " &
- INTEGER'IMAGE(A(1)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 ");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 20");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA4'LAST(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 21 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 22");
- END;
-
- BEGIN
- INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 23 " & INTEGER'IMAGE(INT_VAR));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 24");
- END;
-
- RESULT;
-END C41401A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41402a.ada b/gcc/testsuite/ada/acats/tests/c4/c41402a.ada
deleted file mode 100644
index 003fb12..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41402a.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- C41402A.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 CONSTRAINT_ERROR IS NOT RAISED IF THE PREFIX OF
--- 'ADDRESS, 'SIZE, 'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE
--- VALUE NULL.
-
--- HISTORY:
--- TBN 10/02/86 CREATED ORIGINAL TEST.
--- CJJ 07/01/87 REMOVED TEST FOR 'STORAGE_SIZE, WHICH IS NO LONGER
--- PART OF THE OBJECTIVE.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE C41402A IS
-
- TYPE ARRAY1 IS ARRAY (1 .. 2) OF INTEGER;
- TYPE ACC_ARA IS ACCESS ARRAY1;
-
- PTR_ARA : ACC_ARA;
- VAR1 : INTEGER;
-
- TYPE REC1 IS
- RECORD
- A : INTEGER;
- END RECORD;
-
- TYPE ACC_REC1 IS ACCESS REC1;
-
- TYPE REC2 IS
- RECORD
- P_AR : ACC_ARA;
- P_REC : ACC_REC1;
- END RECORD;
-
- OBJ_REC : REC2;
-
-
- PROCEDURE PROC (A : ADDRESS) IS
- BEGIN
- NULL;
- END;
-
-BEGIN
- TEST ("C41402A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
- "THE PREFIX OF 'ADDRESS, 'SIZE, " &
- "'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE " &
- "VALUE NULL");
-
- BEGIN
- PROC (PTR_ARA'ADDRESS);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR 'ADDRESS");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED 'ADDRESS");
- END;
-
- BEGIN
- VAR1 := PTR_ARA'SIZE;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR 'SIZE");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED 'SIZE");
- END;
-
- BEGIN
- VAR1 := OBJ_REC.P_AR'FIRST_BIT;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR 'FIRST_BIT");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED 'FIRST_BIT");
- END;
-
- BEGIN
- VAR1 := OBJ_REC.P_AR'LAST_BIT;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR 'LAST_BIT");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED 'LAST_BIT");
- END;
-
- BEGIN
- VAR1 := OBJ_REC.P_REC'POSITION;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR 'POSITION");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED 'POSITION");
- END;
-
- RESULT;
-END C41402A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c41404a.ada b/gcc/testsuite/ada/acats/tests/c4/c41404a.ada
deleted file mode 100644
index 9aa9378..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c41404a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C41404A.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 PREFIX OF THE ARRAY ATTRIBUTES CAN BE THE VALUE OF AN
--- IMAGE ATTRIBUTE.
-
--- JBG 6/1/85
--- PWB 2/3/86 CORRECTED COMPARISON VALUES FOR 'LAST AND 'LENGTH.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C41404A IS
-
- TYPE ENUM IS (ONE, FOUR, 'C');
-
-BEGIN
-
- TEST ("C41404A", "CHECK WHEN PREFIX OF AN ATTRIBUTE IS 'IMAGE");
-
- IF ENUM'IMAGE(FOUR)'LENGTH /= IDENT_INT(4) THEN
- FAILED ("WRONG VALUE FOR LENGTH - ENUM");
- END IF;
-
- IF ENUM'IMAGE('C')'LENGTH /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LENGTH - ENUM: 'C'");
- END IF;
-
- IF INTEGER'IMAGE(IDENT_INT(56))'LENGTH /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LENGTH - INTEGER: 56");
- END IF;
-
- IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LENGTH /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LENGTH - CHAR: 'B'");
- END IF;
-
- IF ENUM'IMAGE(FOUR)'FIRST /= IDENT_INT(1) THEN
- FAILED ("WRONG VALUE FOR FIRST - ENUM");
- END IF;
-
- IF ENUM'IMAGE('C')'FIRST(1) /= IDENT_INT(1) THEN
- FAILED ("WRONG VALUE FOR FIRST - ENUM: 'C'");
- END IF;
-
- IF INTEGER'IMAGE(IDENT_INT(56))'FIRST /= IDENT_INT(1) THEN
- FAILED ("WRONG VALUE FOR FIRST - INTEGER: 56");
- END IF;
-
- IF CHARACTER'IMAGE(IDENT_CHAR('B'))'FIRST /= IDENT_INT(1) THEN
- FAILED ("WRONG VALUE FOR FIRST - CHAR: 'B'");
- END IF;
-
- IF ENUM'IMAGE(FOUR)'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG VALUE FOR LAST - ENUM");
- END IF;
-
- IF ENUM'IMAGE('C')'LAST(1) /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LAST - ENUM: 'C'");
- END IF;
-
- IF INTEGER'IMAGE(IDENT_INT(-56))'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LAST - INTEGER: -56");
- END IF;
-
- IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUE FOR LAST - CHAR: 'B'");
- END IF;
-
- DECLARE
-
- FOUR_VAR : STRING(ENUM'IMAGE(FOUR)'RANGE);
- C_VAR : STRING(ENUM'IMAGE('C')'RANGE);
- VAR_101 : STRING(INTEGER'IMAGE(IDENT_INT(101))'RANGE);
- CHAR_VAR : STRING(CHARACTER'IMAGE(IDENT_CHAR('B'))'RANGE);
-
- BEGIN
-
- IF FOUR_VAR'FIRST /= 1 OR
- FOUR_VAR'LAST /= 4 OR
- FOUR_VAR'LENGTH /= 4 THEN
- FAILED ("FOUR_VAR ATTRIBUTES INCORRECT. FIRST IS" &
- INTEGER'IMAGE(FOUR_VAR'FIRST) & ". LAST IS" &
- INTEGER'IMAGE(FOUR_VAR'LAST) & ". LENGTH IS" &
- INTEGER'IMAGE(FOUR_VAR'LENGTH));
- END IF;
-
- IF C_VAR'FIRST /= 1 OR
- C_VAR'LAST /= 3 OR
- C_VAR'LENGTH /= 3 THEN
- FAILED ("C_VAR ATTRIBUTES INCORRECT. FIRST IS" &
- INTEGER'IMAGE(C_VAR'FIRST) & ". LAST IS" &
- INTEGER'IMAGE(C_VAR'LAST) & ". LENGTH IS" &
- INTEGER'IMAGE(C_VAR'LENGTH));
- END IF;
-
- IF VAR_101'FIRST /= 1 OR
- VAR_101'LAST /= 4 OR
- VAR_101'LENGTH /= 4 THEN
- FAILED ("VAR_101 ATTRIBUTES INCORRECT. FIRST IS" &
- INTEGER'IMAGE(VAR_101'FIRST) & ". LAST IS" &
- INTEGER'IMAGE(VAR_101'LAST) & ". LENGTH IS" &
- INTEGER'IMAGE(VAR_101'LENGTH));
- END IF;
-
- IF CHAR_VAR'FIRST /= 1 OR
- CHAR_VAR'LAST /= 3 OR
- CHAR_VAR'LENGTH /= 3 THEN
- FAILED ("CHAR_VAR ATTRIBUTES INCORRECT. FIRST IS" &
- INTEGER'IMAGE(CHAR_VAR'FIRST) & ". LAST IS" &
- INTEGER'IMAGE(CHAR_VAR'LAST) & ". LENGTH IS" &
- INTEGER'IMAGE(CHAR_VAR'LENGTH));
- END IF;
-
- END;
-
- RESULT;
-END C41404A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c420001.a b/gcc/testsuite/ada/acats/tests/c4/c420001.a
deleted file mode 100644
index ae4b4d8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c420001.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- C420001.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 WHATSOVER, 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 index subtype of a string type is a modular subtype
--- whose lower bound is zero, then the evaluation of a null string_literal
--- raises Constraint_Error. This was confirmed by AI95-00138.
---
--- TEST DESCRIPTION
--- In this test, we have a generic formal modular type, and we have
--- several null string literals of that type. Because the type is
--- generic formal, the string literals are not static, and therefore
--- the Constraint_Error should be detected at run time.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments and messages, renamed, issued.
---
---!
-with Report; use Report; pragma Elaborate_All(Report);
-with System;
-procedure C420001 is
- generic
- type Modular is mod <>;
- package Mod_Test is
- type Str is array(Modular range <>) of Character;
- procedure Test_String_Literal;
- end Mod_Test;
-
- package body Mod_Test is
- procedure Test_String_Literal is
- begin
- begin
- declare
- Null_String: Str := ""; -- Should raise C_E.
- begin
- Comment(String(Null_String)); -- Avoid 11.6 issues.
- end;
- Failed("Null string didn't raise Constraint_Error");
- exception
- when Exc: Constraint_Error =>
- null; -- Comment("Constraint_Error -- OK");
- when Exc2: others =>
- Failed("Null string raised wrong exception");
- end;
- begin
- Failed(String(Str'(""))); -- Should raise C_E, not do Failed.
- Failed("Null string didn't raise Constraint_Error");
- exception
- when Exc: Constraint_Error =>
- null; -- Comment("Constraint_Error -- OK");
- when Exc2: others =>
- Failed("Null string raised wrong exception");
- end;
- end Test_String_Literal;
- begin
- Test_String_Literal;
- end Mod_Test;
-begin
- Test("C420001", "Check that if the index subtype of a string type is a " &
- "modular subtype whose lower bound is zero, then the " &
- "evaluation of a null string_literal raises " &
- "Constraint_Error. ");
- declare
- type M1 is mod 1;
- package Test_M1 is new Mod_Test(M1);
- type M2 is mod 2;
- package Test_M2 is new Mod_Test(M2);
- type M3 is mod 3;
- package Test_M3 is new Mod_Test(M3);
- type M4 is mod 4;
- package Test_M4 is new Mod_Test(M4);
- type M5 is mod 5;
- package Test_M5 is new Mod_Test(M5);
- type M6 is mod 6;
- package Test_M6 is new Mod_Test(M6);
- type M7 is mod 7;
- package Test_M7 is new Mod_Test(M7);
- type M8 is mod 8;
- package Test_M8 is new Mod_Test(M8);
- type M_Max_Binary_Modulus is mod System.Max_Binary_Modulus;
- package Test_M_Max_Binary_Modulus is new Mod_Test(M_Max_Binary_Modulus);
- type M_Max_Nonbinary_Modulus is mod System.Max_Nonbinary_Modulus;
- package Test_M_Max_Nonbinary_Modulus is new Mod_Test(M_Max_Nonbinary_Modulus);
- begin
- null;
- end;
- Result;
-end C420001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c42006a.ada b/gcc/testsuite/ada/acats/tests/c4/c42006a.ada
deleted file mode 100644
index 6c22017..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c42006a.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C42006A.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 WHEN A STRING LITERAL OF AN
--- ARRAY TYPE CONTAINS A CHARACTER THAT DOES NOT BELONG TO THE COMPONENT
--- SUBTYPE.
-
--- SPS 2/22/84
--- EDS 12/02/97 MODIFIED THE COMPONENT SUBTYPES SO THAT THEY ARE NON-STATIC.
--- EDS 7/14/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C42006A IS
-BEGIN
-
- TEST ("C42006A", "CHECK THAT THE VALUES OF STRING LITERALS MUST" &
- " BELONG TO THE COMPONENT SUBTYPE.");
-
- DECLARE
-
- TYPE CHAR_COMP IS ('A', 'B', 'C', 'D', 'E', 'F');
-
- ASCIINUL : CHARACTER := ASCII.NUL;
- SUBTYPE NON_GRAPHIC_CHAR IS CHARACTER
- RANGE ASCIINUL .. ASCII.BEL;
-
- BEE : CHAR_COMP := 'B';
- TYPE CHAR_STRING IS ARRAY (POSITIVE RANGE <>)
- OF CHAR_COMP RANGE BEE..'C';
- TYPE NON_GRAPHIC_CHAR_STRING IS ARRAY (POSITIVE RANGE <>)
- OF NON_GRAPHIC_CHAR;
-
- C_STR : CHAR_STRING (1 .. 1);
- C_STR_5 : CHAR_STRING (1 .. 5) := "BBBBB";
- N_G_STR : NON_GRAPHIC_CHAR_STRING (1 .. 1) :=
- (OTHERS => NON_GRAPHIC_CHAR'FIRST);
-
- BEGIN
-
- BEGIN
- C_STR_5 := "BABCC"; -- 'A' NOT IN COMPONENT SUBTYPE.
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " &
- CHAR_COMP'IMAGE(C_STR_5(1)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- C_STR_5 := "BCBCD"; -- 'D' NOT IN COMPONENT SUBTYPE.
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " &
- CHAR_COMP'IMAGE(C_STR_5(1)));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- N_G_STR := "Z";
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " &
- INTEGER'IMAGE(CHARACTER'POS(N_G_STR(1))));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3");
- END;
-
- END;
-
- RESULT;
-
-END C42006A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c42007e.ada b/gcc/testsuite/ada/acats/tests/c4/c42007e.ada
deleted file mode 100644
index 09fd6e6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c42007e.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C42007E.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 BOUNDS OF A STRING LITERAL ARE DETERMINED CORRECTLY.
--- IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY 'FIRST OF THE
--- INDEX SUBTYPE WHEN THE STRING LITERAL IS USED AS:
-
--- E) THE LEFT OR RIGHT OPERAND OF "&".
-
--- TBN 7/28/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C42007E IS
-
-BEGIN
-
- TEST("C42007E", "CHECK THE BOUNDS OF A STRING LITERAL WHEN USED " &
- "AS THE LEFT OR RIGHT OPERAND OF THE CATENATION " &
- "OPERATOR");
-
- BEGIN
-
-CASE_E : DECLARE
-
- SUBTYPE STR_RANGE IS INTEGER RANGE 2 .. 10;
- TYPE STR IS ARRAY (STR_RANGE RANGE <>) OF CHARACTER;
-
- FUNCTION CONCAT1 RETURN STR IS
- BEGIN
- RETURN ("ABC" & (7 .. 8 => 'D'));
- END CONCAT1;
-
- FUNCTION CONCAT2 RETURN STR IS
- BEGIN
- RETURN ((IDENT_INT(4) .. 3 => 'A') & "BC");
- END CONCAT2;
-
- FUNCTION CONCAT3 RETURN STRING IS
- BEGIN
- RETURN ("TEST" & (7 .. 8 => 'X'));
- END CONCAT3;
-
- FUNCTION CONCAT4 RETURN STRING IS
- BEGIN
- RETURN ((8 .. 5 => 'A') & "DE");
- END CONCAT4;
-
- BEGIN
-
- IF CONCAT1'FIRST /= IDENT_INT(2) THEN
- FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 1");
- END IF;
- IF CONCAT1'LAST /= 6 THEN
- FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 1");
- END IF;
- IF CONCAT1 /= "ABCDD" THEN
- FAILED ("STRING INCORRECTLY DETERMINED - 1");
- END IF;
-
- IF CONCAT2'FIRST /= IDENT_INT(2) THEN
- FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 2");
- END IF;
- IF CONCAT2'LAST /= 3 THEN
- FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 2");
- END IF;
- IF CONCAT2 /= "BC" THEN
- FAILED ("STRING INCORRECTLY DETERMINED - 2");
- END IF;
-
- IF CONCAT3'FIRST /= IDENT_INT(1) THEN
- FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 3");
- END IF;
- IF CONCAT3'LAST /= 6 THEN
- FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 3");
- END IF;
- IF CONCAT3 /= "TESTXX" THEN
- FAILED ("STRING INCORRECTLY DETERMINED - 3");
- END IF;
-
- IF CONCAT4'FIRST /= IDENT_INT(1) THEN
- FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 4");
- END IF;
- IF CONCAT4'LAST /= 2 THEN
- FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 4");
- END IF;
- IF CONCAT4 /= "DE" THEN
- FAILED ("STRING INCORRECTLY DETERMINED - 4");
- END IF;
-
- END CASE_E;
-
- END;
-
- RESULT;
-
-END C42007E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43003a.ada b/gcc/testsuite/ada/acats/tests/c4/c43003a.ada
deleted file mode 100644
index 9767881..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43003a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C43003A.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 INITIALIZING AN ARRAY OF ACCESS OBJECTS, WITH
--- AN AGGREGATE CONTAINING A SINGLE ALLOCATOR, ALL ELEMENTS
--- ARE INITIALIZED TO THE SAME INITIAL VALUE.
--- THAT IS, CHECK THAT ALL COMPONENTS OF THE ARRAY DESIGNATE
--- DISTINCT OBJECTS.
-
--- DAT 3/18/81
--- SPS 10/26/82
--- JBG 12/27/82
--- R. WILLIAMS 11/11/86 RENAMED FROM C38007A-B.ADA.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C43003A IS
-
- TYPE AI IS ACCESS INTEGER;
-
- TYPE AAI IS ARRAY (1..5) OF AI;
-
- A : AAI := AAI'(OTHERS => NEW INTEGER '(2));
-
-BEGIN
- TEST ("C43003A", "CHECK THAT ALLOCATORS IN INITIALIZATIONS"
- & " FOR ARRAYS OF ACCESS VALUES ARE EVALUATED ONCE" &
- " FOR EACH COMPONENT");
-
- FOR I IN 1..5
- LOOP
- FOR J IN I+1..5
- LOOP
- IF A(I) = A(J) THEN
- FAILED ("DID NOT EVALUATE ALLOCATOR FOR EACH " &
- "COMPONENT");
- EXIT;
- END IF;
- END LOOP;
- END LOOP;
-
- RESULT;
-END C43003A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43004a.ada b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada
deleted file mode 100644
index 86e705d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43004a.ada
+++ /dev/null
@@ -1,350 +0,0 @@
--- C43004A.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 CONSTRAINT_ERROR IS RAISED IF A VALUE FOR A
--- NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT
--- WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE.
-
--- HISTORY:
--- BCB 01/22/88 CREATED ORIGINAL TEST.
--- RJW 06/27/90 CORRECTED CONSTRAINTS OF TYPE DFIX.
--- LDC 09/25/90 ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN
--- NOT OPTIMIZE IT AWAY, ALSO INITIALIZED EACH
--- OBJECT TO VALID DATA BEFORE DOING THE INVALID,
--- MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN
--- NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE
--- FOR A CONSTRAINT ERROR IN IS PLACE.
--- JRL 06/07/96 Changed value in aggregate in subtest 4 to value
--- guaranteed to be in the base range of the type FIX.
--- Corrected typo.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C43004A IS
-
- TYPE INT IS RANGE 1 .. 8;
- SUBTYPE SINT IS INT RANGE 2 .. 7;
-
- TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE);
- SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN;
-
- TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0;
- SUBTYPE SFL IS FL RANGE 1.0 .. 9.0;
-
- TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0;
- SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0;
-
- TYPE DINT IS NEW INTEGER RANGE 1 .. 8;
- SUBTYPE SDINT IS DINT RANGE 2 .. 7;
-
- TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE;
- SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN;
-
- TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0;
- SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0;
-
- TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5;
- SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0;
-
- TYPE REC1 IS RECORD
- E1, E2, E3, E4, E5 : SENUM;
- END RECORD;
-
- TYPE REC2 IS RECORD
- E1, E2, E3, E4, E5 : SFIX;
- END RECORD;
-
- TYPE REC3 IS RECORD
- E1, E2, E3, E4, E5 : SDENUM;
- END RECORD;
-
- TYPE REC4 IS RECORD
- E1, E2, E3, E4, E5 : SDFIX;
- END RECORD;
-
- ARRAY_OBJ : ARRAY(1..2) OF INTEGER;
-
- A : ARRAY(1..5) OF SINT;
- B : REC1;
- C : ARRAY(1..5) OF SFL;
- D : REC2;
- E : ARRAY(1..5) OF SDINT;
- F : REC3;
- G : ARRAY(1..5) OF SDFL;
- H : REC4;
-
- GENERIC
- TYPE GENERAL_PURPOSE IS PRIVATE;
- FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN;
-
- FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN ONE = TWO;
- ELSE
- RETURN ONE /= TWO;
- END IF;
- END GENEQUAL;
-
- FUNCTION EQUAL IS NEW GENEQUAL(SENUM);
- FUNCTION EQUAL IS NEW GENEQUAL(SFL);
- FUNCTION EQUAL IS NEW GENEQUAL(SFIX);
- FUNCTION EQUAL IS NEW GENEQUAL(SDENUM);
- FUNCTION EQUAL IS NEW GENEQUAL(SDFL);
- FUNCTION EQUAL IS NEW GENEQUAL(SDFIX);
-
- GENERIC
- TYPE GENERAL_PURPOSE IS PRIVATE;
- WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE)
- RETURN BOOLEAN;
- FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE;
- FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS
- BEGIN
- IF EQUAL_GENERAL (X, X) THEN -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- -- NEVER EXECUTED.
- RETURN X;
- END GEN_IDENT;
-
- FUNCTION IDENT_FL IS NEW GEN_IDENT(FL, EQUAL);
- FUNCTION IDENT_FIX IS NEW GEN_IDENT(FIX, EQUAL);
- FUNCTION IDENT_DFL IS NEW GEN_IDENT(DFL, EQUAL);
- FUNCTION IDENT_DFIX IS NEW GEN_IDENT(DFIX, EQUAL);
-
-BEGIN
- TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " &
- "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " &
- "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " &
- "THE COMPONENT'S SUBTYPE");
-
- ARRAY_OBJ := (1, 2);
-
- BEGIN
- A := (2,3,4,5,6); -- OK
-
- IF EQUAL (INTEGER (A(IDENT_INT(1))),
- INTEGER (A(IDENT_INT(2)))) THEN
- COMMENT ("DON'T OPTIMIZE A");
- END IF;
-
- A := (SINT(IDENT_INT(1)),2,3,4,7);
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH INTEGER COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1");
- IF EQUAL (INTEGER (A(IDENT_INT(1))),
- INTEGER (A(IDENT_INT(1)))) THEN
- COMMENT ("DON'T OPTIMIZE A");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 1");
- END;
-
- BEGIN
- B := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK
-
- IF EQUAL (B.E1, B.E2) THEN
- COMMENT ("DON'T OPTIMIZE B");
- END IF;
-
- B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL,
- ROSA, JODIE);
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH COMPONENTS OF AN
- -- ENUMERATION TYPE.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2");
- IF NOT EQUAL (B.E1, B.E1) THEN
- COMMENT ("DON'T OPTIMIZE B");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 2");
- END;
- BEGIN
- C := (2.0,3.0,4.0,5.0,6.0); -- OK
- IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE C");
- END IF;
-
- C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0));
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH FLOATING POINT COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3");
- IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN
- COMMENT ("DON'T OPTIMIZE C");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 3");
- END;
-
- BEGIN
- D := (2.2,3.3,4.4,5.5,6.6); -- OK
- IF EQUAL (D.E1, D.E5) THEN
- COMMENT ("DON'T OPTIMIZE D");
- END IF;
-
- D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75));
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH FIXED POINT COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4");
- IF NOT EQUAL (D.E5, D.E5) THEN
- COMMENT ("DON'T OPTIMIZE D");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 4");
- END;
-
- BEGIN
- E := (2,3,4,5,6); -- OK
- IF EQUAL (INTEGER (E(IDENT_INT(1))),
- INTEGER (E(IDENT_INT(2)))) THEN
- COMMENT ("DON'T OPTIMIZE E");
- END IF;
-
- E := (SDINT(IDENT_INT(1)),2,3,4,7);
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH DERIVED INTEGER COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5");
- IF NOT EQUAL (INTEGER (E(IDENT_INT(1))),
- INTEGER (E(IDENT_INT(1)))) THEN
- COMMENT ("DON'T OPTIMIZE E");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 5");
- END;
-
- BEGIN
- F := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK
- IF EQUAL (F.E1, F.E2) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
-
- F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL,
- ROSA, JODIE);
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH COMPONENTS OF A DERIVED
- -- ENUMERATION TYPE.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6");
- IF NOT EQUAL (F.E1, F.E1) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 6");
- END;
-
- BEGIN
- G := (2.0,3.0,4.0,5.0,6.0); -- OK
- IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE G");
- END IF;
-
- G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0));
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH DERIVED FLOATING POINT
- -- COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7");
- IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN
- COMMENT ("DON'T OPTIMIZE G");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 7");
- END;
-
- BEGIN
- H := (2.2,3.3,4.4,5.5,6.6); -- OK
- IF EQUAL (H.E1, H.E2) THEN
- COMMENT ("DON'T OPTIMIZE H");
- END IF;
-
- H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4));
- -- CONSTRAINT_ERROR BY AGGREGATE
- -- WITH DERIVED FIXED POINT
- -- COMPONENTS.
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8");
- IF EQUAL (H.E1, H.E5) THEN
- COMMENT ("DON'T OPTIMIZE H");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
- ARRAY_OBJ(IDENT_INT(2))) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
- END IF;
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED - 8");
- END;
-
-
- RESULT;
-END C43004A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43004c.ada b/gcc/testsuite/ada/acats/tests/c4/c43004c.ada
deleted file mode 100644
index 2534674..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43004c.ada
+++ /dev/null
@@ -1,230 +0,0 @@
--- C43004C.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 CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A
--- DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES
--- NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE
--- COMPONENT'S SUBTYPE.
-
--- HISTORY:
--- BCB 07/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C43004C IS
-
- ZERO : INTEGER := 0;
-
- TYPE REC (D : INTEGER := 0) IS RECORD
- COMP1 : INTEGER;
- END RECORD;
-
- TYPE DREC (DD : INTEGER := ZERO) IS RECORD
- DCOMP1 : INTEGER;
- END RECORD;
-
- TYPE REC1 IS RECORD
- A : REC(0);
- END RECORD;
-
- TYPE REC2 IS RECORD
- B : DREC(ZERO);
- END RECORD;
-
- TYPE REC3 (D3 : INTEGER := 0) IS RECORD
- C : REC(D3);
- END RECORD;
-
- V : REC1;
- W : REC2;
- X : REC3;
-
- PACKAGE P IS
- TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE;
- TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE;
- FUNCTION INIT (I : INTEGER) RETURN PRIV1;
- PRIVATE
- TYPE PRIV1 (D : INTEGER := 0) IS RECORD
- NULL;
- END RECORD;
-
- TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD
- NULL;
- END RECORD;
- END P;
-
- TYPE REC7 IS RECORD
- H : P.PRIV1 (0);
- END RECORD;
-
- Y : REC7;
-
- GENERIC
- TYPE GP IS PRIVATE;
- FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN;
-
- FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END GEN_EQUAL;
-
- PACKAGE BODY P IS
- TYPE REC4 IS RECORD
- E : PRIV1(0);
- END RECORD;
-
- TYPE REC5 IS RECORD
- F : PRIV2(ZERO);
- END RECORD;
-
- TYPE REC6 (D6 : INTEGER := 0) IS RECORD
- G : PRIV1(D6);
- END RECORD;
-
- VV : REC4;
- WW : REC5;
- XX : REC6;
-
- FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4);
- FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5);
- FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6);
-
- FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS
- VAR : PRIV1;
- BEGIN
- VAR := (D => I);
- RETURN VAR;
- END INIT;
- BEGIN
- TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "IF THE VALUE OF A DISCRIMINANT OF A " &
- "CONSTRAINED COMPONENT OF AN AGGREGATE " &
- "DOES NOT EQUAL THE CORRESPONDING " &
- "DISCRIMINANT VALUE FOR THECOMPONENT'S " &
- "SUBTYPE");
-
- BEGIN
- VV := (E => (D => 1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 1");
- IF REC4_EQUAL (VV,VV) THEN
- COMMENT ("DON'T OPTIMIZE VV");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- WW := (F => (DD => 1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 2");
- IF REC5_EQUAL (WW,WW) THEN
- COMMENT ("DON'T OPTIMIZE WW");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- XX := (D6 => 1, G => (D => 5));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 3");
- IF REC6_EQUAL (XX,XX) THEN
- COMMENT ("DON'T OPTIMIZE XX");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 3");
- END;
- END P;
-
- USE P;
-
- FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
- FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2);
- FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3);
- FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7);
-
-BEGIN
-
- BEGIN
- V := (A => (D => 1, COMP1 => 2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 4");
- IF REC1_EQUAL (V,V) THEN
- COMMENT ("DON'T OPTIMIZE V");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- W := (B => (DD => 1, DCOMP1 => 2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 5");
- IF REC2_EQUAL (W,W) THEN
- COMMENT ("DON'T OPTIMIZE W");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- X := (D3 => 1, C => (D => 5, COMP1 => 2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 6");
- IF REC3_EQUAL (X,X) THEN
- COMMENT ("DON'T OPTIMIZE X");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 6");
- END;
-
- BEGIN
- Y := (H => INIT (1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - 7");
- IF REC7_EQUAL (Y,Y) THEN
- COMMENT ("DON'T OPTIMIZE Y");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 7");
- END;
-
- RESULT;
-END C43004C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c431001.a b/gcc/testsuite/ada/acats/tests/c4/c431001.a
deleted file mode 100644
index 7d417ce..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c431001.a
+++ /dev/null
@@ -1,464 +0,0 @@
--- C431001.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 record aggregate can be given for a nonprivate,
--- nonlimited record extension and that the tag of the aggregate
--- values are initialized to the tag of the record extension.
---
--- TEST DESCRIPTION:
--- From an initial parent tagged type, several type extensions
--- are declared. Each type extension adds components onto
--- the existing record structure.
---
--- In the main procedure, aggregates are declared in two ways.
--- In the declarative part, aggregates are used to supply
--- initial values for objects of specific types. In the executable
--- part, aggregates are used directly as actual parameters to
--- a class-wide formal parameter.
---
--- The abstraction is for a catalog of recordings. A recording
--- can be a CD or a record (vinyl). Additionally, a CD may also
--- be a CD-ROM, containing both music and data. This type is declared
--- as an extension to a type extension, to test that the inclusion
--- of record components is transitive across multiple extensions.
---
--- That the aggregate has the correct tag is verify by feeding
--- it to a dispatching operation and confirming that the
--- expected subprogram is called as a result. To accomplish this,
--- an enumeration type is declared with an enumeration literal
--- representing each of the declared types in the hierarchy. A value
--- of this type is passed as a parameter to the dispatching
--- operation which passes it along to the dispatched subprogram.
--- Each dispatched subprogram verifies that it received the
--- expected enumeration literal.
---
--- Not quite fitting the above abstraction are several test cases
--- for null records. These tests verify that the new syntax for
--- null record aggregates, (null record), is supported. A type is
--- declared which extends a null tagged type and adds components.
--- Aggregates of this type should include associations for the
--- components of the type extension only. Finally, a type is
--- declared that adds a null type extension onto a non-null tagged
--- type. The aggregate associations should remain the same.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
---
-package C431001_0 is
-
- -- Values of TC_Type_ID are passed through to dispatched subprogram
- -- calls so that it can be verified that the dispatching resulted in
- -- the expected call.
- type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM);
-
- type Genre is (Classical, Country, Jazz, Rap, Rock, World);
-
- type Recording is tagged record
- Artist : String (1..20);
- Category : Genre;
- Length : Duration;
- Selections : Positive;
- end record;
-
- function Summary (R : in Recording;
- TC_Type : in TC_Type_ID) return String;
-
- type Recording_Method is (Audio, Digital);
- type CD is new Recording with record
- Recorded : Recording_Method;
- Mastered : Recording_Method;
- end record;
-
- function Summary (Disc : in CD;
- TC_Type : in TC_Type_ID) return String;
-
- type Playing_Speed is (LP_33, Single_45, Old_78);
- type Vinyl is new Recording with record
- Speed : Playing_Speed;
- end record;
-
- function Summary (Album : in Vinyl;
- TC_Type : in TC_Type_ID) return String;
-
-
- type CD_ROM is new CD with record
- Storage : Positive;
- end record;
-
- function Summary (Disk : in CD_ROM;
- TC_Type : in TC_Type_ID) return String;
-
- function Catalog_Entry (R : in Recording'Class;
- TC_Type : in TC_Type_ID) return String;
-
- procedure Print (S : in String); -- provides somewhere for the
- -- results of Catalog_Entry to
- -- "go", so they don't get
- -- optimized away.
-
- -- The types and procedures declared below are not a continuation
- -- of the Recording abstraction. These types are intended to test
- -- support for null tagged types and type extensions. TC_Check mirrors
- -- the operation of function Summary, above. Similarly, TC_Dispatch
- -- mirrors the operation of Catalog_Entry.
-
- type TC_N_Type_ID is
- (TC_Null_Tagged, TC_Null_Extension,
- TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull);
-
- type Null_Tagged is tagged null record;
- procedure TC_Check (N : in Null_Tagged;
- TC_Type : in TC_N_Type_ID);
-
- type Null_Extension is new Null_Tagged with null record;
- procedure TC_Check (N : in Null_Extension;
- TC_Type : in TC_N_Type_ID);
-
- type Extension_Of_Null is new Null_Tagged with record
- New_Component1 : Boolean;
- New_Component2 : Natural;
- end record;
- procedure TC_Check (N : in Extension_Of_Null;
- TC_Type : in TC_N_Type_ID);
-
- type Null_Extension_Of_Nonnull is new Extension_Of_Null
- with null record;
- procedure TC_Check (N : in Null_Extension_Of_Nonnull;
- TC_Type : in TC_N_Type_ID);
-
- procedure TC_Dispatch (N : in Null_Tagged'Class;
- TC_Type : in TC_N_Type_ID);
-
-end C431001_0;
-
-with Report;
-package body C431001_0 is
-
- function Summary (R : in Recording;
- TC_Type : in TC_Type_ID) return String is
- begin
-
- if TC_Type /= TC_Recording then
- Report.Failed ("Did not dispatch on tag for tagged parent " &
- "type Recording");
- end if;
-
- return R.Artist (1..10)
- & ' ' & Genre'Image (R.Category) (1..2)
- & ' ' & Duration'Image (R.Length)
- & ' ' & Integer'Image (R.Selections);
-
- end Summary;
-
- function Summary (Disc : in CD;
- TC_Type : in TC_Type_ID) return String is
- begin
-
- if TC_Type /= TC_CD then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "CD");
- end if;
-
- return Summary (Recording (Disc), TC_Type => TC_Recording)
- & ' ' & Recording_Method'Image(Disc.Recorded)(1)
- & Recording_Method'Image(Disc.Mastered)(1);
-
- end Summary;
-
- function Summary (Album : in Vinyl;
- TC_Type : in TC_Type_ID) return String is
- begin
- if TC_Type /= TC_Vinyl then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "Vinyl");
- end if;
-
- case Album.Speed is
- when LP_33 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 33";
- when Single_45 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 45";
- when Old_78 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 78";
- end case;
-
- end Summary;
-
- function Summary (Disk : in CD_ROM;
- TC_Type : in TC_Type_ID) return String is
- begin
- if TC_Type /= TC_CD_ROM then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "CD_ROM. This is an extension of the type " &
- "extension CD");
- end if;
-
- return Summary (Recording(Disk), TC_Type => TC_Recording)
- & ' ' & Integer'Image (Disk.Storage) & 'K';
-
- end Summary;
-
- function Catalog_Entry (R : in Recording'Class;
- TC_Type : in TC_Type_ID) return String is
- begin
- return Summary (R, TC_Type); -- dispatched call
- end Catalog_Entry;
-
- procedure Print (S : in String) is
- T : String (1..S'Length) := Report.Ident_Str (S);
- begin
- -- Ada.Text_IO.Put_Line (S);
- null;
- end Print;
-
- -- Bodies for null type checks
- procedure TC_Check (N : in Null_Tagged;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Tagged then
- Report.Failed ("Did not dispatch on tag for null tagged " &
- "type Null_Tagged");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Null_Extension;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Extension then
- Report.Failed ("Did not dispatch on tag for null tagged " &
- "type extension Null_Extension");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Extension_Of_Null;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Extension_Of_Null then
- Report.Failed
- ("Did not dispatch on tag for extension of null parent" &
- "type");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Null_Extension_Of_Nonnull;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Extension_Of_Nonnull then
- Report.Failed
- ("Did not dispatch on tag for null extension of nonnull " &
- "parent type");
- end if;
- end TC_Check;
-
- procedure TC_Dispatch (N : in Null_Tagged'Class;
- TC_Type : in TC_N_Type_ID) is
- begin
- TC_Check (N, TC_Type); -- dispatched call
- end TC_Dispatch;
-
-end C431001_0;
-
-
-with C431001_0;
-with Report;
-procedure C431001 is
-
- -- Tagged type
- -- Named component associations
- DAT : C431001_0.Recording :=
- (Artist => "Aerosmith ",
- Category => C431001_0.Rock,
- Length => 48.5,
- Selections => 10);
-
- -- Type extensions
- -- Named component associations
- Disc1 : C431001_0.CD :=
- (Artist => "London Symphony ",
- Category => C431001_0.Classical,
- Length => 55.0,
- Selections => 4,
- Recorded => C431001_0.Digital,
- Mastered => C431001_0.Digital);
-
- -- Named component associations with others
- Disc2 : C431001_0.CD :=
- (Artist => "Pink Floyd ",
- Category => C431001_0.Rock,
- Length => 51.8,
- Selections => 5,
- others => C431001_0.Audio); -- Recorded
- -- Mastered
-
- -- Positional component associations
- Album1 : C431001_0.Vinyl :=
- ("Hammer ", -- Artist
- C431001_0.Rap, -- Category
- 46.2, -- Length
- 9, -- Selections
- C431001_0.LP_33); -- Speed
-
- -- Mixed positional and named component associations
- -- Named component associations out of order
- Album2 : C431001_0.Vinyl :=
- ("Balinese Gamelan ", -- Artist
- C431001_0.World, -- Category
- 42.6, -- Length
- 14, -- Selections
- C431001_0.LP_33); -- Speed
-
- -- Type extension, parent is also type extension
- -- Named notation, components out of order
- Data : C431001_0.CD_ROM :=
- (Storage => 140,
- Mastered => C431001_0.Digital,
- Category => C431001_0.Rock,
- Selections => 10,
- Recorded => C431001_0.Digital,
- Artist => "Black, Clint ",
- Length => 48.5);
-
- -- Null tagged type
- Null_Rec : C431001_0.Null_Tagged := (null record);
-
- -- Null type extension
- Null_Ext : C431001_0.Null_Extension := (null record);
-
- -- Nonnull extension of null parent
- Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0);
-
- -- Null extension of nonnull parent
- Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull
- := (False, 1);
-
-begin
-
- Report.Test ("C431001", "Aggregate values for type extensions");
-
- C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording));
- C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD));
- C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD));
- C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl));
- C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl));
- C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM));
-
- C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged);
- C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension);
- C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null);
- C431001_0.TC_Dispatch
- (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull);
-
- -- Tagged type
- -- Named component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Recording,
- R => C431001_0.Recording'(Artist => "Zappa, Frank ",
- Category => C431001_0.Rock,
- Length => 70.0,
- Selections => 38)));
-
- -- Type extensions
- -- Named component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD,
- R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ",
- Category => C431001_0.Rap,
- Length => 37.3,
- Selections => 8,
- Recorded => C431001_0.Audio,
- Mastered => C431001_0.Digital)));
-
- -- Named component associations with others
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD,
- R => C431001_0.CD'(Artist => "Judd, Winona ",
- Category => C431001_0.Country,
- Length => 51.2,
- Selections => 11,
- others => C431001_0.Digital))); -- Recorded
- -- Mastered
-
- -- Positional component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Vinyl,
- R => C431001_0.Vinyl'("Davis, Miles ", -- Artist
- C431001_0.Jazz, -- Category
- 50.4, -- Length
- 10, -- Selections
- C431001_0.LP_33))); -- Speed
-
- -- Mixed positional and named component associations
- -- Named component associations out of order
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Vinyl,
- R => C431001_0.Vinyl'("Zamfir ", -- Artist
- C431001_0.World, -- Category
- Speed => C431001_0.LP_33,
- Selections => 14,
- Length => 56.5)));
-
- -- Type extension, parent is also type extension
- -- Named notation, components out of order
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD_ROM,
- R => C431001_0.CD_ROM'(Storage => 720,
- Category => C431001_0.Classical,
- Recorded => C431001_0.Digital,
- Artist => "Baltimore Symphony ",
- Length => 68.9,
- Mastered => C431001_0.Digital,
- Selections => 5)));
-
- -- Null tagged type
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Null_Tagged,
- N => C431001_0.Null_Tagged'(null record));
-
- -- Null type extension
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Null_Extension,
- N => C431001_0.Null_Extension'(null record));
-
- -- Nonnull extension of null parent
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Extension_Of_Null,
- N => C431001_0.Extension_Of_Null'(True, 3));
-
- -- Null extension of nonnull parent
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Extension_Of_Null,
- N => C431001_0.Extension_Of_Null'(False, 4));
-
- Report.Result;
-
-end C431001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43103a.ada b/gcc/testsuite/ada/acats/tests/c4/c43103a.ada
deleted file mode 100644
index 4267f58..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43103a.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- C43103A.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 DISCRIMINANT DOES NOT GOVERN A VARIANT PART,
--- ITS VALUE CAN BE GIVEN BY A NON-STATIC EXPRESSION.
-
--- EG 02/13/84
-
-WITH REPORT;
-
-PROCEDURE C43103A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43103A","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " &
- "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " &
- "NON-STATIC EXPRESSION");
-
- BEGIN
-
- COMMENT ("CASE A : DISCRIMINANT THAT IS NOT USED INSIDE " &
- "THE RECORD");
-
-CASE_A : DECLARE
-
- TYPE R1 (A : INTEGER) IS
- RECORD
- B : STRING(1 .. 2);
- C : INTEGER;
- END RECORD;
-
- A1 : R1(IDENT_INT(5)) := (IDENT_INT(5), "AB", -2);
-
- BEGIN
-
- IF A1.A /= IDENT_INT(5) OR A1.B /= "AB" OR
- A1.C /= -2 THEN
- FAILED ("CASE A : INCORRECT VALUES IN RECORD");
- END IF;
-
- END CASE_A;
-
- COMMENT ("CASE B : DISCRIMINANT THAT IS USED AS AN ARRAY " &
- "INDEX BOUND");
-
-CASE_B : DECLARE
-
- SUBTYPE STB IS INTEGER RANGE 1 .. 10;
- TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER;
- TYPE R2 (A : STB) IS
- RECORD
- B : TB(1 .. A);
- C : BOOLEAN;
- END RECORD;
-
- B1 : R2(IDENT_INT(2)) := (IDENT_INT(2), (-1, -2), FALSE);
-
- BEGIN
-
- IF B1.B'LAST /= IDENT_INT(2) THEN
- FAILED ("CASE B : INCORRECT UPPER BOUND");
- ELSIF B1.A /= IDENT_INT(2) OR B1.B /= (-1, -2) OR
- B1.C /= FALSE THEN
- FAILED ("CASE B : INCORRECT VALUES IN RECORD");
- END IF;
-
- END CASE_B;
-
- COMMENT ("CASE C : DISCRIMINANT THAT IS USED IN A " &
- "DISCRIMINANT CONSTRAINT");
-
-CASE_C : DECLARE
-
- SUBTYPE STC IS INTEGER RANGE 1 .. 10;
- TYPE TC IS ARRAY(STC RANGE <>) OF INTEGER;
- TYPE R3 (A : STC) IS
- RECORD
- B : TC(1 .. A);
- C : INTEGER := -4;
- END RECORD;
- TYPE R4 (A : INTEGER) IS
- RECORD
- B : R3(A);
- C : INTEGER;
- END RECORD;
-
- C1 : R4(IDENT_INT(3)) := (IDENT_INT(3),
- (IDENT_INT(3), (1, 2, 3), 4),
- 5);
-
- BEGIN
-
- IF C1.B.B /= (1, 2, 3) OR C1.B.C /= 4 OR
- C1.C /= 5 THEN
- FAILED ("CASE C : INCORRECT VALUES IN RECORD");
- END IF;
-
- END CASE_C;
-
- END;
-
- RESULT;
-
-END C43103A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43103b.ada b/gcc/testsuite/ada/acats/tests/c4/c43103b.ada
deleted file mode 100644
index 994e424..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43103b.ada
+++ /dev/null
@@ -1,186 +0,0 @@
--- C43103B.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 DISCRIMINANT DOES NOT GOVERN A VARIANT PART, ITS
--- VALUE CAN BE GIVEN BY A NONSTATIC EXPRESSION.
--- ADDITIONAL CASES OF USE OF A DISCRIMINANT THAT IS USED AS AN
--- ARRAY INDEX BOUND.
-
--- PK 02/21/84
--- EG 05/30/84
--- EG 11/02/84
--- DN 12/01/95 REMOVED CONFORMANCE CHECKS WHERE RULES RELAXED.
--- PWN 10/25/96 RESTORED CHECK WITH ADA 95 EXPECTED RESULTS INCLUDED.
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE C43103B IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
-
- TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER;
-
- SUBTYPE DINT IS INTEGER RANGE 0 .. 10;
-
- TYPE REC(D, E : DINT := IDENT_INT(1)) IS RECORD
- U : A2(1 .. D, E .. 3) := (1 .. D =>
- (E .. 3 => IDENT_INT(1)));
- END RECORD;
-
-BEGIN
-
- TEST("C43103B","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " &
- "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " &
- "NONSTATIC EXPRESSION");
-
--- SIMPLE DECLARATIONS
-
- BEGIN
-
- DECLARE
-
- L : REC(IDENT_INT(2), IDENT_INT(2));
- K : REC(IDENT_INT(0), IDENT_INT(1));
- M : REC(IDENT_INT(3), IDENT_INT(4));
-
- BEGIN
- IF L.U'FIRST(1) /= IDENT_INT(1) OR
- L.U'LAST(1) /= IDENT_INT(2) OR
- L.U'FIRST(2) /= IDENT_INT(2) OR
- L.U'LAST(2) /= IDENT_INT(3) THEN
- FAILED("1.1 - INCORRECT BOUNDS");
- END IF;
- IF K.U'FIRST(1) /= IDENT_INT(1) OR
- K.U'LAST(1) /= IDENT_INT(0) OR
- K.U'FIRST(2) /= IDENT_INT(1) OR
- K.U'LAST(2) /= IDENT_INT(3) THEN
- FAILED("1.2 - INCORRECT BOUNDS");
- END IF;
- IF M.U'FIRST(1) /= IDENT_INT(1) OR
- M.U'LAST(1) /= IDENT_INT(3) OR
- M.U'FIRST(2) /= IDENT_INT(4) OR
- M.U'LAST(2) /= IDENT_INT(3) THEN
- FAILED("1.3 - INCORRECT BOUNDS");
- END IF;
- IF M.U'LENGTH(1) /= 3 OR M.U'LENGTH(2) /= 0 THEN
- FAILED("1.4 - INCORRECT ARRAY LENGTH");
- END IF;
- END;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("1.5 - EXCEPTION RAISED");
-
- END;
-
--- EXPLICIT INITIAL VALUE - OK
-
- BEGIN
-
- DECLARE
- O : CONSTANT REC := (IDENT_INT(2), IDENT_INT(2),
- ((1, IDENT_INT(2)), (IDENT_INT(2), 3)));
- BEGIN
- IF O.U'FIRST(1) /= IDENT_INT(1) OR
- O.U'LAST(1) /= IDENT_INT(2) OR
- O.U'FIRST(2) /= IDENT_INT(2) OR
- O.U'LAST(2) /= IDENT_INT(3) THEN
- FAILED("2.1 - INCORRECT BOUNDS");
- END IF;
- END;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("2.2 - EXCEPTION RAISED");
- END;
-
--- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS
-
- BEGIN
-
- DECLARE
- P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2),
- (IDENT_INT(3) .. IDENT_INT(0) =>
- (IDENT_INT(2), 3)));
- BEGIN
- NULL;
- END;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("3.1 - CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("3.2 - WRONG EXCEPTION RAISED");
- END;
-
--- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS
-
- BEGIN
-
- DECLARE
- P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2),
- (IDENT_INT(3) .. IDENT_INT(0) =>
- (OTHERS => IDENT_INT(2))));
- BEGIN
- NULL;
- END;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("4.1 - CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("4.2 - WRONG EXCEPTION RAISED");
-
- END;
-
--- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS 2ND DIM.
-
- BEGIN
-
- DECLARE
- P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2),
- (IDENT_INT(1) .. IDENT_INT(0) =>
- (IDENT_INT(1) .. IDENT_INT(2) =>
- 1)));
- BEGIN
- NULL;
- END;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("5.1 - CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("5.2 - WRONG EXCEPTION RAISED");
-
- END;
-
- RESULT;
-
-END C43103B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43104a.ada b/gcc/testsuite/ada/acats/tests/c4/c43104a.ada
deleted file mode 100644
index 3c1ee9d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43104a.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C43104A.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 WITH THE TYPE OF THE AGGREGATE RESOLVED, THE
--- DISCRIMINANT MAY BE USED TO DECIDE TO WHICH OF THE VARIANT'S
--- SUBTYPES THE AGGREGATE BELONGS.
-
--- HISTORY:
--- DHH 08/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43104A IS
-
- TYPE INT IS RANGE 0 .. 10;
-
- TYPE VAR_REC(BOOL : BOOLEAN := TRUE) IS
- RECORD
- CASE BOOL IS
- WHEN TRUE =>
- X : INTEGER;
- WHEN FALSE =>
- Y : INT;
- END CASE;
- END RECORD;
-
- SUBTYPE S_TRUE IS VAR_REC(TRUE);
- SUBTYPE S_FALSE IS VAR_REC(FALSE);
-
- PROCEDURE CHECK(P : IN S_TRUE) IS
- BEGIN
- IF P.BOOL = FALSE THEN
- FAILED("WRONG PROCEDURE ENTERED");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED INSIDE PROCEDURE");
-
- END CHECK;
-
-BEGIN
- TEST("C43104A", "CHECK THAT WITH THE TYPE OF THE AGGREGATE " &
- "RESOLVED, THE DISCRIMINANT MAY BE USED TO " &
- "DECIDE TO WHICH OF THE VARIANT'S SUBTYPES " &
- "THE AGGREGATE BELONGS");
-
- CHECK((TRUE, 1));
-
- BEGIN
-
- CHECK((FALSE, 2));
- FAILED("PROCEDURE CALL USING '(FALSE, 2)' DID NOT RAISE " &
- "EXCEPTION");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("INCORRECT EXCEPTION RAISED ON PROCEDURE CALL " &
- "USING '(FALSE,2)'");
- END;
-
- RESULT;
-END C43104A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43105a.ada b/gcc/testsuite/ada/acats/tests/c4/c43105a.ada
deleted file mode 100644
index 28e9d28..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43105a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- C43105A.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:
--- IN A RECORD AGGREGATE, (X => E, Y => E), WHERE E IS AN OVERLOADED
--- ENUMERATION LITERAL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR
--- THE DIFFERENT OCCURRENCES OF E.
-
--- HISTORY:
--- DHH 08/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43105A IS
-
-BEGIN
- TEST("C43105A", "IN A RECORD AGGREGATE, (X => E, Y => E), WHERE " &
- "E IS AN OVERLOADED ENUMERATION LITERAL, " &
- "OVERLOADING RESOLUTION OCCURS SEPARATELY FOR " &
- "THE DIFFERENT OCCURRENCES OF E");
-
- DECLARE
- TYPE COLOR IS (RED, YELLOW, GREEN);
- TYPE PALETTE IS (GREEN, YELLOW, RED);
-
- TYPE REC IS
- RECORD
- X : COLOR;
- Y : PALETTE;
- END RECORD;
-
- TYPE RECD IS
- RECORD
- X : PALETTE;
- Y : COLOR;
- END RECORD;
-
- REC1 : REC;
- REC2 : RECD;
-
- FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN C;
- ELSE
- RETURN GREEN;
- END IF;
- END IDENT_C;
-
- FUNCTION IDENT_P(P : PALETTE) RETURN PALETTE IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN P;
- ELSE
- RETURN RED;
- END IF;
- END IDENT_P;
-
-
- BEGIN
- REC1 := (X => YELLOW, Y => YELLOW);
- REC2 := (X => YELLOW, Y => YELLOW);
-
- IF REC1.X /= IDENT_C(REC2.Y) THEN
- FAILED("COLOR RESOLUTION FAILED");
- END IF;
-
- IF REC1.Y /= IDENT_P(REC2.X) THEN
- FAILED("PALETTE RESOLUTION FAILED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED");
- END;
-
- RESULT;
-END C43105A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43105b.ada b/gcc/testsuite/ada/acats/tests/c4/c43105b.ada
deleted file mode 100644
index 6a7ea81..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43105b.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C43105B.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:
--- IN A RECORD AGGREGATE (X => E, Y => E), WHERE E IS AN OVERLOADED
--- FUNCTION CALL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR THE
--- DIFFERENT OCCURRENCES OF E.
-
--- HISTORY:
--- DHH 09/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43105B IS
-BEGIN
- TEST ("C43105B", "IN A RECORD AGGREGATE (X => E, Y => E), WHERE " &
- "E IS AN OVERLOADED FUNCTION CALL, OVERLOADING " &
- "RESOLUTION OCCURS SEPARATELY FOR THE " &
- "DIFFERENT OCCURRENCES OF E");
-
- DECLARE
- TYPE COLOR IS (RED, YELLOW, GREEN);
- TYPE PALETTE IS (GREEN, YELLOW, RED);
-
- TYPE REC IS
- RECORD
- X : COLOR;
- Y : PALETTE;
- END RECORD;
-
- TYPE RECD IS
- RECORD
- X : PALETTE;
- Y : COLOR;
- END RECORD;
-
- REC1 : REC;
- REC2 : RECD;
-
- FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN C;
- ELSE
- RETURN GREEN;
- END IF;
- END IDENT_C;
-
- FUNCTION IDENT_C(P : PALETTE) RETURN PALETTE IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN P;
- ELSE
- RETURN RED;
- END IF;
- END IDENT_C;
-
- BEGIN
- REC1 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW));
- REC2 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW));
-
- IF REC1.X /= REC2.Y THEN
- FAILED("COLOR FUNCTION RESOLUTION FAILED");
- END IF;
-
- IF REC1.Y /= REC2.X THEN
- FAILED("PALETTE FUNCTION RESOLUTION FAILED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED");
- END;
- RESULT;
-END C43105B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43106a.ada b/gcc/testsuite/ada/acats/tests/c4/c43106a.ada
deleted file mode 100644
index 64ac950..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43106a.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C43106A.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 BOTH NAMED AND POSITIONAL NOTATIONS ARE PERMITTED
--- WITHIN THE SAME RECORD AGGREGATE, (PROVIDED THAT ALL POSITIONAL
--- ASSOCIATIONS APPEAR BEFORE ANY NAMED ASSOCIATION).
-
--- HISTORY:
--- DHH 08/10/88 CREATED ORIGIANL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43106A IS
-
- TYPE REC IS
- RECORD
- A : INTEGER;
- B : CHARACTER;
- C : BOOLEAN;
- D, E, F, G : INTEGER;
- H, I, J, K : CHARACTER;
- L, M, N, O : BOOLEAN;
- P, Q, R, S : STRING(1 .. 3);
- T, U, V, W, X, Y, Z : BOOLEAN;
- END RECORD;
- AGG : REC := (12, 'A', TRUE, 1, 2, 3, 4, 'B', 'C', 'D', 'E',
- P|R => "ABC", S|Q => "DEF", L|X|O|U => TRUE,
- OTHERS => FALSE);
-
- FUNCTION IDENT_CHAR(X : CHARACTER) RETURN CHARACTER IS
- BEGIN
- IF EQUAL(3, 3) THEN
- RETURN X;
- ELSE
- RETURN 'Z';
- END IF;
- END IDENT_CHAR;
-
-BEGIN
- TEST("C43106A", "CHECK THAT BOTH NAMED AND POSITIONAL NOTATIONS " &
- "ARE PERMITTED WITHIN THE SAME RECORD " &
- "AGGREGATE, (PROVIDED THAT ALL POSITIONAL " &
- "ASSOCIATIONS APPEAR BEFORE ANY NAMED " &
- "ASSOCIATION)");
-
- IF NOT IDENT_BOOL(AGG.C) OR NOT IDENT_BOOL(AGG.L) OR
- NOT IDENT_BOOL(AGG.X) OR NOT IDENT_BOOL(AGG.O) OR
- NOT IDENT_BOOL(AGG.U) OR IDENT_BOOL(AGG.M) OR
- IDENT_BOOL(AGG.N) OR IDENT_BOOL(AGG.T) OR
- IDENT_BOOL(AGG.V) OR IDENT_BOOL(AGG.W) OR
- IDENT_BOOL(AGG.Y) OR IDENT_BOOL(AGG.Z) THEN
- FAILED("BOOLEANS NOT INITIALIZED TO AGGREGATE VALUES");
- END IF;
-
- IF IDENT_STR(AGG.P) /= IDENT_STR(AGG.R) OR
- IDENT_STR(AGG.Q) /= IDENT_STR(AGG.S) THEN
- FAILED("STRINGS NOT INITIALIZED CORRECTLY");
- END IF;
-
- IF IDENT_CHAR(AGG.B) /= IDENT_CHAR('A') OR
- IDENT_CHAR(AGG.H) /= IDENT_CHAR('B') OR
- IDENT_CHAR(AGG.I) /= IDENT_CHAR('C') OR
- IDENT_CHAR(AGG.J) /= IDENT_CHAR('D') OR
- IDENT_CHAR(AGG.K) /= IDENT_CHAR('E') THEN
- FAILED("CHARACTERS NOT INITIALIZED CORRECTLY");
- END IF;
-
- RESULT;
-END C43106A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43107a.ada b/gcc/testsuite/ada/acats/tests/c4/c43107a.ada
deleted file mode 100644
index 5fcc1a2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43107a.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C43107A.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 EXPRESSION ASSOCIATED WITH MORE THAN ONE RECORD
--- COMPONENT IS EVALUATED ONCE FOR EACH ASSOCIATED COMPONENT.
-
--- EG 02/14/84
-
-WITH REPORT;
-
-PROCEDURE C43107A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43107A","CHECK THAT AN EXPRESSION WITH MORE THAN ONE " &
- "RECORD COMPONENT IS EVALUATED ONCE FOR EACH " &
- "ASSOCIATED COMPONENT");
-
- BEGIN
-
-CASE_A : DECLARE
-
- TYPE T1 IS ARRAY(1 .. 2) OF INTEGER;
- TYPE R1 IS
- RECORD
- A : T1;
- B : INTEGER;
- C : T1;
- D : INTEGER;
- E : INTEGER;
- END RECORD;
-
- A1 : R1;
- CNTR : INTEGER := 0;
-
- FUNCTION FUN1 (A : T1) RETURN T1 IS
- BEGIN
- CNTR := IDENT_INT(CNTR+1);
- RETURN A;
- END FUN1;
-
- FUNCTION FUN2 (A : INTEGER) RETURN INTEGER IS
- BEGIN
- CNTR := CNTR+1;
- RETURN IDENT_INT(A);
- END FUN2;
-
- BEGIN
-
- A1 := (A | C => FUN1((-1, -2)), OTHERS => FUN2(-3)+1);
- IF CNTR /= 5 THEN
- FAILED ("CASE A : INCORRECT NUMBER OF EVALUATIONS" &
- " OF RECORD ASSOCIATED COMPONENTS");
- END IF;
- IF A1.A /= (-1, -2) OR A1.C /= (-1, -2) OR
- A1.B /= -2 OR A1.D /= -2 OR A1.E /= -2 THEN
- FAILED ("CASE A : INCORRECT VALUES IN RECORD");
- END IF;
-
- END CASE_A;
-
-CASE_B : DECLARE
-
- TYPE T2 IS ACCESS INTEGER;
- TYPE R2 IS
- RECORD
- A : T2;
- B : INTEGER;
- C : T2;
- D : INTEGER;
- E : INTEGER;
- END RECORD;
-
- B1 : R2;
- CNTR : INTEGER := 0;
-
- FUNCTION FUN3 RETURN INTEGER IS
- BEGIN
- CNTR := CNTR+1;
- RETURN IDENT_INT(2);
- END FUN3;
-
- BEGIN
-
- B1 := (A | C => NEW INTEGER'(-1),
- B | D | E => FUN3);
- IF B1.A = B1.C OR CNTR /= 3 THEN
- FAILED ("CASE B : INCORRECT NUMBER OF EVALUATION" &
- " OF RECORD ASSOCIATED COMPONENTS");
- END IF;
- IF B1.B /= 2 OR B1.D /= 2 OR B1.E /= 2 OR
- B1.A = NULL OR B1.C = NULL OR B1.A = B1.C THEN
- FAILED ("CASE B : INCORRECT VALUES IN RECORD");
- END IF;
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43107A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43108a.ada b/gcc/testsuite/ada/acats/tests/c4/c43108a.ada
deleted file mode 100644
index 24c140f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43108a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C43108A.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 IN A RECORD AGGREGATE THE VALUE OF A DISCRIMINANT IS
--- USED TO RESOLVE THE TYPE OF A COMPONENT THAT DEPENDS ON THE
--- DISCRIMINANT.
-
--- HISTORY:
--- DHH 09/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43108A IS
-
-BEGIN
- TEST ("C43108A", "CHECK THAT IN A RECORD AGGREGATE THE VALUE OF " &
- "A DISCRIMINANT IS USED TO RESOLVE THE TYPE OF " &
- "A COMPONENT THAT DEPENDS ON THE DISCRIMINANT");
-
- DECLARE
- A : INTEGER;
-
- TYPE DIS(A : BOOLEAN) IS
- RECORD
- CASE A IS
- WHEN TRUE =>
- B : BOOLEAN;
- C : INTEGER;
- WHEN FALSE =>
- D : INTEGER;
- END CASE;
- END RECORD;
-
- FUNCTION DIFF(PARAM : DIS) RETURN INTEGER IS
- BEGIN
- IF PARAM.B THEN
- RETURN PARAM.C;
- ELSE
- RETURN PARAM.D;
- END IF;
- END DIFF;
-
- BEGIN
- A := DIFF((C => 3, OTHERS => TRUE));
-
- IF A /= IDENT_INT(3) THEN
- FAILED("STATIC OTHERS NOT DECIDED CORRECTLY");
- END IF;
- END;
-
- DECLARE
- GLOBAL : INTEGER := 0;
- TYPE INT IS NEW INTEGER;
-
- TYPE DIS(A : BOOLEAN) IS
- RECORD
- CASE A IS
- WHEN TRUE =>
- I1 : INT;
- WHEN FALSE =>
- I2 : INTEGER;
- END CASE;
- END RECORD;
- FUNCTION F RETURN INT;
- FUNCTION F RETURN INTEGER;
-
- A : DIS(TRUE);
-
- FUNCTION F RETURN INT IS
- BEGIN
- GLOBAL := 1;
- RETURN 5;
- END F;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- GLOBAL := 2;
- RETURN 5;
- END F;
-
- BEGIN
- A := (TRUE, OTHERS => F);
-
- IF GLOBAL /= 1 THEN
- FAILED("NON_STATIC OTHERS NOT DECIDED CORRECTLY");
- END IF;
- END;
-
- RESULT;
-END C43108A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432001.a b/gcc/testsuite/ada/acats/tests/c4/c432001.a
deleted file mode 100644
index dab75b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432001.a
+++ /dev/null
@@ -1,512 +0,0 @@
--- C432001.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 extension aggregates may be used to specify values
--- for types that are record extensions. Check that the
--- type of the ancestor expression may be any nonlimited type that
--- is a record extension, including private types and private
--- extensions. Check that the type for the aggregate is
--- derived from the type of the ancestor expression.
---
--- TEST DESCRIPTION:
---
--- Two progenitor nonlimited record types are declared, one
--- nonprivate and one private. Using these as parent types,
--- all possible combinations of record extensions are declared
--- (Nonprivate record extension of nonprivate type, private
--- extension of nonprivate type, nonprivate record extension of
--- private type, and private extension of private type). Finally,
--- each of these types is extended using nonprivate record
--- extensions.
---
--- Extension of private types is done in packages other than
--- the ones containing the parent declaration. This is done
--- to eliminate errors with extension of the partial view of
--- a type, which is not an objective of this test.
---
--- All components of private types and private extensions are given
--- default values. This eliminates the need for separate subprograms
--- whose sole purpose is to place a value into a private record type.
---
--- Types that have been extended are checked using an object of their
--- parent type as the ancestor expression. For those types that
--- have been extended twice, using only nonprivate record extensions,
--- a check is made using an object of their grandparent type as
--- the ancestor expression.
---
--- For each type, a subprogram is defined which checks the contents
--- of the parameter, which is a value of the record extension.
--- Components of nonprivate record extensions are checked against
--- passed-in parameters of the component type. Components of private
--- extensions are checked to ensure that they maintain their initial
--- values.
---
--- To check that the aggregate's type is derived from its ancestor,
--- each Check subprogram in turn calls the Check subprogram for
--- its parent type. Explicit conversion is used to convert the
--- record extension to the parent type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-package C432001_0 is
-
- type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);
-
- type N is tagged record
- How_Long_Ago : Natural := Report.Ident_Int(1);
- Era : Eras := Cenozoic;
- end record;
-
- function Check (Rec : in N;
- N : in Natural;
- E : in Eras) return Boolean;
-
- type P is tagged private;
-
- function Check (Rec : in P) return Boolean;
-
-private
-
- type P is tagged record
- How_Long_Ago : Natural := Report.Ident_Int(150);
- Era : Eras := Mesozoic;
- end record;
-
-end C432001_0;
-
-package body C432001_0 is
-
- function Check (Rec : in P) return Boolean is
- begin
- return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic;
- end Check;
-
- function Check (Rec : in N;
- N : in Natural;
- E : in Eras) return Boolean is
- begin
- return Rec.How_Long_Ago = N and Rec.Era = E;
- end Check;
-
-end C432001_0;
-
-with C432001_0;
-package C432001_1 is
-
- type Periods is
- (Aphebian, Helikian, Hadrynian,
- Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
- Triassic, Jurassic, Cretaceous,
- Tertiary, Quaternary);
-
- type N_N is new C432001_0.N with record
- Period : Periods := C432001_1.Quaternary;
- end record;
-
- function Check (Rec : in N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in Periods) return Boolean;
-
- type N_P is new C432001_0.N with private;
-
- function Check (Rec : in N_P) return Boolean;
-
- type P_N is new C432001_0.P with record
- Period : Periods := C432001_1.Jurassic;
- end record;
-
- function Check (Rec : in P_N;
- P : in Periods) return Boolean;
-
- type P_P is new C432001_0.P with private;
-
- function Check (Rec : in P_P) return Boolean;
-
- type P_P_Null is new C432001_0.P with null record;
-
-private
-
- type N_P is new C432001_0.N with record
- Period : Periods := C432001_1.Quaternary;
- end record;
-
- type P_P is new C432001_0.P with record
- Period : Periods := C432001_1.Jurassic;
- end record;
-
-end C432001_1;
-
-with Report;
-package body C432001_1 is
-
- function Check (Rec : in N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in Periods) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.N (Rec), N, E) then
- Report.Failed ("Conversion to parent type of " &
- "nonprivate portion of " &
- "nonprivate extension failed");
- end if;
- return Rec.Period = P;
- end Check;
-
-
- function Check (Rec : in N_P) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then
- Report.Failed ("Conversion to parent type of " &
- "nonprivate portion of " &
- "private extension failed");
- end if;
- return Rec.Period = C432001_1.Quaternary;
- end Check;
-
- function Check (Rec : in P_N;
- P : in Periods) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.P (Rec)) then
- Report.Failed ("Conversion to parent type of " &
- "private portion of " &
- "nonprivate extension failed");
- end if;
- return Rec.Period = P;
- end Check;
-
- function Check (Rec : in P_P) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.P (Rec)) then
- Report.Failed ("Conversion to parent type of " &
- "private portion of " &
- "private extension failed");
- end if;
- return Rec.Period = C432001_1.Jurassic;
- end Check;
-
-end C432001_1;
-
-with C432001_0;
-with C432001_1;
-package C432001_2 is
-
- -- All types herein are nonprivate extensions, since aggregates
- -- cannot be given for private extensions
-
- type N_N_N is new C432001_1.N_N with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in N_N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in C432001_1.Periods;
- B : in Boolean) return Boolean;
-
- type N_P_N is new C432001_1.N_P with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in N_P_N;
- B : Boolean) return Boolean;
-
- type P_N_N is new C432001_1.P_N with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in P_N_N;
- P : in C432001_1.Periods;
- B : Boolean) return Boolean;
-
- type P_P_N is new C432001_1.P_P with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in P_P_N;
- B : Boolean) return Boolean;
-
-end C432001_2;
-
-with Report;
-package body C432001_2 is
-
- -- direct access to operator
- use type C432001_1.Periods;
-
-
- function Check (Rec : in N_N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in C432001_1.Periods;
- B : in Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then
- Report.Failed ("Conversion to parent " &
- "nonprivate type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
-
- function Check (Rec : in N_P_N;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.N_P (Rec)) then
- Report.Failed ("Conversion to parent " &
- "private type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
- function Check (Rec : in P_N_N;
- P : in C432001_1.Periods;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.P_N (Rec), P) then
- Report.Failed ("Conversion to parent " &
- "nonprivate type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
- function Check (Rec : in P_P_N;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.P_P (Rec)) then
- Report.Failed ("Conversion to parent " &
- "private type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
-end C432001_2;
-
-
-with C432001_0;
-with C432001_1;
-with C432001_2;
-with Report;
-procedure C432001 is
-
- N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375),
- Era => C432001_0.Paleozoic);
-
- P_Object : C432001_0.P; -- default value is (150,
- -- C432001_0.Mesozoic)
-
- N_N_Object : C432001_1.N_N :=
- (N_Object with Period => C432001_1.Devonian);
-
- P_N_Object : C432001_1.P_N :=
- (P_Object with Period => C432001_1.Jurassic);
-
- N_P_Object : C432001_1.N_P; -- default is (1,
- -- C432001_0.Cenozoic,
- -- C432001_1.Quaternary)
-
- P_P_Object : C432001_1.P_P; -- default is (150,
- -- C432001_0.Mesozoic,
- -- C432001_1.Jurassic)
-
- P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record);
-
- N_N_N_Object : C432001_2.N_N_N :=
- (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True));
-
- N_P_N_Object : C432001_2.N_P_N :=
- (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False));
-
- P_N_N_Object : C432001_2.P_N_N :=
- (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True));
-
- P_P_N_Object : C432001_2.P_P_N :=
- (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False));
-
- P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object)
- with C432001_1.Carboniferous);
-
- N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian)
- with C432001_1.Carboniferous);
-
-begin
-
- Report.Test ("C432001", "Extension aggregates");
-
- -- check ultimate ancestor types
-
- if not C432001_0.Check (N_Object,
- 375,
- C432001_0.Paleozoic) then
- Report.Failed ("Object of " &
- "nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_0.Check (P_Object) then
- Report.Failed ("Object of " &
- "private type " &
- "failed content check");
- end if;
-
- -- check direct type extensions
-
- if not C432001_1.Check (N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (N_P_Object) then
- Report.Failed ("Object of " &
- "private extension of nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_N_Object,
- C432001_1.Jurassic) then
- Report.Failed ("Object of " &
- "nonprivate extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_P_Object) then
- Report.Failed ("Object of " &
- "private extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_P_Null_Ob) then
- Report.Failed ("Object of " &
- "private type " &
- "failed content check");
- end if;
-
-
- -- check direct extensions of extensions
-
- if not C432001_2.Check (N_N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate extension " &
- "(of nonprivate parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (N_P_N_Object, False) then
- Report.Failed ("Object of " &
- "nonprivate extension of private extension " &
- "(of nonprivate parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (P_N_N_Object,
- C432001_1.Jurassic,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate extension " &
- "(of private parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (P_P_N_Object, False) then
- Report.Failed ("Object of " &
- "nonprivate extension of private extension " &
- "(of private parent) " &
- "failed content check");
- end if;
-
- -- check that the extension aggregate may specify an expression of
- -- a "grandparent" ancestor type
-
- -- types tested are derived through nonprivate extensions only
- -- (extension aggregates are not allowed if the path from the
- -- ancestor type wanders through a private extension)
-
- N_N_N_Object :=
- (N_Object with Period => C432001_1.Devonian,
- Sample_On_Loan => Report.Ident_Bool(True));
-
- if not C432001_2.Check (N_N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension " &
- "of nonprivate ancestor " &
- "failed content check");
- end if;
-
- P_N_N_Object :=
- (P_Object with Period => C432001_1.Jurassic,
- Sample_On_Loan => Report.Ident_Bool(True));
-
- if not C432001_2.Check (P_N_N_Object,
- C432001_1.Jurassic,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension " &
- "of private ancestor " &
- "failed content check");
- end if;
-
- -- Check additional cases
- if not C432001_1.Check (P_N_Object_2,
- C432001_1.Carboniferous) then
- Report.Failed ("Additional Object of " &
- "nonprivate extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (N_N_Object_2,
- 42,
- C432001_0.Precambrian,
- C432001_1.Carboniferous) then
- Report.Failed ("Additional Object of " &
- "nonprivate extension of nonprivate type " &
- "failed content check");
- end if;
-
- Report.Result;
-
-end C432001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432002.a b/gcc/testsuite/ada/acats/tests/c4/c432002.a
deleted file mode 100644
index 5de821b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432002.a
+++ /dev/null
@@ -1,764 +0,0 @@
--- C432002.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 extension aggregate specifies a value for a record
--- extension and the ancestor expression has discriminants that are
--- inherited by the record extension, then a check is made that each
--- discriminant has the value specified.
---
--- Check that if an extension aggregate specifies a value for a record
--- extension and the ancestor expression has discriminants that are not
--- inherited by the record extension, then a check is made that each
--- such discriminant has the value specified for the corresponding
--- discriminant.
---
--- Check that the corresponding discriminant value may be specified
--- in the record component association list or in the derived type
--- definition for an ancestor.
---
--- Check the case of ancestors that are several generations removed.
--- Check the case where the value of the discriminant(s) in question
--- is supplied several generations removed.
---
--- Check the case of multiple discriminants.
---
--- Check that Constraint_Error is raised if the check fails.
---
--- TEST DESCRIPTION:
--- A hierarchy of tagged types is declared from a discriminated
--- root type. Each level declares two kinds of types: (1) a type
--- extension which constrains the discriminant of its parent to
--- the value of an expression and (2) a type extension that
--- constrains the discriminant of its parent to equal a new discriminant
--- of the type extension (These are the two categories of noninherited
--- discriminants).
---
--- Values for each type are declared within nested blocks. This is
--- done so that the instances that produce Constraint_Error may
--- be dealt with cleanly without forcing the program to exit.
---
--- Success and failure cases (which should raise Constraint_Error)
--- are set up for each kind of type. Additionally, for the first
--- level of the hierarchy, separate tests are done for ancestor
--- expressions specified by aggregates and those specified by
--- variables. Later tests are performed using variables only.
---
--- Additionally, the cases tested consist of the following kinds of
--- types:
---
--- Extensions of extensions, using both the parent and grandparent
--- types for the ancestor expression,
---
--- Ancestor expressions which are several generations removed
--- from the type of the aggregate,
---
--- Extensions of types with multiple discriminants, where the
--- extension declares a new discriminant which corresponds to
--- more than one discriminant of the ancestor types.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants
---
---!
-
-package C432002_0 is
-
- subtype Length is Natural range 0..256;
- type Discriminant (L : Length) is tagged
- record
- S1 : String (1..L);
- end record;
-
- procedure Do_Something (Rec : in out Discriminant);
- -- inherited by all type extensions
-
- -- Aggregates of Discriminant are of the form
- -- (L, S1) where L= S1'Length
-
- -- Discriminant of parent constrained to value of an expression
- type Constrained_Discriminant_Extension is
- new Discriminant (L => 10)
- with record
- S2 : String (1..20);
- end record;
-
- -- Aggregates of Constrained_Discriminant_Extension are of the form
- -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20
-
- type Once_Removed is new Constrained_Discriminant_Extension
- with record
- S3 : String (1..3);
- end record;
-
- type Twice_Removed is new Once_Removed
- with record
- S4 : String (1..8);
- end record;
-
- -- Aggregates of Twice_Removed are of the form
- -- (L, S1, S2, S3, S4), where L = S1'Length = 10,
- -- S2'Length = 20,
- -- S3'Length = 3,
- -- S4'Length = 8
-
- -- Discriminant of parent constrained to equal new discriminant
- type New_Discriminant_Extension (N : Length) is
- new Discriminant (L => N) with
- record
- S2 : String (1..N);
- end record;
-
- -- Aggregates of New_Discriminant_Extension are of the form
- -- (N, S1, S2), where N = S1'Length = S2'Length
-
- -- Discriminant of parent extension constrained to the value of
- -- an expression
- type Constrained_Extension_Extension is
- new New_Discriminant_Extension (N => 20)
- with record
- S3 : String (1..5);
- end record;
-
- -- Aggregates of Constrained_Extension_Extension are of the form
- -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20,
- -- S3'Length = 5
-
- -- Discriminant of parent extension constrained to equal a new
- -- discriminant
- type New_Extension_Extension (I : Length) is
- new New_Discriminant_Extension (N => I)
- with record
- S3 : String (1..I);
- end record;
-
- -- Aggregates of New_Extension_Extension are of the form
- -- (I, S1, 2, S3), where
- -- I = S1'Length = S2'Length = S3'Length
-
- type Multiple_Discriminants (A, B : Length) is tagged
- record
- S1 : String (1..A);
- S2 : String (1..B);
- end record;
-
- procedure Do_Something (Rec : in out Multiple_Discriminants);
- -- inherited by type extension
-
- -- Aggregates of Multiple_Discriminants are of the form
- -- (A, B, S1, S2), where A = S1'Length, B = S2'Length
-
- type Multiple_Discriminant_Extension (C : Length) is
- new Multiple_Discriminants (A => C, B => C)
- with record
- S3 : String (1..C);
- end record;
-
- -- Aggregates of Multiple_Discriminant_Extension are of the form
- -- (A, B, S1, S2, C, S3), where
- -- A = B = C = S1'Length = S2'Length = S3'Length
-
-end C432002_0;
-
-with Report;
-package body C432002_0 is
-
- S : String (1..20) := "12345678901234567890";
-
- procedure Do_Something (Rec : in out Discriminant) is
- begin
- Rec.S1 := Report.Ident_Str (S (1..Rec.L));
- end Do_Something;
-
- procedure Do_Something (Rec : in out Multiple_Discriminants) is
- begin
- Rec.S1 := Report.Ident_Str (S (1..Rec.A));
- end Do_Something;
-
-end C432002_0;
-
-
-with C432002_0;
-with Report;
-procedure C432002 is
-
- -- Various different-sized strings for variety
- String_3 : String (1..3) := Report.Ident_Str("123");
- String_5 : String (1..5) := Report.Ident_Str("12345");
- String_8 : String (1..8) := Report.Ident_Str("12345678");
- String_10 : String (1..10) := Report.Ident_Str("1234567890");
- String_11 : String (1..11) := Report.Ident_Str("12345678901");
- String_20 : String (1..20) := Report.Ident_Str("12345678901234567890");
-
-begin
-
- Report.Test ("C432002",
- "Extension aggregates for discriminated types");
-
- --------------------------------------------------------------------
- -- Extension constrains parent's discriminant to value of expression
- --------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- CD_Matched_Aggregate:
- begin
- declare
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (C432002_0.Discriminant'(L => 10,
- S1 => String_10)
- with S2 => String_20);
- begin
- C432002_0.Do_Something(CD); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CD_Matched_Aggregate;
-
- CD_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 10) :=
- C432002_0.Discriminant'(L => 10,
- S1 => String_10);
-
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (D with S2 => String_20);
- begin
- C432002_0.Do_Something(CD); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CD_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- CD_Unmatched_Aggregate:
- begin
- declare
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (C432002_0.Discriminant'(L => 5,
- S1 => String_5)
- with S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CD); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CD_Unmatched_Aggregate;
-
- CD_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (D with S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CD); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CD_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Extension constrains parent's discriminant to equal new discriminant
- -----------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- ND_Matched_Aggregate:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 8) :=
- (C432002_0.Discriminant'(L => 8,
- S1 => String_8)
- with N => 8,
- S2 => String_8);
- begin
- C432002_0.Do_Something(ND); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end ND_Matched_Aggregate;
-
- ND_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 3) :=
- C432002_0.Discriminant'(L => 3,
- S1 => String_3);
-
- ND : C432002_0.New_Discriminant_Extension (N => 3) :=
- (D with N => 3,
- S2 => String_3);
- begin
- C432002_0.Do_Something(ND); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end ND_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- ND_Unmatched_Aggregate:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- (C432002_0.Discriminant'(L => 11,
- S1 => String_11)
- with N => 20,
- S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(ND); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end ND_Unmatched_Aggregate;
-
- ND_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- (D with N => 20,
- S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(ND); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end ND_Unmatched_Variable;
-
- --------------------------------------------------------------------
- -- Extension constrains parent's discriminant to value of expression
- -- Parent is a discriminant extension
- --------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- CE_Matched_Aggregate:
- begin
- declare
- CE : C432002_0.Constrained_Extension_Extension :=
- (C432002_0.Discriminant'(L => 20,
- S1 => String_20)
- with N => 20,
- S2 => String_20,
- S3 => String_5);
- begin
- C432002_0.Do_Something(CE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CE_Matched_Aggregate;
-
- CE_Matched_Variable:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- C432002_0.New_Discriminant_Extension'
- (N => 20,
- S1 => String_20,
- S2 => String_20);
-
- CE : C432002_0.Constrained_Extension_Extension :=
- (ND with S3 => String_5);
- begin
- C432002_0.Do_Something(CE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CE_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- CE_Unmatched_Aggregate:
- begin
- declare
- CE : C432002_0.Constrained_Extension_Extension :=
- (C432002_0.New_Discriminant_Extension'
- (N => 11,
- S1 => String_11,
- S2 => String_11)
- with S3 => String_5);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "Constraint_Error was not raised " &
- "with discriminant constrained: " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CE_Unmatched_Aggregate;
-
- CE_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 8) :=
- C432002_0.Discriminant'(L => 8,
- S1 => String_8);
-
- CE : C432002_0.Constrained_Extension_Extension :=
- (D with N => 8,
- S2 => String_8,
- S3 => String_5);
- begin
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CE_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Extension constrains parent's discriminant to equal new discriminant
- -- Parent is a discriminant extension
- -----------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- NE_Matched_Aggregate:
- begin
- declare
- NE : C432002_0.New_Extension_Extension (I => 8) :=
- (C432002_0.Discriminant'(L => 8,
- S1 => String_8)
- with I => 8,
- S2 => String_8,
- S3 => String_8);
- begin
- C432002_0.Do_Something(NE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end NE_Matched_Aggregate;
-
- NE_Matched_Variable:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 3) :=
- C432002_0.New_Discriminant_Extension'
- (N => 3,
- S1 => String_3,
- S2 => String_3);
-
- NE : C432002_0.New_Extension_Extension (I => 3) :=
- (ND with I => 3,
- S3 => String_3);
- begin
- C432002_0.Do_Something(NE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end NE_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- NE_Unmatched_Aggregate:
- begin
- declare
- NE : C432002_0.New_Extension_Extension (I => 8) :=
- (C432002_0.New_Discriminant_Extension'
- (C432002_0.Discriminant'(L => 11,
- S1 => String_11)
- with N => 11,
- S2 => String_11)
- with I => 8,
- S3 => String_8);
- begin
- Report.Comment ("Ancestor expression is an extension aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(NE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end NE_Unmatched_Aggregate;
-
- NE_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- NE : C432002_0.New_Extension_Extension (I => 20) :=
- (D with I => 5,
- S2 => String_5,
- S3 => String_20);
- begin
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(NE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end NE_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Corresponding discriminant is two levels deeper than aggregate
- -----------------------------------------------------------------------
-
- -- Successful case - value matches corresponding discriminant value
-
- TR_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant (L => 10) :=
- C432002_0.Discriminant'(L => 10,
- S1 => String_10);
-
- TR : C432002_0.Twice_Removed :=
- C432002_0.Twice_Removed'(D with S2 => String_20,
- S3 => String_3,
- S4 => String_8);
- -- N is constrained to a value in the derived_type_definition
- -- of Constrained_Discriminant_Extension. Its omission from
- -- the above record_component_association_list is allowed by
- -- 4.3.2(6).
-
- begin
- C432002_0.Do_Something(TR); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Failed ("Aggregate of far-removed extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end TR_Matched_Variable;
-
-
- -- Unsuccessful case - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- TR_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant (L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- TR : C432002_0.Twice_Removed :=
- C432002_0.Twice_Removed'(D with S2 => String_20,
- S3 => String_3,
- S4 => String_8);
-
- begin
- Report.Failed ("Aggregate of far-removed extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(TR); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end TR_Unmatched_Variable;
-
- ------------------------------------------------------------------------
- -- Parent has multiple discriminants.
- -- Discriminant in extension corresponds to both parental discriminants.
- ------------------------------------------------------------------------
-
- -- Successful case - value matches corresponding discriminant value
-
- MD_Matched_Variable:
- begin
- declare
- MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) :=
- C432002_0.Multiple_Discriminants'(A => 10,
- B => 10,
- S1 => String_10,
- S2 => String_10);
- MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=
- (MD with C => 10,
- S3 => String_10);
-
- begin
- C432002_0.Do_Something(MDE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Failed ("Aggregate of extension " &
- "of multiply-discriminated parent: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end MD_Matched_Variable;
-
-
- -- Unsuccessful case - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- MD_Unmatched_Variable:
- begin
- declare
- MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) :=
- C432002_0.Multiple_Discriminants'(A => 10,
- B => 8,
- S1 => String_10,
- S2 => String_8);
- MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=
- (MD with C => 10,
- S3 => String_10);
-
- begin
- Report.Failed ("Aggregate of extension " &
- "of multiply-discriminated parent: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(MDE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end MD_Unmatched_Variable;
-
- Report.Result;
-
-end C432002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc/testsuite/ada/acats/tests/c4/c432003.a
deleted file mode 100644
index 8988992..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432003.a
+++ /dev/null
@@ -1,594 +0,0 @@
--- C432003.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 type of the ancestor part of an extension aggregate
--- has discriminants that are not inherited by the type of the aggregate,
--- and the ancestor part is a subtype mark that denotes a constrained
--- subtype, Constraint_Error is raised if: 1) any discriminant of the
--- ancestor has a different value than that specified for a corresponding
--- discriminant in the derived type definition for some ancestor of the
--- type of the aggregate, or 2) the value for the discriminant in the
--- record association list is not the value of the corresponding
--- discriminant. Check that the components of the value of the
--- aggregate not given by the record component association list are
--- initialized by default as for an object of the ancestor type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- type T (D1: ...) is tagged ...
---
--- type DT is new T with ...
--- subtype ST is DT (D1 => 3); -- Constrained subtype.
---
--- type NT1 (D2: ...) is new DT (D1 => D2) with null record;
--- type NT2 (D2: ...) is new DT (D1 => 6) with null record;
--- type NT3 is new DT (D1 => 6) with null record;
---
--- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained.
--- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained.
--- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2.
---
--- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained.
--- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained.
--- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2.
---
--- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained.
--- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained.
--- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3.
---
--- In A, B, D, E, G, and H the ancestor part is the name of an
--- unconstrained subtype, so this rule does not apply. In C, F, and I
--- the ancestor part (ST) is the name of a constrained subtype of DT,
--- which is itself a derived type of a discriminated tagged type T. ST
--- constrains the discriminant of DT (D1) to the value 3; thus, the
--- type of any extension aggregate for which ST is the ancestor part
--- must have an ancestor which also constrained D1 to 3. F and I raise
--- Constraint_Error because NT2 and NT3, respectively, constrain D1 to
--- 6. C raises Constraint_Error because NT1 constrains D1 to the value
--- of D2, which is set to 6 in the record component association list of
--- the aggregate.
---
--- This test verifies each of the three scenarios above:
---
--- (1) Ancestor of type of aggregate constrains discriminant with
--- new discriminant.
--- (2) Ancestor of type of aggregate constrains discriminant with
--- value, and has a new discriminant part.
--- (3) Ancestor of type of aggregate constrains discriminant with
--- value, and has no discriminant part.
---
--- Verification is made for cases where the type of the aggregate is
--- once- and twice-removed from the type of the ancestor part.
---
--- Additionally, a case is included where a new discriminant corresponds
--- to multiple discriminants of the type of the ancestor part.
---
--- To test the portion of the objective concerning "initialization by
--- default," the test verifies that, after a successful aggregate
--- assignment, components not assigned an explicit value by the aggregate
--- contain the default values for the corresponding components of the
--- ancestor type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Dec 94 SAIC Removed discriminant defaults from tagged types.
--- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint
--- for component NT_C3.Str2. Added missing component
--- checks. Removed record component update from
--- Avoid_Optimization. Fixed incorrect component
--- checks.
--- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for
--- Q case.
---
---!
-
-package C432003_0 is
-
- Default_String : constant String := "This is a default string"; -- len = 24
- Another_String : constant String := "Another default string"; -- len = 22
-
- subtype Length is Natural range 0..255;
-
- type ROOT (D1 : Length) is tagged
- record
- S1 : String (1..D1) := Default_String(1..D1);
- Acc : Natural := 356;
- end record;
-
- procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type
- -- extensions.
-
- type Unconstrained_Der is new ROOT with
- record
- Str1 : String(1..5) := "abcde";
- end record;
-
- subtype Constrained_Subtype is Unconstrained_Der (D1 => 10);
-
- type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with
- record
- S2 : String(1..D2); -- Inherited discrim. constrained by
- end record; -- new discriminant.
-
- type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with
- record
- S3 : String(1..D3); -- Inherited discrim. constrained by
- end record; -- new discriminant.
-
-
- type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with
- record
- S2 : String(1..D2); -- Inherited discrim. constrained by
- end record; -- explicit value.
-
- type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with
- record
- S3 : String(1..D3); -- Inherited discrim. constrained by
- end record; -- explicit value.
-
- type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with
- record
- S2 : String(1..D2);
- end record;
-
-
- type NT_C1 is new Unconstrained_Der (D1 => 5) with
- record
- Str2 : String(1..5); -- Inherited discrim. constrained
- end record; -- No new value.
-
- type NT_C2 (D2 : Length) is new NT_C1 with
- record
- S2 : String(1..D2); -- Inherited discrim. not further
- end record; -- constrained, new discriminant.
-
- type NT_C3 is new Unconstrained_Der(D1 => 10) with
- record
- Str2 : String(1..5);
- end record;
-
-
- type MULTI_ROOT (D1 : Length; D2 : Length) is tagged
- record
- S1 : String (1..D1) := Default_String(1..D1);
- S2 : String (1..D2) := Another_String(1..D2);
- end record;
-
- procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all
- -- type extensions.
-
- type Mult_Unconstr_Der is new MULTI_ROOT with
- record
- Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints.
- end record;
-
- -- Subtypes with constrained discriminants.
- subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
- D2 => 20); -- diff values
-
- subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
- D2 => 15); -- same value
-
- type Mult_NT_A1 (D3 : Length) is
- new Mult_Unconstr_Der (D1 => D3, D2 => D3) with
- record
- S3 : String(1..D3); -- Both inherited discriminants constrained
- end record; -- by new discriminant.
-
-end C432003_0;
-
-
- --=====================================================================--
-
-
-with Report;
-package body C432003_0 is
-
- procedure Avoid_Optimization (Rec : in out ROOT) is
- begin
- Rec.S1 := Report.Ident_Str(Rec.S1);
- end Avoid_Optimization;
-
- procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is
- begin
- Rec.S1 := Report.Ident_Str(Rec.S1);
- end Avoid_Optimization;
-
-end C432003_0;
-
-
- --=====================================================================--
-
-
-with C432003_0;
-with Report;
-procedure C432003 is
-begin
-
- Report.Test("C432003", "Extension aggregates where ancestor part " &
- "is a subtype mark that denotes a constrained " &
- "subtype causing Constraint_Error if any " &
- "discriminant of the ancestor has a different " &
- "value than that specified for a corresponding " &
- "discriminant in the derived type definition " &
- "for some ancestor of the type of the aggregate");
-
- Test_Block:
- declare
-
- -- Variety of string object declarations.
- String2 : String(1..2) := Report.Ident_Str("12");
- String5 : String(1..5) := Report.Ident_Str("12345");
- String8 : String(1..8) := Report.Ident_Str("AbCdEfGh");
- String10 : String(1..10) := Report.Ident_Str("1234567890");
- String15 : String(1..15) := Report.Ident_Str("123456789012345");
- String20 : String(1..20) := Report.Ident_Str("12345678901234567890");
-
- begin
-
-
- begin
- declare
- A : C432003_0.NT_A1 := -- OK
- (C432003_0.ROOT with D2 => 5,
- Str1 => "cdefg",
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(A);
- if A.Acc /= 356 or
- A.Str1 /= "cdefg" or
- A.S2 /= String5 or
- A.D2 /= 5 or
- A.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object A");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object A");
- end;
-
-
- begin
- declare
- C: C432003_0.NT_A1 := -- OK
- (C432003_0.Constrained_Subtype with D2 => 10,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(C);
- if C.D2 /= 10 or C.Acc /= 356 or
- C.Str1 /= "abcde" or C.S2 /= String10 or
- C.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object C");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object C");
- end;
-
-
- begin
- declare
- D: C432003_0.NT_A1 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(5),
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(D);
- Report.Failed("Constraint_Error not raised for Object D");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- E: C432003_0.NT_A2 := -- OK
- (C432003_0.Constrained_Subtype with D3 => 10,
- S2 => String10,
- S3 => String10);
- begin
- C432003_0.Avoid_Optimization(E);
- if E.D3 /= 10 or E.Acc /= 356 or
- E.Str1 /= "abcde" or E.S2 /= String10 or
- E.S3 /= String10 or
- E.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object E");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object E");
- end;
-
-
- begin
- declare
- F: C432003_0.NT_A2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D3 => Report.Ident_Int(5),
- S2 => String5,
- S3 => String5);
- begin
- C432003_0.Avoid_Optimization(F);
- Report.Failed("Constraint_Error not raised for Object F");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- G: C432003_0.NT_B2 := -- OK
- (C432003_0.ROOT with D3 => 5,
- Str1 => "cdefg",
- S2 => String10,
- S3 => String5);
- begin
- C432003_0.Avoid_Optimization(G);
- if G.D3 /= 5 or G.Acc /= 356 or
- G.Str1 /= "cdefg" or G.S2 /= String10 or
- G.S3 /= String5 or
- G.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object G");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object G");
- end;
-
-
- begin
- declare
- H: C432003_0.NT_B3 := -- OK
- (C432003_0.Unconstrained_Der with D2 => 5,
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(H);
- if H.D2 /= 5 or H.Acc /= 356 or
- H.Str1 /= "abcde" or H.S2 /= String5 or
- H.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object H");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object H");
- end;
-
-
- begin
- declare
- I: C432003_0.NT_B1 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(10),
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(I);
- Report.Failed("Constraint_Error not raised for Object I");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- J: C432003_0.NT_B2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D3 => Report.Ident_Int(10),
- S2 => String10,
- S3 => String10);
- begin
- C432003_0.Avoid_Optimization(J);
- Report.Failed("Constraint_Error not raised by Object J");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- K: C432003_0.NT_B3 := -- OK
- (C432003_0.Constrained_Subtype with D2 => 5,
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(K);
- if K.D2 /= 5 or K.Acc /= 356 or
- K.Str1 /= "abcde" or K.S2 /= String5 or
- K.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object K");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object K");
- end;
-
-
- begin
- declare
- M: C432003_0.NT_C2 := -- OK
- (C432003_0.ROOT with D2 => 10,
- Str1 => "cdefg",
- Str2 => String5,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(M);
- if M.D2 /= 10 or M.Acc /= 356 or
- M.Str1 /= "cdefg" or M.S2 /= String10 or
- M.Str2 /= String5 or
- M.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object M");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object M");
- end;
-
-
- begin
- declare
- O: C432003_0.NT_C1 := -- C_E
- (C432003_0.Constrained_Subtype with
- Str2 => Report.Ident_Str(String5));
- begin
- C432003_0.Avoid_Optimization(O);
- Report.Failed("Constraint_Error not raised for Object O");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- P: C432003_0.NT_C2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(10),
- Str2 => String5,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(P);
- Report.Failed("Constraint_Error not raised by Object P");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- Q: C432003_0.NT_C3 :=
- (C432003_0.Constrained_Subtype with Str2 => String5); -- OK
- begin
- C432003_0.Avoid_Optimization(Q);
- if Q.Str2 /= String5 or
- Q.Acc /= 356 or
- Q.Str1 /= "abcde" or
- Q.D1 /= 10 or
- Q.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object Q");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object Q");
- end;
-
-
- -- The following cases test where a new discriminant corresponds
- -- to multiple discriminants of the type of the ancestor part.
-
- begin
- declare
- S: C432003_0.Mult_NT_A1 := -- OK
- (C432003_0.Mult_Unconstr_Der with D3 => 15,
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(S);
- if S.S1 /= C432003_0.Default_String(1..15) or
- S.Str1 /= String8 or
- S.S2 /= C432003_0.Another_String(1..15) or
- S.S3 /= String15 or
- S.D3 /= 15
- then
- Report.Failed("Incorrect object values for Object S");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object S");
- end;
-
-
- begin
- declare
- U: C432003_0.Mult_NT_A1 := -- C_E
- (C432003_0.Mult_Constr_Sub1 with
- D3 => Report.Ident_Int(15),
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(U);
- Report.Failed("Constraint_Error not raised for Object U");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- V: C432003_0.Mult_NT_A1 := -- OK
- (C432003_0.Mult_Constr_Sub2 with D3 => 15,
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(V);
- if V.D3 /= 15 or
- V.Str1 /= String8 or
- V.S3 /= String15 or
- V.S1 /= C432003_0.Default_String(1..15) or
- V.S2 /= C432003_0.Another_String(1..15)
- then
- Report.Failed("Incorrect object values for Object V");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object V");
- end;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end C432003;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432004.a b/gcc/testsuite/ada/acats/tests/c4/c432004.a
deleted file mode 100644
index 3a14862..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432004.a
+++ /dev/null
@@ -1,319 +0,0 @@
--- C432004.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 type of an extension aggregate may be derived from the
--- type of the ancestor part through multiple record extensions. Check
--- for ancestor parts that are subtype marks. Check that the type of the
--- ancestor part may be abstract.
---
--- TEST DESCRIPTION:
--- This test defines the following type hierarchies:
---
--- (A) (F)
--- Abstract Abstract
--- Tagged record Tagged private
--- / \ / \
--- / (C) (G) \
--- (B) Abstract Abstract (H)
--- Record private record Private
--- extension extension extension extension
--- | | | |
--- (D) (E) (I) (J)
--- Record Record Record Record
--- extension extension extension extension
---
--- Extension aggregates for B, D, E, I, and J are constructed using each
--- of its ancestor types as the ancestor part (except for E and J, for
--- which only the immediate ancestor is used, since using A and F,
--- respectively, as the ancestor part would be illegal).
---
--- X1 : B := (A with ...);
--- X2 : D := (A with ...); X5 : I := (F with ...);
--- X3 : D := (B with ...); X6 : I := (G with ...);
--- X4 : E := (C with ...); X7 : J := (H with ...);
---
--- For each assignment of an aggregate, the value of the target object is
--- checked to ensure that the proper values for each component were
--- assigned.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C432004_0 is
-
- type Drawers is record
- Building : natural;
- end record;
-
- type Location is access Drawers;
-
- type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);
-
- type SampleType_A is abstract tagged record
- Era : Eras := Cenozoic;
- Loc : Location;
- end record;
-
- type SampleType_F is abstract tagged private;
-
- -- The following function is needed to verify the values of the
- -- private components.
- function TC_Correct_Result (Rec : SampleType_F'Class;
- E : Eras) return Boolean;
-
-private
- type SampleType_F is abstract tagged record
- Era : Eras := Mesozoic;
- end record;
-
-end C432004_0;
-
- --==================================================================--
-
-package body C432004_0 is
-
- function TC_Correct_Result (Rec : SampleType_F'Class;
- E : Eras) return Boolean is
- begin
- return (Rec.Era = E);
- end TC_Correct_Result;
-
-end C432004_0;
-
- --==================================================================--
-
-with C432004_0;
-package C432004_1 is
-
- type Periods is
- (Aphebian, Helikian, Hadrynian,
- Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
- Triassic, Jurassic, Cretaceous,
- Tertiary, Quaternary);
-
- type SampleType_B is new C432004_0.SampleType_A with record
- Period : Periods := Quaternary;
- end record;
-
- type SampleType_C is abstract new C432004_0.SampleType_A with private;
-
- -- The following function is needed to verify the values of the
- -- extension's private components.
- function TC_Correct_Result (Rec : SampleType_C'Class;
- P : Periods) return Boolean;
-
- type SampleType_G is abstract new C432004_0.SampleType_F with record
- Period : Periods := Jurassic;
- Loc : C432004_0.Location;
- end record;
-
- type SampleType_H is new C432004_0.SampleType_F with private;
-
- -- The following function is needed to verify the values of the
- -- extension's private components.
- function TC_Correct_Result (Rec : SampleType_H'Class;
- P : Periods;
- E : C432004_0.Eras) return Boolean;
-
-private
- type SampleType_C is abstract new C432004_0.SampleType_A with record
- Period : Periods := Quaternary;
- end record;
-
- type SampleType_H is new C432004_0.SampleType_F with record
- Period : Periods := Jurassic;
- end record;
-
-end C432004_1;
-
- --==================================================================--
-
-package body C432004_1 is
-
- function TC_Correct_Result (Rec : SampleType_C'Class;
- P : Periods) return Boolean is
- begin
- return (Rec.Period = P);
- end TC_Correct_Result;
-
- -------------------------------------------------------------
- function TC_Correct_Result (Rec : SampleType_H'Class;
- P : Periods;
- E : C432004_0.Eras) return Boolean is
- begin
- return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E);
- end TC_Correct_Result;
-
-end C432004_1;
-
- --==================================================================--
-
-with C432004_0;
-with C432004_1;
-package C432004_2 is
-
- -- All types herein are record extensions, since aggregates
- -- cannot be given for private extensions
-
- type SampleType_D is new C432004_1.SampleType_B with record
- Sample_On_Loan : Boolean := False;
- end record;
-
- type SampleType_E is new C432004_1.SampleType_C
- with null record;
-
- type SampleType_I is new C432004_1.SampleType_G with record
- Sample_On_Loan : Boolean := True;
- end record;
-
- type SampleType_J is new C432004_1.SampleType_H with record
- Sample_On_Loan : Boolean := True;
- end record;
-
-end C432004_2;
-
-
- --==================================================================--
-
-with Report;
-with C432004_0;
-with C432004_1;
-with C432004_2;
-use C432004_1;
-use C432004_2;
-
-procedure C432004 is
-
- -- Variety of extension aggregates.
-
- -- Default values for the components of SampleType_A
- -- (Era => Cenozoic, Loc => null).
- Sample_B : SampleType_B
- := (C432004_0.SampleType_A with Period => Devonian);
-
- -- Default values from SampleType_A (Era => Cenozoic, Loc => null).
- Sample_D1 : SampleType_D
- := (C432004_0.SampleType_A with Period => Cambrian,
- Sample_On_Loan => True);
-
- -- Default values from SampleType_A and SampleType_B
- -- (Era => Cenozoic, Loc => null, Period => Quaternary).
- Sample_D2 : SampleType_D
- := (SampleType_B with Sample_On_Loan => True);
-
- -- Default values from SampleType_A and SampleType_C
- -- (Era => Cenozoic, Loc => null, Period => Quaternary).
- Sample_E : SampleType_E
- := (SampleType_C with null record);
-
- -- Default value from SampleType_F (Era => Mesozoic).
- Sample_I1 : SampleType_I
- := (C432004_0.SampleType_F with Period => Tertiary,
- Loc => new C432004_0.Drawers'(Building => 9),
- Sample_On_Loan => False);
-
- -- Default values from SampleType_F and SampleType_G
- -- (Era => Mesozoic, Period => Jurassic, Loc => null).
- Sample_I2 : SampleType_I
- := (SampleType_G with Sample_On_Loan => False);
-
- -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic).
- Sample_J : SampleType_J
- := (SampleType_H with Sample_On_Loan => False);
-
- use type C432004_0.Eras;
- use type C432004_0.Location;
-
-begin
-
- Report.Test ("C432004", "Check that the type of an extension aggregate " &
- "may be derived from the type of the ancestor part through " &
- "multiple record extensions");
-
- if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then
- Report.Failed ("Object of record extension of abstract ancestor, " &
- "SampleType_B, failed content check");
- end if;
-
- -------------------
- if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null,
- Period => Cambrian, Sample_On_Loan => True) then
- Report.Failed ("Object 1 of record extension of record extension, " &
- "of abstract ancestor, SampleType_D, failed content " &
- "check");
- end if;
-
- -------------------
- if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then
- Report.Failed ("Object 2 of record extension of record extension, " &
- "of abstract ancestor, SampleType_D, failed content " &
- "check");
- end if;
- -------------------
- if Sample_E.Era /= C432004_0.Cenozoic or
- Sample_E.Loc /= null or
- not TC_Correct_Result (Sample_E, Quaternary) then
- Report.Failed ("Object of record extension of abstract private " &
- "extension of abstract ancestor, SampleType_E, " &
- "failed content check");
- end if;
-
- -------------------
- if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or
- Sample_I1.Period /= Tertiary or
- Sample_I1.Loc.Building /= 9 or
- Sample_I1.Sample_On_Loan /= False then
- Report.Failed ("Object 1 of record extension of abstract record " &
- "extension of abstract private ancestor, " &
- "SampleType_I, failed content check");
- end if;
-
- -------------------
- if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or
- Sample_I2.Period /= Jurassic or
- Sample_I2.Loc /= null or
- Sample_I2.Sample_On_Loan /= False then
- Report.Failed ("Object 2 of record extension of abstract record " &
- "extension of abstract private ancestor, " &
- "SampleType_I, failed content check");
- end if;
-
- -------------------
- if not TC_Correct_Result (Sample_J,
- Jurassic,
- C432004_0.Mesozoic) or
- Sample_J.Sample_On_Loan /= False then
- Report.Failed ("Object of record extension of private extension " &
- "of abstract private ancestor, SampleType_J, " &
- "failed content check");
- end if;
-
- Report.Result;
-
-end C432004;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204a.ada b/gcc/testsuite/ada/acats/tests/c4/c43204a.ada
deleted file mode 100644
index 33450db..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204a.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C43204A.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 ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR
--- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF
--- A SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS CONSTRAINED.
-
--- HISTORY:
--- JET 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204A IS
-
- TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER;
- TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER;
- TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER;
-
- TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0),
- IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1,
- INTEGER RANGE -1..1) OF INTEGER;
- TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1),
- IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY(INTEGER'(-1)..1,
- IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER;
-
- PROCEDURE PROC10 (A : ARR10) IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(0) THEN
- FAILED ("PROC10 ARRAY IS NOT NULL");
- END IF;
- END PROC10;
-
- PROCEDURE PROC11 (A : ARR11; C : INTEGER) IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(7) OR
- A'FIRST /= IDENT_INT(-3) OR
- A'LAST /= IDENT_INT(3) THEN
- FAILED ("INCORRECT LENGTH IN PROC11 CALL NUMBER" &
- INTEGER'IMAGE(C));
- END IF;
-
- FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP
- IF IDENT_INT(A(I)) /= C THEN
- FAILED ("INCORRECT VALUE OF COMPONENT " &
- INTEGER'IMAGE(I) & ", PROC11 CALL NUMBER" &
- INTEGER'IMAGE(C));
- END IF;
- END LOOP;
- END PROC11;
-
- PROCEDURE PROC12 (A : ARR12) IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(7) THEN
- FAILED ("INCORRECT LENGTH IN PROC12");
- END IF;
-
- FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP
- IF IDENT_INT(A(I)) /= 3 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT " &
- INTEGER'IMAGE(I) & ", PROC12");
- END IF;
- END LOOP;
- END PROC12;
-
- PROCEDURE PROC20 (A : ARR20) IS
- BEGIN
- IF A'LENGTH(1) /= IDENT_INT(0) OR
- A'LENGTH(2) /= IDENT_INT(0) THEN
- FAILED ("PROC20 ARRAY IS NOT NULL");
- END IF;
- END PROC20;
-
- PROCEDURE PROC21 (A : ARR21; C : INTEGER) IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= C THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), PROC21 CALL " &
- "NUMBER" & INTEGER'IMAGE(C));
- END IF;
- END LOOP;
- END LOOP;
- END PROC21;
-
- PROCEDURE PROC22 (A : ARR22) IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= 5 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), PROC22");
- END IF;
- END LOOP;
- END LOOP;
- END PROC22;
-
- PROCEDURE PROC23 (A : ARR23) IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= 7 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), PROC23");
- END IF;
- END LOOP;
- END LOOP;
- END PROC23;
-
-BEGIN
- TEST ("C43204A", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " &
- "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " &
- "CORRECTLY) AS AN ACTUAL PARAMETER OF A " &
- "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " &
- "CONSTRAINED");
-
- PROC11 ((1,1,1, OTHERS => 1), 1);
- PROC11 ((2 => 2, 3 => 2, OTHERS => 2), 2);
- PROC12 ((OTHERS => 3));
- PROC10 ((OTHERS => 4));
-
- PROC21 (((1,1,1), OTHERS => (1,1,1)), 1);
- PROC21 ((1 => (2,2,2), OTHERS => (2,2,2)), 2);
- PROC21 (((3,OTHERS => 3), (3,OTHERS => 3), (3,3,OTHERS => 3)), 3);
- PROC21 (((-1 => 4, OTHERS => 4), (0 => 4, OTHERS => 4),
- (1 => 4, OTHERS => 4)), 4);
- PROC22 ((OTHERS => (OTHERS => 5)));
- PROC20 ((OTHERS => (OTHERS => 6)));
- PROC23 ((OTHERS => (7,7,7)));
-
- RESULT;
-END C43204A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204c.ada b/gcc/testsuite/ada/acats/tests/c4/c43204c.ada
deleted file mode 100644
index 1db9f7f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204c.ada
+++ /dev/null
@@ -1,192 +0,0 @@
--- C43204C.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 ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR
--- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF
--- A GENERIC INSTANTIATION WHEN THE GENERIC FORMAL PARAMETER IS
--- CONSTRAINED.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204C IS
-
- TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER;
- TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER;
- TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER;
-
- TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0),
- IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1,
- INTEGER RANGE -1..1) OF INTEGER;
- TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1),
- IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY(INTEGER'(-1)..1,
- IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER;
-
- GENERIC
- A : ARR10;
- PROCEDURE GPROC10;
-
- GENERIC
- A : ARR11;
- PROCEDURE GPROC11;
-
- GENERIC
- A : ARR12;
- PROCEDURE GPROC12;
-
- GENERIC
- A : ARR20;
- PROCEDURE GPROC20;
-
- GENERIC
- A : ARR21;
- PROCEDURE GPROC21 (C : INTEGER);
-
- GENERIC
- A : ARR22;
- PROCEDURE GPROC22;
-
- GENERIC
- A : ARR23;
- PROCEDURE GPROC23;
-
- PROCEDURE GPROC10 IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(0) THEN
- FAILED ("PROC10 ARRAY IS NOT NULL");
- END IF;
- END GPROC10;
-
- PROCEDURE GPROC11 IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(7) OR
- A'FIRST /= IDENT_INT(-3) OR
- A'LAST /= IDENT_INT(3) THEN
- FAILED ("INCORRECT LENGTH IN PROC11");
- END IF;
-
- FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP
- IF IDENT_INT(A(I)) /= 1 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT " &
- INTEGER'IMAGE(I) & ", PROC11");
- END IF;
- END LOOP;
- END GPROC11;
-
- PROCEDURE GPROC12 IS
- BEGIN
- IF A'LENGTH /= IDENT_INT(7) THEN
- FAILED ("INCORRECT LENGTH IN PROC12");
- END IF;
-
- FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP
- IF IDENT_INT(A(I)) /= 2 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT " &
- INTEGER'IMAGE(I) & ", PROC12");
- END IF;
- END LOOP;
- END GPROC12;
-
- PROCEDURE GPROC20 IS
- BEGIN
- IF A'LENGTH(1) /= IDENT_INT(0) OR
- A'LENGTH(2) /= IDENT_INT(0) THEN
- FAILED ("GPROC20 ARRAY IS NOT NULL");
- END IF;
- END GPROC20;
-
- PROCEDURE GPROC21 (C : INTEGER) IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= C THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), GPROC21 CALL " &
- "NUMBER" & INTEGER'IMAGE(C));
- END IF;
- END LOOP;
- END LOOP;
- END GPROC21;
-
- PROCEDURE GPROC22 IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= 3 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), GPROC22");
- END IF;
- END LOOP;
- END LOOP;
- END GPROC22;
-
- PROCEDURE GPROC23 IS
- BEGIN
- FOR I IN INTEGER'(-1)..1 LOOP
- FOR J IN INTEGER'(-1)..1 LOOP
- IF IDENT_INT(A(I,J)) /= 4 THEN
- FAILED ("INCORRECT VALUE OF COMPONENT (" &
- INTEGER'IMAGE(I) & "," &
- INTEGER'IMAGE(J) & "), GPROC23");
- END IF;
- END LOOP;
- END LOOP;
- END GPROC23;
-
- PROCEDURE PROC11 IS NEW GPROC11((1,1,1, OTHERS => 1));
- PROCEDURE PROC12 IS NEW GPROC12((OTHERS => 2));
- PROCEDURE PROC10 IS NEW GPROC10((OTHERS => 3));
-
- PROCEDURE PROC21 IS NEW GPROC21(((1,1,1), OTHERS => (1,1,1)));
- PROCEDURE PROC22 IS NEW GPROC21(((2,OTHERS => 2), (2,OTHERS => 2),
- (2,2,OTHERS => 2)));
- PROCEDURE PROC23 IS NEW GPROC22((OTHERS => (OTHERS => 3)));
- PROCEDURE PROC24 IS NEW GPROC23((OTHERS => (4,4,4)));
- PROCEDURE PROC20 IS NEW GPROC20((OTHERS => (OTHERS => 5)));
-
-BEGIN
- TEST ("C43204C", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " &
- "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " &
- "CORRECTLY) AS AN ACTUAL PARAMETER OF A " &
- "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " &
- "CONSTRAINED");
-
- PROC11;
- PROC12;
- PROC10;
-
- PROC21(1);
- PROC22(2);
- PROC23;
- PROC24;
- PROC20;
-
- RESULT;
-END C43204C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204e.ada b/gcc/testsuite/ada/acats/tests/c4/c43204e.ada
deleted file mode 100644
index 8b65666..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204e.ada
+++ /dev/null
@@ -1,179 +0,0 @@
--- C43204E.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 ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR
--- AS THE INITIALIZATION EXPRESSION OF A CONSTRAINED CONSTANT,
--- VARIABLE OBJECT DECLARATION, OR RECORD COMPONENT DECLARATION,
--- AND THAT THE BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204E IS
-
- TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER;
- TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER;
- TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1,
- INTEGER RANGE -1 .. 1) OF INTEGER;
- TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1,
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
-
- CA11 : CONSTANT ARR11 := (1, OTHERS => IDENT_INT(2));
- CA12 : CONSTANT ARR12 := (OTHERS => IDENT_INT(2));
- CA13 : CONSTANT ARR13 := (OTHERS => IDENT_INT(2));
- CA21 : CONSTANT ARR21 := (OTHERS => (-1..1 => IDENT_INT(2)));
- CA22 : CONSTANT ARR22 := (OTHERS => (-1..1 => IDENT_INT(2)));
- CA23 : CONSTANT ARR23 := (-1..1 => (OTHERS => IDENT_INT(2)));
- CA24 : CONSTANT ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)));
-
- VA11 : ARR11 := (1,1, OTHERS => IDENT_INT(2));
- VA12 : ARR12 := (OTHERS => IDENT_INT(2));
- VA13 : ARR13 := (OTHERS => IDENT_INT(2));
- VA21 : ARR21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2)));
- VA22 : ARR22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2)));
- VA23 : ARR23 := (OTHERS => (OTHERS => IDENT_INT(2)));
- VA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)));
-
- TYPE REC IS RECORD
- RA11 : ARR11 := (1,1,1, OTHERS => IDENT_INT(2));
- RA12 : ARR12 := (OTHERS => IDENT_INT(2));
- RA13 : ARR13 := (OTHERS => IDENT_INT(2));
- RA21 : ARR21 := ((1,1,1), (1,1,1), OTHERS => (IDENT_INT(2),
- IDENT_INT(2), IDENT_INT(2)));
- RA22 : ARR22 := (OTHERS => (OTHERS => IDENT_INT(2)));
- RA23 : ARR23 := (-1 => (OTHERS => 1),
- 0..1 => (OTHERS => IDENT_INT(2)));
- RA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)));
- END RECORD;
-
- R : REC;
-
-BEGIN
- TEST ("C43204E", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " &
- "CHOICE CAN APPEAR AS THE INITIALIZATION " &
- "EXPRESSION OF A CONSTRAINED CONSTANT, " &
- "VARIABLE OBJECT DECLARATION, OR RECORD " &
- "COMPONENT DECLARATION, AND THAT THE BOUNDS OF " &
- "THE AGGREGATE ARE DETERMINED CORRECTLY");
-
- IF CA11 /= (1, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF CA11");
- END IF;
-
- IF CA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF CA12");
- END IF;
-
- IF CA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF CA13");
- END IF;
-
- IF CA21 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF CA21");
- END IF;
-
- IF CA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF CA22");
- END IF;
-
- IF CA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF CA23");
- END IF;
-
- IF CA24'LENGTH /= 0 OR CA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF CA24");
- END IF;
-
- IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF VA11");
- END IF;
-
- IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF VA12");
- END IF;
-
- IF VA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF VA13");
- END IF;
-
- IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA21");
- END IF;
-
- IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA22");
- END IF;
-
- IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA23");
- END IF;
-
- IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF VA24");
- END IF;
-
- IF R.RA11 /= (1, 1, 1, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF RA11");
- END IF;
-
- IF R.RA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF RA12");
- END IF;
-
- IF R.RA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF RA13");
- END IF;
-
- IF R.RA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF RA21");
- END IF;
-
- IF R.RA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF RA22");
- END IF;
-
- IF R.RA23 /= ((1,1,1), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF RA23");
- END IF;
-
- IF R.RA24'LENGTH /= 0 OR R.RA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF RA24");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " &
- "RAISED");
-
- RESULT;
-END C43204E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204f.ada b/gcc/testsuite/ada/acats/tests/c4/c43204f.ada
deleted file mode 100644
index bd6cc61..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204f.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C43204F.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 AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A
--- CONSTRAINED FORMAL PARAMETER OF A SUBPROGRAM AND THAT THE BOUNDS
--- OF THE AGGREGATE ARE DETERMINED CORRECTLY.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204F IS
-
- TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER;
- TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER;
- TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1,
- INTEGER RANGE -1 .. 1) OF INTEGER;
- TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1,
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
-
- PROCEDURE PROC (PA11 : ARR11 := (1,1,1,1,1,1,
- OTHERS => IDENT_INT(2));
- PA12 : ARR12 := (OTHERS => IDENT_INT(2));
- PA13 : ARR13 := (OTHERS => IDENT_INT(2));
- PA21 : ARR21 := ((1,1,1), (1,1,1),
- (1, OTHERS => IDENT_INT(2)));
- PA22 : ARR22 := ((1,1,1), (1,1,1),
- (OTHERS => IDENT_INT(2)));
- PA23 : ARR23 := ((1,1,1), (1,1,1), (1,1,1),
- OTHERS => (OTHERS =>
- IDENT_INT(2)));
- PA24 : ARR24 := (OTHERS => (OTHERS =>
- IDENT_INT(2)))) IS
- BEGIN
- IF PA11 /= (1, 1, 1, 1, 1, 1, 2) THEN
- FAILED("INCORRECT VALUE OF PA11");
- END IF;
-
- IF PA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF PA12");
- END IF;
-
- IF PA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF PA13");
- END IF;
-
- IF PA21 /= ((1,1,1), (1,1,1), (1,2,2)) THEN
- FAILED("INCORRECT VALUE OF PA21");
- END IF;
-
- IF PA22 /= ((1,1,1), (1,1,1), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF PA22");
- END IF;
-
- IF PA23 /= ((1,1,1), (1,1,1), (1,1,1)) THEN
- FAILED("INCORRECT VALUE OF PA23");
- END IF;
-
- IF PA24'LENGTH /= 0 OR PA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF PA24");
- END IF;
- END PROC;
-
-BEGIN
- TEST ("C43204F", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " &
- "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " &
- "OF A SUBPROGRAM AND THAT THE BOUNDS OF THE " &
- "AGGREGATE ARE DETERMINED CORRECTLY");
-
- PROC;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " &
- "RAISED");
-
- RESULT;
-END C43204F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204g.ada b/gcc/testsuite/ada/acats/tests/c4/c43204g.ada
deleted file mode 100644
index 3474e57..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204g.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C43204G.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 AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A
--- CONSTRAINED FORMAL PARAMETER OF AN ENTRY, AND THAT THE BOUNDS
--- OF THE AGGREGATE ARE DETERMINED CORRECTLY.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204G IS
-
- TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER;
- TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER;
- TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1,
- INTEGER RANGE -1 .. 1) OF INTEGER;
- TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1,
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
-
- TASK T IS
- ENTRY E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2));
- EA12 : ARR12 := (OTHERS => IDENT_INT(2));
- EA13 : ARR13 := (OTHERS => IDENT_INT(2));
- EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1),
- OTHERS => (-1..1 => IDENT_INT(2)));
- EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1),
- (1,1,1));
- EA23 : ARR23 := (-1..0 => (OTHERS => 1),
- 1 => (OTHERS => IDENT_INT(2)));
- EA24: ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))));
- END T;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2));
- EA12 : ARR12 := (OTHERS => IDENT_INT(2));
- EA13 : ARR13 := (OTHERS => IDENT_INT(2));
- EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1),
- OTHERS => (-1..1 => IDENT_INT(2)));
- EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1),
- (1,1,1));
- EA23 : ARR23 := (-1..0 => (OTHERS => 1),
- 1 => (OTHERS => IDENT_INT(2)));
- EA24 : ARR24 := (OTHERS => (OTHERS =>
- IDENT_INT(2))))
- DO
- IF EA11 /= (1, 1, 1, 1, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF EA11");
- END IF;
-
- IF EA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF EA12");
- END IF;
-
- IF EA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF EA13");
- END IF;
-
- IF EA21 /= ((1,1,1), (1,1,1), (1,1,1)) THEN
- FAILED("INCORRECT VALUE OF EA21");
- END IF;
-
- IF EA22 /= ((2,2,2), (1,1,1), (1,1,1)) THEN
- FAILED("INCORRECT VALUE OF EA22");
- END IF;
-
- IF EA23 /= ((1,1,1), (1,1,1), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF EA23");
- END IF;
-
- IF EA24'LENGTH /= 0 OR EA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF EA24");
- END IF;
- END E;
- END T;
-
-BEGIN
- TEST ("C43204G", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " &
- "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " &
- "OF AN ENTRY, AND THAT THE BOUNDS OF THE " &
- "AGGREGATE ARE DETERMINED CORRECTLY");
-
- T.E;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " &
- "RAISED");
-
- IF T'CALLABLE THEN
- T.E;
- END IF;
-
- RESULT;
-END C43204G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204h.ada b/gcc/testsuite/ada/acats/tests/c4/c43204h.ada
deleted file mode 100644
index 54b1958..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204h.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C43204H.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 AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A
--- CONSTRAINED FORMAL PARAMETER OF A GENERIC UNIT, AND THAT THE
--- BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204H IS
-
- TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER;
- TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER;
- TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1,
- INTEGER RANGE -1 .. 1) OF INTEGER;
- TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1,
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
-
- GENERIC
- GA11 : ARR11 := (1,1,1,1,1, OTHERS => IDENT_INT(2));
- GA12 : ARR12 := (OTHERS => IDENT_INT(2));
- GA13 : ARR13 := (OTHERS => IDENT_INT(2));
- GA21 : ARR21 := ((1,1,1), (1,1,1), (OTHERS => IDENT_INT(2)));
- GA22 : ARR22 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1));
- GA23 : ARR23 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1));
- GA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)));
- PROCEDURE GEN;
-
- PROCEDURE GEN IS
- BEGIN
- IF GA11 /= (1, 1, 1, 1, 1, 2, 2) THEN
- FAILED("INCORRECT VALUE OF GA11");
- END IF;
-
- IF GA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF GA12");
- END IF;
-
- IF GA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF GA13");
- END IF;
-
- IF GA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF GA21");
- END IF;
-
- IF GA22 /= ((1,1,1), (2,2,2), (1,1,1)) THEN
- FAILED("INCORRECT VALUE OF GA22");
- END IF;
-
- IF GA23 /= ((1,1,1), (2,2,2), (1,1,1)) THEN
- FAILED("INCORRECT VALUE OF GA23");
- END IF;
-
- IF GA24'LENGTH /= 0 OR GA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF GA24");
- END IF;
- END GEN;
-
- PROCEDURE PROCG IS NEW GEN;
-
-BEGIN
- TEST ("C43204H", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " &
- "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " &
- "OF A GENERIC UNIT, AND THAT THE BOUNDS OF " &
- "THE AGGREGATE ARE DETERMINED CORRECTLY");
-
- PROCG;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " &
- "RAISED");
-
- RESULT;
-END C43204H;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204i.ada b/gcc/testsuite/ada/acats/tests/c4/c43204i.ada
deleted file mode 100644
index 1a761a5..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43204i.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- C43204I.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 AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS THE
--- EXPRESSION IN AN ASSIGNMENT STATEMENT, AND THAT THE BOUNDS OF
--- THE AGGREGATE ARE DETERMINED CORRECTLY.
-
--- HISTORY:
--- JET 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43204I IS
-
- TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER;
- TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER;
- TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER;
- TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1,
- INTEGER RANGE -1 .. 1) OF INTEGER;
- TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1,
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
- TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1),
- IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER;
-
- VA11 : ARR11;
- VA12 : ARR12;
- VA13 : ARR13;
- VA21 : ARR21;
- VA22 : ARR22;
- VA23 : ARR23;
- VA24 : ARR24;
-
-BEGIN
- TEST ("C43204I", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " &
- "CAN APPEAR AS THE EXPRESSION IN AN ASSIGNMENT " &
- "STATEMENT, AND THAT THE BOUNDS OF THE " &
- "AGGREGATE ARE DETERMINED CORRECTLY");
-
- VA11 := (1,1, OTHERS => IDENT_INT(2));
- VA12 := (OTHERS => IDENT_INT(2));
- VA13 := (OTHERS => IDENT_INT(2));
- VA21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2)));
- VA22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2)));
- VA23 := (OTHERS => (OTHERS => IDENT_INT(2)));
- VA24 := (OTHERS => (OTHERS => IDENT_INT(2)));
-
- IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF VA11");
- END IF;
-
- IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN
- FAILED("INCORRECT VALUE OF VA12");
- END IF;
-
- IF VA13'LENGTH /= 0 THEN
- FAILED("INCORRECT VALUE OF VA13");
- END IF;
-
- IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA21");
- END IF;
-
- IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA22");
- END IF;
-
- IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN
- FAILED("INCORRECT VALUE OF VA23");
- END IF;
-
- IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN
- FAILED("INCORRECT VALUE OF VA24");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " &
- "RAISED");
-
- RESULT;
-END C43204I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205a.ada b/gcc/testsuite/ada/acats/tests/c4/c43205a.ada
deleted file mode 100644
index 9946ba9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C43205A.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS:
-
--- A) AN ACTUAL PARAMETER IN A SUBPROGRAM OR ENTRY CALL, AND THE
--- FORMAL PARAMETER IS UNCONSTRAINED.
-
--- EG 01/26/84
-
-WITH REPORT;
-
-PROCEDURE C43205A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205A", "CASE A1 : SUBPROGRAM WITH UNCONSTRAINED " &
- "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER");
-
- BEGIN
-
-CASE_A : BEGIN
-
- CASE_A1 : DECLARE
-
- SUBTYPE STA IS INTEGER RANGE 11 .. 15;
- TYPE TA IS ARRAY (STA RANGE <>) OF INTEGER;
-
- PROCEDURE PROC1 (A : TA) IS
- BEGIN
- IF A'FIRST /= IDENT_INT(11) THEN
- FAILED ("CASE A1 : LOWER BOUND " &
- "INCORRECTLY GIVEN BY 'FIRST");
- ELSIF A'LAST /= 15 THEN
- FAILED ("CASE A1 : UPPER BOUND " &
- "INCORRECTLY GIVEN BY 'LAST");
- ELSIF A /= (6, 7, 8, 9, 10) THEN
- FAILED ("CASE A1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 ((6, 7, 8, 9, IDENT_INT(10)));
-
- END CASE_A1;
-
- COMMENT ("CASE A2 : SUBPROGRAM WITH UNCONSTRAINED " &
- "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER");
-
- CASE_A2 : DECLARE
-
- SUBTYPE STA1 IS INTEGER RANGE 11 .. IDENT_INT(12);
- SUBTYPE STA2 IS INTEGER RANGE 10 .. 11;
- TYPE TA IS ARRAY (STA1 RANGE <>, STA2 RANGE <>)
- OF INTEGER;
-
- PROCEDURE PROC1 (A : TA) IS
- BEGIN
- IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN
- FAILED ("CASE A2 : LOWER BOUND " &
- "INCORRECTLY GIVEN BY 'FIRST");
- ELSIF A'LAST(1) /= 12 OR
- A'LAST(2) /= IDENT_INT(11) THEN
- FAILED ("CASE A2 : UPPER BOUND " &
- "INCORRECTLY GIVEN BY 'LAST");
- ELSIF A /= ((1, 2), (3, 4)) THEN
- FAILED ("CASE A2 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 (((1, 2), (IDENT_INT(3), 4)));
-
- END CASE_A2;
-
- END CASE_A;
-
- END;
-
- RESULT;
-
-END C43205A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205b.ada b/gcc/testsuite/ada/acats/tests/c4/c43205b.ada
deleted file mode 100644
index 7f4dfd6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205b.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C43205B.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS:
-
--- B) AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL
--- PARAMETER IS UNCONSTRAINED.
-
--- EG 01/26/84
-
-WITH REPORT;
-
-PROCEDURE C43205B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205B", "CASE B : UNCONSTRAINED ARRAY FORMAL GENERIC " &
- "PARAMETER");
-
- BEGIN
-
-CASE_B : DECLARE
-
- SUBTYPE STB IS INTEGER RANGE IDENT_INT(-8) .. -5;
- TYPE TB IS ARRAY (STB RANGE <>) OF INTEGER;
-
- GENERIC
- B1 : TB;
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN
- IF B1'FIRST /= -8 THEN
- FAILED ("CASE B : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF B1'LAST /= IDENT_INT(-5) THEN
- FAILED ("CASE B : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF B1 /= (7, 6, 5, 4) THEN
- FAILED ("CASE B : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- PROCEDURE PROC2 IS NEW PROC1 ((7, 6, IDENT_INT(5), 4));
-
- BEGIN
-
- PROC2;
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43205B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205c.ada b/gcc/testsuite/ada/acats/tests/c4/c43205c.ada
deleted file mode 100644
index e788370..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205c.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C43205C.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS:
-
--- C) THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS
--- UNCONSTRAINED.
-
--- EG 01/26/84
-
-WITH REPORT;
-
-PROCEDURE C43205C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205C", "CASE C : UNCONSTRAINED FUNCTION RESULT TYPE");
-
- BEGIN
-
-CASE_C : DECLARE
-
- SUBTYPE STC1 IS INTEGER RANGE -2 .. 3;
- SUBTYPE STC2 IS INTEGER RANGE 7 .. 20;
- TYPE TC IS ARRAY (STC1 RANGE <>, STC2 RANGE <>)
- OF INTEGER;
-
- FUNCTION FUN1 (A : INTEGER) RETURN TC IS
- BEGIN
- RETURN ((5, 4, 3), (2, IDENT_INT(1), 0));
- END;
-
- BEGIN
-
- IF FUN1(5)'FIRST(1) /= -2 THEN
- FAILED ("CASE C : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST(1)");
- ELSIF FUN1(5)'FIRST(2) /= 7 THEN
- FAILED ("CASE C : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST(2)");
- ELSIF FUN1(5)'LAST(1) /= -1 THEN
- FAILED ("CASE C : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST(1)");
- ELSIF FUN1(5)'LAST(2) /= 9 THEN
- FAILED ("CASE C : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST(2)");
- ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN
- FAILED ("CASE C : FUNCTION DOES NOT " &
- "RETURN THE CORRECT VALUES");
- END IF;
-
- END CASE_C;
-
- END;
-
- RESULT;
-
-END C43205C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205d.ada b/gcc/testsuite/ada/acats/tests/c4/c43205d.ada
deleted file mode 100644
index ddffcbe..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205d.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C43205D.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS:
-
--- D) THE INITIALIZATION EXPRESSION OF A CONSTANT WHOSE TYPE MARK
--- DENOTES AN UNCONSTRAINED ARRAY.
-
--- EG 01/26/84
-
-WITH REPORT;
-
-PROCEDURE C43205D IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205D", "CASE D : INITIALIZATION OF UNCONSTRAINED " &
- "ARRAY CONSTANT");
-
- BEGIN
-
-CASE_D : DECLARE
-
- SUBTYPE STD IS INTEGER RANGE IDENT_INT(11) .. 13;
- TYPE TD IS ARRAY (STD RANGE <>) OF INTEGER;
-
- D1 : CONSTANT TD := (-1, -2, -3);
-
- BEGIN
-
- IF D1'FIRST /= 11 THEN
- FAILED ("CASE D : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF D1'LAST /= 13 THEN
- FAILED ("CASE D : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF D1 /= (-1, -2, -3) THEN
- FAILED ("CASE D : ARRAY DOES NOT CONTAIN " &
- "THE CORRECT VALUES");
- END IF;
-
- END CASE_D;
-
- END;
-
- RESULT;
-
-END C43205D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205e.ada b/gcc/testsuite/ada/acats/tests/c4/c43205e.ada
deleted file mode 100644
index d06f209..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205e.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C43205E.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS:
-
--- E) THE LEFT OR RIGHT OPERAND OF "&".
-
--- EG 01/26/84
-
-WITH REPORT;
-
-PROCEDURE C43205E IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205E", "CASE E : OPERAND OF &");
-
- BEGIN
-
-CASE_E : DECLARE
-
- SUBTYPE STE IS INTEGER RANGE 2 .. 10;
-
- TYPE COLOR IS (RED, GREEN, BLUE);
- TYPE TE IS ARRAY (STE RANGE <>) OF COLOR;
-
- FUNCTION CONCAT1 RETURN TE IS
- BEGIN
- RETURN (RED, GREEN, BLUE) & (7 .. 8 => RED);
- END;
-
- FUNCTION CONCAT2 RETURN TE IS
- BEGIN
- RETURN (IDENT_INT(4) .. 3 => RED) & (GREEN, BLUE);
- END;
-
- FUNCTION CONCAT3 RETURN STRING IS
- BEGIN
- RETURN "TEST" & (7 .. 8 => 'X');
- END;
-
- FUNCTION CONCAT4 RETURN STRING IS
- BEGIN
- RETURN (8 .. 5 => 'A') & "BC";
- END;
-
- BEGIN
-
- IF CONCAT1'FIRST /= IDENT_INT(2) THEN
- FAILED ("CASE E1 : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF CONCAT1'LAST /= 6 THEN
- FAILED ("CASE E1 : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF CONCAT1 /= (RED, GREEN, BLUE, RED, RED) THEN
- FAILED ("CASE E1 : INCORRECT VALUES PRODUCED");
- END IF;
- IF CONCAT2'FIRST /= IDENT_INT(2) THEN
- FAILED ("CASE E2 : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF CONCAT2'LAST /= 3 THEN
- FAILED ("CASE E2 : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF CONCAT2 /= (GREEN, BLUE) THEN
- FAILED ("CASE E2 : INCORRECT VALUES PRODUCED");
- END IF;
- IF CONCAT3'FIRST /= IDENT_INT(1) THEN
- FAILED ("CASE E3 : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF CONCAT3'LAST /= 6 THEN
- FAILED ("CASE E3 : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF CONCAT3 /= "TESTXX" THEN
- FAILED ("CASE E3 : INCORRECT VALUES PRODUCED");
- END IF;
- IF CONCAT4'FIRST /= IDENT_INT(1) THEN
- FAILED ("CASE E4 : LOWER BOUND INCORRECTLY " &
- "GIVEN BY 'FIRST");
- ELSIF CONCAT4'LAST /= 2 THEN
- FAILED ("CASE E4 : UPPER BOUND INCORRECTLY " &
- "GIVEN BY 'LAST");
- ELSIF CONCAT4 /= "BC" THEN
- FAILED ("CASE E4 : INCORRECT VALUES PRODUCED");
- END IF;
-
- END CASE_E;
-
- END;
-
- RESULT;
-
-END C43205E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205g.ada b/gcc/testsuite/ada/acats/tests/c4/c43205g.ada
deleted file mode 100644
index 54e0b74..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205g.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C43205G.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE
--- POSITIONAL AGGREGATE IS USED AS:
-
--- AN ACTUAL PARAMETER IN A SUBPROGRAM, AND THE
--- FORMAL PARAMETER IS CONSTRAINED.
-
--- EG 01/27/84
-
-WITH REPORT;
-
-PROCEDURE C43205G IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205G", "SUBPROGRAM WITH CONSTRAINED " &
- "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER");
-
- BEGIN
-
-CASE_G : BEGIN
-
- CASE_G1 : DECLARE
-
- TYPE TA IS ARRAY (IDENT_INT(11) .. 15) OF INTEGER;
-
- PROCEDURE PROC1 (A : TA) IS
- BEGIN
- IF A'FIRST /= 11 THEN
- FAILED ("CASE A1 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST /= 15 THEN
- FAILED ("CASE A1 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= (6, 7, 8, 9, 10) THEN
- FAILED ("CASE A1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 ((6, 7, 8, IDENT_INT(9), 10));
-
- END CASE_G1;
-
- CASE_G2 : DECLARE
-
- TYPE TA IS ARRAY (11 .. 12,
- IDENT_INT(10) .. 11) OF INTEGER;
-
- PROCEDURE PROC1 (A : TA) IS
- BEGIN
- IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN
- FAILED ("CASE A2 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN
- FAILED ("CASE A2 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= ((1, 2), (3, 4)) THEN
- FAILED ("CASE A2 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 (((1, 2), (3, 4)));
-
- END CASE_G2;
-
- END CASE_G;
-
- END;
-
- RESULT;
-
-END C43205G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205h.ada b/gcc/testsuite/ada/acats/tests/c4/c43205h.ada
deleted file mode 100644
index 9e4dc4a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205h.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C43205H.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE
--- POSITIONAL AGGREGATE IS USED AS:
-
--- AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL
--- PARAMETER IS CONSTRAINED.
-
--- EG 01/27/84
-
-WITH REPORT;
-
-PROCEDURE C43205H IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205H", "CONSTRAINED ARRAY FORMAL GENERIC " &
- "PARAMETER");
-
- BEGIN
-
-CASE_H : DECLARE
-
- SUBTYPE STH IS INTEGER RANGE -10 .. 0;
- TYPE BASE IS ARRAY(STH RANGE <>) OF INTEGER;
- SUBTYPE TB IS BASE(IDENT_INT(-8) .. -5);
-
- GENERIC
- B1 : TB;
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN
- IF B1'FIRST /= -8 THEN
- FAILED ("CASE B : LOWER BOUND INCORRECT");
- ELSIF B1'LAST /= -5 THEN
- FAILED ("CASE B : UPPER BOUND INCORRECT");
- ELSIF B1 /= (7, 6, 5, 4) THEN
- FAILED ("CASE B : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- PROCEDURE PROC2 IS NEW PROC1 ((7, 6, 5, 4));
-
- BEGIN
-
- PROC2;
-
- END CASE_H;
-
- END;
-
- RESULT;
-
-END C43205H;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205i.ada b/gcc/testsuite/ada/acats/tests/c4/c43205i.ada
deleted file mode 100644
index 44c2557..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205i.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C43205I.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE
--- POSITIONAL AGGREGATE IS USED AS:
-
--- THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS
--- CONSTRAINED.
-
--- EG 01/27/84
-
-WITH REPORT;
-
-PROCEDURE C43205I IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205I", "CONSTRAINED FUNCTION RESULT TYPE");
-
- BEGIN
-
-CASE_I : DECLARE
-
- SUBTYPE STC IS INTEGER RANGE -2 .. 10;
- TYPE BASE IS ARRAY(STC RANGE <>, STC RANGE <>)OF INTEGER;
- SUBTYPE TC IS BASE(IDENT_INT(-1) .. 0, 7 .. 9);
-
- FUNCTION FUN1 (A : INTEGER) RETURN TC IS
- BEGIN
- RETURN ((5, 4, 3), (2, 1, 0));
- END;
-
- BEGIN
-
- IF FUN1(5)'FIRST(1) /= -1 THEN
- FAILED ("CASE I : LOWER BOUND INCORRECT " &
- "FOR 'FIRST(1)");
- ELSIF FUN1(5)'FIRST(2) /= 7 THEN
- FAILED ("CASE I : LOWER BOUND INCORRECT " &
- "FOR 'FIRST(2)");
- ELSIF FUN1(5)'LAST(1) /= 0 THEN
- FAILED ("CASE I : UPPER BOUND INCORRECT " &
- "FOR 'LAST(1)");
- ELSIF FUN1(5)'LAST(2) /= 9 THEN
- FAILED ("CASE I : UPPER BOUND INCORRECT " &
- "FOR 'LAST(2)");
- ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN
- FAILED ("CASE I : FUNCTION DOES NOT " &
- "RETURN THE CORRECT VALUES");
- END IF;
-
- END CASE_I;
-
- END;
-
- RESULT;
-
-END C43205I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205j.ada b/gcc/testsuite/ada/acats/tests/c4/c43205j.ada
deleted file mode 100644
index 946e074..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205j.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C43205J.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE
--- POSITIONAL AGGREGATE IS USED AS:
-
--- J) THE INITIALIZATION EXPRESSION OF A CONSTANT, VARIABLE, OR FORMAL
--- PARAMETER (OF A SUBPROGRAM, ENTRY, OR GENERIC UNIT) WHEN THE
--- TYPE OF THE CONSTANT, VARIABLE, OR PARAMETER IS CONSTRAINED.
-
--- EG 01/27/84
-
-WITH REPORT;
-
-PROCEDURE C43205J IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205J", "CASE J : INITIALIZATION OF CONSTRAINED " &
- "ARRAY");
-
- BEGIN
-
-CASE_J : BEGIN
-
- CASE_J1 : DECLARE
-
- TYPE TD1 IS ARRAY (IDENT_INT(11) .. 13) OF INTEGER;
-
- D1 : CONSTANT TD1 := (-1, -2, -3);
-
- BEGIN
-
- IF D1'FIRST /= 11 THEN
- FAILED ("CASE J1 : LOWER BOUND INCORRECT");
- ELSIF D1'LAST /= 13 THEN
- FAILED ("CASE J1 : UPPER BOUND INCORRECT");
- ELSIF D1 /= (-1, -2, -3) THEN
- FAILED ("CASE J1 : ARRAY DOES NOT " &
- "CONTAINING THE CORRECT VALUES");
- END IF;
-
- END CASE_J1;
-
- CASE_J2 : DECLARE
-
- TYPE TD2 IS ARRAY(INTEGER RANGE -13 .. -11)
- OF INTEGER;
- D2 : TD2 := (3, 2, 1);
-
- BEGIN
-
- IF D2'FIRST /= -13 THEN
- FAILED ("CASE J2 : LOWER BOUND INCORRECT");
- ELSIF D2'LAST /= -11 THEN
- FAILED ("CASE J2 : UPPER BOUND INCORRECT");
- ELSIF D2 /= (3, 2, 1) THEN
- FAILED ("CASE J2 : INCORRECT VALUES");
- END IF;
-
- END CASE_J2;
-
- CASE_J3 : DECLARE
-
- TYPE TD3 IS ARRAY(IDENT_INT(5) .. 7) OF INTEGER;
-
- PROCEDURE PROC1 (A : TD3 := (2, 3, 4)) IS
- BEGIN
- IF A'FIRST /= 5 THEN
- FAILED ("CASE J3 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST /= 7 THEN
- FAILED ("CASE J3 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= (2, 3, 4) THEN
- FAILED ("CASE J3 : INCORRECT VALUES");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1;
-
- END CASE_J3;
-
- CASE_J4 : DECLARE
-
- TYPE TD4 IS ARRAY(5 .. 8) OF INTEGER;
-
- GENERIC
- D4 : TD4 := (1, -2, 3, -4);
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN
- IF D4'FIRST /= 5 THEN
- FAILED ("CASE J4 : LOWER BOUND " &
- "INCORRECT");
- ELSIF D4'LAST /= 8 THEN
- FAILED ("CASE J4 : UPPER BOUND " &
- "INCORRECT");
- ELSIF D4 /= (1, -2, 3, -4) THEN
- FAILED ("CASE J4 : INCORRECT VALUES");
- END IF;
- END PROC1;
-
- PROCEDURE PROC2 IS NEW PROC1;
-
- BEGIN
-
- PROC2;
-
- END CASE_J4;
-
- END CASE_J;
-
- END;
-
- RESULT;
-
-END C43205J;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205k.ada b/gcc/testsuite/ada/acats/tests/c4/c43205k.ada
deleted file mode 100644
index a3a712a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43205k.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C43205K.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 BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED
--- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY
--- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE
--- POSITIONAL AGGREGATE IS USED AS:
-
--- THE EXPRESSION OF AN ENCLOSING RECORD OR ARRAY AGGREGATE, AND
--- THE EXPRESSION GIVES THE VALUE OF A RECORD OR ARRAY COMPONENT
--- (WHICH IS NECESSARILY CONSTRAINED).
-
--- EG 01/27/84
--- JBG 3/30/84
-
-WITH REPORT;
-
-PROCEDURE C43205K IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43205K", "THE EXPRESSION OF AN ENCLOSING RECORD " &
- "OR ARRAY AGGREGATE, AND THE EXPRESSION GIVES " &
- "THE VALUE OF A RECORD OR ARRAY COMPONENT");
-
- BEGIN
-
-CASE_K : BEGIN
-
- CASE_K1 : DECLARE
-
- SUBTYPE SK1 IS INTEGER RANGE 2 .. 6;
- TYPE BASE IS ARRAY(SK1 RANGE <>) OF INTEGER;
- SUBTYPE TE1 IS BASE(IDENT_INT(3) .. 5);
- TYPE TE2 IS ARRAY(1 .. 2) OF TE1;
-
- E1 : TE2;
-
- BEGIN
-
- E1 := (1 .. 2 => (3, 2, 1));
- IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE
- (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR
- E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN
- FAILED ("CASE K1 : INCORRECT BOUNDS");
- ELSE
- IF E1 /= (1 .. 2 => (3, 2, 1)) THEN
- FAILED ("CASE K1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END IF;
-
- END CASE_K1;
-
- CASE_K2 : DECLARE
-
- TYPE SK2 IS RANGE 2 .. 6;
- TYPE BASE IS ARRAY(SK2 RANGE <>) OF INTEGER;
- SUBTYPE TE1 IS BASE(3 .. 5);
- TYPE TER IS
- RECORD
- REC : TE1;
- END RECORD;
-
- E2 : TER;
-
- BEGIN
-
- E2 := (REC => (3, 2, 1));
- IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN
- FAILED ("CASE K2 : INCORRECT BOUNDS");
- ELSE
- IF E2.REC /= (3, 2, 1) THEN
- FAILED ("CASE K2 : ARRAY DOES NOT " &
- "CONTAIN CORRECT VALUES");
- END IF;
- END IF;
-
- END CASE_K2;
-
- END CASE_K;
-
- END;
-
- RESULT;
-
-END C43205K;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43206a.ada b/gcc/testsuite/ada/acats/tests/c4/c43206a.ada
deleted file mode 100644
index af73892..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43206a.ada
+++ /dev/null
@@ -1,242 +0,0 @@
--- C43206A.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 BOUNDS OF A NULL ARRAY AGGREGATE ARE DETERMINED
--- BY THE BOUNDS SPECIFIED BY THE CHOICES. IN PARTICULAR, CHECK
--- THAT:
-
--- A) THE UPPER BOUND IS NOT REQUIRED TO BE THE PREDECESSOR OF
--- THE LOWER BOUND.
-
--- B) NEITHER THE UPPER NOR THE LOWER BOUND NEED BELONG TO THE
--- INDEX SUBTYPE FOR NULL RANGES.
-
--- C) IF ONE CHOICE OF A MULTIDIMENSIONAL AGGREGATE IS NON-NULL
--- BUT THE AGGREGATE IS A NULL ARRAY, CONSTRAINT_ERROR IS
--- RAISED WHEN THE NON-NULL CHOICES DO NOT BELONG TO THE
--- INDEX SUBTYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- EG 02/02/84
--- JBG 12/6/84
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT;
-
-PROCEDURE C43206A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43206A", "CHECK THAT THE BOUNDS OF A NULL ARRAY ARE " &
- "DETERMINED BY THE BOUNDS SPECIFIED BY THE " &
- "CHOICES");
-
- DECLARE
-
- SUBTYPE ST1 IS INTEGER RANGE 10 .. 15;
- SUBTYPE ST2 IS INTEGER RANGE 1 .. 5;
-
- TYPE T1 IS ARRAY (ST1 RANGE <>) OF INTEGER;
- TYPE T2 IS ARRAY (ST2 RANGE <>, ST1 RANGE <>) OF INTEGER;
-
- BEGIN
-
-CASE_A : BEGIN
-
- CASE_A1 : DECLARE
-
- PROCEDURE PROC1 (A : T1) IS
- BEGIN
- IF A'FIRST /= 12 OR A'LAST /= 10 THEN
- FAILED ("CASE A1 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1((12 .. 10 => -2));
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("CASE A1 : EXCEPTION RAISED");
-
- END CASE_A1;
-
- CASE_A2 : DECLARE
-
- PROCEDURE PROC1 (A : STRING) IS
- BEGIN
- IF A'FIRST /= 5 OR A'LAST /= 2 THEN
- FAILED ("CASE A2 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 ((5 .. 2 => 'E'));
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("CASE A2 : EXCEPTION RAISED");
-
- END CASE_A2;
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- CASE_B1 : DECLARE
-
- PROCEDURE PROC1 (A : T1; L, U : INTEGER) IS
- BEGIN
- IF A'FIRST /= L OR A'LAST /= U THEN
- FAILED ("CASE B1 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- BEGIN
-
- PROC1 ((5 .. INTEGER'FIRST => -2),
- 5, INTEGER'FIRST);
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CASE B1A : CONSTRAINT_ERROR " &
- "RAISED FOR NULL RANGE");
- WHEN OTHERS =>
- FAILED ("CASE B1A : EXCEPTION RAISED");
-
- END;
-
- BEGIN
-
- PROC1 ((IDENT_INT(6) .. 3 => -2),6,3);
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("CASE B1B : EXCEPTION RAISED");
-
- END;
-
- END CASE_B1;
-
- CASE_B2 : DECLARE
-
- PROCEDURE PROC1 (A : STRING) IS
- BEGIN
- IF A'FIRST /= 1 OR
- A'LAST /= INTEGER'FIRST THEN
- FAILED ("CASE B2 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 ((1 .. INTEGER'FIRST => ' '));
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("CASE B2 : EXCEPTION RAISED");
-
- END CASE_B2;
-
- END CASE_B;
-
-CASE_C : BEGIN
-
- CASE_C1 : DECLARE
-
- PROCEDURE PROC1 (A : T2) IS
- BEGIN
- IF A'FIRST(1) /= 5 OR A'LAST(1) /= 3 OR
- A'FIRST(2) /= INTEGER'LAST-1 OR
- A'LAST(2) /= INTEGER'LAST THEN
- FAILED ("CASE C1 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 ((5 .. 3 =>
- (IDENT_INT(INTEGER'LAST-1) ..
- IDENT_INT(INTEGER'LAST) => -2)));
- FAILED ("CASE C1 : CONSTRAINT_ERROR NOT RAISED");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE C1 : EXCEPTION RAISED");
-
- END CASE_C1;
-
- CASE_C2 : DECLARE
-
- PROCEDURE PROC1 (A : T2) IS
- BEGIN
- IF A'FIRST(1) /= INTEGER'FIRST OR
- A'LAST(1) /= INTEGER'FIRST+1 OR
- A'FIRST(2) /= 14 OR A'LAST(2) /= 11 THEN
- FAILED ("CASE C2 : INCORRECT BOUNDS");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 ((IDENT_INT(INTEGER'FIRST) ..
- IDENT_INT(INTEGER'FIRST+1) =>
- (14 .. IDENT_INT(11) => -2)));
- FAILED ("CASE C2 : CONSTRAINT_ERROR NOT RAISED");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE C2 : EXCEPTION RAISED");
-
- END CASE_C2;
-
- END CASE_C;
-
- END;
-
- RESULT;
-
-END C43206A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43207b.ada b/gcc/testsuite/ada/acats/tests/c4/c43207b.ada
deleted file mode 100644
index 197a915..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43207b.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- C43207B.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.
---*
--- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)),
--- CHECK THAT:
-
--- B) IF H..I IS A NULL RANGE, CONSTRAINT_ERROR IS RAISED IF
--- F..G IS NON-NULL AND F OR G DO NOT BELONG TO THE INDEX
--- SUBTYPE;
-
--- EG 01/18/84
--- BHS 7/13/84
--- JBG 12/6/84
-
-WITH REPORT;
-
-PROCEDURE C43207B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43207B", "CHECK THAT THE EVALUATION OF A MULTI" &
- "DIMENSIONAL AGGREGATE OF THE FORM " &
- "(F..G => (H..I = J)) IS PERFORMED " &
- "CORRECTLY");
-
- DECLARE
-
- TYPE CHOICE_INDEX IS (F, G, H, I, J);
- TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER;
-
- CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
-
- SUBTYPE SINT IS INTEGER RANGE 1 .. 8;
- TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER;
-
- FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
- RETURN INTEGER IS
- BEGIN
- CNTR(A) := CNTR(A) + 1;
- RETURN IDENT_INT(B);
- END CALC;
-
- BEGIN
-
-CASE_B : DECLARE
- PROCEDURE CHECK (A : T0; M : STRING) IS
- BEGIN
- IF (A'FIRST(1) /= 1) OR (A'LAST(1) /= 9) OR
- (A'FIRST(2) /= 6) OR (A'LAST(2) /= 5) THEN
- FAILED("CASE B" & M & " : ARRAY NOT " &
- "BOUNDED CORRECTLY");
- END IF;
- END CHECK;
- BEGIN
-
- CASE_B1 : BEGIN
- CHECK ((1 .. 9 => (6 .. 5 => 2)),"1");
- FAILED ("CASE B1 : CONSTRAINT_ERROR NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("CASE B1 : EXCEPTION RAISED");
- END CASE_B1;
-
- CASE_B2 : BEGIN
- CHECK ((CALC(F,1) .. CALC(G,9) => (6 .. 5 => 2)),
- "2");
- FAILED ("CASE B2 : CONSTRAINT_ERROR NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("CASE B2 : EXCEPTION RAISED");
- END CASE_B2;
-
- CASE_B3 : BEGIN
- CHECK ((1 .. 9 => (CALC(H,6) .. CALC(I,5) => 2)),
- "3");
- FAILED ("CASE B3 : CONSTRAINT_ERROR NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("CASE B3 : EXCEPTION RAISED");
- END CASE_B3;
-
- END CASE_B;
-
- IF CNTR(F) /= 1 THEN
- FAILED ("CASE B2 : F WAS NOT EVALUATED " &
- "ONCE. F WAS EVALUATED" &
- INTEGER'IMAGE(CNTR(F)) & " TIMES");
- END IF;
- IF CNTR(G) /= 1 THEN
- FAILED ("CASE B2 : G WAS NOT EVALUATED " &
- "ONCE. G WAS EVALUATED" &
- INTEGER'IMAGE(CNTR(G)) & " TIMES");
- END IF;
-
- IF CNTR(H) /= 0 AND CNTR(I) /= 0 THEN
- COMMENT ("CASE B3 : ALL CHOICES " &
- "EVALUATED BEFORE CHECKING " &
- "INDEX SUBTYPE");
- ELSIF CNTR(H) = 0 AND CNTR(I) = 0 THEN
- COMMENT ("CASE B3 : SUBTYPE CHECKS "&
- "MADE AS CHOICES ARE EVALUATED");
- END IF;
-
- IF CNTR(H) > 1 THEN
- FAILED("CASE B3 : H WAS NOT EVALUATED " &
- "AT MOST ONCE. H WAS EVALUATED" &
- INTEGER'IMAGE(CNTR(H)) & " TIMES");
- END IF;
-
- IF CNTR(I) > 1 THEN
- FAILED("CASE B3 : I WAS NOT EVALUATED " &
- "AT MOST ONCE. I WAS EVALUATED" &
- INTEGER'IMAGE(CNTR(I)) & " TIMES");
- END IF;
-
- END;
-
- RESULT;
-
-END C43207B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43207d.ada b/gcc/testsuite/ada/acats/tests/c4/c43207d.ada
deleted file mode 100644
index 5733ec8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43207d.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- C43207D.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.
---*
--- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)),
--- CHECK THAT:
-
--- D) J IS EVALUATED ONCE FOR EACH COMPONENT (ZERO TIMES IF THE
--- ARRAY IS NULL).
-
--- EG 01/18/84
-
-WITH REPORT;
-
-PROCEDURE C43207D IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43207D", "CHECK THAT THE EVALUATION OF A MULTI" &
- "DIMENSIONAL AGGREGATE OF THE FORM " &
- "(F..G => (H..I = J)) IS PERFORMED " &
- "CORRECTLY");
-
- DECLARE
-
- TYPE CHOICE_INDEX IS (F, G, H, I, J);
- TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER;
-
- CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
-
- SUBTYPE SINT IS INTEGER RANGE 1 .. 8;
- TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER;
-
- FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
- RETURN INTEGER IS
- BEGIN
- CNTR(A) := CNTR(A) + 1;
- RETURN IDENT_INT(B);
- END CALC;
-
- BEGIN
-
-CASE_D : BEGIN
-
- CASE_D1 : DECLARE
- D1 : T0(8 .. 4, 5 .. 1);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- D1 := (8 .. 4 => (5 .. 1 => CALC(J,2)));
- IF CNTR(J) /= 0 THEN
- FAILED("CASE D1 : INCORRECT NUMBER " &
- "OF EVALUATIONS. J EVALUATED" &
- INTEGER'IMAGE(CNTR(J)) & " TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE D1 : EXCEPTION RAISED");
- END CASE_D1;
-
- CASE_D2 : DECLARE
- D2 : T0(8 .. 4, 5 .. 1);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- D2 := (CALC(F,8) .. CALC(G,4) =>
- (CALC(H,5) .. CALC(I,1) => CALC(J,2)));
- IF CNTR(J) /= 0 THEN
- FAILED("CASE D2 : INCORRECT NUMBER " &
- "OF EVALUATIONS. J EVALUATED" &
- INTEGER'IMAGE(CNTR(J)) & " TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE D2 : EXCEPTION RAISED");
- END CASE_D2;
-
- CASE_D3 : DECLARE
- D3 : T0(3 .. 5, 1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- D3 := (3 .. 5 => (1 .. 2 => CALC(J,2)));
- IF CNTR(J) /= 6 THEN
- FAILED("CASE D3 : INCORRECT NUMBER " &
- "OF EVALUATIONS. J EVALUATED" &
- INTEGER'IMAGE(CNTR(J)) & " TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE D3 : EXCEPTION RAISED");
- END CASE_D3;
-
- CASE_D4 : DECLARE
- D4 : T0(1 .. 2, 5 .. 7);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- D4 := (CALC(F,1) .. CALC(G,2) =>
- (CALC(H,5) .. CALC(I,7) => CALC(J,2)));
- IF CNTR(J) /= 6 THEN
- FAILED("CASE D4 : INCORRECT NUMBER " &
- "OF EVALUATIONS. J EVALUATED" &
- INTEGER'IMAGE(CNTR(J)) & " TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE D4 : EXCEPTION RAISED");
- END CASE_D4;
-
- END CASE_D;
-
- END;
-
- RESULT;
-
-END C43207D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43208a.ada b/gcc/testsuite/ada/acats/tests/c4/c43208a.ada
deleted file mode 100644
index c04a395..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43208a.ada
+++ /dev/null
@@ -1,208 +0,0 @@
--- C43208A.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.
---*
--- FOR A ONE-DIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)),
--- CHECK THAT:
-
--- A) IF F..G IS A NULL RANGE, H, I, AND J ARE NOT EVALUATED.
-
--- B) IF F..G IS A NON-NULL RANGE, H AND I ARE EVALUATED G-F+1
--- TIMES, AND J IS EVALUATED (I-H+1)*(G-F+1) TIMES IF H..I
--- IS NON-NULL.
-
--- EG 01/19/84
-
-WITH REPORT;
-
-PROCEDURE C43208A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43208A", "CHECK THAT THE EVALUATION OF A ONE-" &
- "DIMENSIONAL AGGREGATE OF THE FORM " &
- "(F..G => (H..I = J)) IS PERFORMED " &
- "CORRECTLY");
-
- DECLARE
-
- TYPE CHOICE_INDEX IS (F, G, H, I, J);
- TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER;
-
- CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
-
- TYPE T1 IS ARRAY(INTEGER RANGE <>) OF INTEGER;
-
- FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
- RETURN INTEGER IS
- BEGIN
- CNTR(A) := CNTR(A) + 1;
- RETURN IDENT_INT(B);
- END CALC;
-
- BEGIN
-
-CASE_A : BEGIN
-
- CASE_A1 : DECLARE
- A1 : ARRAY(4 .. 2) OF T1(1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- A1 := (4 .. 2 =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)));
- IF CNTR(H) /= 0 THEN
- FAILED("CASE A1 : H WAS EVALUATED");
- END IF;
- IF CNTR(I) /= 0 THEN
- FAILED("CASE A1 : I WAS EVALUATED");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE A1 : J WAS EVALUATED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE A1 : EXCEPTION RAISED");
- END CASE_A1;
-
- CASE_A2 : DECLARE
- A2 : ARRAY(4 .. 2) OF T1(1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- A2 := (CALC(F,4) .. CALC(G,2) =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)));
- IF CNTR(H) /= 0 THEN
- FAILED("CASE A2 : H WAS EVALUATED");
- END IF;
- IF CNTR(I) /= 0 THEN
- FAILED("CASE A2 : I WAS EVALUATED");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE A2 : J WAS EVALUATED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE A2 : EXCEPTION RAISED");
- END CASE_A2;
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- CASE_B1 : DECLARE
- B1 : ARRAY(2 .. 3) OF T1(1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B1 := (2 .. 3 =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)));
- IF CNTR(H) /= 2 THEN
- FAILED("CASE B1 : H NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(I) /= 2 THEN
- FAILED("CASE B1 : I NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(J) /= 4 THEN
- FAILED("CASE B1 : J NOT EVALUATED (I-H+1)*" &
- "(G-F+1) TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B1 : EXECEPTION RAISED");
- END CASE_B1;
-
- CASE_B2 : DECLARE
- B2 : ARRAY(2 .. 3) OF T1(9 .. 10);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B2 := (CALC(F,2) .. CALC(G,3) =>
- (CALC(H,9) .. CALC(I,10) => CALC(J,2)));
- IF CNTR(H) /= 2 THEN
- FAILED("CASE B2 : H NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(I) /= 2 THEN
- FAILED("CASE B2 : I NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(J) /= 4 THEN
- FAILED("CASE B2 : J NOT EVALUATED (I-H+1)*" &
- "(G-F+1) TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B2 : EXECEPTION RAISED");
- END CASE_B2;
-
- CASE_B3 : DECLARE
- B3 : ARRAY(2 .. 3) OF T1(2 .. 1);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B3 := (2 .. 3 =>
- (CALC(H,2) .. CALC(I,1) => CALC(J,2)));
- IF CNTR(H) /= 2 THEN
- FAILED("CASE B3 : H NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(I) /= 2 THEN
- FAILED("CASE B3 : I NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B3 : EXECEPTION RAISED");
- END CASE_B3;
-
- CASE_B4 : DECLARE
- B4 : ARRAY(2 .. 3) OF T1(2 .. 1);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B4 := (CALC(F,2) .. CALC(G,3) =>
- (CALC(H,2) .. CALC(I,1) => CALC(J,2)));
- IF CNTR(H) /= 2 THEN
- FAILED("CASE B4 : H NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(I) /= 2 THEN
- FAILED("CASE B4 : I NOT EVALUATED G-F+1 " &
- "TIMES");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B4 : EXECEPTION RAISED");
- END CASE_B4;
-
- END CASE_B;
- END;
-
- RESULT;
-
-END C43208A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43208b.ada b/gcc/testsuite/ada/acats/tests/c4/c43208b.ada
deleted file mode 100644
index de5ac5f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43208b.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- C43208B.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.
---*
--- FOR AN AGGREGATE OF THE FORM:
--- (B..C => (D..E => (F..G => (H..I => J))))
--- WHOSE TYPE IS A TWO-DIMENSIONAL ARRAY TYPE THAT HAS A TWO-
--- DIMENSIONAL ARRAY COMPONENT TYPE, CHECK THAT:
-
--- A) IF B..C OR D..E IS A NULL RANGE, THEN F, G, H, I, AND J
--- ARE NOT EVALUATED.
-
--- B) IF B..C AND D..E ARE NON-NULL RANGES, THEN F, G, H AND I
--- ARE EVALUATED (C-B+1)*(E-D+1) TIMES, AND J IS EVALUATED
--- (C-B+1)*(E-D+1)*(G-F+1)*(I-H+1) TIMES IF F..G AND H..I
--- ARE NON-NULL.
-
--- EG 01/19/84
-
-WITH REPORT;
-
-PROCEDURE C43208B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43208B", "CHECK THAT THE EVALUATION OF A MULTI" &
- "DIMENSIONAL ARRAY TYPE THAT HAS AN " &
- "ARRAY COMPONENT TYPE IS PERFORMED " &
- "CORRECTLY");
-
- DECLARE
-
- TYPE CHOICE_INDEX IS (B, C, D, E, F, G, H, I, J);
- TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER;
-
- CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
-
- TYPE T1 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>)
- OF INTEGER;
-
- FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
- RETURN INTEGER IS
- BEGIN
- CNTR(A) := CNTR(A) + 1;
- RETURN IDENT_INT(B);
- END CALC;
-
- BEGIN
-
-CASE_A : BEGIN
-
- CASE_A1 : DECLARE
- A1 : ARRAY(4 .. 3, 3 .. 4) OF T1(2 .. 3, 1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- A1 := (4 .. 3 => (3 .. 4 =>
- (CALC(F,2) .. CALC(G,3) =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)))));
- IF CNTR(F) /= 0 THEN
- FAILED("CASE A1 : F WAS EVALUATED");
- END IF;
- IF CNTR(G) /= 0 THEN
- FAILED("CASE A1 : G WAS EVALUATED");
- END IF;
- IF CNTR(H) /= 0 THEN
- FAILED("CASE A1 : H WAS EVALUATED");
- END IF;
- IF CNTR(I) /= 0 THEN
- FAILED("CASE A1 : I WAS EVALUATED");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE A1 : J WAS EVALUATED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE A1 : EXCEPTION RAISED");
- END CASE_A1;
-
- CASE_A2 : DECLARE
- A2 : ARRAY(3 .. 4, 4 .. 3) OF T1(2 .. 3, 1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- A2 := (CALC(B,3) .. CALC(C,4) =>
- (CALC(D,4) .. CALC(E,3) =>
- (CALC(F,2) .. CALC(G,3) =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)))));
- IF CNTR(F) /= 0 THEN
- FAILED("CASE A2 : F WAS EVALUATED");
- END IF;
- IF CNTR(G) /= 0 THEN
- FAILED("CASE A2 : G WAS EVALUATED");
- END IF;
- IF CNTR(H) /= 0 THEN
- FAILED("CASE A2 : H WAS EVALUATED");
- END IF;
- IF CNTR(I) /= 0 THEN
- FAILED("CASE A2 : I WAS EVALUATED");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE A2 : J WAS EVALUATED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE A2 : EXCEPTION RAISED");
- END CASE_A2;
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- CASE_B1 : DECLARE
- B1 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B1 := (2 .. 3 => (1 .. 2 =>
- (CALC(F,1) .. CALC(G,2) =>
- (CALC(H,9) .. CALC(I,10) => CALC(J,2)))));
- IF CNTR(F) /= 4 THEN
- FAILED("CASE B1 : F NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(G) /= 4 THEN
- FAILED("CASE B1 : G NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(H) /= 4 THEN
- FAILED("CASE B1 : H NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(I) /= 4 THEN
- FAILED("CASE B1 : I NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(J) /= 16 THEN
- FAILED("CASE B1 : J NOT EVALUATED (C-B+1)*" &
- "(E-D+1)*(G-F+1)*(I-H+1) TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B1 : EXECEPTION RAISED");
- END CASE_B1;
-
- CASE_B2 : DECLARE
- B2 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B2 := (CALC(B,2) .. CALC(C,3) =>
- (CALC(D,1) .. CALC(E,2) =>
- (CALC(F,1) .. CALC(G,2) =>
- (CALC(H,9) .. CALC(I,10) => CALC(J,2)))));
- IF CNTR(F) /= 4 THEN
- FAILED("CASE B2 : F NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(G) /= 4 THEN
- FAILED("CASE B2 : G NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(H) /= 4 THEN
- FAILED("CASE B2 : H NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(I) /= 4 THEN
- FAILED("CASE B2 : I NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(J) /= 16 THEN
- FAILED("CASE B2 : J NOT EVALUATED (C-B+1)*" &
- "(E-D+1)*(G-F+1)*(I-H+1) TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B2 : EXECEPTION RAISED");
- END CASE_B2;
-
- CASE_B3 : DECLARE
- B3 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 2 .. 1);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B3 := (2 .. 3 => (1 .. 2 =>
- (CALC(F,1) .. CALC(G,2) =>
- (CALC(H,2) .. CALC(I,1) => CALC(J,2)))));
- IF CNTR(F) /= 4 THEN
- FAILED("CASE B3 : F NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(G) /= 4 THEN
- FAILED("CASE B3 : G NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(H) /= 4 THEN
- FAILED("CASE B3 : H NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(I) /= 4 THEN
- FAILED("CASE B3 : I NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B3 : EXECEPTION RAISED");
- END CASE_B3;
-
- CASE_B4 : DECLARE
- B4 : ARRAY(2 .. 3, 1 .. 2) OF T1(2 .. 1, 1 .. 2);
- BEGIN
- CNTR := (CHOICE_INDEX => 0);
- B4 := (CALC(B,2) .. CALC(C,3) =>
- (CALC(D,1) .. CALC(E,2) =>
- (CALC(F,2) .. CALC(G,1) =>
- (CALC(H,1) .. CALC(I,2) => CALC(J,2)))));
- IF CNTR(F) /= 4 THEN
- FAILED("CASE B4 : F NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(G) /= 4 THEN
- FAILED("CASE B4 : G NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(H) /= 4 THEN
- FAILED("CASE B4 : H NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(I) /= 4 THEN
- FAILED("CASE B4 : I NOT EVALUATED (C-B+1)*" &
- "(E-D+1) TIMES");
- END IF;
- IF CNTR(J) /= 0 THEN
- FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CASE B4 : EXECEPTION RAISED");
- END CASE_B4;
-
- END CASE_B;
- END;
-
- RESULT;
-
-END C43208B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43209a.ada b/gcc/testsuite/ada/acats/tests/c4/c43209a.ada
deleted file mode 100644
index c86d949..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43209a.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- C43209A.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 STRING LITERAL IS ALLOWED IN A MULTIDIMENSIONAL
--- ARRAY AGGREGATE AT THE PLACE OF A ONE DIMENSIONAL ARRAY OF
--- CHARACTER TYPE.
-
--- HISTORY:
--- DHH 08/12/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43209A IS
-
- TYPE MULTI_ARRAY IS ARRAY(1 .. 2, 1 .. 3, 1 .. 6) OF CHARACTER;
-
-BEGIN
- TEST("C43209A", "CHECK THAT A STRING LITERAL IS ALLOWED IN A " &
- "MULTIDIMENSIONAL ARRAY AGGREGATE AT THE PLACE " &
- "OF A ONE DIMENSIONAL ARRAY OF CHARACTER TYPE");
-
- DECLARE
- X : MULTI_ARRAY := ((('A', 'B', 'C', 'D', 'E', 'F'),
- ('G', 'H', 'I', 'J', 'K', 'L'),
- ('M', 'N', 'O', 'P', 'Q', 'R')),
- (('S', 'T', 'U', 'V', 'W', 'X'),
- ('W', 'Z', 'A', 'B', 'C', 'D'),
- "WHOZAT"));
-
- Y : MULTI_ARRAY := (("WHOZAT",
- ('A', 'B', 'C', 'D', 'E', 'F'),
- ('G', 'H', 'I', 'J', 'K', 'L')),
- (('M', 'N', 'O', 'P', 'Q', 'R'),
- ('S', 'T', 'U', 'V', 'W', 'X'),
- ('W', 'Z', 'A', 'B', 'C', 'D')));
-
- BEGIN
- IF X(IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)) /=
- Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(6)) THEN
- FAILED("INITIALIZATION FAILURE");
- END IF;
- END;
-
- DECLARE
- PROCEDURE FIX_AGG(T : MULTI_ARRAY) IS
- BEGIN
- IF T(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /=
- T(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN
- FAILED("SUBPROGRAM FAILURE");
- END IF;
- END;
- BEGIN
- FIX_AGG((("WHOZAT", ('A', 'B', 'C', 'D', 'E', 'F'),
- ('G', 'H', 'I', 'J', 'K', 'L')),
- (('M', 'N', 'O', 'P', 'Q', 'R'),
- ('S', 'T', 'U', 'V', 'W', 'X'),
- ('W', 'Z', 'A', 'B', 'C', 'D'))));
-
- END;
-
- DECLARE
-
- Y : CONSTANT MULTI_ARRAY := (("WHOZAT",
- ('A', 'B', 'C', 'D', 'E', 'F'),
- ('G', 'H', 'I', 'J', 'K', 'L')),
- (('M', 'N', 'O', 'P', 'Q', 'R'),
- ('S', 'T', 'U', 'V', 'W', 'X'),
- ('W', 'Z', 'A', 'B', 'C', 'D')));
-
- BEGIN
- IF Y(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /=
- Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN
- FAILED("CONSTANT FAILURE");
- END IF;
- END;
-
- DECLARE
- BEGIN
- IF MULTI_ARRAY'((1 =>(('A', 'B', 'C', 'D', 'E', 'F'),
- ('G', 'H', 'I', 'J', 'K', 'L'),
- ('M', 'N', 'O', 'P', 'Q', 'R')),
- 2 => (('S', 'T', 'U', 'V', 'W', 'X'),
- ('W', 'Z', 'A', 'B', 'C', 'D'),
- "WHOZAT"))) = MULTI_ARRAY'((1 =>(1 =>"WHOZAT",
- 2 =>('A', 'B', 'C', 'D', 'E', 'F'),
- 3 =>('G', 'H', 'I', 'J', 'K', 'L')),
- 2 => (1 =>('M', 'N', 'O', 'P', 'Q', 'R'),
- 2 =>('S', 'T', 'U', 'V', 'W', 'X'),
- 3 => ('W', 'Z', 'A', 'B', 'C', 'D')))) THEN
- FAILED("EQUALITY OPERATOR FAILURE");
- END IF;
- END;
-
- DECLARE
- SUBTYPE SM IS INTEGER RANGE 1 .. 10;
- TYPE UNCONSTR IS ARRAY(SM RANGE <>, SM RANGE<>) OF CHARACTER;
-
- FUNCTION FUNC(X : SM) RETURN UNCONSTR IS
- BEGIN
- IF EQUAL(X,X) THEN
- RETURN (1 => "WHEN", 2 => "WHAT");
- ELSE
- RETURN (" ", " ");
- END IF;
- END FUNC;
-
- BEGIN
- IF FUNC(1) /= FUNC(2) THEN
- FAILED("UNCONSTRAINED FUNCTION RETURN FAILURE");
- END IF;
- END;
-
- RESULT;
-END C43209A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43210a.ada b/gcc/testsuite/ada/acats/tests/c4/c43210a.ada
deleted file mode 100644
index 549021e..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43210a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C43210A.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-AGGREGATE EXPRESSION IN A NAMED COMPONENT
--- ASSOCIATION IS EVALUATED ONCE FOR EACH COMPONENT SPECIFIED
--- BY THE ASSOCIATION.
-
--- EG 02/02/84
-
-WITH REPORT;
-
-PROCEDURE C43210A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43210A", "CHECK THAT A NON-AGGREGATE IN A NAMED " &
- "COMPONENT ASSOCIATION IS EVALUATED ONCE " &
- "FOR EACH COMPONENT SPECIFIED BY THE " &
- "ASSOCIATION");
-
- DECLARE
-
- TYPE T1 IS ARRAY(1 .. 10) OF INTEGER;
- TYPE T2 IS ARRAY(1 .. 8, 1 .. 2) OF INTEGER;
- TYPE T3 IS ARRAY(1 .. 2, 1 .. 8) OF INTEGER;
- TYPE T4 IS ARRAY(1 .. 8, 1 .. 8) OF INTEGER;
-
- A1 : T1;
- A2 : T2;
- A3 : T3;
- A4 : T4;
- CC : INTEGER;
-
- FUNCTION CALC (A : INTEGER) RETURN INTEGER IS
- BEGIN
- CC := CC + 1;
- RETURN IDENT_INT(A);
- END CALC;
-
- PROCEDURE CHECK (A : STRING; B : INTEGER) IS
- BEGIN
- IF CC /= B THEN
- FAILED ("CASE " & A & " : INCORRECT NUMBER OF " &
- "EVALUATIONS. NUMBER OF EVALUATIONS " &
- "SHOULD BE " & INTEGER'IMAGE(B) &
- ", BUT IS " & INTEGER'IMAGE(CC));
- END IF;
- END CHECK;
-
- BEGIN
-
-CASE_A : BEGIN
-
- CC := 0;
- A1 := T1'(4 .. 5 => CALC(2), 6 .. 8 => CALC(4),
- OTHERS => 5);
- CHECK ("A", 5);
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- CC := 0;
- A1 := T1'(1 | 4 .. 6 | 3 | 2 => CALC(-1), OTHERS => -2);
- CHECK ("B", 6);
-
- END CASE_B;
-
-CASE_C : BEGIN
-
- CC := 0;
- A1 := T1'(1 | 3 | 5 | 7 .. 9 => -1, OTHERS => CALC(-2));
- CHECK ("C", 4);
-
- END CASE_C;
-
-CASE_D : BEGIN
-
- CC := 0;
- A2 := T2'(4 .. 6 | 8 | 2 .. 3 => (1 .. 2 => CALC(1)),
- OTHERS => (1 .. 2 => -1));
- CHECK ("D", 12);
-
- END CASE_D;
-
-CASE_E : BEGIN
-
- CC := 0;
- A3 := T3'(1 .. 2 => (2 | 4 | 6 .. 8 => CALC(-1),
- OTHERS => -2));
- CHECK ("E", 10);
-
- END CASE_E;
-
-CASE_F : BEGIN
-
- CC := 0;
- A4 := T4'(7 .. 8 | 3 .. 5 =>
- (1 | 2 | 4 | 6 .. 8 => CALC(1), OTHERS => -2),
- OTHERS => (OTHERS => -2));
- CHECK ("F", 30);
-
- END CASE_F;
-
-CASE_G : BEGIN
-
- CC := 0;
- A4 := T4'(5 .. 8 | 3 | 1 => (7 | 1 .. 5 | 8 => -1,
- OTHERS => CALC(-2)),
- OTHERS => (OTHERS => CALC(-2)));
- CHECK ("G", 22);
-
- END CASE_G;
-
- END;
-
- RESULT;
-
-END C43210A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43211a.ada b/gcc/testsuite/ada/acats/tests/c4/c43211a.ada
deleted file mode 100644
index cf745d0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43211a.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C43211A.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 IF A BOUND IN A NON-NULL
--- RANGE OF A NON-NULL AGGREGATE DOES NOT BELONG TO THE INDEX SUBTYPE.
-
--- EG 02/06/84
--- EG 05/08/85
--- EDS 07/15/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-
-PROCEDURE C43211A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43211A","CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " &
- "BOUND IN A NON-NULL RANGE OF A NON-NULL " &
- "AGGREGATE DOES NOT BELONG TO THE INDEX " &
- "SUBTYPE");
-
- DECLARE
-
- SUBTYPE ST IS INTEGER RANGE 4 .. 8;
- TYPE BASE IS ARRAY(ST RANGE <>, ST RANGE <>) OF INTEGER;
- SUBTYPE T IS BASE(5 .. 7, 5 .. 7);
-
- A : T;
-
- BEGIN
-
-CASE_A : BEGIN
-
- A := (6 .. 8 => (4 .. 6 => 0));
- IF A /= (6 .. 8 => (4 .. 6 => 0)) THEN
- FAILED ("CASE A : INCORRECT VALUES");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE A");
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- A := (6 .. IDENT_INT(8) =>
- (IDENT_INT(4) .. 6 => 1));
- IF A /= (6 .. IDENT_INT(8) =>
- (IDENT_INT(4) .. 6 => 1)) THEN
- FAILED ("CASE B : INCORRECT VALUES");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE B");
-
- END CASE_B;
-
-CASE_C : BEGIN
-
- A := (7 .. 9 => (5 .. 7 => IDENT_INT(2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE C " &
- INTEGER'IMAGE(A(IDENT_INT(7),7)));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE C");
-
- END CASE_C;
-
-CASE_D : BEGIN
-
- A := (5 .. 7 => (3 .. 5 => IDENT_INT(3)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE D " &
- INTEGER'IMAGE(A(7,IDENT_INT(5))));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE D");
-
- END CASE_D;
-
-CASE_E : BEGIN
-
- A := (7 .. IDENT_INT(9) => (5 .. 7 => IDENT_INT(4)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE E " &
- INTEGER'IMAGE(A(IDENT_INT(7),7)));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE E : EXCEPTION RAISED");
-
- END CASE_E;
-
-CASE_F : BEGIN
-
- A := (5 .. 7 => (IDENT_INT(3) .. 5 => IDENT_INT(5)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE F " &
- INTEGER'IMAGE(A(7,IDENT_INT(5))));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE F");
-
- END CASE_F;
-
-CASE_G : BEGIN
-
- A := (7 .. 8 => (5 .. 7 => IDENT_INT(6)),
- 9 => (5 .. 7 => IDENT_INT(6)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE G " &
- INTEGER'IMAGE(A(7,IDENT_INT(7))));
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED: CASE G");
-
- END CASE_G;
-
- END;
-
- RESULT;
-
-END C43211A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43212a.ada b/gcc/testsuite/ada/acats/tests/c4/c43212a.ada
deleted file mode 100644
index fd94033..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43212a.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- C43212A.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 IF ALL SUBAGGREGATES FOR A
--- PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS.
-
--- EG 02/06/1984
--- JBG 3/30/84
--- JRK 4/18/86 CORRECTED ERROR TO ALLOW CONSTRAINT_ERROR TO BE
--- RAISED EARLIER.
--- EDS 7/15/98 AVOID OPTIMIZATION.
-
-WITH REPORT;
-
-PROCEDURE C43212A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C43212A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " &
- "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " &
- "NOT HAVE THE SAME BOUNDS");
-
- DECLARE
-
- TYPE CHOICE_INDEX IS (H, I);
- TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER;
-
- CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
-
- FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
- RETURN INTEGER IS
- BEGIN
- CNTR(A) := CNTR(A) + 1;
- RETURN IDENT_INT(B);
- END CALC;
-
- BEGIN
-
-CASE_1 : DECLARE
-
- TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>)
- OF INTEGER;
-
- A1 : T(1 .. 3, 2 .. 5) := (OTHERS => (OTHERS => 0));
-
- BEGIN
-
- CNTR := (CHOICE_INDEX => 0);
- A1 := (1 => (CALC(H,2) .. CALC(I,5) => -4),
- 2 => (CALC(H,3) .. CALC(I,6) => -5),
- 3 => (CALC(H,2) .. CALC(I,5) => -3));
- FAILED ("CASE 1 : CONSTRAINT_ERROR NOT RAISED" &
- INTEGER'IMAGE(A1(1,5)) );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- IF CNTR(H) < 2 AND CNTR(I) < 2 THEN
- FAILED ("CASE 1 : BOUNDS OF SUBAGGREGATES " &
- "NOT DETERMINED INDEPENDENTLY");
- END IF;
-
- WHEN OTHERS =>
- FAILED ("CASE 1 : WRONG EXCEPTION RAISED");
-
- END CASE_1;
-
-CASE_1A : DECLARE
-
- TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>)
- OF INTEGER;
-
- A1 : T(1 .. 3, 2 .. 3) := (1 .. 3 => (2 .. 3 => 1));
-
- BEGIN
-
- IF (1 .. 2 => (IDENT_INT(3) .. IDENT_INT(4) => 0),
- 3 => (1, 2)) = A1 THEN
- BEGIN
- COMMENT(" IF SHOULD GENERATE CONSTRAINT_ERROR " &
- INTEGER'IMAGE(A1(1,2)) );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED");
- END;
- END IF;
- FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE 1A : WRONG EXCEPTION RAISED");
-
- END CASE_1A;
-
-CASE_2 : DECLARE
-
- TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>)
- OF INTEGER;
-
- A2 : T(1 .. 3, IDENT_INT(4) .. 2);
-
- BEGIN
-
- CNTR := (CHOICE_INDEX => 0);
- A2 := (1 => (CALC(H,5) .. CALC(I,3) => -4),
- 3 => (CALC(H,4) .. CALC(I,2) => -5),
- 2 => (CALC(H,4) .. CALC(I,2) => -3));
- FAILED ("CASE 2 : CONSTRAINT_ERROR NOT RAISED " &
- INTEGER'IMAGE(IDENT_INT(A2'FIRST(1))));
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- IF CNTR(H) < 2 AND CNTR(I) < 2 THEN
- FAILED ("CASE 2 : BOUNDS OF SUBAGGREGATES " &
- "NOT DETERMINED INDEPENDENTLY");
- END IF;
-
- WHEN OTHERS =>
- FAILED ("CASE 2 : WRONG EXCEPTION RAISED");
-
- END CASE_2;
-
- END;
-
- RESULT;
-
-END C43212A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43212c.ada b/gcc/testsuite/ada/acats/tests/c4/c43212c.ada
deleted file mode 100644
index 3076467..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43212c.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C43212C.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 IF ALL SUBAGGREGATES FOR
--- A PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS.
--- ADDITIONAL CASES FOR THE THIRD DIMENSION AND FOR THE NULL ARRAYS.
-
--- PK 02/21/84
--- EG 05/30/84
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE C43212C IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
-
-BEGIN
-
- TEST("C43212C","CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " &
- "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " &
- "NOT HAVE THE SAME BOUNDS");
-
- DECLARE
- TYPE A3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>)
- OF INTEGER;
- BEGIN
- IF A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)),
- (1 .. IDENT_INT(2) => IDENT_INT(1))),
- ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)),
- (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1))))
- =
- A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)),
- (1 .. IDENT_INT(2) => IDENT_INT(1))),
- ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)),
- (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1))))
- THEN
- FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS EQUAL");
- END IF;
- FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("A3 - WRONG EXCEPTION RAISED");
-
- END;
-
- DECLARE
-
- TYPE B3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>)
- OF INTEGER;
-
- BEGIN
-
- IF B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)),
- (2 .. IDENT_INT(1) => IDENT_INT(1))),
- ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)),
- (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1))))
- =
- B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)),
- (2 .. IDENT_INT(1) => IDENT_INT(1))),
- ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)),
- (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1))))
- THEN
- FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS EQUAL");
- END IF;
- FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("B3 - WRONG EXCEPTION RAISED");
-
- END;
-
- RESULT;
-
-END C43212C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214a.ada b/gcc/testsuite/ada/acats/tests/c4/c43214a.ada
deleted file mode 100644
index 6d953c4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C43214A.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.
---*
--- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => ""), CHECK
--- THAT CONSTRAINT_ERROR IS RAISED IF F..G IS NON-NULL AND
--- F OR G DO NOT BELONG TO THE INDEX SUBTYPE.
-
--- EG 02/10/1984
--- JBG 12/6/84
--- EDS 07/15/98 AVOID OPTIMIZATION
-
-WITH REPORT;
-
-PROCEDURE C43214A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214A", "FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM " &
- "(F..G => """"), CHECK THAT CONSTRAINT ERROR " &
- "IS RAISED IF F..G IS NON-NULL AND NOT IN THE " &
- "INDEX SUBTYPE");
-
- DECLARE
-
- SUBTYPE STA IS INTEGER RANGE 4 .. 7;
- TYPE TA IS ARRAY(STA RANGE 5 .. 6,
- STA RANGE 6 .. IDENT_INT(4)) OF CHARACTER;
-
- A : TA := (5 .. 6 => "");
-
- BEGIN
-
-CASE_A : BEGIN
-
- IF (6 .. IDENT_INT(8) => "") = A THEN
- FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED");
- END IF;
- FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED - 2");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE A : WRONG EXCEPTION RAISED");
-
- END CASE_A;
-
-CASE_B : BEGIN
-
- A := (IDENT_INT(3) .. 4 => "");
- FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED");
- BEGIN
- FAILED("ATTEMPT TO USE A " &
- CHARACTER'VAL(IDENT_INT(CHARACTER'POS(
- A(A'FIRST(1), A'FIRST(2)) ))) );
- EXCEPTION
- WHEN OTHERS =>
- FAILED("CONSTRAINT_ERROR NOT RAISED AT PROPER PLACE");
- END;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE B : WRONG EXCEPTION RAISED");
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43214A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214b.ada b/gcc/testsuite/ada/acats/tests/c4/c43214b.ada
deleted file mode 100644
index 6db7e2b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214b.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C43214B.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 LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY
--- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS.
-
--- EG 02/10/84
-
-WITH REPORT;
-
-PROCEDURE C43214B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214B", "SUBPROGRAM WITH CONSTRAINED ARRAY FORMAL " &
- "PARAMETER");
-
- BEGIN
-
-CASE_A : BEGIN
-
--- COMMENT ("CASE A1 : SUBPROGRAM WITH CONSTRAINED " &
--- "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER");
-
- CASE_A1 : DECLARE
-
- SUBTYPE STA1 IS STRING(IDENT_INT(11) .. 15);
-
- PROCEDURE PROC1 (A : STA1) IS
- BEGIN
- IF A'FIRST /= 11 THEN
- FAILED ("CASE 1 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST /= 15 THEN
- FAILED ("CASE 1 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= "ABCDE" THEN
- FAILED ("CASE 1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 ("ABCDE");
-
- END CASE_A1;
-
--- COMMENT ("CASE A2 : SUBPROGRAM WITH CONSTRAINED " &
--- "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER");
-
- CASE_A2 : DECLARE
-
- TYPE TA IS ARRAY (11 .. 12, 10 .. 11) OF CHARACTER;
-
- PROCEDURE PROC1 (A : TA) IS
- BEGIN
- IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN
- FAILED ("CASE 2 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN
- FAILED ("CASE 2 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= ("AB", "CD") THEN
- FAILED ("CASE 2 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- BEGIN
-
- PROC1 (("AB", "CD"));
-
- END CASE_A2;
-
- END CASE_A;
-
- END;
-
- RESULT;
-
-END C43214B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214c.ada b/gcc/testsuite/ada/acats/tests/c4/c43214c.ada
deleted file mode 100644
index b523302..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214c.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C43214C.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 LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY
--- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS.
-
--- EG 02/10/84
-
-WITH REPORT;
-
-PROCEDURE C43214C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214C", "CONSTRAINED ARRAY FORMAL GENERIC " &
- "PARAMETER");
-
- BEGIN
-
-CASE_B : DECLARE
-
- SUBTYPE STB IS STRING(5 .. 8);
-
- GENERIC
- B1 : STB;
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN
- IF B1'FIRST /= 5 THEN
- FAILED ("LOWER BOUND INCORRECT");
- ELSIF B1'LAST /= 8 THEN
- FAILED ("UPPER BOUND INCORRECT");
- ELSIF B1 /= "ABCD" THEN
- FAILED ("ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
- END;
-
- PROCEDURE PROC2 IS NEW PROC1 ("ABCD");
-
- BEGIN
-
- PROC2;
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43214C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214d.ada b/gcc/testsuite/ada/acats/tests/c4/c43214d.ada
deleted file mode 100644
index 7274a4b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214d.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C43214D.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 LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY
--- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS.
-
--- EG 02/10/84
-
-WITH REPORT;
-
-PROCEDURE C43214D IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214D", "CONSTRAINED FUNCTION RESULT TYPE");
-
- BEGIN
-
-CASE_C : DECLARE
-
- TYPE TC IS ARRAY (INTEGER RANGE -1 .. 0,
- IDENT_INT(7) .. 9) OF CHARACTER;
-
- FUNCTION FUN1 (A : INTEGER) RETURN TC IS
- BEGIN
- RETURN ("ABC", "DEF");
- END;
-
- BEGIN
-
- IF FUN1(5)'FIRST(1) /= -1 THEN
- FAILED ("LOWER BOUND INCORRECT " &
- "FOR 'FIRST(1)");
- ELSIF FUN1(5)'FIRST(2) /= 7 THEN
- FAILED ("LOWER BOUND INCORRECT " &
- "FOR 'FIRST(2)");
- ELSIF FUN1(5)'LAST(1) /= 0 THEN
- FAILED ("UPPER BOUND INCORRECT " &
- "FOR 'LAST(1)");
- ELSIF FUN1(5)'LAST(2) /= 9 THEN
- FAILED ("UPPER BOUND INCORRECT " &
- "FOR 'LAST(2)");
- ELSIF FUN1(5) /= ("ABC", "DEF") THEN
- FAILED ("FUNCTION DOES NOT " &
- "RETURN THE CORRECT VALUES");
- END IF;
-
- END CASE_C;
-
- END;
-
- RESULT;
-
-END C43214D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214e.ada b/gcc/testsuite/ada/acats/tests/c4/c43214e.ada
deleted file mode 100644
index 88ebb51..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214e.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- C43214E.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 LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY
--- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS.
-
--- EG 02/10/84
-
-WITH REPORT;
-
-PROCEDURE C43214E IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214E", "INITIALIZATION OF CONSTRAINED ARRAY");
-
- BEGIN
-
-CASE_D : BEGIN
-
--- COMMENT ("CASE D1 : INITIALIZATION OF CONSTRAINED " &
--- "ARRAY CONSTANT");
-
- CASE_D1 : DECLARE
-
- D1 : CONSTANT STRING(11 .. 13) := "ABC";
-
- BEGIN
-
- IF D1'FIRST /= 11 THEN
- FAILED ("CASE 1 : LOWER BOUND INCORRECT");
- ELSIF D1'LAST /= 13 THEN
- FAILED ("CASE 1 : UPPER BOUND INCORRECT");
- ELSIF D1 /= "ABC" THEN
- FAILED ("CASE 1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
-
- END CASE_D1;
-
--- COMMENT ("CASE D2 : INITIALIZATION OF CONSTRAINED " &
--- "ARRAY VARIABLE");
-
- CASE_D2 : DECLARE
-
- D2 : STRING(11 .. 13) := "ABC";
-
- BEGIN
-
- IF D2'FIRST /= 11 THEN
- FAILED ("CASE 2 : LOWER BOUND INCORRECT");
- ELSIF D2'LAST /= 13 THEN
- FAILED ("CASE 2 : UPPER BOUND INCORRECT");
- ELSIF D2 /= "ABC" THEN
- FAILED ("CASE 2 : INCORRECT VALUES");
- END IF;
-
- END CASE_D2;
-
--- COMMENT ("CASE D3 : INITIALIZATION OF CONSTRAINED " &
--- "ARRAY FORMAL PARAMETER OF A SUBPROGRAM");
-
- CASE_D3 : DECLARE
-
- SUBTYPE STD3 IS STRING(IDENT_INT(5) .. 7);
-
- PROCEDURE PROC1 (A : STD3 := "ABC") IS
- BEGIN
- IF A'FIRST /= 5 THEN
- FAILED ("CASE 3 : LOWER BOUND " &
- "INCORRECT");
- ELSIF A'LAST /= 7 THEN
- FAILED ("CASE 3 : UPPER BOUND " &
- "INCORRECT");
- ELSIF A /= "ABC" THEN
- FAILED ("CASE 3 : INCORRECT VALUES");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1;
-
- END CASE_D3;
-
--- COMMENT ("CASE D4 : INITIALIZATION OF CONSTRAINED " &
--- "ARRAY FORMAL PARAMETER OF A GENERIC UNIT");
-
- CASE_D4 : DECLARE
-
- SUBTYPE STD4 IS STRING(5 .. 8);
-
- GENERIC
- D4 : STD4 := "ABCD";
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN
- IF D4'FIRST /= 5 THEN
- FAILED ("CASE 4 : LOWER BOUND " &
- "INCORRECT");
- ELSIF D4'LAST /= 8 THEN
- FAILED ("CASE 4 : UPPER BOUND " &
- "INCORRECT");
- ELSIF D4 /= "ABCD" THEN
- FAILED ("CASE 4 : INCORRECT VALUES");
- END IF;
- END PROC1;
-
- PROCEDURE PROC2 IS NEW PROC1;
-
- BEGIN
-
- PROC2;
-
- END CASE_D4;
-
- END CASE_D;
-
- END;
-
- RESULT;
-
-END C43214E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214f.ada b/gcc/testsuite/ada/acats/tests/c4/c43214f.ada
deleted file mode 100644
index 2c19d17..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43214f.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- C43214F.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 LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY
--- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS.
-
--- EG 02/10/84
--- JBG 3/30/84
-
-WITH REPORT;
-
-PROCEDURE C43214F IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C43214F", "ARRAY COMPONENT EXPRESSION OF AN ENCLOSING " &
- "AGGREGATE");
-
- BEGIN
-
-CASE_E : BEGIN
-
--- COMMENT ("CASE E1 : ARRAY COMPONENT EXPRESSION OF " &
--- "AN ENCLOSING ARRAY AGGREGATE");
-
- CASE_E1 : DECLARE
-
- TYPE TE2 IS ARRAY(1 .. 2) OF
- STRING(IDENT_INT(3) .. 5);
-
- E1 : TE2;
-
- BEGIN
-
- E1 := (1 .. 2 => "ABC");
- IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE
- (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR
- E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN
- FAILED ("CASE 1 : INCORRECT BOUNDS");
- ELSIF E1 /= (1 .. 2 => "ABC") THEN
- FAILED ("CASE 1 : ARRAY DOES NOT " &
- "CONTAIN THE CORRECT VALUES");
- END IF;
-
- END CASE_E1;
-
--- COMMENT ("CASE E2 : ARRAY COMPONENT EXPRESSION OF " &
--- "AN ENCLOSING RECORD AGGREGATE");
-
- CASE_E2 : DECLARE
-
- TYPE TER IS
- RECORD
- REC : STRING(3 .. 5);
- END RECORD;
-
- E2 : TER;
-
- BEGIN
-
- E2 := (REC => "ABC");
- IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN
- FAILED ("CASE 2 : INCORRECT BOUNDS");
- ELSIF E2.REC /= "ABC" THEN
- FAILED ("CASE 2 : ARRAY DOES NOT " &
- "CONTAIN CORRECT VALUES");
- END IF;
-
- END CASE_E2;
-
--- COMMENT ("CASE E3 : NULL LITERAL OF AN ENCLOSING " &
--- "ARRAY AGGREGATE");
-
- CASE_E3 : DECLARE
-
- TYPE TE2 IS ARRAY(1 .. 2) OF
- STRING(3 .. IDENT_INT(2));
-
- E3 : TE2;
-
- BEGIN
-
- E3 := (1 .. 2 => "");
- IF (E3'FIRST /= 1 OR E3'LAST /= 2) OR ELSE
- (E3(1)'FIRST /= 3 OR E3(1)'LAST /= 2 OR
- E3(2)'FIRST /= 3 OR E3(2)'LAST /= 2) THEN
- FAILED ("CASE 3 : INCORRECT BOUND");
- ELSIF E3 /= (1 .. 2 => "") THEN
- FAILED ("CASE 3 : ARRAY DOES NOT CONTAIN " &
- "THE CORRECT VALUES");
- END IF;
-
- END CASE_E3;
-
--- COMMENT ("CASE E4 : ARRAY COMPONENT EXPRESSION OF " &
--- "AN ENCLOSING RECORD AGGREGATE THAT HAS A " &
--- "DISCRIMINANT AND THE DISCRIMINANT DETER" &
--- "MINES THE BOUNDS OF THE COMPONENT");
-
- CASE_E4 : DECLARE
-
- SUBTYPE TEN IS INTEGER RANGE 1 .. 10;
- TYPE TER (A : TEN) IS
- RECORD
- REC : STRING(3 .. A);
- END RECORD;
-
- E4 : TER(5);
-
- BEGIN
-
- E4 := (REC => "ABC", A => 5);
- IF E4.REC'FIRST /= 3 OR E4.REC'LAST /= 5 THEN
- FAILED ("CASE 4 : INCORRECT BOUNDS");
- ELSIF E4.REC /= "ABC" THEN
- FAILED ("CASE 4 : ARRAY DOES NOT CONTAIN " &
- "CORRECT VALUES");
- END IF;
-
- END CASE_E4;
-
- END CASE_E;
-
- END;
-
- RESULT;
-
-END C43214F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43215a.ada b/gcc/testsuite/ada/acats/tests/c4/c43215a.ada
deleted file mode 100644
index ff832cc..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43215a.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- C43215A.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 A POSITIONAL
--- ARRAY AGGREGATE WHOSE UPPER BOUND EXCEEDS THE UPPER BOUND
--- OF THE INDEX SUBTYPE BUT BELONGS TO THE INDEX BASE TYPE.
-
--- EG 02/13/84
-
-WITH REPORT;
-WITH SYSTEM;
-
-PROCEDURE C43215A IS
-
- USE REPORT;
- USE SYSTEM;
-
-BEGIN
-
- TEST("C43215A","CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "FOR A POSITIONAL ARRAY AGGREGATE WHOSE " &
- "UPPER BOUND EXCEEDS THE UPPER BOUND OF THE " &
- "INDEX SUBTYPE BUT BELONGS TO THE INDEX " &
- "BASE TYPE");
-
- BEGIN
-
-CASE_A : DECLARE
-
- LOWER_BOUND : CONSTANT := MAX_INT-3;
- UPPER_BOUND : CONSTANT := MAX_INT-1;
-
- TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND;
-
- TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER;
-
- A1 : TA(STA);
- OK : EXCEPTION;
-
- FUNCTION FUN1 RETURN TA IS
- BEGIN
- RETURN (1, 2, 3, 4);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- BEGIN
- COMMENT ("CASE A : CONSTRAINT_ERROR RAISED");
- RAISE OK;
- END;
- WHEN OTHERS =>
- BEGIN
- FAILED ("CASE A : EXCEPTION RAISED IN FUN1");
- RAISE OK;
- END;
- END FUN1;
-
- BEGIN
-
- A1 := FUN1;
- FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED");
-
- EXCEPTION
-
- WHEN OK =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE A : EXCEPTION RAISED");
-
- END CASE_A;
-
-CASE_B : DECLARE
-
- TYPE ENUM IS (A, B, C, D);
-
- SUBTYPE STB IS ENUM RANGE A .. C;
-
- TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER;
-
- B1 : TB(STB);
- OK : EXCEPTION;
-
- FUNCTION FUN1 RETURN TB IS
- BEGIN
- RETURN (1, 2, 3, 4);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- BEGIN
- COMMENT ("CASE B : CONSTRAINT_ERROR RAISED");
- RAISE OK;
- END;
- WHEN OTHERS =>
- BEGIN
- FAILED ("CASE B : EXCEPTION RAISED IN FUN1");
- RAISE OK;
- END;
- END FUN1;
-
- BEGIN
-
- B1 := FUN1;
- FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED");
-
- EXCEPTION
-
- WHEN OK =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE B : EXCEPTION RAISED");
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43215A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43215b.ada b/gcc/testsuite/ada/acats/tests/c4/c43215b.ada
deleted file mode 100644
index a80f818..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43215b.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C43215B.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 WHEN THE UPPER BOUND
--- OF A POSITIONAL AGGREGATE DOES NOT BELONG TO THE INDEX BASE TYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- EG 02/13/84
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT;
-WITH SYSTEM;
-
-PROCEDURE C43215B IS
-
- USE REPORT;
- USE SYSTEM;
-
-BEGIN
-
- TEST("C43215B","CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "WHEN THE UPPER BOUND OF A POSITIONAL ARRAY " &
- "AGGREGATE DOES NOT BELONG TO THE INDEX " &
- "BASE TYPE");
-
- BEGIN
-
-CASE_A : DECLARE
-
- LOWER_BOUND : CONSTANT := MAX_INT-3;
- UPPER_BOUND : CONSTANT := MAX_INT-1;
-
- TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND;
-
- TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER;
-
- A1 : TA(STA);
- OK : EXCEPTION;
-
- FUNCTION FUN1 RETURN TA IS
- BEGIN
- RETURN (1, 2, 3, 4, 5);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- BEGIN
- COMMENT ("CASE A : CONSTRAINT_ERROR RAISED");
- RAISE OK;
- END;
- WHEN OTHERS =>
- BEGIN
- FAILED ("CASE A : EXCEPTION RAISED IN FUN1");
- RAISE OK;
- END;
- END FUN1;
-
- BEGIN
-
- A1 := FUN1;
- FAILED ("CASE A : CONSTRAINT OR NUMERIC ERROR WAS " &
- "NOT RAISED");
-
- EXCEPTION
-
- WHEN OK =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE A : WRONG EXCEPTION RAISED");
-
- END CASE_A;
-
-CASE_B : DECLARE
-
- TYPE ENUM IS (A, B, C, D);
-
- SUBTYPE STB IS ENUM RANGE A .. C;
-
- TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER;
-
- B1 : TB(STB);
- OK : EXCEPTION;
-
- FUNCTION FUN1 RETURN TB IS
- BEGIN
- RETURN (1, 2, 3, 4, 5);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- BEGIN
- COMMENT ("CASE B : CONSTRAINT_ERROR RAISED");
- RAISE OK;
- END;
- WHEN OTHERS =>
- BEGIN
- FAILED ("CASE B : EXCEPTION RAISED IN FUN1");
- RAISE OK;
- END;
- END FUN1;
-
- BEGIN
-
- B1 := FUN1;
- FAILED ("CASE B : CONSTRAINT ERROR WAS NOT RAISED");
-
- EXCEPTION
-
- WHEN OK =>
- NULL;
-
- WHEN OTHERS =>
- FAILED ("CASE B : WRONG EXCEPTION RAISED");
-
- END CASE_B;
-
- END;
-
- RESULT;
-
-END C43215B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43222a.ada b/gcc/testsuite/ada/acats/tests/c4/c43222a.ada
deleted file mode 100644
index f105657..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43222a.ada
+++ /dev/null
@@ -1,49 +0,0 @@
--- C43222A.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 ARRAY AGGREGATE NEED NOT BE RESOLVABLE TO A
--- CONSTRAINED SUBTYPE.
-
--- HISTORY:
--- DHH 08/12/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43222A IS
-
-BEGIN
- TEST("C43222A", "CHECK THAT AN ARRAY AGGREGATE NEED NOT BE " &
- "RESOLVABLE TO A CONSTRAINED SUBTYPE");
-
- DECLARE
- TYPE A IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- B : BOOLEAN := (1, 2, 3) = A'(1, 2, 3);
- BEGIN
- IF IDENT_BOOL(B) /= IDENT_BOOL(TRUE) THEN
- FAILED("INITIALIZATION FAILURE");
- END IF;
- END;
-
- RESULT;
-END C43222A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43224a.ada b/gcc/testsuite/ada/acats/tests/c4/c43224a.ada
deleted file mode 100644
index 799309a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c43224a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C43224A.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-STATIC CHOICE OF AN ARRAY AGGREGATE CAN BE A
--- 'RANGE ATTRIBUTE.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C43224A IS
-
- M, O : INTEGER := IDENT_INT(2);
- N : INTEGER := IDENT_INT(3);
-
- TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE D3_ARR IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>,
- INTEGER RANGE <>) OF INTEGER;
-
- SUBTYPE ARR1 IS ARR(IDENT_INT(2) .. IDENT_INT(3));
- SUBTYPE ARR2 IS D3_ARR(1 .. M, 1 .. N, 1 ..O);
-
- SUB : ARR1;
- SUB1 : ARR2;
-
- PROCEDURE PROC(ARRY : IN OUT ARR) IS
- BEGIN
- ARRY := (ARR1'RANGE => IDENT_INT(7));
- IF ARRY(IDENT_INT(ARRY'FIRST)) /= IDENT_INT(7) THEN
- FAILED("RANGE NOT INITIALIZED - 1");
- END IF;
- END PROC;
-
- PROCEDURE PROC1(ARRY : IN OUT D3_ARR) IS
- BEGIN
- ARRY := (ARR2'RANGE(1) => (ARRY'RANGE(2) =>
- (ARRY'RANGE(3) => IDENT_INT(7))));
-
- IF ARRY(IDENT_INT(1), IDENT_INT(2), IDENT_INT(1)) /=
- IDENT_INT(7) THEN
- FAILED("RANGE NOT INITIALIZED - 2");
- END IF;
- END PROC1;
-
-BEGIN
- TEST("C43224A", "CHECK THAT A NON-STATIC CHOICE OF AN ARRAY " &
- "AGGREGATE CAN BE A 'RANGE ATTRIBUTE");
-
- PROC(SUB);
- PROC1(SUB1);
-
- RESULT;
-END C43224A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a
deleted file mode 100644
index 305e010..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c433001.a
+++ /dev/null
@@ -1,303 +0,0 @@
--- C433001.A
-
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 others choice is allowed in an array aggregate whose
--- applicable index constraint is dynamic. (This was an extension to
--- Ada 83). Check that index choices are within the applicable index
--- constraint for array aggregates with others choices.
---
--- TEST DESCRIPTION
--- In this test, we declare several unconstrained array types, and
--- several dynamic subtypes. We then test a variety of cases of using
--- appropriate aggregates. Some cases expect to raise Constraint_Error.
---
--- HISTORY:
--- 16 DEC 1999 RLB Initial Version.
--- 20 JAN 2009 RLB Corrected error messages.
-
-with Report;
-procedure C433001 is
-
- type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
-
- type Array_1 is array (Positive range <>) of Integer;
-
- subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3));
- subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5));
- subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9));
-
- type Array_2 is array (Color_Type range <>) of Integer;
-
- subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) ..
- Color_Type'Val(Report.Ident_Int(2)));
- -- Red .. Yellow
- subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) ..
- Color_Type'Val(Report.Ident_Int(6)));
- -- Green .. Violet
- type Array_3 is array (Color_Type range <>, Positive range <>) of Integer;
-
- subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) ..
- Color_Type'Val(Report.Ident_Int(2)),
- Report.Ident_Int(3) .. Report.Ident_Int(5));
- -- Red .. Yellow, 3 .. 5
- subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) ..
- Color_Type'Val(Report.Ident_Int(3)),
- Report.Ident_Int(6) .. Report.Ident_Int(8));
- -- Orange .. Green, 6 .. 8
-
- procedure Check_1 (Obj : Array_1; Low, High : Integer;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- if Obj'First /= Low then
- Report.Failed ("Low bound incorrect (" & Test_Case & ")");
- end if;
- if Obj'Last /= High then
- Report.Failed ("High bound incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low) /= First_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low+1) /= Second_Component then
- Report.Failed ("Second Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(High) /= Last_Component then
- Report.Failed ("Last Component incorrect (" & Test_Case & ")");
- end if;
- end Check_1;
-
- procedure Check_2 (Obj : Array_2; Low, High : Color_Type;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- if Obj'First /= Low then
- Report.Failed ("Low bound incorrect (" & Test_Case & ")");
- end if;
- if Obj'Last /= High then
- Report.Failed ("High bound incorrect (" & Test_Case & ")");
- end if;
- if Obj(Low) /= First_Component then
- Report.Failed ("First Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(Color_Type'Succ(Low)) /= Second_Component then
- Report.Failed ("Second Component incorrect (" & Test_Case & ")");
- end if;
- if Obj(High) /= Last_Component then
- Report.Failed ("Last Component incorrect (" & Test_Case & ")");
- end if;
- end Check_2;
-
- procedure Check_3 (Test_Obj, Check_Obj : Array_3;
- Low_1, High_1 : Color_Type;
- Low_2, High_2 : Integer;
- Test_Case : Character) is
- begin
- if Test_Obj'First(1) /= Low_1 then
- Report.Failed ("Low bound for dimension 1 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'Last(1) /= High_1 then
- Report.Failed ("High bound for dimension 1 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'First(2) /= Low_2 then
- Report.Failed ("Low bound for dimension 2 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj'Last(2) /= High_2 then
- Report.Failed ("High bound for dimension 2 incorrect (" &
- Test_Case & ")");
- end if;
- if Test_Obj /= Check_Obj then
- Report.Failed ("Components incorrect (" & Test_Case & ")");
- end if;
- end Check_3;
-
- procedure Subtest_Check_1 (Obj : Sub_1_3;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component,
- Test_Case);
- end Subtest_Check_1;
-
- procedure Subtest_Check_2 (Obj : Sub_2_2;
- First_Component, Second_Component,
- Last_Component : Integer;
- Test_Case : Character) is
- begin
- Check_2 (Obj, Green, Violet, First_Component, Second_Component,
- Last_Component, Test_Case);
- end Subtest_Check_2;
-
- procedure Subtest_Check_3 (Obj : Sub_3_2;
- Test_Case : Character) is
- begin
- Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case);
- end Subtest_Check_3;
-
-begin
-
- Report.Test ("C433001",
- "Check that an others choice is allowed in an array " &
- "aggregate whose applicable index constraint is dynamic. " &
- "Also check index choices are within the applicable index " &
- "constraint for array aggregates with others choices");
-
- -- Check with a qualified expression:
- Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3,
- First_Component => 2, Second_Component => 3, Last_Component => 4,
- Test_Case => 'A');
-
- Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)),
- Low => Red, High => Yellow,
- First_Component => 1, Second_Component => 6, Last_Component => 6,
- Test_Case => 'B');
-
- Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)),
- Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)),
- Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5,
- Test_Case => 'C');
-
- -- Check that the others clause does not need to represent any components:
- Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5,
- First_Component => 5, Second_Component => 6, Last_Component => 8,
- Test_Case => 'D');
-
- -- Check named choices are allowed:
- Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8),
- Low => 1, High => 3,
- First_Component => 8, Second_Component => -1, Last_Component => 8,
- Test_Case => 'E');
-
- -- Check named choices and formal parameters:
- Subtest_Check_1 ((6 => 4, 8 => 86, others => 1),
- First_Component => 1, Second_Component => 4, Last_Component => 1,
- Test_Case => 'F');
-
- Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89,
- Indigo => Report.Ident_Int(42), Blue => 0, others => -1),
- First_Component => 88, Second_Component => 0, Last_Component => 89,
- Test_Case => 'G');
-
- Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)),
- Test_Case => 'H');
-
- -- Check object declarations and assignment:
- declare
- Var : Sub_1_2 := (4, 36, others => 86);
- begin
- Check_1 (Var, Low => 3, High => 5,
- First_Component => 4, Second_Component => 36,
- Last_Component => 86,
- Test_Case => 'I');
- Var := (5 => 415, others => Report.Ident_Int(1522));
- Check_1 (Var, Low => 3, High => 5,
- First_Component => 1522, Second_Component => 1522,
- Last_Component => 415,
- Test_Case => 'J');
- end;
-
- -- Check positional aggregates that are too long:
- begin
- Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93),
- First_Component => 88, Second_Component => 89,
- Last_Component => 91,
- Test_Case => 'K');
- Report.Failed ("Constraint_Error not raised by positional " &
- "aggregate with too many choices (K)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 (((0, others => 10), (2, 3, others => 4),
- (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)),
- Test_Case => 'L');
- Report.Failed ("Constraint_Error not raised by positional " &
- "aggregate with too many choices (L)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- -- Check named aggregates with choices in the index subtype but not in the
- -- applicable index constraint:
-
- begin
- Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89,
- 10 => 66, -- 10 not in applicable index constraint
- others => 93),
- First_Component => 88, Second_Component => 93,
- Last_Component => 93,
- Test_Case => 'M');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (M)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_2 (
- (Yellow => 23, -- Yellow not in applicable index constraint.
- Blue => 16, others => 77),
- First_Component => 77, Second_Component => 16,
- Last_Component => 77,
- Test_Case => 'N');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (N)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 ((Orange => (0, others => 10),
- Blue => (2, 3, others => 4), -- Blue not in applicable index cons.
- others => (1, 2, 3)),
- Test_Case => 'P');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (P)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- begin
- Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)),
- Green => (8 => 2, 4 => 3, others => 7),
- -- 4 not in applicable index cons.
- others => (1, 2, 3, others => Report.Ident_Int(10))),
- Test_Case => 'Q');
- Report.Failed ("Constraint_Error not raised by aggregate choice " &
- "index outside of applicable index constraint (Q)");
- exception
- when Constraint_Error => null; -- Expected exception.
- end;
-
- Report.Result;
-
-end C433001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003d.ada b/gcc/testsuite/ada/acats/tests/c4/c44003d.ada
deleted file mode 100644
index 57ad7c4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c44003d.ada
+++ /dev/null
@@ -1,188 +0,0 @@
--- C44003D.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 FOR CORRECT PRECEDENCE OF PREDEFINED AND OVERLOADED
--- OPERATIONS ON PREDEFINED TYPE FLOAT, USER-DEFINED TYPES, AND
--- ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT.
-
--- HISTORY:
--- RJW 10/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C44003D IS
-
-BEGIN
- TEST ("C44003D", "CHECK FOR CORRECT PRECEDENCE OF PREDEFINED " &
- "AND OVERLOADED OPERATIONS ON PREDEFINED TYPE " &
- "FLOAT, USER-DEFINED TYPES, AND ONE-DIMEN" &
- "SIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT");
-
------ PREDEFINED FLOAT:
-
- DECLARE
- F1 : FLOAT := 1.0;
- F2 : FLOAT := 2.0;
- F5 : FLOAT := 5.0;
-
- FUNCTION "OR" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 4.5;
- END "OR";
-
- FUNCTION "<" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 5.5;
- END "<";
-
- FUNCTION "-" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 6.5;
- END "-";
-
- FUNCTION "+" (RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 7.5;
- END "+";
-
- FUNCTION "*" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 8.5;
- END "*";
-
- FUNCTION "NOT" (RIGHT : FLOAT) RETURN FLOAT IS
- BEGIN
- RETURN 9.5;
- END "NOT";
-
- BEGIN
- IF NOT (-ABS F1 + F2 / F1 + F5 ** 2 = 26.0 AND
- F1 > 0.0 AND
- - F2 * F2 ** 3 = -8.5) THEN
- FAILED ("INCORRECT RESULT - 1");
- END IF;
-
- IF (F1 OR NOT F2 < F1 - F5 * F5 ** 3) /= 4.5 THEN
- FAILED ("INCORRECT RESULT - 2");
- END IF;
- END;
-
------ USER-DEFINED TYPE:
-
- DECLARE
- TYPE USR IS DIGITS 5;
-
- F1 : USR := 1.0;
- F2 : USR := 2.0;
- F5 : USR := 5.0;
-
- FUNCTION "AND" (LEFT, RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 4.5;
- END "AND";
-
- FUNCTION ">=" (LEFT, RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 5.5;
- END ">=";
-
- FUNCTION "+" (LEFT, RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 6.5;
- END "+";
-
- FUNCTION "-" (RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 7.5;
- END "-";
-
- FUNCTION "/" (LEFT, RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 8.5;
- END "/";
-
- FUNCTION "**" (LEFT, RIGHT : USR) RETURN USR IS
- BEGIN
- RETURN 9.5;
- END "**";
- BEGIN
- IF +F5 - F2 * F1 ** 2 /= 3.0 OR
- ABS F1 <= 0.0 OR
- - F2 * F2 ** 3.0 /= 7.5 THEN
- FAILED ("INCORRECT RESULT - 3");
- END IF;
-
- IF (F1 AND F2 >= F1 + F5 / F5 ** 3) /= 4.5 THEN
- FAILED ("INCORRECT RESULT - 4");
- END IF;
- END;
-
------ ARRAYS:
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF FLOAT;
-
- SUBTYPE SARR IS ARR (1 .. 3);
-
- F1 : SARR := (OTHERS => 1.0);
- F2 : SARR := (OTHERS => 2.0);
- F5 : SARR := (OTHERS => 5.0);
-
- FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => 4.5);
- END "XOR";
-
- FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => 5.5);
- END "<=";
-
- FUNCTION "&" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => 6.5);
- END "&";
-
- FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => 8.5);
- END "MOD";
-
- FUNCTION "ABS" (RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => 9.5);
- END "ABS";
- BEGIN
- IF (ABS F1 <= F2 & F5 MOD F1 XOR F1) /= (1 .. 3 => 4.5) THEN
- FAILED ("INCORRECT RESULT - 5");
- END IF;
-
- IF (ABS F1 & F2) /= (1 .. 3 => 6.5) OR
- (F1 MOD F2 <= F5) /= (1 .. 3 => 5.5) THEN
- FAILED ("INCORRECT RESULT - 6");
- END IF;
- END;
-
- RESULT;
-END C44003D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003f.ada b/gcc/testsuite/ada/acats/tests/c4/c44003f.ada
deleted file mode 100644
index 11121b2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c44003f.ada
+++ /dev/null
@@ -1,143 +0,0 @@
--- C44003F.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 FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED
--- OPERATIONS ON ENUMERATION TYPES OTHER THAN BOOLEAN OR CHARACTER
--- AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF SUCH TYPES.
-
--- HISTORY:
--- RJW 10/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C44003F IS
-
- TYPE ENUM IS (ZERO, ONE, TWO, THREE, FOUR, FIVE);
-
-BEGIN
- TEST ("C44003F", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " &
- "AND OVERLOADED OPERATIONS ON ENUMERATION " &
- "TYPES OTHER THAN BOOLEAN OR CHARACTER AND " &
- "ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " &
- "SUCH TYPES");
-
-
------ ENUMERATION TYPE:
-
- DECLARE
- E1 : ENUM := ONE;
- E2 : ENUM := TWO;
- E5 : ENUM := FIVE;
-
- FUNCTION "AND" (LEFT, RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ZERO;
- END "AND";
-
- FUNCTION "<" (LEFT, RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN THREE;
- END "<";
-
- FUNCTION "-" (LEFT, RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (ENUM'POS (LEFT) - ENUM'POS (RIGHT));
- END "-";
-
- FUNCTION "+" (RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN RIGHT;
- END "+";
-
- FUNCTION "*" (LEFT, RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (ENUM'POS (LEFT) * ENUM'POS (RIGHT));
- END "*";
-
- FUNCTION "**" (LEFT, RIGHT : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (ENUM'POS (LEFT) ** ENUM'POS (RIGHT));
- END "**";
-
- BEGIN
- IF NOT (+E1 < E2) OR NOT (E2 >= +E2) OR NOT (E5 = +FIVE) THEN
- FAILED ("INCORRECT RESULT - 1");
- END IF;
-
- IF (E5 ** E1 AND E2) /= (E5 - E1 * E5 ** E1) THEN
- FAILED ("INCORRECT RESULT - 2");
- END IF;
-
- END;
-
------ ARRAYS:
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF ENUM;
-
- SUBTYPE SARR IS ARR (1 .. 3);
-
- E1 : SARR := (OTHERS => ONE);
- E2 : SARR := (OTHERS => TWO);
- E5 : SARR := (OTHERS => FIVE);
-
- FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => ZERO);
- END "XOR";
-
- FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => THREE);
- END "<=";
-
- FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => ZERO);
- END "+";
-
- FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => THREE);
- END "MOD";
-
- FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => FOUR);
- END "**";
- BEGIN
- IF (E5 ** E1 <= E2 + E5 MOD E1 XOR E1) /= (1 .. 3 => ZERO)
- THEN
- FAILED ("INCORRECT RESULT - 3");
- END IF;
-
- IF (E5 ** E1 & E2) /= (FOUR, FOUR, FOUR, TWO, TWO, TWO) OR
- (E1 MOD E2 <= E5) /= (1 .. 3 => THREE) THEN
- FAILED ("INCORRECT RESULT - 4");
- END IF;
- END;
-
- RESULT;
-
-END C44003F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003g.ada b/gcc/testsuite/ada/acats/tests/c4/c44003g.ada
deleted file mode 100644
index 6825cc2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c44003g.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- C44003G.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 FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED
--- OPERATIONS ON BOOLEAN TYPES AND ONE-DIMENSIONAL ARRAYS WITH
--- COMPONENTS OF TYPE BOOLEAN.
-
--- HISTORY:
--- RJW 10/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C44003G IS
-
-BEGIN
- TEST ("C44003G", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " &
- "AND OVERLOADED OPERATIONS ON BOOLEAN TYPES " &
- "AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " &
- "TYPE BOOLEAN");
-
------ PREDEFINED BOOLEAN:
-
- DECLARE
- T : BOOLEAN := TRUE;
- F : BOOLEAN := FALSE;
-
- FUNCTION "AND" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END "AND";
-
- FUNCTION "<" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END "<";
-
- FUNCTION "-" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END "-";
-
- FUNCTION "+" (RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN NOT RIGHT;
- END "+";
-
- FUNCTION "*" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END "*";
-
- FUNCTION "**" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END "**";
-
- BEGIN
- IF NOT (+T = F) OR T /= +F OR (TRUE AND FALSE ** TRUE) OR
- NOT (+T < F) OR NOT (T - F * T) OR (NOT T - F XOR + F - F)
- THEN
- FAILED ("INCORRECT RESULT - 1");
- END IF;
-
- END;
-
------ ARRAYS:
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
-
- SUBTYPE SARR IS ARR (1 .. 3);
-
- T : SARR := (OTHERS => TRUE);
- F : SARR := (OTHERS => FALSE);
-
- FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => FALSE);
- END "XOR";
-
- FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => TRUE);
- END "<=";
-
- FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => FALSE);
- END "+";
-
- FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => TRUE);
- END "MOD";
-
- FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS
- BEGIN
- RETURN (1 .. 3 => FALSE);
- END "**";
- BEGIN
- IF (F ** T <= F + T MOD T XOR T) /= (1 .. 3 => FALSE)
- THEN
- FAILED ("INCORRECT RESULT - 2");
- END IF;
-
- IF F ** T & T /= NOT T & T OR
- (T MOD F <= T) /= (1 .. 3 => TRUE) THEN
- FAILED ("INCORRECT RESULT - 3");
- END IF;
- END;
-
- RESULT;
-END C44003G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c450001.a b/gcc/testsuite/ada/acats/tests/c4/c450001.a
deleted file mode 100644
index e398ffc..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c450001.a
+++ /dev/null
@@ -1,434 +0,0 @@
--- C450001.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 operations on modular types perform correctly.
---
--- Check that loops over the range of a modular type do not over or
--- under run the loop.
---
--- TEST DESCRIPTION:
--- Check logical and arithmetic operations.
--- (Attributes are tested elsewhere)
--- Checks to make sure that:
--- for X in Mod_Type loop
--- doesn't do something silly like infinite loop.
---
---
--- CHANGE HISTORY:
--- 20 SEP 95 SAIC Initial version
--- 20 FEB 96 SAIC Added underrun cases for 2.1
---
---!
-
------------------------------------------------------------------ C450001_0
-
-package C450001_0 is
-
- type Unsigned_8_Bit is mod 2**8;
-
- Shy_By_One : constant := 2**8-1;
-
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
-
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- procedure Loop_Check;
-
- -- embed some calls to Report.Ident_Int:
-
- function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit;
- function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8;
- function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8;
-
-end C450001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C450001_0 is
-
- procedure Loop_Check is
- Counter_Check : Natural := 0;
- begin
- for Ever in Unsigned_8_Bit loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > 2**8 then
- Report.Failed("Unsigned_8_Bit loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < 2**8 then
- Report.Failed("Unsigned_8_Bit loop underrun");
- end if;
-
- Counter_Check := 0;
-
- for Never in Unsigned_Edge_8 loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > Shy_By_One then
- Report.Failed("Unsigned_Edge_8 loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < Shy_By_One then
- Report.Failed("Unsigned_Edge_8 loop underrun");
- end if;
-
- Counter_Check := 0;
-
- for Getful in reverse Unsigned_Over_8 loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > Heavy_By_Two then
- Report.Failed("Unsigned_Over_8 loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < Heavy_By_Two then
- Report.Failed("Unsigned_Over_8 loop underrun");
- end if;
-
- end Loop_Check;
-
- function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit is
- begin
- return Unsigned_8_Bit(Report.Ident_Int(Integer(U8B)));
- end ID;
-
- function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8 is
- begin
- return Unsigned_Edge_8(Report.Ident_Int(Integer(UEB)));
- end ID;
-
- function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8 is
- begin
- return Unsigned_Over_8(Report.Ident_Int(Integer(UOB)));
- end ID;
-
-end C450001_0;
-
-------------------------------------------------------------------- C450001
-
-with Report;
-with C450001_0;
-with TCTouch;
-procedure C450001 is
- use C450001_0;
-
- BR : constant String := " produced the wrong result";
-
- procedure Is_T(B:Boolean;S:String) renames TCTouch.Assert;
- procedure Is_F(B:Boolean;S:String) renames TCTouch.Assert_Not;
-
- Whole_8_A, Whole_8_B, Whole_8_C : C450001_0.Unsigned_8_Bit;
-
- Short_8_A, Short_8_B, Short_8_C : C450001_0.Unsigned_Edge_8;
-
- Over_8_A, Over_8_B, Over_8_C : C450001_0.Unsigned_Over_8;
-
-begin -- Main test procedure. C450001
-
- Report.Test ("C450001", "Check that operations on modular types " &
- "perform correctly." );
-
-
- -- the cases for the whole 8 bit type are pretty simple
-
- Whole_8_A := 2#00000000#;
- Whole_8_B := 2#11111111#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00000000#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11111111#,"8 bit xor" & BR);
-
- Whole_8_A := 2#00001111#;
- Whole_8_B := 2#11111111#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00001111#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11110000#,"8 bit xor" & BR);
-
- Whole_8_A := 2#10101010#;
- Whole_8_B := 2#11110000#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#10100000#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111010#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#01011010#,"8 bit xor" & BR);
-
- -- the cases for the partial 8 bit type involve subtracting the modulus
- -- from results that exceed the modulus.
- -- hence, any of the following operations that exceed 2#11111110# must
- -- have 2#11111111# subtracted from the result; i.e. where you would
- -- expect to see 2#11111111# as in the above operations, the correct
- -- result will be 2#00000000#. Note that 2#11111111# is not a legal
- -- value of type C450001_0.Unsigned_Edge_8.
-
- Short_8_A := 2#11100101#;
- Short_8_B := 2#00011111#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000101#,"8 short and 1" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 1" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#11111010#,"8 short xor 1" & BR);
-
- Short_8_A := 2#11110000#;
- Short_8_B := 2#11111110#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#11110000#,"8 short and 2" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 2" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00001110#,"8 short xor 2" & BR);
-
- Short_8_A := 2#10101010#;
- Short_8_B := 2#01010101#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000000#,"8 short and 3" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 3" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00000000#,"8 short xor 3" & BR);
-
- Short_8_A := 2#10101010#;
- Short_8_B := 2#11111110#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#10101010#,"8 short and 4" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 4" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#01010100#,"8 short xor 4" & BR);
-
- -- the cases for the over 8 bit type have similar issues to the short type
- -- however the bit patterns are a little different. The rule is to subtract
- -- the modulus (258) from any resulting value equal or greater than the
- -- modulus -- note that 258 = 2#100000010#
-
- Over_8_A := 2#100000000#;
- Over_8_B := 2#011111111#;
-
- Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000000#,"8 over and" & BR);
- Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR);
- Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111101#,"8 over xor" & BR);
-
- Over_8_A := 2#100000001#;
- Over_8_B := 2#011111111#;
-
- Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000001#,"8 over and" & BR);
- Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR);
- Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111100#,"8 over xor" & BR);
-
-
-
- Whole_8_A := 128;
- Whole_8_B := 255;
-
- Is_T(ID(Whole_8_A) /= ID(Whole_8_B), "8 /=" & BR);
- Is_F(ID(Whole_8_A) = ID(Whole_8_B), "8 =" & BR);
-
- Is_T(ID(Whole_8_A) <= ID(Whole_8_B), "8 <=" & BR);
- Is_T(ID(Whole_8_A) < ID(Whole_8_B), "8 < " & BR);
-
- Is_F(ID(Whole_8_A) >= ID(Whole_8_B), "8 >=" & BR);
- Is_T(ID(Whole_8_A) > ID(Whole_8_B + 7), "8 > " & BR);
-
- Is_T(ID(Whole_8_A) in ID(100)..ID(200), "8 in" & BR);
- Is_F(ID(Whole_8_A) not in ID(100)..ID(200), "8 not in" & BR);
-
- Is_F(ID(Whole_8_A) in ID(200)..ID(250), "8 in" & BR);
- Is_T(ID(Whole_8_A) not in ID(200)..ID(250), "8 not in" & BR);
-
- Short_8_A := 127;
- Short_8_B := 254;
-
- Is_T(ID(Short_8_A) /= ID(Short_8_B), "short 8 /=" & BR);
- Is_F(ID(Short_8_A) = ID(Short_8_B), "short 8 =" & BR);
-
- Is_T(ID(Short_8_A) <= ID(Short_8_B), "short 8 <=" & BR);
- Is_T(ID(Short_8_A) < ID(Short_8_B), "short 8 < " & BR);
-
- Is_F(ID(Short_8_A) >= ID(Short_8_B), "short 8 >=" & BR);
- Is_F(ID(Short_8_A) > ID(Short_8_B), "short 8 > " & BR);
-
- Is_T(ID(Short_8_A) in ID(100)..ID(200), "8 in" & BR);
- Is_F(ID(Short_8_A) not in ID(100)..ID(200), "8 not in" & BR);
-
- Is_F(ID(Short_8_A) in ID(200)..ID(250), "8 in" & BR);
- Is_T(ID(Short_8_A) not in ID(200)..ID(250), "8 not in" & BR);
-
-
- Whole_8_A := 1;
- Whole_8_B := 254;
- Short_8_A := 1;
- Short_8_B := 2;
-
- Whole_8_C := ID(Whole_8_A) + ID(Whole_8_B);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 1" & BR);
-
- Whole_8_C := Whole_8_C + ID(Whole_8_A);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'First, "8 binary + 2" & BR);
-
- Whole_8_C := ID(Whole_8_A) - ID(Whole_8_A);
- Is_T(Whole_8_C = 0, "8 binary -" & BR);
-
- Whole_8_C := Whole_8_C - ID(Whole_8_A);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 3" & BR);
-
- Short_8_C := ID(Short_8_A) + ID(C450001_0.Unsigned_Edge_8'Last);
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'First, "Short binary + 1" & BR);
-
- Short_8_C := Short_8_A + ID(Short_8_A);
- Is_T(Short_8_C = ID(Short_8_B), "Short binary + 2" & BR);
-
- Short_8_C := ID(Short_8_A) - ID(Short_8_A);
- Is_T(Short_8_C = 0, "Short 8 binary -" & BR);
-
- Short_8_C := Short_8_C - ID(Short_8_A);
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short binary + 3" & BR);
-
-
- Whole_8_C := ( + ID(Whole_8_B) );
- Is_T(Whole_8_C = 254, "8 unary +" & BR);
-
- Whole_8_C := ( - ID(Whole_8_A) );
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 unary -" & BR);
-
- Whole_8_C := ( - ID(0) );
- Is_T(Whole_8_C = 0, "8 unary -0" & BR);
-
- Short_8_C := ( + ID(C450001_0.Unsigned_Edge_8'Last) );
- Is_T(Short_8_C = 254, "Short 8 unary +" & BR);
-
- Short_8_C := ( - ID(Short_8_A) );
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short 8 unary -" & BR);
-
-
- Whole_8_A := 20;
- Whole_8_B := 255;
-
- Whole_8_C := ID(Whole_8_A) * ID(Whole_8_B); -- 5100 = 19*256 + 236 (256-20)
- Is_T(Whole_8_C = 236, "8 *" & BR);
-
- Short_8_A := 9;
- Short_8_B := 254;
-
- Short_8_C := ID(Short_8_A) * ID(Short_8_B); -- 2286 = 8*255 + 246 (255-9)
- Is_T(Short_8_C = 246, "short 8 *" & BR);
-
- Over_8_A := 12;
- Over_8_B := 86;
-
- Over_8_C := ID(Over_8_A) * ID(Over_8_B); -- 1032 = 4*258 + 0
- Is_T(Over_8_C = 0, "over 8 *" & BR);
-
-
- Whole_8_A := 255;
- Whole_8_B := 4;
-
- Whole_8_C := ID(Whole_8_A) / ID(Whole_8_B);
- Is_T(Whole_8_C = 63, "8 /" & BR);
-
- Short_8_A := 253;
- Short_8_B := 127;
-
- Short_8_C := ID(Short_8_A) / ID(Short_8_B);
- Is_T(Short_8_C = 1, "short 8 / 1" & BR);
-
- Short_8_C := ID(Short_8_A) / ID(126);
- Is_T(Short_8_C = 2, "short 8 / 2" & BR);
-
-
- Whole_8_A := 255;
- Whole_8_B := 254;
-
- Whole_8_C := ID(Whole_8_A) rem ID(Whole_8_B);
- Is_T(Whole_8_C = 1, "8 rem" & BR);
-
- Short_8_A := 222;
- Short_8_B := 111;
-
- Short_8_C := ID(Short_8_A) rem ID(Short_8_B);
- Is_T(Short_8_C = 0, "short 8 rem" & BR);
-
-
- Whole_8_A := 99;
- Whole_8_B := 9;
-
- Whole_8_C := ID(Whole_8_A) mod ID(Whole_8_B);
- Is_T(Whole_8_C = 0, "8 mod" & BR);
-
- Short_8_A := 254;
- Short_8_B := 250;
-
- Short_8_C := ID(Short_8_A) mod ID(Short_8_B);
- Is_T(Short_8_C = 4, "short 8 mod" & BR);
-
-
- Whole_8_A := 99;
-
- Whole_8_C := abs Whole_8_A;
- Is_T(Whole_8_C = ID(99), "8 abs" & BR);
-
- Short_8_A := 254;
-
- Short_8_C := ID( abs Short_8_A );
- Is_T(Short_8_C = 254, "short 8 abs" & BR);
-
-
- Whole_8_B := 2#00001111#;
-
- Whole_8_C := not Whole_8_B;
- Is_T(Whole_8_C = ID(2#11110000#), "8 not" & BR);
-
- Short_8_B := 2#00001111#; -- 15
-
- Short_8_C := ID( not Short_8_B ); -- 254 - 15
- Is_T(Short_8_C = 2#11101111#, "short 8 not" & BR); -- 239
-
-
- Whole_8_A := 2;
-
- Whole_8_C := Whole_8_A ** 7;
- Is_T(Whole_8_C = ID(128), "2 ** 7, whole 8" & BR);
-
- Whole_8_C := Whole_8_A ** 9;
- Is_T(Whole_8_C = ID(0), "2 ** 9, whole 8" & BR);
-
- Short_8_A := 4;
-
- Short_8_C := ID( Short_8_A ) ** 4;
- Is_T(Short_8_C = 1, "4 ** 4, short" & BR);
-
- Over_8_A := 4;
-
- Over_8_C := ID( Over_8_A ) ** 4;
- Is_T(Over_8_C = 256, "4 ** 4, over" & BR);
-
- Over_8_C := ID( Over_8_A ) ** 5; -- 1024 = 3*258 + 250
- Is_T(Over_8_C = 250, "4 ** 5, over" & BR);
-
-
- C450001_0.Loop_Check;
-
- Report.Result;
-
-end C450001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45112a.ada b/gcc/testsuite/ada/acats/tests/c4/c45112a.ada
deleted file mode 100644
index f18b1be..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45112a.ada
+++ /dev/null
@@ -1,233 +0,0 @@
--- C45112A.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 BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION
--- ARE THE BOUNDS OF THE LEFT OPERAND.
-
--- RJW 2/3/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45112A IS
-
- TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN;
- A1 : ARR(IDENT_INT(3) .. IDENT_INT(4)) := (TRUE, FALSE);
- A2 : ARR(IDENT_INT(1) .. IDENT_INT(2)) := (TRUE, FALSE);
- SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST));
-
- PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS
- BEGIN
- IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN
- FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 );
- END IF;
- END CHECK;
-
-BEGIN
-
- TEST ( "C45112A", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " &
- "ARRAY OPERATIONS" );
-
- BEGIN
- DECLARE
- AAND : CONSTANT ARR := A1 AND A2;
- AOR : CONSTANT ARR := A1 OR A2;
- AXOR : CONSTANT ARR := A1 XOR A2;
- BEGIN
- CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ",
- "'AND'" );
-
- CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ",
- "'OR'" );
-
- CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ",
- "'XOR'" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED DURING " &
- "INTIALIZATIONS" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED DURING " &
- "INITIALIZATIONS" );
- END;
-
- DECLARE
- PROCEDURE PROC (A : ARR; STR : STRING) IS
- BEGIN
- CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY",
- STR);
- END PROC;
- BEGIN
- PROC ((A1 AND A2), "'AND'" );
- PROC ((A1 OR A2), "'OR'" );
- PROC ((A1 XOR A2), "'XOR'" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " &
- "PARAMETERS" );
- END;
-
- DECLARE
- FUNCTION FUNCAND RETURN ARR IS
- BEGIN
- RETURN A1 AND A2;
- END FUNCAND;
-
- FUNCTION FUNCOR RETURN ARR IS
- BEGIN
- RETURN A1 OR A2;
- END FUNCOR;
-
- FUNCTION FUNCXOR RETURN ARR IS
- BEGIN
- RETURN A1 XOR A2;
- END FUNCXOR;
-
- BEGIN
- CHECK (FUNCAND, "RETURN STATEMENT", "'AND'");
- CHECK (FUNCOR, "RETURN STATEMENT", "'OR'");
- CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'");
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " &
- "FROM FUNCTION" );
- END;
-
- BEGIN
- DECLARE
- GENERIC
- X : IN ARR;
- PACKAGE PKG IS
- FUNCTION G RETURN ARR;
- END PKG;
-
- PACKAGE BODY PKG IS
- FUNCTION G RETURN ARR IS
- BEGIN
- RETURN X;
- END G;
- END PKG;
-
- PACKAGE PAND IS NEW PKG(X => A1 AND A2);
- PACKAGE POR IS NEW PKG(X => A1 OR A2);
- PACKAGE PXOR IS NEW PKG(X => A1 XOR A2);
- BEGIN
- CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'");
- CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'");
- CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING GENERIC " &
- "INSTANTIATION" );
- END;
-
- DECLARE
- TYPE ACC IS ACCESS ARR;
- AC : ACC;
-
- BEGIN
- AC := NEW ARR'(A1 AND A2);
- CHECK (AC.ALL, "ALLOCATION", "'AND'");
- AC := NEW ARR'(A1 OR A2);
- CHECK (AC.ALL, "ALLOCATION", "'OR'");
- AC := NEW ARR'(A1 XOR A2);
- CHECK (AC.ALL, "ALLOCATION", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON ALLOCATION" );
- END;
-
- BEGIN
- CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'");
- CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'");
- CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" );
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- RCA : CARR;
- END RECORD;
- R1 : REC;
-
- BEGIN
- R1 := (RCA => (A1 AND A2));
- CHECK (R1.RCA, "AGGREGATE", "'AND'");
- R1 := (RCA => (A1 OR A2));
- CHECK (R1.RCA, "AGGREGATE", "'OR'");
- R1 := (RCA => (A1 XOR A2));
- CHECK (R1.RCA, "AGGREGATE", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON AGGREGATE" );
- END;
-
- BEGIN
- DECLARE
- TYPE RECDEF IS
- RECORD
- RCDF1 : CARR := A1 AND A2;
- RCDF2 : CARR := A1 OR A2;
- RCDF3 : CARR := A1 XOR A2;
- END RECORD;
- RD : RECDEF;
- BEGIN
- CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'");
- CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'");
- CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " &
- "DEFAULT RECORD" );
- END;
-
- DECLARE
- PROCEDURE PDEF (X : CARR := A1 AND A2;
- Y : CARR := A1 OR A2;
- Z : CARR := A1 XOR A2 ) IS
- BEGIN
- CHECK (X, "DEFAULT PARAMETER", "'AND'");
- CHECK (Y, "DEFAULT PARAMETER", "'OR'");
- CHECK (Z, "DEFAULT PARAMETER", "'XOR'");
- END PDEF;
-
- BEGIN
- PDEF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" );
- END;
-
- RESULT;
-
-END C45112A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45112b.ada b/gcc/testsuite/ada/acats/tests/c4/c45112b.ada
deleted file mode 100644
index ef6a7c0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45112b.ada
+++ /dev/null
@@ -1,234 +0,0 @@
--- C45112B.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 BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION
--- ARE THE BOUNDS OF THE LEFT OPERAND WHEN THE OPERANDS ARE NULL
--- ARRAYS.
-
--- RJW 2/3/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45112B IS
-
- TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN;
- A1 : ARR(IDENT_INT(4) .. IDENT_INT(3));
- A2 : ARR(IDENT_INT(2) .. IDENT_INT(1));
- SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST));
-
- PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS
- BEGIN
- IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN
- FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 );
- END IF;
- END CHECK;
-
-BEGIN
-
- TEST ( "C45112B", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " &
- "ARRAY OPERATIONS ON NULL ARRAYS" );
-
- BEGIN
- DECLARE
- AAND : CONSTANT ARR := A1 AND A2;
- AOR : CONSTANT ARR := A1 OR A2;
- AXOR : CONSTANT ARR := A1 XOR A2;
- BEGIN
- CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ",
- "'AND'" );
-
- CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ",
- "'OR'" );
-
- CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ",
- "'XOR'" );
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED DURING " &
- "INTIALIZATIONS" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED DURING " &
- "INITIALIZATIONS" );
- END;
-
- DECLARE
- PROCEDURE PROC (A : ARR; STR : STRING) IS
- BEGIN
- CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY",
- STR);
- END PROC;
- BEGIN
- PROC ((A1 AND A2), "'AND'" );
- PROC ((A1 OR A2), "'OR'" );
- PROC ((A1 XOR A2), "'XOR'" );
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " &
- "PARAMETERS" );
- END;
-
- DECLARE
- FUNCTION FUNCAND RETURN ARR IS
- BEGIN
- RETURN A1 AND A2;
- END FUNCAND;
-
- FUNCTION FUNCOR RETURN ARR IS
- BEGIN
- RETURN A1 OR A2;
- END FUNCOR;
-
- FUNCTION FUNCXOR RETURN ARR IS
- BEGIN
- RETURN A1 XOR A2;
- END FUNCXOR;
-
- BEGIN
- CHECK (FUNCAND, "RETURN STATEMENT", "'AND'");
- CHECK (FUNCOR, "RETURN STATEMENT", "'OR'");
- CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'");
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " &
- "FROM FUNCTION" );
- END;
-
- BEGIN
- DECLARE
- GENERIC
- X : IN ARR;
- PACKAGE PKG IS
- FUNCTION G RETURN ARR;
- END PKG;
-
- PACKAGE BODY PKG IS
- FUNCTION G RETURN ARR IS
- BEGIN
- RETURN X;
- END G;
- END PKG;
-
- PACKAGE PAND IS NEW PKG(X => A1 AND A2);
- PACKAGE POR IS NEW PKG(X => A1 OR A2);
- PACKAGE PXOR IS NEW PKG(X => A1 XOR A2);
- BEGIN
- CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'");
- CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'");
- CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING GENERIC " &
- "INSTANTIATION" );
- END;
-
- DECLARE
- TYPE ACC IS ACCESS ARR;
- AC : ACC;
-
- BEGIN
- AC := NEW ARR'(A1 AND A2);
- CHECK (AC.ALL, "ALLOCATION", "'AND'");
- AC := NEW ARR'(A1 OR A2);
- CHECK (AC.ALL, "ALLOCATION", "'OR'");
- AC := NEW ARR'(A1 XOR A2);
- CHECK (AC.ALL, "ALLOCATION", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON ALLOCATION" );
- END;
-
- BEGIN
- CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'");
- CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'");
- CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" );
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- RCA : CARR;
- END RECORD;
- R1 : REC;
-
- BEGIN
- R1 := (RCA => (A1 AND A2));
- CHECK (R1.RCA, "AGGREGATE", "'AND'");
- R1 := (RCA => (A1 OR A2));
- CHECK (R1.RCA, "AGGREGATE", "'OR'");
- R1 := (RCA => (A1 XOR A2));
- CHECK (R1.RCA, "AGGREGATE", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON AGGREGATE" );
- END;
-
- BEGIN
- DECLARE
- TYPE RECDEF IS
- RECORD
- RCDF1 : CARR := A1 AND A2;
- RCDF2 : CARR := A1 OR A2;
- RCDF3 : CARR := A1 XOR A2;
- END RECORD;
- RD : RECDEF;
- BEGIN
- CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'");
- CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'");
- CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" );
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " &
- "DEFAULT RECORD" );
- END;
-
- DECLARE
- PROCEDURE PDEF (X : CARR := A1 AND A2;
- Y : CARR := A1 OR A2;
- Z : CARR := A1 XOR A2 ) IS
- BEGIN
- CHECK (X, "DEFAULT PARAMETER", "'AND'");
- CHECK (Y, "DEFAULT PARAMETER", "'OR'");
- CHECK (Z, "DEFAULT PARAMETER", "'XOR'");
- END PDEF;
-
- BEGIN
- PDEF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" );
- END;
-
- RESULT;
-
-END C45112B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45113a.ada b/gcc/testsuite/ada/acats/tests/c4/c45113a.ada
deleted file mode 100644
index 14471d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45113a.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- C45113A.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 WHEN THE OPERANDS OF LOGICAL
--- OPERATORS HAVE DIFFERENT LENGTHS.
-
--- RJW 1/15/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45113A IS
-
-BEGIN
-
- TEST( "C45113A" , "CHECK ON LOGICAL OPERATORS WITH " &
- "OPERANDS OF DIFFERENT LENGTHS" );
-
- DECLARE
-
- TYPE ARR IS ARRAY ( INTEGER RANGE <> ) OF BOOLEAN;
-
- A : ARR( IDENT_INT(1) .. IDENT_INT(2) ) := ( TRUE, FALSE );
- B : ARR( IDENT_INT(1) .. IDENT_INT(3) ) := ( TRUE, FALSE,
- TRUE );
-
- BEGIN
-
- BEGIN -- TEST FOR 'AND'.
- IF (A AND B) = B THEN
- FAILED ( "A AND B = B" );
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR 'AND'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'AND'" );
- END;
-
-
- BEGIN -- TEST FOR 'OR'.
- IF (A OR B) = B THEN
- FAILED ( "A OR B = B" );
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR 'OR'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'OR'" );
- END;
-
-
- BEGIN -- TEST FOR 'XOR'.
- IF (A XOR B) = B THEN
- FAILED ( "A XOR B = B" );
- END IF;
- FAILED ( "NO EXCEPTION RAISED FOR 'XOR'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'XOR'" );
- END;
-
- END;
-
- RESULT;
-
-END C45113A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45114b.ada b/gcc/testsuite/ada/acats/tests/c4/c45114b.ada
deleted file mode 100644
index d49b9ed..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45114b.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C45114B.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 LOGICAL OPERATORS ARE DEFINED FOR PACKED BOOLEAN ARRAYS.
-
--- RJW 1/17/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45114B IS
-
-BEGIN
-
- TEST( "C45114B" , "CHECK THAT LOGICAL OPERATORS ARE DEFINED " &
- "FOR PACKED BOOLEAN ARRAYS" );
-
- DECLARE
-
- TYPE ARR IS ARRAY (1 .. 32) OF BOOLEAN;
-
- PRAGMA PACK (ARR);
-
- A : ARR := ( TRUE, TRUE, FALSE, FALSE, OTHERS => TRUE );
- B : ARR := ( TRUE, FALSE, TRUE, FALSE, OTHERS => FALSE );
-
- A_AND_B : ARR := ( TRUE, OTHERS => FALSE );
- A_OR_B : ARR := ARR'( 4 => FALSE, OTHERS => TRUE );
- A_XOR_B : ARR := ARR'( 1|4 => FALSE, OTHERS => TRUE );
- NOT_A : ARR := ARR'( 3|4 => TRUE, OTHERS => FALSE );
-
- BEGIN
-
- IF ( A AND B ) /= A_AND_B THEN
- FAILED ( "'AND' NOT CORRECTLY DEFINED" );
- END IF;
-
- IF ( A OR B ) /= A_OR_B THEN
- FAILED ( "'OR' NOT CORRECTLY DEFINED" );
- END IF;
-
- IF ( A XOR B ) /= A_XOR_B THEN
- FAILED ( "'XOR' NOT CORRECTLY DEFINED" );
- END IF;
-
- IF NOT A /= NOT_A THEN
- FAILED ( "'NOT' NOT CORRECTLY DEFINED" );
- END IF;
-
- END;
-
- RESULT;
-
-END C45114B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c452001.a b/gcc/testsuite/ada/acats/tests/c4/c452001.a
deleted file mode 100644
index ec78cd2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c452001.a
+++ /dev/null
@@ -1,707 +0,0 @@
--- C452001.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:
--- For a type extension, check that predefined equality is defined in
--- terms of the primitive equals operator of the parent type and any
--- tagged components of the extension part.
---
--- For other composite types, check that the primitive equality operator
--- of any matching tagged components is used to determine equality of the
--- enclosing type.
---
--- For private types, check that predefined equality is defined in
--- terms of the user-defined (primitive) operator of the full type if
--- the full type is tagged. The partial view of the type may be
--- tagged or untagged. Check that predefined equality for a private
--- type whose full view is untagged is defined in terms of the
--- predefined equality operator of its full type.
---
--- TEST DESCRIPTION:
--- Tagged types are declared and used as components in several
--- differing composite type declarations, both tagged and untagged.
--- To differentiate between predefined and primitive equality
--- operations, user-defined equality operators are declared for
--- each component type that is to contribute to the equality
--- operator of the composite type that houses it. All user-defined
--- equality operations are designed to yield the opposite result
--- from the predefined operator, given the same component values.
---
--- For cases where primitive equality is to be incorporated into
--- equality for the enclosing composite type, values are assigned
--- to the component type so that user-defined equality will return
--- True. If predefined equality is to be used instead, then the
--- same strategy results in the equality operator returning False.
---
--- When equality for a type incorporates the user-defined equality
--- operator of one of its component types, the resulting operator
--- is considered to be the predefined operator of the composite type.
--- This case is confirmed by defining an tagged component of an
--- untagged composite type, then using the resulting untagged type
--- as a component of another composite type. The user-defined operator
--- for the lowest level should still be called.
---
--- Three cases are set up to test private types:
---
--- Case 1 Case 2 Case 3
--- partial view: tagged untagged untagged
--- full view: tagged tagged untagged
---
--- Types are declared for each of the above cases and user-defined
--- (primitive) operators are declared following the full type
--- declaration of each type (i.e., in the private part).
---
--- Values are assigned into objects of these types using the same
--- strategy outlined above. Cases 1 and 2 should execute the
--- user-defined operator. Case 3 should ignore the user-defined
--- operator and user predefined equality for the type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 15 Nov 95 SAIC Fixed for 2.0.1
--- 04 NOV 96 SAIC Typographical revision
---
---!
-
-package c452001_0 is
-
- type Point is
- record
- X : Integer := 0;
- Y : Integer := 0;
- end record;
-
- type Circle is tagged
- record
- Center : Point;
- Radius : Integer;
- end record;
-
- function "=" (L, R : Circle) return Boolean;
-
- type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White);
-
- type Colored_Circle is new Circle
- with record
- Color : Colors := White;
- end record;
-
- function "=" (L, R : Colored_Circle) return Boolean;
- -- Override predefined equality for this tagged type. Predefined
- -- equality should incorporate user-defined (primitive) equality
- -- from type Circle. See C340001 for a test of that feature.
-
- -- Equality is overridden to ensure that predefined equality
- -- incorporates this user-defined function for
- -- any composite type with Colored_Circle as a component type.
- -- (i.e., the type extension is recognized as a tagged type for
- -- the purpose of defining predefined equality for the composite type).
-
-end C452001_0;
-
-package body c452001_0 is
-
- function "=" (L, R : Circle) return Boolean is
- begin
- return L.Radius = R.Radius; -- circles are same size
- end "=";
-
- function "=" (L, R : Colored_Circle) return Boolean is
- begin
- return Circle(L) = Circle(R);
- end "=";
-
-end C452001_0;
-
-with C452001_0;
-package C452001_1 is
-
- type Planet is tagged record
- Name : String (1..15);
- Representation : C452001_0.Colored_Circle;
- end record;
-
- -- Type Planet will be used to check that predefined equality
- -- for a tagged type with a tagged component incorporates
- -- user-defined equality for the component type.
-
- type TC_Planet is new Planet with null record;
-
- -- A "copy" of Planet. Used to create a type extension. An "="
- -- operator will be defined for this type that should be
- -- incorporated by the type extension.
-
- function "=" (Arg1, Arg2 : in TC_Planet) return Boolean;
-
- type Craters is array (1..3) of C452001_0.Colored_Circle;
-
- -- An array type (untagged) with tagged components
-
- type Moon is new TC_Planet
- with record
- Crater : Craters;
- end record;
-
- -- A tagged record type. Extended component type is untagged,
- -- but its predefined equality operator should incorporate
- -- the user-defined operator of its tagged component type.
-
-end C452001_1;
-
-package body C452001_1 is
-
- function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is
- begin
- return Arg1.Name = Arg2.Name;
- end "=";
-
-end C452001_1;
-
-package C452001_2 is
-
- -- Untagged record types
- -- Equality should not be incorporated
-
- type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager);
- type Spacecraft is record
- Design : Spacecraft_Design;
- Operational : Boolean;
- end record;
-
- function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean;
-
- type Mission is record
- Craft : Spacecraft;
- Launch_Date : Natural;
- end record;
-
- type Inventory is array (Positive range <>) of Spacecraft;
-
-end C452001_2;
-
-package body C452001_2 is
-
- function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is
- begin
- return L.Design = R.Design;
- end "=";
-
-end C452001_2;
-
-package C452001_3 is
-
- type Tagged_Partial_Tagged_Full is tagged private;
- procedure Change (Object : in out Tagged_Partial_Tagged_Full;
- Value : in Boolean);
-
- type Untagged_Partial_Tagged_Full is private;
- procedure Change (Object : in out Untagged_Partial_Tagged_Full;
- Value : in Integer);
-
- type Untagged_Partial_Untagged_Full is private;
- procedure Change (Object : in out Untagged_Partial_Untagged_Full;
- Value : in Duration);
-
-private
-
- type Tagged_Partial_Tagged_Full is
- tagged record
- B : Boolean := True;
- C : Character := ' ';
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean;
- -- primitive equality checks that records equate in component C only
-
- type Untagged_Partial_Tagged_Full is
- tagged record
- I : Integer := 0;
- P : Positive := 1;
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean;
- -- primitive equality checks that records equate in component P only
-
- type Untagged_Partial_Untagged_Full is
- record
- D : Duration := 0.0;
- S : String (1..12) := "Ada 9X rules";
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean;
- -- primitive equality checks that records equate in component S only
-
-end C452001_3;
-
-with Report;
-package body C452001_3 is
-
- procedure Change (Object : in out Tagged_Partial_Tagged_Full;
- Value : in Boolean) is
- begin
- Object := (Report.Ident_Bool(Value), Object.C);
- end Change;
-
- procedure Change (Object : in out Untagged_Partial_Tagged_Full;
- Value : in Integer) is
- begin
- Object := (Report.Ident_Int(Value), Object.P);
- end Change;
-
- procedure Change (Object : in out Untagged_Partial_Untagged_Full;
- Value : in Duration) is
- begin
- Object := (Value, Report.Ident_Str(Object.S));
- end Change;
-
- function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is
- begin
- return L.C = R.C;
- end "=";
-
- function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is
- begin
- return L.P = R.P;
- end "=";
-
- function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is
- begin
- return R.S = L.S;
- end "=";
-
-end C452001_3;
-
-
-with C452001_0;
-with C452001_1;
-with C452001_2;
-with C452001_3;
-with Report;
-procedure C452001 is
-
- Mars_Aphelion : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(20),
- Report.Ident_Int(0)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Red));
-
- Mars_Perihelion : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(-20),
- Report.Ident_Int(0)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Red));
-
- -- Mars_Perihelion = Mars_Aphelion if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the tagged type Planet. User-defined
- -- equality for Colored_Circle checks only that the Radii are equal.
-
- Blue_Mars : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(10)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Blue));
-
- -- Blue_Mars should equal Mars_Perihelion, because Names and
- -- Radii are equal (all other components are not).
-
- Green_Mars : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(10)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Green));
-
- -- Blue_Mars should equal Green_Mars. They differ only in the
- -- Color component. All user-defined equality operations return
- -- True, but records are not equal by predefined equality.
-
- -- Blue_Mars should equal Mars_Perihelion, because Names and
- -- Radii are equal (all other components are not).
-
- Moon_Craters : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black),
- (Center => (Report.Ident_Int(11), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black));
-
- Alternate_Moon_Craters : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Yellow),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Purple),
- (Center => (Report.Ident_Int(11), Report.Ident_Int(11)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Purple));
-
- -- Moon_Craters = Alternate_Moon_Craters if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the untagged type Craters. User-defined
- -- equality checks only that the Radii are equal.
-
- New_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Moon_Craters);
-
- Full_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Alternate_Moon_Craters);
-
- -- New_Moon = Full_Moon if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the untagged type Craters. This
- -- equality test should call user-defined equality for type
- -- TC_Planet (checks that Names are equal), then predefined
- -- equality for Craters (ultimately calls user-defined equality
- -- for type Circle, checking that Radii of craters are equal).
-
- Mars_Moon : C452001_1.Moon :=
- (Name => "Phobos ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Alternate_Moon_Craters);
-
- -- Mars_Moon /= Full_Moon since the Names differ.
-
- Alternate_Moon_Craters_2 : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red),
- (Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red));
-
- Harvest_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(11),
- Report.Ident_Int(7)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Orange),
- Crater => Alternate_Moon_Craters_2);
-
- -- Only the fields that are employed by the user-defined equality
- -- operators are the same. Everything else differs. Equality should
- -- still return True.
-
- Viking_1_Orbiter : C452001_2.Mission :=
- (Craft => (Design => C452001_2.Viking,
- Operational => Report.Ident_Bool(False)),
- Launch_Date => 1975);
-
- Viking_1_Lander : C452001_2.Mission :=
- (Craft => (Design => C452001_2.Viking,
- Operational => Report.Ident_Bool(True)),
- Launch_Date => 1975);
-
- -- Viking_1_Orbiter /= Viking_1_Lander if predefined equality
- -- from the untagged type Spacecraft is used for equality
- -- of matching components in type Mission. If user-defined
- -- equality for type Spacecraft is incorporated, which it
- -- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander.
-
- Voyagers : C452001_2.Inventory (1..2):=
- ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
- (C452001_2.Voyager, Operational => Report.Ident_Bool(False)));
-
- Jupiter_Craft : C452001_2.Inventory (1..2):=
- ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
- (C452001_2.Voyager, Operational => Report.Ident_Bool(True)));
-
- -- Voyagers /= Jupiter_Craft if predefined equality
- -- from the untagged type Spacecraft is used for equality
- -- of matching components in type Inventory. If user-defined
- -- equality for type Spacecraft is incorporated, which it
- -- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft.
-
- TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full;
- TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full;
-
- -- With differing values for Boolean component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is tagged, primitive equality
- -- should be used.
-
- UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full;
- UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full;
-
- -- With differing values for Boolean component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is tagged, primitive equality
- -- should be used.
-
- UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full;
- UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full;
-
- -- With differing values for Duration component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is untagged, predefined equality
- -- should be used.
-
- -- Use type clauses make "=" and "/=" operators directly visible
- use type C452001_1.Planet;
- use type C452001_1.Craters;
- use type C452001_1.Moon;
- use type C452001_2.Mission;
- use type C452001_2.Inventory;
- use type C452001_3.Tagged_Partial_Tagged_Full;
- use type C452001_3.Untagged_Partial_Tagged_Full;
- use type C452001_3.Untagged_Partial_Untagged_Full;
-
-begin
-
- Report.Test ("C452001", "Equality of private types and " &
- "composite types with tagged components");
-
- -------------------------------------------------------------------
- -- Tagged type with tagged component.
- -------------------------------------------------------------------
-
- if not (Mars_Aphelion = Mars_Perihelion) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for enclosing tagged record type");
- end if;
-
- if Mars_Aphelion /= Mars_Perihelion then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for enclosing tagged record type");
- end if;
-
- if not (Blue_Mars = Mars_Perihelion) then
- Report.Failed ("Equality test for tagged record type " &
- "incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Blue_Mars /= Mars_Perihelion then
- Report.Failed ("Inequality test for tagged record type " &
- "incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Blue_Mars /= Green_Mars then
- Report.Failed ("Records are unequal even though they only differ " &
- "in a component not used by user-defined equality");
- end if;
-
- if not (Blue_Mars = Green_Mars) then
- Report.Failed ("Records are not equal even though they only differ " &
- "in a component not used by user-defined equality");
- end if;
-
- -------------------------------------------------------------------
- -- Untagged (array) type with tagged component.
- -------------------------------------------------------------------
-
- if not (Moon_Craters = Alternate_Moon_Craters) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for enclosing array type");
- end if;
-
- if Moon_Craters /= Alternate_Moon_Craters then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for enclosing array type");
- end if;
-
- -------------------------------------------------------------------
- -- Tagged type with untagged composite component. Untagged
- -- component itself has tagged components.
- -------------------------------------------------------------------
- if not (New_Moon = Full_Moon) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for array component of tagged record type");
- end if;
-
- if New_Moon /= Full_Moon then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for array component of tagged record type");
- end if;
-
- if Mars_Moon = Full_Moon then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for array component of tagged record type");
- end if;
-
- if not (Mars_Moon /= Full_Moon) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for array component of tagged record type");
- end if;
-
- if not (Harvest_Moon = Full_Moon) then
- Report.Failed ("Equality test for record with array of tagged " &
- "components incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Harvest_Moon /= Full_Moon then
- Report.Failed ("Inequality test for record with array of tagged " &
- "components incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- -------------------------------------------------------------------
- -- Untagged types with no tagged components.
- -------------------------------------------------------------------
-
- -- Record type
-
- if Viking_1_Orbiter = Viking_1_Lander then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "equality for " &
- "untagged record type");
- end if;
-
- if not (Viking_1_Orbiter /= Viking_1_Lander) then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "inequality for " &
- "untagged record type");
- end if;
-
- -- Array type
-
- if Voyagers = Jupiter_Craft then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "equality for " &
- "array type");
- end if;
-
- if not (Voyagers /= Jupiter_Craft) then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "inequality for " &
- "array type");
- end if;
-
- -------------------------------------------------------------------
- -- Private types tests.
- -------------------------------------------------------------------
-
- -- Make objects differ from one another
-
- C452001_3.Change (TPTF_1, False);
- C452001_3.Change (UPTF_1, 999);
- C452001_3.Change (UPUF_1, 40.0);
-
- -------------------------------------------------------------------
- -- Partial type and full type are tagged. (Full type must be tagged
- -- if partial type is tagged)
- -------------------------------------------------------------------
-
- if not (TPTF_1 = TPTF_2) then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine equality of " &
- "tagged private type " &
- "instead of user-defined (primitive) equality");
- end if;
-
- if TPTF_1 /= TPTF_2 then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine inequality of " &
- "tagged private type " &
- "instead of user-defined (primitive) equality");
- end if;
-
- -------------------------------------------------------------------
- -- Partial type untagged, full type tagged.
- -------------------------------------------------------------------
-
- if not (UPTF_1 = UPTF_2) then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine equality of " &
- "private type (untagged partial view, " &
- "tagged full view) " &
- "instead of user-defined (primitive) equality");
- end if;
-
- if UPTF_1 /= UPTF_2 then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine inequality of " &
- "private type (untagged partial view, " &
- "tagged full view) " &
- "instead of user-defined (primitive) equality");
- end if;
-
- -------------------------------------------------------------------
- -- Partial type and full type are both untagged.
- -------------------------------------------------------------------
-
- if UPUF_1 = UPUF_2 then
- Report.Failed ("User-defined (primitive) equality for full type " &
- "was used to determine equality of " &
- "private type (untagged partial view, " &
- "untagged full view) " &
- "instead of predefined equality");
- end if;
-
- if not (UPUF_1 /= UPUF_2) then
- Report.Failed ("User-defined (primitive) equality for full type " &
- "was used to determine inequality of " &
- "private type (untagged partial view, " &
- "untagged full view) " &
- "instead of predefined equality");
- end if;
-
- -------------------------------------------------------------------
- Report.Result;
-
-end C452001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45201a.ada b/gcc/testsuite/ada/acats/tests/c4/c45201a.ada
deleted file mode 100644
index 5c1970d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45201a.ada
+++ /dev/null
@@ -1,242 +0,0 @@
--- C45201A.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 '=' AND '/=' PRODUCE CORRECT RESULTS ON
--- ENUMERATION-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING
--- DIFFERENT SUBTYPES).
-
--- THIS TEST'S FRAMEWORK IS FROM C45201B.ADA , C45210A.ADA .
-
-
--- RM 20 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45201A IS
-
- USE REPORT;
-
- TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E );
-
- -- S-LIT , P-LIT , NUL , 'R' CORRESPOND
- -- TO 'S' , 'P' , 'M' , 'R' IN C45210A.
-
- SUBTYPE T1 IS T RANGE A..B ;
- SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1
- SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4
- SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2
-
- MVAR : T3 := T'(NUL ) ;
- PVAR : T2 := T'(PLIT) ;
- RVAR : T4 := T'('R' ) ;
- SVAR : T1 := T'(SLIT) ;
-
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
- FUNCTION ITSELF( THE_ARGUMENT : T ) RETURN T IS
- BEGIN
- IF EQUAL(2,2) THEN RETURN THE_ARGUMENT;
- ELSE RETURN A ;
- END IF;
- END ;
-
-
-BEGIN
-
- TEST( "C45201A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" &
- " RESULTS ON ENUMERATION-TYPE LITERALS" ) ;
-
- -- 128 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES,
- -- 2 (4) OPERATORS (2, TWICE): '=' , '/=' , '=' , '/='
- -- (IN THE TABLE: A , B , C , D )
- -- (C45201B.ADA HAD < <= > >= ; REVERSED)
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND,
- -- (IN THE TABLE: VV = ALPHA ,
- -- VL = BETA ,
- -- LV = GAMMA ,
- -- LL = DELTA ) RANDOMIZED
- -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL-
- -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES):
-
- -- RIGHT OPERAND: 'S' 'P' 'M' 'R'
- -- LEFT
- -- OPERAND:
-
- -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA
- -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA
- -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA
- -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA
-
- -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4
- -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.)
-
- -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN
- -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE
- -- ( VV , ALPHA ) FOR BOTH OPERATORS.
-
- -----------------------------------------------------------------
-
- -- PART 1
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- IF T'(SVAR) = T'(SVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(SVAR) /= T'(PLIT) THEN NULL; ELSE BUMP ; END IF;
- IF T'(SLIT) = T'(MVAR) THEN BUMP ; END IF;
- IF T'(SLIT) /= T'('R' ) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'(PLIT) = T'(SLIT) THEN BUMP ; END IF;
- IF T'(PLIT) /= T'(PVAR) THEN BUMP ; END IF;
- IF T'(PVAR) = T'(NUL ) THEN BUMP ; END IF;
- IF T'(PVAR) /= T'(RVAR) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'(MVAR) /= T'(SLIT) THEN NULL; ELSE BUMP ; END IF;
- IF T'(MVAR) = T'(PVAR) THEN BUMP ; END IF;
- IF T'(NUL ) /= T'(NUL ) THEN BUMP ; END IF;
- IF T'(NUL ) = T'(RVAR) THEN BUMP ; END IF;
-
- IF T'('R' ) /= T'(SVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'('R' ) = T'(PLIT) THEN BUMP ; END IF;
- IF T'(RVAR) /= T'(MVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(RVAR) = T'('R' ) THEN NULL; ELSE BUMP ; END IF;
-
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE1" );
- END IF;
-
- -----------------------------------------------------------------
-
- -- PART 2
-
- -- 'BUMP' STILL MEANS 'BUMP THE ERROR COUNT'
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- IF AVAR = BVAR THEN
- IF AVAR /= BVAR THEN BUMP ; END IF;
- END IF;
-
- IF AVAR /= BVAR THEN
- IF AVAR = BVAR THEN BUMP ; END IF;
- END IF;
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE2" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- IF ( AVAR /= BVAR ) /= ( T'POS(AVAR) /= T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- IF ( AVAR = BVAR ) /= ( T'POS(AVAR) = T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- END LOOP;
-
- END LOOP;
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE3" );
- END IF;
-
- ERROR_COUNT := 0 ;
-
- FOR IVAR IN 0..8 LOOP -- 9 VALUES
-
- FOR JVAR IN 0..8 LOOP -- 9 VALUES
-
- IF ( IVAR /= JVAR ) /= ( T'VAL(IVAR) /= T'VAL(JVAR) )THEN
- BUMP ;
- END IF;
-
- IF ( IVAR = JVAR ) /= ( T'VAL(IVAR) = T'VAL(JVAR) )THEN
- BUMP ;
- END IF;
-
- END LOOP;
-
- END LOOP;
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE4" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES (THE DIAGONAL)
-
- IF AVAR = ITSELF(AVAR) THEN NULL; ELSE BUMP; END IF;
- IF AVAR /= ITSELF(AVAR) THEN BUMP; END IF;
-
- END LOOP;
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE5" );
- END IF;
-
-
- -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S'
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- IF AVAR /= BVAR THEN BUMP ; END IF; -- COUNT +:= 72
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 72 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE6" );
- END IF;
-
-
- RESULT;
-
-END C45201A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45201b.ada b/gcc/testsuite/ada/acats/tests/c4/c45201b.ada
deleted file mode 100644
index 7c64c8b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45201b.ada
+++ /dev/null
@@ -1,236 +0,0 @@
--- C45201B.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 ORDERING OF ENUMERATION LITERALS AS DEFINED BY THE
--- ORDERING OPERATORS IS THE SAME AS THE ORDER OF OCCURRENCE OF THE
--- LITERALS IN THE TYPE DEFINITION.
-
--- THIS TEST IS DERIVED FROM C45210A.ADA .
-
-
--- RM 17 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45201B IS
-
- USE REPORT;
-
- TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E );
-
- -- S-LIT , P-LIT , NUL , 'R' CORRESPOND
- -- TO 'S' , 'P' , 'M' , 'R' IN C45210A.
-
- SUBTYPE T1 IS T RANGE A..B ;
- SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1
- SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4
- SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2
-
- MVAR : T3 := T'(NUL ) ;
- PVAR : T2 := T'(PLIT) ;
- RVAR : T4 := T'('R' ) ;
- SVAR : T1 := T'(SLIT) ;
-
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
-
-BEGIN
-
- TEST( "C45201B","CHECK THAT THE ORDERING OF ENUMERATION LITERALS "&
- " AS DEFINED BY THE ORDERING OPERATORS" &
- " IS THE SAME AS THE ORDER OF OCCURRENCE OF THE " &
- " LITERALS IN THE TYPE DEFINITION" ) ;
-
- -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES,
- -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>='
- -- (IN THE TABLE: A , B , C , D )
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND,
- -- (IN THE TABLE: VV = ALPHA ,
- -- VL = BETA ,
- -- LV = GAMMA ,
- -- LL = DELTA ) RANDOMIZED
- -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL-
- -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES):
-
- -- RIGHT OPERAND: 'S' 'P' 'M' 'R'
- -- LEFT
- -- OPERAND:
-
- -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA
- -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA
- -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA
- -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA
-
- -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4
- -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.)
-
- -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN
- -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE
- -- ( VV , ALPHA ) FOR ALL 4 OPERATORS.
-
- -----------------------------------------------------------------
-
- -- PART 1
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF;
- IF T'(SVAR) <= T'(PLIT) THEN NULL; ELSE BUMP ; END IF;
- IF T'(SLIT) > T'(MVAR) THEN BUMP ; END IF;
- IF T'(SLIT) >= T'('R' ) THEN BUMP ; END IF;
-
- IF T'(PLIT) > T'(SLIT) THEN NULL; ELSE BUMP ; END IF;
- IF T'(PLIT) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(PVAR) < T'(NUL ) THEN NULL; ELSE BUMP ; END IF;
- IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'(MVAR) >= T'(SLIT) THEN NULL; ELSE BUMP ; END IF;
- IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(NUL ) <= T'(NUL ) THEN NULL; ELSE BUMP ; END IF;
- IF T'(NUL ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF;
- IF T'('R' ) < T'(PLIT) THEN BUMP ; END IF;
- IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF;
-
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE1" );
- END IF;
-
- -----------------------------------------------------------------
-
- -- PART 2
-
- -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S'
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES
-
- IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 6
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 6 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE2" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES
-
- IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 10
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /=10 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE3" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES
-
- IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 26
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /=26 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE4" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
- FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES
-
- IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 30
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /=30 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE5" );
- END IF;
-
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' (AGAIN)
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES
-
- IF ( AVAR < BVAR ) /= ( T'POS(AVAR) < T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- IF ( AVAR <= BVAR ) /= ( T'POS(AVAR) <= T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- IF ( AVAR > BVAR ) /= ( T'POS(AVAR) > T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- IF ( AVAR >= BVAR ) /= ( T'POS(AVAR) >= T'POS(BVAR) )THEN
- BUMP ;
- END IF;
-
- END LOOP;
-
- END LOOP;
-
-
- IF ERROR_COUNT /= 0 THEN -- REAL ERROR COUNT AGAIN
- FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE6" );
- END IF;
-
-
- RESULT;
-
-END C45201B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45202b.ada b/gcc/testsuite/ada/acats/tests/c4/c45202b.ada
deleted file mode 100644
index bf2a02f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45202b.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C45202B.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 MEMBERSHIP OPERATIONS IN THE CASE IN WHICH A USER HAS
--- REDEFINED THE ORDERING OPERATORS.
-
--- RJW 1/22/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45202B IS
-
-
-BEGIN
-
- TEST( "C45202B" , "CHECK MEMBERSHIP OPERATIONS IN WHICH A USER " &
- "HAS REDEFINED THE ORDERING OPERATORS" ) ;
-
-
- DECLARE
-
- TYPE T IS ( AA, BB, CC, LIT, XX, YY, ZZ );
- SUBTYPE ST IS T RANGE AA .. LIT;
-
- VAR : T := LIT ;
- CON : CONSTANT T := LIT ;
-
- FUNCTION ">" ( L, R : T ) RETURN BOOLEAN IS
- BEGIN
- RETURN T'POS(L) <= T'POS(R);
- END;
-
- FUNCTION ">=" ( L, R : T ) RETURN BOOLEAN IS
- BEGIN
- RETURN T'POS(L) < T'POS(R);
- END;
-
- FUNCTION "<" ( L, R : T ) RETURN BOOLEAN IS
- BEGIN
- RETURN T'POS(L) >= T'POS(R);
- END;
-
- FUNCTION "<=" ( L, R : T ) RETURN BOOLEAN IS
- BEGIN
- RETURN T'POS(L) > T'POS(R);
- END;
-
-
- BEGIN
-
- IF LIT NOT IN ST OR
- VAR NOT IN ST OR
- CON NOT IN ST OR
- NOT (VAR IN ST) OR
- XX IN ST OR
- NOT (XX NOT IN ST)
- THEN
- FAILED( "WRONG VALUES FOR 'IN ST'" );
- END IF;
-
- IF LIT IN AA ..CC OR
- VAR NOT IN LIT..ZZ OR
- CON IN ZZ ..AA OR
- NOT (CC IN CC .. YY) OR
- NOT (BB NOT IN CC .. YY)
- THEN
- FAILED( "WRONG VALUES FOR 'IN AA..CC'" );
- END IF;
-
- END;
-
- RESULT;
-
-END C45202B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45210a.ada b/gcc/testsuite/ada/acats/tests/c4/c45210a.ada
deleted file mode 100644
index e7461aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45210a.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C45210A.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 ENUMERATION IMPOSING AN "UNNATURAL" ORDER ON ALPHABETIC
--- CHARACTERS CORRECTLY EVALUATES THE ORDERING OPERATORS.
-
-
--- RM 15 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45210A IS
-
- USE REPORT;
-
- TYPE T IS ( 'S' , 'P' , 'M' , 'R' );
-
- MVAR : T := T'('M') ;
- PVAR : T := T'('P') ;
- RVAR : T := T'('R') ;
- SVAR : T := T'('S') ;
-
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT +1 ;
- END BUMP ;
-
-
-BEGIN
-
- TEST( "C45210A" , "CHECK THAT AN ENUMERATION IMPOSING" &
- " AN ""UNNATURAL"" ORDER ON ALPHABETIC" &
- " CHARACTERS CORRECTLY EVALUATES THE " &
- " ORDERING OPERATORS" ) ;
-
- -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES,
- -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>='
- -- (IN THE TABLE: A , B , C , D )
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND,
- -- (IN THE TABLE: VV = ALPHA ,
- -- VL = BETA ,
- -- LV = GAMMA ,
- -- LL = DELTA ) RANDOMIZED
- -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL-
- -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES):
-
- -- RIGHT OPERAND: 'S' 'P' 'M' 'R'
- -- LEFT
- -- OPERAND:
-
- -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA
- -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA
- -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA
- -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA
-
- -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4
- -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.)
-
- -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN
- -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE
- -- ( VV , ALPHA ) FOR ALL 4 OPERATORS.
-
- -----------------------------------------------------------------
-
- -- PART 1
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF;
- IF T'(SVAR) <= T'('P' ) THEN NULL; ELSE BUMP ; END IF;
- IF T'('S' ) > T'(MVAR) THEN BUMP ; END IF;
- IF T'('S' ) >= T'('R' ) THEN BUMP ; END IF;
-
- IF T'('P' ) > T'('S' ) THEN NULL; ELSE BUMP ; END IF;
- IF T'('P' ) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(PVAR) < T'('M' ) THEN NULL; ELSE BUMP ; END IF;
- IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'(MVAR) >= T'('S' ) THEN NULL; ELSE BUMP ; END IF;
- IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'('M' ) <= T'('M' ) THEN NULL; ELSE BUMP ; END IF;
- IF T'('M' ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF;
-
- IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF;
- IF T'('R' ) < T'('P' ) THEN BUMP ; END IF;
- IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF;
- IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF;
-
-
- IF ERROR_COUNT /= 0 THEN
- FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE1" );
- END IF;
-
- -----------------------------------------------------------------
-
- -- PART 2
-
- -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S'
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES
- FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES
-
- IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 1
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 1 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE2" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES
- FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES
-
- IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 3
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 3 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE3" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES
- FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES
-
- IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 5
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 5 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE4" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES
- FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES
-
- IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 7
-
- END LOOP;
- END LOOP;
-
- IF ERROR_COUNT /= 7 THEN -- THIS IS A PLAIN COUNT, NOT AN
- -- ERROR COUNT
- FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE5" );
- END IF;
-
-
- RESULT;
-
-END C45210A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45211a.ada b/gcc/testsuite/ada/acats/tests/c4/c45211a.ada
deleted file mode 100644
index 8d73d77..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45211a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- C45211A.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 MEMBERSHIP TESTS FOR AN 'UNNATURAL' ORDERING OF CHARACTER
--- LITERALS.
-
--- RJW 1/22/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45211A IS
-
- TYPE T IS ( 'S' , 'Q' , 'P' , 'M' , 'R' );
- SUBTYPE ST IS T RANGE 'P' .. 'R';
-
- MVAR : T := T'('M') ;
- QVAR : T := T'('Q') ;
- MCON : CONSTANT T := T'('M');
- QCON : CONSTANT T := T'('Q');
-
-BEGIN
-
- TEST( "C45211A" , "CHECK MEMBERSHIP TESTS FOR AN 'UNNATURAL' " &
- "ORDERING OF CHARACTER LITERALS" ) ;
-
- IF QVAR IN T'('P') .. T'('R') OR
- 'Q' IN ST
- THEN
- FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 1" );
- END IF;
-
- IF MVAR NOT IN T'('P') .. T'('R') OR
- 'M' NOT IN ST
- THEN
- FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 2" );
- END IF;
-
- IF QCON IN T'('P') .. T'('R') OR
- MCON NOT IN ST
- THEN
- FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 3" );
- END IF;
-
- RESULT;
-
-END C45211A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220a.ada b/gcc/testsuite/ada/acats/tests/c4/c45220a.ada
deleted file mode 100644
index 382ccbb..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220a.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C45220A.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 '=' AND '/=' PRODUCE CORRECT RESULTS ON
--- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING
--- DIFFERENT SUBTYPES).
-
--- THIS TEST IS DERIVED FROM C45201A.ADA .
-
-
--- RM 27 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45220A IS
-
-
- USE REPORT;
-
- SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ;
- SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ;
- SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ;
- SUBTYPE T4 IS T3 RANGE TRUE..TRUE ;
-
- FVAR1 : T1 := FALSE ;
- TVAR1 : T2 := TRUE ;
- FVAR2 : T3 := FALSE ;
- TVAR2 : T4 := TRUE ;
-
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
-
-BEGIN
-
-
- TEST( "C45220A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" &
- " RESULTS ON BOOLEAN-TYPE OPERANDS" ) ;
-
- -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES,
- -- 2 OPERATORS : '=' , '/=' ,
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND.
-
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- FVAR1 := IDENT_BOOL( FALSE ) ;
- TVAR1 := IDENT_BOOL( TRUE ) ;
- FVAR2 := IDENT_BOOL( FALSE ) ;
- TVAR2 := IDENT_BOOL( TRUE ) ;
-
- IF FALSE = FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 = FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE = FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF FALSE = TRUE THEN BUMP ; END IF;
- IF FVAR1 = TRUE THEN BUMP ; END IF;
- IF FALSE = TVAR2 THEN BUMP ; END IF;
- IF FVAR2 = TVAR1 THEN BUMP ; END IF;
-
- IF TRUE = FALSE THEN BUMP ; END IF;
- IF TRUE = FVAR1 THEN BUMP ; END IF;
- IF TVAR2 = FALSE THEN BUMP ; END IF;
- IF TVAR1 = FVAR2 THEN BUMP ; END IF;
-
- IF TRUE = TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 = TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE = TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
-
- IF FALSE /= FALSE THEN BUMP ; END IF;
- IF FVAR1 /= FALSE THEN BUMP ; END IF;
- IF FALSE /= FVAR2 THEN BUMP ; END IF;
- IF FVAR2 /= FVAR1 THEN BUMP ; END IF;
-
- IF FALSE /= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 /= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE /= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE /= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE /= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 /= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE /= TRUE THEN BUMP ; END IF;
- IF TVAR1 /= TRUE THEN BUMP ; END IF;
- IF TRUE /= TVAR2 THEN BUMP ; END IF;
- IF TVAR2 /= TVAR1 THEN BUMP ; END IF;
-
-
- IF ERROR_COUNT /=0 THEN
- FAILED( "(IN)EQUALITY OF BOOLEAN VALUES - FAILURE1" );
- END IF;
-
-
- RESULT ;
-
-
-END C45220A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220b.ada b/gcc/testsuite/ada/acats/tests/c4/c45220b.ada
deleted file mode 100644
index 87ba734..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220b.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C45220B.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 '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON
--- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING
--- DIFFERENT SUBTYPES).
-
--- THIS TEST IS DERIVED FROM C45220A.ADA .
-
-
--- RM 28 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45220B IS
-
-
- USE REPORT;
-
- SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ;
- SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ;
- SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ;
- SUBTYPE T4 IS T3 RANGE TRUE..TRUE ;
-
- FVAR1 : T1 := FALSE ;
- TVAR1 : T2 := TRUE ;
- FVAR2 : T3 := FALSE ;
- TVAR2 : T4 := TRUE ;
-
- ERROR_COUNT : INTEGER := 0 ;
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
-
-BEGIN
-
-
- TEST( "C45220B" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" &
- " CORRECT RESULTS ON BOOLEAN-TYPE OPERANDS" ) ;
-
- -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES,
- -- 4 OPERATORS : '<' , <=' , '>' , '>='
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND.
-
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- FVAR1 := IDENT_BOOL( FALSE ) ;
- TVAR1 := IDENT_BOOL( TRUE ) ;
- FVAR2 := IDENT_BOOL( FALSE ) ;
- TVAR2 := IDENT_BOOL( TRUE ) ;
-
-
- ERROR_COUNT := 0 ;
-
- IF FALSE < FALSE THEN BUMP ; END IF;
- IF FVAR1 < FALSE THEN BUMP ; END IF;
- IF FALSE < FVAR2 THEN BUMP ; END IF;
- IF FVAR2 < FVAR1 THEN BUMP ; END IF;
-
- IF FALSE < TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 < TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE < TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE < FALSE THEN BUMP ; END IF;
- IF TRUE < FVAR1 THEN BUMP ; END IF;
- IF TVAR2 < FALSE THEN BUMP ; END IF;
- IF TVAR1 < FVAR2 THEN BUMP ; END IF;
-
- IF TRUE < TRUE THEN BUMP ; END IF;
- IF TVAR1 < TRUE THEN BUMP ; END IF;
- IF TRUE < TVAR2 THEN BUMP ; END IF;
- IF TVAR2 < TVAR1 THEN BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<'" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF FALSE <= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 <= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE <= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF FALSE <= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE <= FALSE THEN BUMP ; END IF;
- IF TRUE <= FVAR1 THEN BUMP ; END IF;
- IF TVAR2 <= FALSE THEN BUMP ; END IF;
- IF TVAR1 <= FVAR2 THEN BUMP ; END IF;
-
- IF TRUE <= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<='" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF FALSE > FALSE THEN BUMP ; END IF;
- IF FVAR1 > FALSE THEN BUMP ; END IF;
- IF FALSE > FVAR2 THEN BUMP ; END IF;
- IF FVAR2 > FVAR1 THEN BUMP ; END IF;
-
- IF FALSE > TRUE THEN BUMP ; END IF;
- IF FVAR1 > TRUE THEN BUMP ; END IF;
- IF FALSE > TVAR2 THEN BUMP ; END IF;
- IF FVAR2 > TVAR1 THEN BUMP ; END IF;
-
- IF TRUE > FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE > FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 > FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE > TRUE THEN BUMP ; END IF;
- IF TVAR1 > TRUE THEN BUMP ; END IF;
- IF TRUE > TVAR2 THEN BUMP ; END IF;
- IF TVAR2 > TVAR1 THEN BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>'" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF FALSE >= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 >= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF FALSE >= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF FALSE >= TRUE THEN BUMP ; END IF;
- IF FVAR1 >= TRUE THEN BUMP ; END IF;
- IF FALSE >= TVAR2 THEN BUMP ; END IF;
- IF FVAR2 >= TVAR1 THEN BUMP ; END IF;
-
- IF TRUE >= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE >= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 >= FALSE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF TRUE >= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 >= TRUE THEN NULL ; ELSE BUMP ; END IF;
- IF TRUE >= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>='" );
- END IF;
-
-
- RESULT ;
-
-
-END C45220B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220c.ada b/gcc/testsuite/ada/acats/tests/c4/c45220c.ada
deleted file mode 100644
index cb505f2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220c.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- C45220C.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 '=' AND '/=' PRODUCE CORRECT RESULTS ON
--- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN'
--- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES).
-
--- THIS TEST IS DERIVED FROM C45220A.ADA .
-
-
--- RM 27 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-
-WITH REPORT ;
-PROCEDURE C45220C IS
-
-
- USE REPORT;
-
- TYPE NB IS NEW BOOLEAN ;
-
- SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ;
- SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE );
- SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE );
- SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE );
-
- FVAR1 : T1 := NB'(FALSE) ;
- TVAR1 : T2 := NB'(TRUE );
- FVAR2 : T3 := NB'(FALSE) ;
- TVAR2 : T4 := NB'(TRUE );
-
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
- FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS
- BEGIN
- IF EQUAL(2,2) THEN RETURN THE_ARGUMENT;
- ELSE RETURN NB'(FALSE) ;
- END IF;
- END ;
-
-
-BEGIN
-
-
- TEST( "C45220C" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" &
- " RESULTS ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ;
-
- -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES,
- -- 2 OPERATORS : '=' , '/=' ,
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND.
-
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ;
- TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ;
- FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ;
- TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ;
-
- IF NB'(FALSE) = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) = FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(FALSE) = NB'(TRUE ) THEN BUMP ; END IF;
- IF FVAR1 = NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(FALSE) = TVAR2 THEN BUMP ; END IF;
- IF FVAR2 = TVAR1 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) = NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(TRUE ) = FVAR1 THEN BUMP ; END IF;
- IF TVAR2 = NB'(FALSE) THEN BUMP ; END IF;
- IF TVAR1 = FVAR2 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) = TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
-
- IF NB'(FALSE) /= NB'(FALSE) THEN BUMP ; END IF;
- IF FVAR1 /= NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(FALSE) /= FVAR2 THEN BUMP ; END IF;
- IF FVAR2 /= FVAR1 THEN BUMP ; END IF;
-
- IF NB'(FALSE) /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) /= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) /= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) /= NB'(TRUE ) THEN BUMP ; END IF;
- IF TVAR1 /= NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(TRUE ) /= TVAR2 THEN BUMP ; END IF;
- IF TVAR2 /= TVAR1 THEN BUMP ; END IF;
-
-
- IF ERROR_COUNT /=0 THEN
- FAILED( "(IN)EQUALITY OF N_BOOLEAN VALUES - FAILURE1" );
- END IF;
-
-
- RESULT ;
-
-
-END C45220C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220d.ada b/gcc/testsuite/ada/acats/tests/c4/c45220d.ada
deleted file mode 100644
index 752d1fc..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220d.ada
+++ /dev/null
@@ -1,200 +0,0 @@
--- C45220D.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 '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON
--- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN'
--- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES).
-
--- THIS TEST IS DERIVED FROM C45220B.ADA , C45220C.ADA .
-
-
--- RM 28 OCTOBER 1980
--- JWC 7/8/85 RENAMED TO -AB
-
-WITH REPORT ;
-PROCEDURE C45220D IS
-
-
- USE REPORT;
-
- TYPE NB IS NEW BOOLEAN ;
-
- SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ;
- SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE );
- SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE );
- SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE );
-
- FVAR1 : T1 := NB'(FALSE) ;
- TVAR1 : T2 := NB'(TRUE );
- FVAR2 : T3 := NB'(FALSE) ;
- TVAR2 : T4 := NB'(TRUE );
-
- ERROR_COUNT : INTEGER := 0 ;
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
- FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS
- BEGIN
- IF EQUAL(2,2) THEN RETURN THE_ARGUMENT;
- ELSE RETURN NB'(FALSE) ;
- END IF;
- END ;
-
-
-BEGIN
-
-
- TEST( "C45220D" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" &
- " CORRECT RESULTS ON DERIVED-BOOLEAN-TYPE" &
- " OPERANDS" ) ;
-
- -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES,
- -- 4 OPERATORS : '<' , <=' , '>' , '>='
- -- 4 VARIABLE/LITERAL FOR LEFT OPERAND,
- -- VARIABLE/LITERAL FOR RIGHT OPERAND.
-
-
- -- 'BUMP' MEANS 'BUMP THE ERROR COUNT'
-
- FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ;
- TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ;
- FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ;
- TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ;
-
-
- ERROR_COUNT := 0 ;
-
- IF NB'(FALSE) < NB'(FALSE) THEN BUMP ; END IF;
- IF FVAR1 < NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(FALSE) < FVAR2 THEN BUMP ; END IF;
- IF FVAR2 < FVAR1 THEN BUMP ; END IF;
-
- IF NB'(FALSE) < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) < TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) < NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(TRUE ) < FVAR1 THEN BUMP ; END IF;
- IF TVAR2 < NB'(FALSE) THEN BUMP ; END IF;
- IF TVAR1 < FVAR2 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) < NB'(TRUE ) THEN BUMP ; END IF;
- IF TVAR1 < NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(TRUE ) < TVAR2 THEN BUMP ; END IF;
- IF TVAR2 < TVAR1 THEN BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<'" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF NB'(FALSE) <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) <= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(FALSE) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) <= NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(TRUE ) <= FVAR1 THEN BUMP ; END IF;
- IF TVAR2 <= NB'(FALSE) THEN BUMP ; END IF;
- IF TVAR1 <= FVAR2 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<='" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF NB'(FALSE) > NB'(FALSE) THEN BUMP ; END IF;
- IF FVAR1 > NB'(FALSE) THEN BUMP ; END IF;
- IF NB'(FALSE) > FVAR2 THEN BUMP ; END IF;
- IF FVAR2 > FVAR1 THEN BUMP ; END IF;
-
- IF NB'(FALSE) > NB'(TRUE ) THEN BUMP ; END IF;
- IF FVAR1 > NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(FALSE) > TVAR2 THEN BUMP ; END IF;
- IF FVAR2 > TVAR1 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) > FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) > NB'(TRUE ) THEN BUMP ; END IF;
- IF TVAR1 > NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(TRUE ) > TVAR2 THEN BUMP ; END IF;
- IF TVAR2 > TVAR1 THEN BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>'" );
- END IF;
-
-
- ERROR_COUNT := 0 ;
-
- IF NB'(FALSE) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR1 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(FALSE) >= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(FALSE) >= NB'(TRUE ) THEN BUMP ; END IF;
- IF FVAR1 >= NB'(TRUE ) THEN BUMP ; END IF;
- IF NB'(FALSE) >= TVAR2 THEN BUMP ; END IF;
- IF FVAR2 >= TVAR1 THEN BUMP ; END IF;
-
- IF NB'(TRUE ) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) >= FVAR1 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF;
-
- IF NB'(TRUE ) >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR1 >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF;
- IF NB'(TRUE ) >= TVAR2 THEN NULL ; ELSE BUMP ; END IF;
- IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF;
-
- IF ERROR_COUNT > 0 THEN
- FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>='" );
- END IF;
-
-
- RESULT ;
-
-
-END C45220D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220e.ada b/gcc/testsuite/ada/acats/tests/c4/c45220e.ada
deleted file mode 100644
index 0fbf5bf..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220e.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C45220E.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 PROPER OPERATION OF THE MEMBERSHIP OPERATORS 'IN' AND
--- 'NOT IN' FOR BOOLEAN TYPES.
-
-
--- RM 03/20/81
--- SPS 10/26/82
-
-
-WITH REPORT;
-PROCEDURE C45220E IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C45220E" , "CHECK THE PROPER OPERATION OF THE MEMBERSHIP" &
- " OPERATORS 'IN' AND 'NOT IN' FOR" &
- " BOOLEAN TYPES" );
-
- DECLARE
-
- SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE..TRUE ;
-
- VAR : BOOLEAN := FALSE ;
- CON : CONSTANT BOOLEAN := FALSE ;
-
- BEGIN
-
- IF TRUE NOT IN SUBBOOL OR
- VAR NOT IN SUBBOOL OR
- CON NOT IN SUBBOOL
- THEN
- FAILED( "WRONG VALUES FOR 'IN SUBBOOL'" );
- END IF;
-
- IF FALSE IN TRUE..FALSE OR
- VAR NOT IN FALSE..TRUE OR
- CON IN TRUE..TRUE
- THEN
- FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" );
- END IF;
-
-
- RESULT ;
-
-
- END ;
-
-
-END C45220E ;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220f.ada b/gcc/testsuite/ada/acats/tests/c4/c45220f.ada
deleted file mode 100644
index 3d557d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45220f.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- C45220F.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 MEMBERSHIP OPERATIONS WORK CORRECTLY FOR DERIVED
--- BOOLEAN TYPES.
-
--- GLH 08/01/85
-
-WITH REPORT;
-PROCEDURE C45220F IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C45220F" , "CHECK MEMBERSHIP OPERATIONS FOR " &
- "DERIVED BOOLEAN");
-
- DECLARE
-
- TYPE NEWBOOL IS NEW BOOLEAN;
-
- VAR : NEWBOOL := FALSE ;
- CON : CONSTANT NEWBOOL := FALSE ;
-
- BEGIN
-
- IF TRUE NOT IN NEWBOOL OR
- VAR NOT IN NEWBOOL OR
- CON NOT IN NEWBOOL
- THEN
- FAILED( "WRONG VALUES FOR 'IN NEWBOOL'" );
- END IF;
-
- IF NEWBOOL'(FALSE) IN TRUE..FALSE OR
- VAR NOT IN FALSE..TRUE OR
- CON IN TRUE..TRUE
- THEN
- FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" );
- END IF;
-
- RESULT ;
-
- END ;
-
-END C45220F ;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231a.ada b/gcc/testsuite/ada/acats/tests/c4/c45231a.ada
deleted file mode 100644
index d5fce67..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45231a.ada
+++ /dev/null
@@ -1,252 +0,0 @@
--- C45231A.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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT
--- RESULTS FOR PREDEFINED TYPE INTEGER (INCLUDING THE CASE IN WHICH THE
--- RELATIONAL OPERATORS ARE REDEFINED).
-
--- SUBTESTS ARE:
--- (A). TESTS FOR RELATIONAL OPERATORS.
--- (B). TESTS FOR MEMBERSHIP OPERATORS.
--- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE
--- RELATIONAL OPERATORS ARE REDEFINED.
-
-
--- RJW 2/4/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45231A IS
-
-
-BEGIN
-
- TEST ( "C45231A", "CHECK THAT THE RELATIONAL AND " &
- "MEMBERSHIP OPERATIONS YIELD CORRECT " &
- "RESULTS FOR PREDEFINED TYPE INTEGER " &
- "(INCLUDING THE CASE IN WHICH THE " &
- "RELATIONAL OPERATORS ARE REDEFINED)" );
-
- DECLARE -- (A)
-
- I1A, I1B : INTEGER := IDENT_INT (1);
- I2 : INTEGER := IDENT_INT (2);
- CI2 : CONSTANT INTEGER := 2;
-
-
- BEGIN -- (A)
-
- IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 1" );
- END IF;
-
- IF (I2 /= 4) AND (NOT (I2 = 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 2" );
- END IF;
-
- IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 3" );
- END IF;
-
- IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 4");
- END IF;
-
- IF (I2 <= 4) AND (NOT (I2 > 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 5" );
- END IF;
-
- IF (I1A >= I1B) AND (I1A <= I1B) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 6" );
- END IF;
-
- IF ">" (LEFT => CI2, RIGHT => I1A) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 7" );
- END IF;
-
- IF "<" (LEFT => I1A, RIGHT => I2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 8" );
- END IF;
-
- IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 9 ");
- END IF;
-
- IF "<=" (LEFT => I1A, RIGHT => CI2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 10 ");
- END IF;
-
- IF "=" (LEFT => I1A, RIGHT => I1B ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 11 ");
- END IF;
-
- IF "/=" (LEFT => CI2, RIGHT => 4) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 12 ");
- END IF;
-
- END; -- (A)
-
- ----------------------------------------------------------------
-
- DECLARE -- (B)
-
- SUBTYPE ST IS INTEGER RANGE -10 .. 10;
-
- I1 : INTEGER := IDENT_INT (1);
- I5 : INTEGER := IDENT_INT (5);
-
- CI2 : CONSTANT INTEGER := 2;
- CI10 : CONSTANT INTEGER := 10;
-
-
- BEGIN -- (B)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.1" );
- END IF;
-
- IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST)
- THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.5" );
- END IF;
-
- END; -- (B)
-
- -------------------------------------------------------------
-
- DECLARE -- (C)
-
- SUBTYPE ST IS INTEGER RANGE -10 .. 10;
-
- I1 : INTEGER := IDENT_INT (1);
- I5 : INTEGER := IDENT_INT (5);
-
- CI2 : CONSTANT INTEGER := 2;
- CI10 : CONSTANT INTEGER := 10;
-
-
- FUNCTION ">" ( L, R : INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN INTEGER'POS (L) <= INTEGER'POS (R);
- END;
-
- FUNCTION ">=" ( L, R : INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN INTEGER'POS (L) < INTEGER'POS (R);
- END;
-
- FUNCTION "<" ( L, R : INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN INTEGER'POS (L) >= INTEGER'POS (R);
- END;
-
- FUNCTION "<=" ( L, R : INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN INTEGER'POS (L) > INTEGER'POS (R);
- END;
-
- BEGIN -- (C)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.1" );
- END IF;
-
- IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST)
- THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.5" );
- END IF;
-
- END; -- (C)
-
- RESULT;
-
-END C45231A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231b.dep b/gcc/testsuite/ada/acats/tests/c4/c45231b.dep
deleted file mode 100644
index ba5fecf..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45231b.dep
+++ /dev/null
@@ -1,265 +0,0 @@
--- C45231B.DEP
-
--- 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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD
--- CORRECT RESULTS FOR PREDEFINED TYPE SHORT_INTEGER (INCLUDING
--- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED).
-
--- SUBTESTS ARE:
--- (A). TESTS FOR RELATIONAL OPERATORS.
--- (B). TESTS FOR MEMBERSHIP OPERATORS.
--- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE
--- RELATIONAL OPERATORS ARE REDEFINED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH
--- SUPPORT SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 02/04/86 CREATED ORIGINAL TEST.
--- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45231B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ( "C45231B", "CHECK THAT THE RELATIONAL AND " &
- "MEMBERSHIP OPERATIONS YIELD CORRECT " &
- "RESULTS FOR PREDEFINED TYPE SHORT_INTEGER " &
- "(INCLUDING THE CASE IN WHICH THE " &
- "RELATIONAL OPERATORS ARE REDEFINED)" );
-
- DECLARE -- (A)
-
- I1A, I1B : SHORT_INTEGER := IDENT (1);
- I2 : SHORT_INTEGER := IDENT (2);
- CI2 : CONSTANT SHORT_INTEGER := 2;
-
-
- BEGIN -- (A)
-
- IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 1" );
- END IF;
-
- IF (I2 /= 4) AND (NOT (I2 = 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 2" );
- END IF;
-
- IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 3" );
- END IF;
-
- IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 4");
- END IF;
-
- IF (I2 <= 4) AND (NOT (I2 > 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 5" );
- END IF;
-
- IF (I1A >= I1B) AND (I1A <= I1B) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 6" );
- END IF;
-
- IF ">" (LEFT => CI2, RIGHT => I1A) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 7" );
- END IF;
-
- IF "<" (LEFT => I1A, RIGHT => I2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 8" );
- END IF;
-
- IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 9 ");
- END IF;
-
- IF "<=" (LEFT => I1A, RIGHT => CI2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 10 ");
- END IF;
-
- IF "=" (LEFT => I1A, RIGHT => I1B ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 11 ");
- END IF;
-
- IF "/=" (LEFT => CI2, RIGHT => 4) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 12 ");
- END IF;
-
- END; -- (A)
-
- ----------------------------------------------------------------
-
- DECLARE -- (B)
-
- SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10;
-
- I1 : SHORT_INTEGER := IDENT (1);
- I5 : SHORT_INTEGER := IDENT (5);
-
- CI2 : CONSTANT SHORT_INTEGER := 2;
- CI10 : CONSTANT SHORT_INTEGER := 10;
-
-
- BEGIN -- (B)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.5" );
- END IF;
-
- END; -- (B)
-
- -------------------------------------------------------------
-
- DECLARE -- (C)
-
- SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10;
-
- I1 : SHORT_INTEGER := IDENT (1);
- I5 : SHORT_INTEGER := IDENT (5);
-
- CI2 : CONSTANT SHORT_INTEGER := 2;
- CI10 : CONSTANT SHORT_INTEGER := 10;
-
-
- FUNCTION ">" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN SHORT_INTEGER'POS (L) <= SHORT_INTEGER'POS (R);
- END;
-
- FUNCTION ">=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN SHORT_INTEGER'POS (L) < SHORT_INTEGER'POS (R);
- END;
-
- FUNCTION "<" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN SHORT_INTEGER'POS (L) >= SHORT_INTEGER'POS (R);
- END;
-
- FUNCTION "<=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN SHORT_INTEGER'POS (L) > SHORT_INTEGER'POS (R);
- END;
-
- BEGIN -- (C)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.5" );
- END IF;
-
- END; -- (C)
-
- RESULT;
-
-END C45231B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231c.dep b/gcc/testsuite/ada/acats/tests/c4/c45231c.dep
deleted file mode 100644
index d2971e2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45231c.dep
+++ /dev/null
@@ -1,265 +0,0 @@
--- C45231C.DEP
-
--- 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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD
--- CORRECT RESULTS FOR PREDEFINED TYPE LONG_INTEGER (INCLUDING
--- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED).
-
--- SUBTESTS ARE:
--- (A). TESTS FOR RELATIONAL OPERATORS.
--- (B). TESTS FOR MEMBERSHIP OPERATORS.
--- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE
--- RELATIONAL OPERATORS ARE REDEFINED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 02/04/86 CREATED ORIGINAL TEST.
--- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45231C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- RETURN LONG_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ( "C45231C", "CHECK THAT THE RELATIONAL AND " &
- "MEMBERSHIP OPERATIONS YIELD CORRECT " &
- "RESULTS FOR PREDEFINED TYPE LONG_INTEGER " &
- "(INCLUDING THE CASE IN WHICH THE " &
- "RELATIONAL OPERATORS ARE REDEFINED)" );
-
- DECLARE -- (A)
-
- I1A, I1B : LONG_INTEGER := IDENT (1);
- I2 : LONG_INTEGER := IDENT (2);
- CI2 : CONSTANT LONG_INTEGER := 2;
-
-
- BEGIN -- (A)
-
- IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 1" );
- END IF;
-
- IF (I2 /= 4) AND (NOT (I2 = 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 2" );
- END IF;
-
- IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 3" );
- END IF;
-
- IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 4");
- END IF;
-
- IF (I2 <= 4) AND (NOT (I2 > 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 5" );
- END IF;
-
- IF (I1A >= I1B) AND (I1A <= I1B) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 6" );
- END IF;
-
- IF ">" (LEFT => CI2, RIGHT => I1A) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 7" );
- END IF;
-
- IF "<" (LEFT => I1A, RIGHT => I2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 8" );
- END IF;
-
- IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 9 ");
- END IF;
-
- IF "<=" (LEFT => I1A, RIGHT => CI2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 10 ");
- END IF;
-
- IF "=" (LEFT => I1A, RIGHT => I1B ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 11 ");
- END IF;
-
- IF "/=" (LEFT => CI2, RIGHT => 4) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 12 ");
- END IF;
-
- END; -- (A)
-
- ----------------------------------------------------------------
-
- DECLARE -- (B)
-
- SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10;
-
- I1 : LONG_INTEGER := IDENT (1);
- I5 : LONG_INTEGER := IDENT (5);
-
- CI2 : CONSTANT LONG_INTEGER := 2;
- CI10 : CONSTANT LONG_INTEGER := 10;
-
-
- BEGIN -- (B)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.5" );
- END IF;
-
- END; -- (B)
-
- -------------------------------------------------------------
-
- DECLARE -- (C)
-
- SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10;
-
- I1 : LONG_INTEGER := IDENT (1);
- I5 : LONG_INTEGER := IDENT (5);
-
- CI2 : CONSTANT LONG_INTEGER := 2;
- CI10 : CONSTANT LONG_INTEGER := 10;
-
-
- FUNCTION ">" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN LONG_INTEGER'POS (L) <= LONG_INTEGER'POS (R);
- END;
-
- FUNCTION ">=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN LONG_INTEGER'POS (L) < LONG_INTEGER'POS (R);
- END;
-
- FUNCTION "<" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN LONG_INTEGER'POS (L) >= LONG_INTEGER'POS (R);
- END;
-
- FUNCTION "<=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS
- BEGIN
- RETURN LONG_INTEGER'POS (L) > LONG_INTEGER'POS (R);
- END;
-
- BEGIN -- (C)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.5" );
- END IF;
-
- END; -- (C)
-
- RESULT;
-
-END C45231C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231d.tst b/gcc/testsuite/ada/acats/tests/c4/c45231d.tst
deleted file mode 100644
index 66be11b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45231d.tst
+++ /dev/null
@@ -1,274 +0,0 @@
--- C45231D.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.
---*
--- OBJECTIVE:
--- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT
--- RESULTS FOR PREDEFINED TYPE $NAME (INCLUDING THE CASE IN
--- WHICH THE RELATIONAL OPERATORS ARE REDEFINED).
-
--- SUBTESTS ARE:
--- (A). TESTS FOR RELATIONAL OPERATORS.
--- (B). TESTS FOR MEMBERSHIP OPERATORS.
--- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE
--- RELATIONAL OPERATORS ARE REDEFINED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT A
--- PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER, OR
--- LONG_INTEGER.
-
--- IF NO SUCH PREDEFINED INTEGER TYPE IS SUPPORTED, THEN THE
--- SPECIFICATION OF THE FUNCTION IDENT MUST BE REJECTED.
-
--- MACRO SUBSTITUTION:
--- $NAME IS A PREDEFINED INTEGER TYPE OTHER THAN INTEGER,
--- SHORT_INTEGER, AND LONG_INTEGER.
-
--- HISTORY:
--- RJW 02/04/86
--- THS 04/16/90 ADDED OMITTED "-- N/A => ERROR." MESSAGE AND
--- MODIFIED HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45231D IS
-
- FUNCTION IDENT (X : $NAME)
- RETURN $NAME IS -- N/A => ERROR.
- BEGIN
- RETURN $NAME (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ( "C45231D", "CHECK THAT THE RELATIONAL AND " &
- "MEMBERSHIP OPERATIONS YIELD CORRECT " &
- "RESULTS FOR PREDEFINED TYPE $NAME " &
- "(INCLUDING THE CASE IN WHICH THE " &
- "RELATIONAL OPERATORS ARE REDEFINED)" );
-
- DECLARE -- (A)
-
- I1A, I1B : $NAME := IDENT (1);
- I2 : $NAME := IDENT (2);
- CI2 : CONSTANT $NAME := 2;
-
-
- BEGIN -- (A)
-
- IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 1" );
- END IF;
-
- IF (I2 /= 4) AND (NOT (I2 = 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 2" );
- END IF;
-
- IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 3" );
- END IF;
-
- IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 4");
- END IF;
-
- IF (I2 <= 4) AND (NOT (I2 > 4)) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 5" );
- END IF;
-
- IF (I1A >= I1B) AND (I1A <= I1B) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 6" );
- END IF;
-
- IF ">" (LEFT => CI2, RIGHT => I1A) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 7" );
- END IF;
-
- IF "<" (LEFT => I1A, RIGHT => I2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 8" );
- END IF;
-
- IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 9 ");
- END IF;
-
- IF "<=" (LEFT => I1A, RIGHT => CI2) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 10 ");
- END IF;
-
- IF "=" (LEFT => I1A, RIGHT => I1B ) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 11 ");
- END IF;
-
- IF "/=" (LEFT => CI2, RIGHT => 4) THEN
- NULL;
- ELSE
- FAILED ( "RELATIONAL TEST - 12 ");
- END IF;
-
- END; -- (A)
-
- ----------------------------------------------------------------
-
- DECLARE -- (B)
-
- SUBTYPE ST IS $NAME RANGE -10 .. 10;
-
- I1 : $NAME := IDENT (1);
- I5 : $NAME := IDENT (5);
-
- CI2 : CONSTANT $NAME := 2;
- CI10 : CONSTANT $NAME := 10;
-
-
- BEGIN -- (B)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - B.5" );
- END IF;
-
- END; -- (B)
-
- -------------------------------------------------------------
-
- DECLARE -- (C)
-
- SUBTYPE ST IS $NAME RANGE -10 .. 10;
-
- I1 : $NAME := IDENT (1);
- I5 : $NAME := IDENT (5);
-
- CI2 : CONSTANT $NAME := 2;
- CI10 : CONSTANT $NAME := 10;
-
-
- FUNCTION ">" ( L, R : $NAME ) RETURN BOOLEAN IS
- BEGIN
- RETURN $NAME'POS (L) <=
- $NAME'POS (R);
- END;
-
- FUNCTION ">=" ( L, R : $NAME ) RETURN BOOLEAN IS
- BEGIN
- RETURN $NAME'POS (L) <
- $NAME'POS (R);
- END;
-
- FUNCTION "<" ( L, R : $NAME ) RETURN BOOLEAN IS
- BEGIN
- RETURN $NAME'POS (L) >=
- $NAME'POS (R);
- END;
-
- FUNCTION "<=" ( L, R : $NAME ) RETURN BOOLEAN IS
- BEGIN
- RETURN $NAME'POS (L) >
- $NAME'POS (R);
- END;
-
- BEGIN -- (C)
-
- IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.1" );
- END IF;
-
- IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.2" );
- END IF;
-
- IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.3" );
- END IF;
-
- IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.4" );
- END IF;
-
- IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN
- NULL;
- ELSE
- FAILED ( "MEMBERSHIP TEST - C.5" );
- END IF;
-
- END; -- (C)
-
- RESULT;
-
-END C45231D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45232b.ada b/gcc/testsuite/ada/acats/tests/c4/c45232b.ada
deleted file mode 100644
index 459bc83..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45232b.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- C45232B.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 EXCEPTION IS RAISED WHEN AN INTEGER LITERAL IN
--- A COMPARISON BELONGS TO THE BASE TYPE BUT IS OUTSIDE THE
--- SUBTYPE OF THE OTHER OPERAND.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- P. BRASHEAR 08/21/86
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT, SYSTEM; USE REPORT;
-PROCEDURE C45232B IS
-
-BEGIN
-
- TEST ("C45232B", "NO EXCEPTION IS RAISED WHEN AN INTEGER " &
- "LITERAL IN A COMPARISON BELONGS TO THE BASE " &
- "TYPE BUT IS OUTSIDE THE SUBTYPE OF THE " &
- "OTHER OPERAND");
-
- DECLARE
-
- TYPE INT10 IS RANGE -10 .. 5;
-
- BEGIN
-
- IF 7 > INT10'(-10) THEN
- COMMENT ("NO EXCEPTION RAISED FOR '7 > " &
- "INT10'(-10)'");
- ELSE
- FAILED ("WRONG RESULT FOR '7 > INT10'(-10)'");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " &
- "> INT10'(-10)'");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR '7 > " &
- "INT10'(-10)'");
- END;
-
- DECLARE
-
- TYPE INT10 IS RANGE -10 .. 5;
-
- BEGIN
-
- IF 7 NOT IN INT10 THEN
- COMMENT ("NO EXCEPTION RAISED FOR '7 NOT IN " &
- "INT'");
- ELSE
- FAILED ("WRONG RESULT FOR '7 NOT IN INT'");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " &
- "NOT IN INT'");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR '7 NOT IN " &
- "INT'");
- END;
-
- DECLARE
-
- TYPE INT700 IS RANGE -700 .. 500;
-
- BEGIN
- IF 600 > INT700'(5) THEN
- COMMENT ("NO EXCEPTION RAISED FOR '600 > " &
- "INT700'(5)'");
- ELSE
- FAILED ("WRONG RESULT FOR '600 > INT700'(5)'");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " &
- "> INT700'(5)'");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR '600 > " &
- "INT700'(5)'");
- END;
-
- DECLARE
-
- TYPE INT700 IS RANGE -700 .. 500;
-
- BEGIN
-
- IF 600 NOT IN INT700 THEN
- COMMENT ("NO EXCEPTION RAISED FOR '600 NOT IN " &
- "INT700'");
- ELSE
- FAILED ("WRONG RESULT FOR '600 NOT IN INT700'");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " &
- "NOT IN INT700'");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR '600 NOT IN " &
- "INT700'");
- END;
-
- RESULT;
-
-END C45232B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45242b.ada b/gcc/testsuite/ada/acats/tests/c4/c45242b.ada
deleted file mode 100644
index bd05afc..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45242b.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- C45242B.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 NO EXCEPTION IS RAISED WHEN A FLOATING POINT LITERAL
--- OPERAND IN A COMPARISON OR A FLOATING POINT LITERAL LEFT OPERAND
--- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE
--- THE RANGE OF THE SUBTYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- PWB 09/04/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT, SYSTEM; USE REPORT;
-PROCEDURE C45242B IS
-
-BEGIN
-
- TEST ("C45242B", "NO EXCEPTION IS RAISED WHEN A FLOATING " &
- "LITERAL USED IN A COMPARISON OR AS THE " &
- "LEFT OPERAND IN A MEMBERSHIP TEST " &
- "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " &
- "THE RANGE OF THE SUBTYPE");
-
- DECLARE
- N : FLOAT := FLOAT (IDENT_INT (1));
- SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N;
- NUM : FLOAT_1 := N;
- BEGIN -- PRE-DEFINED FLOAT COMPARISON
-
- IF EQUAL(3,3) THEN
- NUM := FLOAT_1'(0.5);
- END IF;
-
- IF 2.0 > NUM THEN
- COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " &
- "COMPARISON");
- ELSE
- FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " &
- "COMPARISON");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " &
- "FLOAT COMPARISON");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " &
- "FLOAT COMPARISON");
- END; -- PRE-DEFINED FLOAT COMPARISON
-
- DECLARE
- N : FLOAT := FLOAT (IDENT_INT (1));
- SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N;
- BEGIN -- PRE-DEFINED FLOAT MEMBERSHIP
-
- IF 2.0 IN FLOAT_1 THEN
- FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " &
- "MEMBERSHIP");
- ELSE
- COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " &
- "MEMBERSHIP");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " &
- "FLOAT MEMBERSHIP");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " &
- "FLOAT MEMBERSHIP");
- END; -- PRE-DEFINED FLOAT MEMBERSHIP
-
- DECLARE -- PRECISE FLOAT COMPARISON
- TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS;
- N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1));
- SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N;
- NUM : SUB_FINE := N;
- BEGIN
- IF EQUAL(3,3) THEN
- NUM := 0.25;
- END IF;
-
- IF 0.75 > NUM THEN
- COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " &
- "COMPARISON");
- ELSE
- FAILED ("WRONG RESULT FROM FINE_FLOAT COMPARISON");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FINE_FLOAT COMPARISON");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FINE_FLOAT COMPARISON");
- END; -- FINE_FLOAT COMPARISON
-
- DECLARE -- PRECISE FLOAT MEMBERSHIP
- TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS;
- N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1));
- SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N;
- BEGIN
-
- IF 0.75 IN SUB_FINE THEN
- FAILED ("WRONG RESULT FROM FINE_FLOAT MEMBERSHIP");
- ELSE
- COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " &
- "MEMBERSHIP");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FINE_FLOAT MEMBERSHIP");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FINE_FLOAT MEMBERSHIP");
- END; -- FINE_FLOAT MEMBERSHIP
-
- RESULT;
-
-END C45242B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45251a.ada b/gcc/testsuite/ada/acats/tests/c4/c45251a.ada
deleted file mode 100644
index 0e1bbb5..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45251a.ada
+++ /dev/null
@@ -1,178 +0,0 @@
--- C45251A.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 RELATIONAL OPERATIONS ON FIXED POINT TYPES THE
--- FOLLOWING HOLD:
--- (A) A /= B IS THE SAME AS NOT (A = B).
--- (B) A < B IS THE SAME AS NOT (A >= B).
--- (C) A > B IS THE SAME AS NOT (A <= B).
--- (D) ADJACENT MODEL NUMBERS GIVE CORRECT RESULTS.
--- (E) NON-MODEL NUMBERS WITH DISTINCT MODEL INTERVALS GIVE
--- CORRECT RESULTS.
--- (F) CASE WHERE MODEL INTERVALS INTERSECT IN A SINGLE MODEL
--- NUMBER GIVES CORRECT RESULT.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- WRG 8/26/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45251A IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
-
-BEGIN
-
- TEST ("C45251A", "CHECK RELATIONAL OPERATIONS FOR FIXED POINT " &
- "TYPES - BASIC TYPES");
-
- -------------------------------------------------------------------
-
- DECLARE
- A, B : LIKE_DURATION_M23 := 0.0;
- C, D : DECIMAL_M4 := 0.0;
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 2#0.0000_0011#; -- JUST BELOW LIKE_DURATION'SMALL.
- B := 2#0.0000_0101#; -- JUST ABOVE LIKE_DURATION'SMALL.
- END IF;
-
- -- (A)
- IF A /= B XOR NOT (A = B) THEN
- FAILED ("A /= B IS NOT THE SAME AS NOT (A = B)");
- END IF;
-
- -- (B)
- IF A < B XOR NOT (A >= B) THEN
- FAILED ("A < B IS NOT THE SAME AS NOT (A >= B)");
- END IF;
-
- -- (C)
- IF A > B XOR NOT (A <= B) THEN
- FAILED ("A > B IS NOT THE SAME AS NOT (A <= B)");
- END IF;
-
- -- (D)
- IF EQUAL (3, 3) THEN
- A := -(16#1_5180.00#); -- (-86_400.0)
- B := -(16#1_517F.FC#); -- (-86_400.0 + 1.0/64)
-
- C := 64.0; -- DECIMAL_M4'SMALL.
- D := 128.0; -- 2 * DECIMAL_M4'SMALL.
- END IF;
- IF "=" (LEFT => A, RIGHT => B) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (A = B)");
- END IF;
- IF NOT "/=" (LEFT => C, RIGHT => D) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (C /= D)");
- END IF;
- IF "<" (LEFT => B, RIGHT => A) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (B < A)");
- END IF;
- IF ">" (LEFT => C, RIGHT => D) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (C > D)");
- END IF;
- IF ">=" (LEFT => A, RIGHT => B) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (A >= B)");
- END IF;
- IF "<=" (LEFT => D, RIGHT => C) THEN
- FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " &
- "- (D <= C)");
- END IF;
-
- -- (E)
- IF EQUAL (3, 3) THEN
- A := 0.02; -- INTERVAL IS 1.0/64 .. 2.0/64.
- B := -0.02; -- INTERVAL IS -2.0/64 .. -1.0/64.
-
- C := 800.0; -- INTERVAL IS 768.0 .. 832.0.
- D := 900.0; -- INTERVAL IS 896.0 .. 960.0.
- END IF;
- IF A = B THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (A = B)");
- END IF;
- IF NOT (C /= D) THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (C /= D)");
- END IF;
- IF A < B THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (A < B)");
- END IF;
- IF C > D THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (C > D)");
- END IF;
- IF B >= A THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (B >= A)");
- END IF;
- IF D <= C THEN
- FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " &
- "INTERVALS GIVE INCORRECT RESULT - (D <= C)");
- END IF;
-
- -- (F)
- IF EQUAL (3, 3) THEN
- B := 0.035; -- INTERVAL IS 2.0/64 .. 3.0/64.
-
- C := 850.0; -- INTERVAL IS 832.0 .. 896.0.
- END IF;
- IF NOT (A <= B) THEN
- FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " &
- "COMMON MODEL INTERVAL END-POINT GIVES " &
- "INCORRECT RESULT - (A <= B)");
- END IF;
- IF A > B THEN
- FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " &
- "COMMON MODEL INTERVAL END-POINT GIVES " &
- "INCORRECT RESULT - (A > B)");
- END IF;
- IF NOT (D >= C) THEN
- FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " &
- "COMMON MODEL INTERVAL END-POINT GIVES " &
- "INCORRECT RESULT - (D >= C)");
- END IF;
- IF D < C THEN
- FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " &
- "COMMON MODEL INTERVAL END-POINT GIVES " &
- "INCORRECT RESULT - (D < C)");
- END IF;
- END;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C45251A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45252a.ada b/gcc/testsuite/ada/acats/tests/c4/c45252a.ada
deleted file mode 100644
index e214966..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45252a.ada
+++ /dev/null
@@ -1,200 +0,0 @@
--- C45252A.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.
---*
--- FOR FIXED POINT TYPES, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED WHEN A LITERAL USED IN A COMPARISON OR
--- MEMBERSHIP OPERATION (AS THE FIRST OPERAND) DOES NOT BELONG TO THE
--- BASE TYPE.
---
--- CHECK THAT NO EXCEPTION IS RAISED FOR A FIXED POINT RELATIONAL OR
--- MEMBERSHIP OPERATION IF LITERAL VALUES BELONG TO THE BASE TYPE.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- WRG 9/10/86
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45252A IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
- TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5;
- TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
-
-BEGIN
-
- TEST ("C45252A", "CHECK RAISING OF EXCEPTIONS BY RELATIONAL " &
- "OPERATIONS FOR FIXED POINT TYPES - BASIC TYPES");
-
- -------------------------------------------------------------------
-
- BEGIN
- -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32.
- IF 2.9E9 <= LIKE_DURATION_M23'LAST THEN
- FAILED ("2.9E9 <= LIKE_DURATION_M23'LAST");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " &
- """2.9E9 <= LIKE_DURATION_M23'LAST""");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " &
- """2.9E9 <= LIKE_DURATION_M23'LAST""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64.
- IF 1.0E19 IN LIKE_DURATION_M23 THEN
- FAILED ("1.0E19 IN LIKE_DURATION_M23");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " &
- """1.0E19 IN LIKE_DURATION_M23""");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " &
- """1.0E19 IN LIKE_DURATION_M23""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64.
- IF 1.0E19 <= MIDDLE_M3'LAST THEN
- FAILED ("1.0E19 <= MIDDLE_M3'LAST");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " &
- """1.0E19 <= MIDDLE_M3'LAST""");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " &
- """1.0E19 <= MIDDLE_M3'LAST""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32.
- IF 2.9E9 IN MIDDLE_M3 THEN
- FAILED ("2.9E9 IN MIDDLE_M3");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " &
- """2.9E9 IN MIDDLE_M3""");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " &
- """2.9E9 IN MIDDLE_M3""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- -- 3.5 IS A MODEL NUMBER OF THE TYPE MIDDLE_M3.
- IF 3.5 <= MIDDLE_M3'LAST THEN
- FAILED ("3.5 <= MIDDLE_M3'LAST");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " &
- """3.5 <= MIDDLE_M3'LAST""");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED BY COMPARISON " &
- """3.5 <= MIDDLE_M3'LAST""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- IF 3.0 IN MIDDLE_M3 THEN
- FAILED ("3.0 IN MIDDLE_M3");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " &
- """3.0 IN MIDDLE_M3""");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " &
- """3.0 IN MIDDLE_M3""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- IF 86_450.0 <= LIKE_DURATION_M23'LAST THEN
- FAILED ("86_450.0 <= LIKE_DURATION_M23'LAST");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " &
- """86_450.0 <= LIKE_DURATION_M23'LAST""");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED BY COMPARISON " &
- """86_450.0 <= LIKE_DURATION_M23'LAST""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- IF 86_500.0 IN LIKE_DURATION_M23 THEN
- FAILED ("86_500.0 IN LIKE_DURATION_M23");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " &
- """86_500.0 IN LIKE_DURATION_M23""");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " &
- """86_500.0 IN LIKE_DURATION_M23""");
- END;
-
- -------------------------------------------------------------------
-
- BEGIN
- IF -86_450.0 IN LIKE_DURATION_M23 THEN
- FAILED ("-86_450.0 IN LIKE_DURATION_M23");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " &
- """-86_450.0 IN LIKE_DURATION_M23""");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " &
- """-86_450.0 IN LIKE_DURATION_M23""");
- END;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C45252A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45252b.ada b/gcc/testsuite/ada/acats/tests/c4/c45252b.ada
deleted file mode 100644
index bc6b46d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45252b.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C45252B.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 NO EXCEPTION IS RAISED WHEN A FIXED POINT LITERAL
--- OPERAND IN A COMPARISON OR A FIXED POINT LITERAL LEFT OPERAND
--- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE
--- THE RANGE OF THE SUBTYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- PWB 09/04/86 CREATED ORIGINAL TEST.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT, SYSTEM; USE REPORT;
-PROCEDURE C45252B IS
-
-BEGIN
-
- TEST ("C45252B", "NO EXCEPTION IS RAISED WHEN A FIXED " &
- "LITERAL USED IN A COMPARISON OR AS THE " &
- "LEFT OPERAND IN A MEMBERSHIP TEST " &
- "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " &
- "THE RANGE OF THE SUBTYPE");
-
- DECLARE
- TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0;
- SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0;
- NUM : FIXED_1 := 0.0;
- BEGIN -- FIXED COMPARISON
-
- IF EQUAL(3,3) THEN
- NUM := FIXED_1'(0.5);
- END IF;
-
- IF 2.0 > NUM THEN
- COMMENT ("NO EXCEPTION RAISED FOR FIXED " &
- "COMPARISON");
- ELSE
- FAILED ("WRONG RESULT FROM FIXED " &
- "COMPARISON");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FIXED COMPARISON");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FIXED COMPARISON");
- END; -- FIXED COMPARISON
-
- DECLARE
- TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0;
- SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0;
- BEGIN -- FIXED MEMBERSHIP
-
- IF 2.0 IN FIXED_1 THEN
- FAILED ("WRONG RESULT FROM FIXED " &
- "MEMBERSHIP");
- ELSE
- COMMENT ("NO EXCEPTION RAISED FOR FIXED " &
- "MEMBERSHIP");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FIXED MEMBERSHIP");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FIXED MEMBERSHIP");
- END; -- FIXED MEMBERSHIP
-
- DECLARE -- PRECISE FIXED COMPARISON
- TYPE FINE_FIXED IS DELTA SYSTEM.FINE_DELTA RANGE -1.0 .. 1.0;
- SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5;
- NUM : SUB_FINE := 0.0;
- BEGIN
- IF EQUAL(3,3) THEN
- NUM := 0.25;
- END IF;
-
- IF 0.75 > NUM THEN
- COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " &
- "COMPARISON");
- ELSE
- FAILED ("WRONG RESULT FROM FINE_FIXED COMPARISON");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FINE_FIXED COMPARISON");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FINE_FIXED COMPARISON");
- END; -- FINE_FIXED COMPARISON
-
- DECLARE -- PRECISE FIXED MEMBERSHIP
- TYPE FINE_FIXED IS DIGITS SYSTEM.MAX_DIGITS;
- SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5;
- BEGIN
-
- IF 0.75 IN SUB_FINE THEN
- FAILED ("WRONG RESULT FROM FINE_FIXED MEMBERSHIP");
- ELSE
- COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " &
- "MEMBERSHIP");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR " &
- "FINE_FIXED MEMBERSHIP");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "FINE_FIXED MEMBERSHIP");
- END; -- FINE_FIXED MEMBERSHIP
-
- RESULT;
-
-END C45252B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45253a.ada b/gcc/testsuite/ada/acats/tests/c4/c45253a.ada
deleted file mode 100644
index d2a0661..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45253a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- C45253A.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 FIXED POINT TYPES "A IN T" AND "A NOT IN T" GIVE
--- APPROPRIATE RESULTS, EVEN WHEN USER-DEFINED ORDERING OPERATORS EXIST
--- FOR T.
-
--- WRG 8/27/86
--- JRL 06/12/96 Added function The_Delta. Eliminated static expressions
--- outside the base range of type T.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45253A IS
-
- TYPE FIXED IS DELTA 0.25 RANGE 0.0 .. 1000.0;
- TYPE T IS NEW FIXED;
-
- FUNCTION "<" (LEFT, RIGHT : T) RETURN BOOLEAN IS
- BEGIN
- RETURN FIXED (LEFT) >= FIXED (RIGHT);
- END "<";
-
- FUNCTION "<=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
- BEGIN
- RETURN FIXED (LEFT) > FIXED (RIGHT);
- END "<=";
-
- FUNCTION ">" (LEFT, RIGHT : T) RETURN BOOLEAN IS
- BEGIN
- RETURN FIXED (LEFT) <= FIXED (RIGHT);
- END ">";
-
- FUNCTION ">=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
- BEGIN
- RETURN FIXED (LEFT) < FIXED (RIGHT);
- END ">=";
-
- function The_Delta return T is
- begin
- return T'Delta;
- end The_Delta;
-
-BEGIN
-
- TEST ("C45253A", "CHECK THAT FOR FIXED POINT TYPES ""A IN T"" " &
- "AND ""A NOT IN T"" GIVE APPROPRIATE RESULTS, " &
- "EVEN WHEN USER-DEFINED ORDERING OPERATORS " &
- "EXIST FOR T");
-
- IF IDENT_INT (1) * 0.0 NOT IN T THEN
- FAILED ("0.0 NOT IN T");
- END IF;
-
--- 06/12/96 IF IDENT_INT (1) * 1000.0 NOT IN T THEN
- if Ident_Int (2) * 500.0 not in T then
- FAILED ("1000.0 NOT IN T");
- END IF;
-
--- 06/12/96 IF IDENT_INT (1) * (-0.25) IN T THEN
- if Ident_Int (1) * (-The_Delta) in T then
- FAILED ("-0.25 IN T");
- END IF;
-
--- 06/12/96 IF IDENT_INT (1) * 1000.25 IN T THEN
- if Ident_Int (2) * 500.0 + The_Delta in T then
- FAILED ("1000.25 IN T");
- END IF;
-
--- 06/12/96 IF IDENT_INT (1) * (-1000.0) IN T THEN
- if Ident_Int (2) * (-500.0) in T then
- FAILED ("-1000.0 IN T");
- END IF;
-
- RESULT;
-
-END C45253A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262a.ada b/gcc/testsuite/ada/acats/tests/c4/c45262a.ada
deleted file mode 100644
index 270dc88..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45262a.ada
+++ /dev/null
@@ -1,214 +0,0 @@
--- C45262A.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 ORDERING COMPARISONS YIELD CORRECT RESULTS FOR
--- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF
--- INTEGERS.
-
--- JWC 8/19/85
--- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45262A IS
-BEGIN
- TEST ("C45262A", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " &
- "DISCRETE ARRAY TYPES - INTEGER COMPONENTS");
-
- DECLARE
-
- TYPE ARR IS ARRAY( INTEGER RANGE <> ) OF INTEGER;
- ARR1 : ARR(1 .. IDENT_INT(0));
- ARR2 : ARR(2 .. IDENT_INT(0));
- ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0);
- ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0);
- ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1);
- ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0);
- ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1);
- ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => 0);
- ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 0);
- ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 1);
-
- BEGIN
- IF ARR1 < ARR2 THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR1 <= ARR2) THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <=");
- END IF;
-
- IF ARR1 > ARR2 THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >");
- END IF;
-
- IF NOT ( ">=" (ARR1, ARR2) ) THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >=");
- END IF;
-
- IF ARR3 < ARR1 THEN
- FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1");
- END IF;
-
- IF ARR3 <= ARR1 THEN
- FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1");
- END IF;
-
- IF NOT ( ">" (ARR3, ARR1) ) THEN
- FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " &
- "ARR1");
- END IF;
-
- IF NOT (ARR3 >= ARR1) THEN
- FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " &
- "NULL ARR1");
- END IF;
-
- IF ARR3 < ARR4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT ( "<=" (ARR3, ARR4) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF ARR3 > ARR4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR3 >= ARR4) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT ( "<" (ARR3, ARR5) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR3 <= ARR5) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF ARR3 > ARR5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ARR3 >= ARR5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- IF NOT (ARR6 < ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR6 <= ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- "<=");
- END IF;
-
- IF ARR6 > ARR7 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- ">=");
- END IF;
-
- IF ARR6 < ARR8 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT (ARR6 <= ARR8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <=");
- END IF;
-
- IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR6 >= ARR8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >=");
- END IF;
-
- IF ARR8 < ARR9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF ARR8 <= ARR9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF NOT (ARR8 > ARR9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR8 >= ARR9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT (ARR8 < ARRA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR8 <= ARRA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF ARR8 > ARRA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ARR8 >= ARRA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- END;
-
- RESULT;
-
-END C45262A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262b.ada b/gcc/testsuite/ada/acats/tests/c4/c45262b.ada
deleted file mode 100644
index 9d4e806..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45262b.ada
+++ /dev/null
@@ -1,219 +0,0 @@
--- C45262B.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 ORDERING COMPARISONS YIELD CORRECT RESULTS FOR
--- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS STRING TYPES.
-
--- JWC 9/9/85
--- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45262B IS
-BEGIN
- TEST ("C45262B", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " &
- "DISCRETE ARRAY TYPES - TYPE STRING");
-
- DECLARE
-
- STRING1 : STRING(2 .. IDENT_INT(1));
- STRING2 : STRING(3 .. IDENT_INT(1));
- STRING3 : STRING(2 .. IDENT_INT(2)) := (IDENT_INT(2) => 'A');
- STRING4 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'A');
- STRING5 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'B');
- STRING6 : STRING(2 .. IDENT_INT(6)) :=
- (2 .. IDENT_INT(6) => 'A');
- STRING7 : STRING(1 .. 5) := (1 .. 4 => 'A', 5 => 'B');
- STRING8 : STRING(1 .. IDENT_INT(5)) :=
- (1 .. IDENT_INT(5) => 'A');
- STRING9 : STRING(1 .. IDENT_INT(4)) :=
- (1 .. IDENT_INT(4) => 'A');
- STRINGA : STRING(1 .. IDENT_INT(4)) :=
- (1 .. IDENT_INT(4) => 'B');
-
- BEGIN
- IF STRING1 < STRING2 THEN
- FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - <");
- END IF;
-
- IF NOT (STRING1 <= STRING2) THEN
- FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " &
- "<=");
- END IF;
-
- IF STRING1 > STRING2 THEN
- FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - >");
- END IF;
-
- IF NOT ( ">=" (STRING1, STRING2) ) THEN
- FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " &
- ">=");
- END IF;
-
- IF STRING3 < STRING1 THEN
- FAILED ("NON-NULL ARRAY STRING3 LESS THAN NULL STRING1");
- END IF;
-
- IF STRING3 <= STRING1 THEN
- FAILED ("NON-NULL ARRAY STRING3 LESS THAN EQUAL NULL " &
- "STRING1");
- END IF;
-
- IF NOT ( ">" (STRING3, STRING1) ) THEN
- FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN NULL " &
- "STRING1");
- END IF;
-
- IF NOT (STRING3 >= STRING1) THEN
- FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN " &
- "EQUAL NULL STRING1");
- END IF;
-
- IF STRING3 < STRING4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT ( "<=" (STRING3, STRING4) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF STRING3 > STRING4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (STRING3 >= STRING4) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT ( "<" (STRING3, STRING5) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (STRING3 <= STRING5) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF STRING3 > STRING5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF STRING3 >= STRING5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- IF NOT (STRING6 < STRING7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (STRING6 <= STRING7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- "<=");
- END IF;
-
- IF STRING6 > STRING7 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ">=" (LEFT => STRING6, RIGHT => STRING7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- ">=");
- END IF;
-
- IF STRING6 < STRING8 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT (STRING6 <= STRING8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <=");
- END IF;
-
- IF ">" (RIGHT => STRING8, LEFT => STRING6) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (STRING6 >= STRING8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >=");
- END IF;
-
- IF STRING8 < STRING9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF STRING8 <= STRING9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF NOT (STRING8 > STRING9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (STRING8 >= STRING9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT (STRING8 < STRINGA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (STRING8 <= STRINGA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF STRING8 > STRINGA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF STRING8 >= STRINGA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- END;
-
- RESULT;
-
-END C45262B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262c.ada b/gcc/testsuite/ada/acats/tests/c4/c45262c.ada
deleted file mode 100644
index a4e156a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45262c.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- C45262C.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 ORDERING COMPARISONS YIELD CORRECT RESULTS FOR
--- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF
--- AN ENUMERATION TYPE.
-
--- JWC 8/19/85
--- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45262C IS
-BEGIN
- TEST ("C45262C", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " &
- "DISCRETE ARRAY TYPES - ENUMERATED COMPONENTS");
-
- DECLARE
-
- SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5;
- TYPE ENUM IS (E0, E1);
- TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF ENUM;
- ARR1 : ARR(1 .. IDENT_INT(0));
- ARR2 : ARR(2 .. IDENT_INT(0));
- ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => E0);
- ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E0);
- ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E1);
- ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => E0);
- ARR7 : ARR(0 .. 4) := (0 .. 3 => E0, 4 => E1);
- ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => E0);
- ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E0);
- ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E1);
-
- BEGIN
- IF ARR1 < ARR2 THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR1 <= ARR2) THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <=");
- END IF;
-
- IF ARR1 > ARR2 THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >");
- END IF;
-
- IF NOT ( ">=" (ARR1, ARR2) ) THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >=");
- END IF;
-
- IF ARR3 < ARR1 THEN
- FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1");
- END IF;
-
- IF ARR3 <= ARR1 THEN
- FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1");
- END IF;
-
- IF NOT ( ">" (ARR3, ARR1) ) THEN
- FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " &
- "ARR1");
- END IF;
-
- IF NOT (ARR3 >= ARR1) THEN
- FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " &
- "NULL ARR1");
- END IF;
-
- IF ARR3 < ARR4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT ( "<=" (ARR3, ARR4) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF ARR3 > ARR4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR3 >= ARR4) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT ( "<" (ARR3, ARR5) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR3 <= ARR5) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF ARR3 > ARR5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ARR3 >= ARR5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- IF NOT (ARR6 < ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR6 <= ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- "<=");
- END IF;
-
- IF ARR6 > ARR7 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " &
- ">=");
- END IF;
-
- IF ARR6 < ARR8 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <");
- END IF;
-
- IF NOT (ARR6 <= ARR8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <=");
- END IF;
-
- IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR6 >= ARR8) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >=");
- END IF;
-
- IF ARR8 < ARR9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <");
- END IF;
-
- IF ARR8 <= ARR9 THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - <=");
- END IF;
-
- IF NOT (ARR8 > ARR9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR8 >= ARR9) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >=");
- END IF;
-
- IF NOT (ARR8 < ARRA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <");
- END IF;
-
- IF NOT (ARR8 <= ARRA) THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - <=");
- END IF;
-
- IF ARR8 > ARRA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >");
- END IF;
-
- IF ARR8 >= ARRA THEN
- FAILED ("DIFFERENT NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- END;
-
- RESULT;
-
-END C45262C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262d.ada b/gcc/testsuite/ada/acats/tests/c4/c45262d.ada
deleted file mode 100644
index 7889501..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45262d.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C45262D.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 ORDERING COMPARISONS YIELD CORRECT RESULTS FOR
--- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST USES
--- USER-DEFINED ORDERING OPERATORS FOR THE DISCRETE COMPONENT TYPE.
-
--- JWC 8/19/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45262D IS
-
- FUNCTION "<"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN STANDARD.">="(LEFT, RIGHT);
- END "<";
-
- FUNCTION "<="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN STANDARD.">"(LEFT, RIGHT);
- END "<=";
-
- FUNCTION ">"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN STANDARD."<="(LEFT, RIGHT);
- END ">";
-
- FUNCTION ">="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN STANDARD."<"(LEFT, RIGHT);
- END ">=";
-
-BEGIN
- TEST ("C45262D", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " &
- "DISCRETE ARRAY TYPES");
-
- DECLARE
-
- SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5;
- TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF INTEGER;
- ARR1 : ARR(1 .. IDENT_INT(0));
- ARR2 : ARR(2 .. IDENT_INT(0));
- ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0);
- ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0);
- ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1);
- ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0);
- ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1);
-
- BEGIN
-
- IF ARR1 < ARR2 THEN
- FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <");
- END IF;
-
- IF ARR3 <= ARR1 THEN
- FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL " &
- "ARR1");
- END IF;
-
- IF ARR3 > ARR4 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS EQUAL - >");
- END IF;
-
- IF NOT (ARR3(1) > ARR4(0)) THEN
- FAILED ("REDEFINED COMPONENT COMPARISON - >");
- END IF;
-
- IF ARR3 >= ARR5 THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "COMPONENTS NOT EQUAL - >=");
- END IF;
-
- IF NOT ( "<" (ARR6, ARR7) ) THEN
- FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " &
- "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <");
- END IF;
-
- END;
-
- RESULT;
-
-END C45262D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264a.ada b/gcc/testsuite/ada/acats/tests/c4/c45264a.ada
deleted file mode 100644
index d701be0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45264a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C45264A.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 EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE
--- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES.
--- CASE THAT CHECKS THAT TWO NULL ARRAYS OF THE SAME TYPE ARE
--- ALWAYS EQUAL.
-
--- PK 02/21/84
--- EG 05/30/84
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE C45264A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
-
-BEGIN
-
- TEST("C45264A","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " &
- "RESULTS FOR ONE DIMENSIONAL AND MULTI-" &
- "DIMENSIONAL ARRAY TYPES");
-
- DECLARE
-
- TYPE A1 IS ARRAY(INT RANGE <>) OF INTEGER;
-
- BEGIN
-
- IF A1'(1 .. IDENT_INT(2) => IDENT_INT(1)) /=
- A1'(IDENT_INT(2) .. 3 => IDENT_INT(1)) THEN
- FAILED ("A1 - ARRAYS NOT EQUAL");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("A1 - EXCEPTION RAISED");
-
- END;
-
- DECLARE
-
- TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER;
-
- BEGIN
- IF A2'(1 .. IDENT_INT(2) =>
- (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1))) /=
- A2'(IDENT_INT(2) .. 3 =>
- (IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1))) THEN
- FAILED ("A2 - ARRAYS NOT EQUAL");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("A2 - EXCEPTION RAISED");
-
- END;
-
- DECLARE
-
- TYPE A3 IS
- ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) OF
- INTEGER;
-
- BEGIN
-
- IF A3'(1 .. IDENT_INT(2) =>
- (IDENT_INT(1) .. IDENT_INT(3) =>
- (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1)))) /=
- A3'(IDENT_INT(1) .. 3 =>
- (IDENT_INT(2) .. IDENT_INT(1) =>
- (IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)))) THEN
- FAILED ("A3 - ARRAYS NOT EQUAL");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("A3 - EXCEPTION RAISED");
-
- END;
-
- RESULT;
-
-END C45264A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264b.ada b/gcc/testsuite/ada/acats/tests/c4/c45264b.ada
deleted file mode 100644
index 44063f7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45264b.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- C45264B.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 EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE
--- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES.
--- THIS TEST CHECKS THE CASE WHERE THE ARRAY HAS A BOUND THAT DEPENDS ON
--- A DISCRIMINANT WITH DEFAULTS.
-
--- JWC 11/18/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45264B IS
-
-BEGIN
-
- TEST("C45264B","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " &
- "RESULTS FOR ONE DIMENSIONAL AND MULTI-" &
- "DIMENSIONAL ARRAY TYPES");
-
- DECLARE
-
- SUBTYPE SUBINT IS INTEGER RANGE 1 .. 5;
- TYPE REC (DISC : SUBINT := 1) IS
- RECORD
- COMP : STRING(IDENT_INT(3) .. DISC);
- END RECORD;
- TYPE ARR IS ARRAY (1 .. 3) OF REC;
-
- A1, A2 : ARR;
-
- BEGIN
-
- IF A1 /= A2 THEN
- FAILED ("NULL ARRAYS, RESULT NOT EQUAL");
- END IF;
-
- A1(2) := (5, "ABC");
-
- IF A1 = A2 THEN
- FAILED ("NON-NULL ARRAY AND NULL ARRAY, RESULT EQUAL");
- END IF;
-
- A2(2) := (5, "ABD");
-
- IF A1 = A2 THEN
- FAILED ("ARRAYS DIFFER BY LAST ELEMENT, RESULT EQUAL");
- END IF;
-
- A2(2) := (4, "AB");
-
- IF A1 = A2 THEN
- FAILED ("ARRAYS OF DIFFERENT LENGTH, RESULT EQUAL");
- END IF;
-
- A1(2) := (4, "AB");
-
- IF A1 /= A2 THEN
- FAILED ("DISCRIMINANTS AND COMPONENTS ARE THE SAME, " &
- "RESULT NOT EQUAL");
- END IF;
-
- END;
-
- RESULT;
-
-END C45264B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264c.ada b/gcc/testsuite/ada/acats/tests/c4/c45264c.ada
deleted file mode 100644
index c9959a5..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45264c.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45264C.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 COMPARING ARRAYS OF DIFFERENT LENGTHS DOES NOT RAISE AN
--- EXCEPTION.
-
--- TBN 7/21/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45264C IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
- TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER;
- TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER;
- TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>,
- INT RANGE <>) OF INTEGER;
-
- ARRAY_1 : ARRAY_TYPE_1 (1..5) := (1..5 => 1);
- ARRAY_2 : ARRAY_TYPE_1 (1..7) := (1..7 => 1);
- ARRAY_3 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 1));
- ARRAY_4 : ARRAY_TYPE_2 (1..2, 1..3) := (1..2 => (1..3 => 1));
- ARRAY_5 : ARRAY_TYPE_3 (1..2, 1..3, 1..2) := (1..2 => (1..3 =>
- (1..2 => 2)));
- ARRAY_6 : ARRAY_TYPE_3 (1..1, 1..2, 1..3) := (1..1 => (1..2 =>
- (1..3 => 2)));
- ARRAY_7 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 3));
- ARRAY_8 : ARRAY_TYPE_2 (1..5, 1..3) := (1..5 => (1..3 => 3));
- ARRAY_9 : ARRAY_TYPE_2 (1..3, 1..2) := (1..3 => (1..2 => 4));
- ARRAY_10 : ARRAY_TYPE_2 (1..2, 1..2) := (1..2 => (1..2 => 4));
-
-BEGIN
- TEST ("C45264C", "CHECK THAT COMPARING ARRAYS OF DIFFERENT " &
- "LENGTHS DOES NOT RAISE AN EXCEPTION");
-
- BEGIN -- (A)
- IF "=" (ARRAY_1 (1..INTEGER'FIRST), ARRAY_2) THEN
- FAILED ("INCORRECT RESULTS FROM COMPARING ONE " &
- "DIMENSIONAL ARRAYS - 1");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 1");
- END; -- (A)
-
- BEGIN -- (B)
- IF ARRAY_1 /= ARRAY_2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM COMPARING ONE " &
- "DIMENSIONAL ARRAYS - 2");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 2");
- END; -- (B)
-
- BEGIN -- (C)
- IF ARRAY_3 = ARRAY_4 THEN
- FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" &
- "DIMENSIONAL ARRAYS - 3");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 3");
- END; -- (C)
-
- BEGIN -- (D)
- IF "/=" (ARRAY_3, ARRAY_4) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" &
- "DIMENSIONAL ARRAYS - 4");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 4");
- END; -- (D)
-
- BEGIN -- (E)
- IF "=" (ARRAY_5, ARRAY_6) THEN
- FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" &
- "DIMENSIONAL ARRAYS - 5");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 5");
- END; -- (E)
-
- BEGIN -- (F)
- IF ARRAY_6 /= ARRAY_5 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" &
- "DIMENSIONAL ARRAYS - 6");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 6");
- END; -- (F)
-
- BEGIN -- (G)
- IF ARRAY_7 = ARRAY_8 THEN
- FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" &
- "DIMENSIONAL ARRAYS - 7");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 7");
- END; -- (G)
-
- BEGIN -- (H)
- IF ARRAY_9 /= ARRAY_10 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" &
- "DIMENSIONAL ARRAYS - 8");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED EVALUATING - 8");
- END; -- (H)
-
- RESULT;
-END C45264C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45265a.ada b/gcc/testsuite/ada/acats/tests/c4/c45265a.ada
deleted file mode 100644
index 7111243..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45265a.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- C45265A.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 MEMBERSHIP TESTS YIELD THE CORRECT RESULTS FOR ONE
--- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES WHEN:
--- A) THE SUBTYPE INDICATION DENOTES AN UNCONSTRAINED ARRAY.
--- B) THE SUBTYPE INDICATION DENOTES A CONSTRAINED ARRAY.
-
--- TBN 7/22/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45265A IS
-
- PACKAGE P IS
- TYPE KEY IS LIMITED PRIVATE;
- PRIVATE
- TYPE KEY IS NEW NATURAL;
- END P;
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 20;
- TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER;
- TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER;
- TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>,
- INT RANGE <>) OF INTEGER;
- TYPE ARRAY_TYPE_4 IS ARRAY (INT RANGE <>) OF P.KEY;
- TYPE ARRAY_TYPE_5 IS ARRAY (INT RANGE <>, INT RANGE <>) OF P.KEY;
-
- SUBTYPE ARRAY_SUB1 IS ARRAY_TYPE_1;
- SUBTYPE ARRAY_SUB2 IS ARRAY_TYPE_2;
- SUBTYPE ARRAY_SUB3 IS ARRAY_TYPE_3;
- SUBTYPE ARRAY_SUB4 IS ARRAY_TYPE_4;
- SUBTYPE ARRAY_SUB5 IS ARRAY_TYPE_5;
- SUBTYPE CON_ARRAY1 IS ARRAY_TYPE_1 (1..5);
- SUBTYPE CON_ARRAY2 IS ARRAY_TYPE_2 (1..2, 1..2);
- SUBTYPE CON_ARRAY3 IS ARRAY_TYPE_3 (1..2, 1..3, 1..4);
- SUBTYPE CON_ARRAY4 IS ARRAY_TYPE_4 (1..4);
- SUBTYPE CON_ARRAY5 IS ARRAY_TYPE_5 (1..2, 1..3);
- SUBTYPE NULL_ARRAY1 IS ARRAY_TYPE_1 (2 .. 1);
-
- ARRAY1 : ARRAY_TYPE_1 (1..10);
- ARRAY2 : ARRAY_SUB1 (11..20);
- ARRAY3 : ARRAY_TYPE_2 (1..4, 1..3);
- ARRAY4 : ARRAY_SUB2 (5..7, 5..8);
- ARRAY5 : ARRAY_TYPE_3 (1..2, 1..3, 1..4);
- ARRAY6 : ARRAY_SUB3 (1..3, 1..2, 1..4);
- NULL_ARRAY_1 : ARRAY_TYPE_1 (3..2);
- NULL_ARRAY_2 : ARRAY_SUB1 (2..1);
- ARRAY7 : ARRAY_TYPE_1 (1..10) := (1..10 => 7);
- ARRAY8 : CON_ARRAY1 := (1..5 => 8);
- ARRAY9 : ARRAY_TYPE_2 (1..10, 1..10) := (1..10 => (1..10 => 9));
- ARRAY10 : CON_ARRAY2 := (1..2 => (1..2 => 10));
- ARRAY11 : ARRAY_TYPE_3 (1..10, 1..10, 1..10) := (1..10 =>
- (1..10 => (1..10 => 11)));
- ARRAY12 : CON_ARRAY3 := (1..2 => (1..3 => (1..4 => 12)));
- ARRAY13 : ARRAY_TYPE_4 (1..2);
- ARRAY14 : ARRAY_SUB4 (1..5);
- ARRAY15 : ARRAY_TYPE_4 (1..6);
- ARRAY16 : CON_ARRAY4;
- ARRAY17 : ARRAY_TYPE_5 (1..3, 1..2);
- ARRAY18 : ARRAY_SUB5 (1..2, 1..3);
- ARRAY19 : ARRAY_TYPE_5 (1..4, 1..3);
- ARRAY20 : CON_ARRAY5;
-
-BEGIN
- TEST ("C45265A", "CHECK THAT MEMBERSHIP TESTS YIELD THE CORRECT " &
- "RESULTS FOR ONE DIMENSIONAL AND MULTI-" &
- "DIMENSIONAL ARRAY TYPES");
-
- ARRAY1 := (ARRAY1'RANGE => 1);
- ARRAY2 := (ARRAY2'RANGE => 2);
- ARRAY3 := (ARRAY3'RANGE(1) => (ARRAY3'RANGE(2) => 3));
- ARRAY4 := (ARRAY4'RANGE(1) => (ARRAY4'RANGE(2) => 4));
- ARRAY5 := (ARRAY5'RANGE(1) => (ARRAY5'RANGE(2) =>
- (ARRAY5'RANGE(3) => 5)));
- ARRAY6 := (ARRAY6'RANGE(1) => (ARRAY6'RANGE(2) =>
- (ARRAY6'RANGE(3) => 6)));
-
- IF ARRAY1 IN ARRAY_SUB1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 1");
- END IF;
- IF ARRAY2 NOT IN ARRAY_SUB1 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 2");
- END IF;
-
- IF ARRAY3 IN ARRAY_SUB2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 3");
- END IF;
- IF ARRAY4 NOT IN ARRAY_SUB2 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 4");
- END IF;
-
- IF ARRAY5 IN ARRAY_SUB3 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 5");
- END IF;
- IF ARRAY6 NOT IN ARRAY_SUB3 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 6");
- END IF;
-
- IF NULL_ARRAY_1 IN ARRAY_SUB1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 7");
- END IF;
- IF NULL_ARRAY_2 NOT IN ARRAY_SUB1 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 8");
- END IF;
-
- IF ARRAY7 IN CON_ARRAY1 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 9");
- END IF;
- IF ARRAY8 NOT IN CON_ARRAY1 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 10");
- END IF;
-
- IF ARRAY9 IN CON_ARRAY2 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 11");
- END IF;
- IF ARRAY10 NOT IN CON_ARRAY2 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 12");
- END IF;
-
- IF ARRAY11 IN CON_ARRAY3 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 13");
- END IF;
- IF ARRAY12 NOT IN CON_ARRAY3 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 14");
- END IF;
-
- IF ARRAY13 IN ARRAY_SUB4 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 15");
- END IF;
- IF ARRAY14 NOT IN ARRAY_SUB4 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 16");
- END IF;
-
- IF ARRAY15 IN CON_ARRAY4 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 17");
- END IF;
- IF ARRAY16 NOT IN CON_ARRAY4 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 18");
- END IF;
-
- IF ARRAY17 IN ARRAY_SUB5 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 19");
- END IF;
- IF ARRAY18 NOT IN ARRAY_SUB5 THEN
- FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 20");
- END IF;
-
- IF ARRAY19 IN CON_ARRAY5 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 21");
- END IF;
- IF ARRAY20 NOT IN CON_ARRAY5 THEN
- FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 22");
- END IF;
-
- IF NULL_ARRAY_1 IN NULL_ARRAY1 THEN
- FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 23");
- END IF;
- IF NULL_ARRAY_2 NOT IN NULL_ARRAY1 THEN
- FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 24");
- END IF;
-
- RESULT;
-END C45265A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45271a.ada b/gcc/testsuite/ada/acats/tests/c4/c45271a.ada
deleted file mode 100644
index 8e62199..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45271a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C45271A.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 EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR
--- RECORDS WHOSE COMPONENTS DO NOT HAVE CHANGEABLE DISCRIMINANTS.
-
--- TBN 8/6/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45271A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 20;
- TYPE ARRAY_BOOL IS ARRAY (1 .. 5) OF BOOLEAN;
-
- TYPE REC_TYPE1 IS
- RECORD
- BOOL : ARRAY_BOOL;
- A : INTEGER;
- END RECORD;
-
- TYPE REC_TYPE2 (LEN : INT := 3) IS
- RECORD
- A : STRING (1 .. LEN);
- END RECORD;
-
- TYPE REC_TYPE3 (NUM : INT := 1) IS
- RECORD
- A : REC_TYPE1;
- END RECORD;
-
- REC1, REC2 : REC_TYPE1 := (A => 2, OTHERS => (OTHERS => TRUE));
- REC3, REC4 : REC_TYPE2 (5) := (5, "WHERE");
- REC5, REC6 : REC_TYPE2;
- REC7, REC8 : REC_TYPE3;
- REC9, REC10 : REC_TYPE3 (3) := (NUM => 3, A =>
- (A => 5, BOOL => (OTHERS => FALSE)));
-
-BEGIN
- TEST ("C45271A", "CHECK THAT EQUALITY AND INEQUALITY ARE " &
- "EVALUATED CORRECTLY FOR RECORDS WHOSE " &
- "COMPONENTS DO NOT HAVE CHANGEABLE " &
- "DISCRIMINANTS");
-
- IF "/=" (LEFT => REC1, RIGHT => REC2) THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 1");
- END IF;
- REC1.A := IDENT_INT(1);
- IF "=" (LEFT => REC2, RIGHT => REC1) THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 2");
- END IF;
-
- IF REC3 /= REC4 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 3");
- END IF;
- REC4.A := IDENT_STR("12345");
- IF REC3 = REC4 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 4");
- END IF;
-
- REC5.A := IDENT_STR("WHO");
- REC6.A := IDENT_STR("WHY");
- IF REC5 = REC6 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 5");
- END IF;
- REC5.A := "WHY";
- IF REC6 /= REC5 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 6");
- END IF;
-
- REC7.A.A := IDENT_INT(1);
- REC7.A.BOOL := (OTHERS => IDENT_BOOL(TRUE));
- REC8.A.A := 1;
- REC8.A.BOOL := (OTHERS => TRUE);
- IF REC7 /= REC8 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 7");
- END IF;
- REC8.A.BOOL := (OTHERS => IDENT_BOOL(FALSE));
- IF REC8 = REC7 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 8");
- END IF;
-
- IF "/=" (LEFT => REC9, RIGHT => REC10) THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 9");
- END IF;
- REC9.A.A := IDENT_INT(1);
- IF "=" (LEFT => REC9, RIGHT => REC10) THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 10");
- END IF;
-
- RESULT;
-END C45271A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45272a.ada b/gcc/testsuite/ada/acats/tests/c4/c45272a.ada
deleted file mode 100644
index 447d468..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45272a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C45272A.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 EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR
--- RECORDS WHOSE COMPONENTS HAVE CHANGEABLE DISCRIMINANTS, INCLUDING
--- RECORDS DESIGNATED BY ACCESS VALUES.
-
--- TBN 8/7/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45272A IS
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 20;
- TYPE VARSTR (LEN : INT := 0) IS
- RECORD
- VAL : STRING (1..LEN);
- END RECORD;
- TYPE VARREC IS
- RECORD
- A, B : VARSTR;
- END RECORD;
-
- TYPE CELL2;
- TYPE LINK IS ACCESS CELL2;
- TYPE CELL1 (NAM_LEN : INT := 0) IS
- RECORD
- NAME : STRING (1..NAM_LEN);
- END RECORD;
- TYPE CELL2 IS
- RECORD
- ONE : CELL1;
- TWO : CELL1;
- NEW_LINK : LINK;
- END RECORD;
-
- X, Y : VARREC;
- FRONT : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL);
- BACK : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL);
-
-BEGIN
- TEST ("C45272A", "CHECK THAT EQUALITY AND INEQUALITY ARE " &
- "EVALUATED CORRECTLY FOR RECORDS WHOSE " &
- "COMPONENTS HAVE CHANGEABLE DISCRIMINANTS");
-
- X := ((5, "AAAXX"), (5, "BBBYY"));
- Y := ((5, "AAAZZ"), (5, "BBBYY"));
- IF X = Y THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 1");
- END IF;
-
- X.A := (3, "HHH");
- Y.A := (IDENT_INT(3), IDENT_STR("HHH"));
- IF X /= Y THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 2");
- END IF;
-
- IF FRONT.ALL /= BACK.ALL THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 3");
- END IF;
-
- BACK.NEW_LINK := FRONT;
- IF FRONT.ALL = BACK.ALL THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 4");
- END IF;
-
- FRONT.NEW_LINK := FRONT;
- IF FRONT.ALL /= BACK.ALL THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 5");
- END IF;
-
- FRONT.ONE := (5, "XXXXX");
- BACK.ONE := (5, "ZZZZZ");
- IF FRONT.ALL = BACK.ALL THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 6");
- END IF;
-
- FRONT.ONE := (3, "XXX");
- BACK.ONE := (3, "XXX");
- IF FRONT.ALL /= BACK.ALL THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 7");
- END IF;
-
- RESULT;
-END C45272A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45273a.ada b/gcc/testsuite/ada/acats/tests/c4/c45273a.ada
deleted file mode 100644
index ae74c29..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45273a.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- C45273A.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 EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR
--- RECORD OBJECTS HAVING DIFFERENT VALUES OF THE 'CONSTRAINED
--- ATTRIBUTE.
-
--- HISTORY:
--- TBN 08/07/86 CREATED ORIGINAL TEST.
--- VCL 10/27/87 MODIFIED THIS HEADER; RELOCATED THE CALL TO
--- REPORT.TEST SO THAT IT COMES BEFORE ANY
--- DECLARATIONS; CHANGED THE 'ELSEIF' CONDITION IN
--- THE PROCEDURE 'PROC' SO THAT IT REFERS TO THE
--- FORMAL PARAMETERS.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45273A IS
-BEGIN
- TEST ("C45273A", "EQUALITY AND INEQUALITY ARE " &
- "EVALUATED CORRECTLY FOR RECORD OBJECTS HAVING " &
- "DIFFERENT VALUES OF THE 'CONSTRAINED' " &
- " ATTRIBUTE");
-
- DECLARE
- SUBTYPE INT IS INTEGER RANGE 1 .. 20;
- TYPE REC_TYPE1 IS
- RECORD
- A : INTEGER;
- END RECORD;
-
- TYPE REC_TYPE2 (LEN : INT := 3) IS
- RECORD
- A : STRING (1 .. LEN);
- END RECORD;
-
- TYPE REC_TYPE3 (NUM : INT := 1) IS
- RECORD
- A : REC_TYPE1;
- END RECORD;
-
- REC1 : REC_TYPE2 (3) := (3, "WHO");
- REC2 : REC_TYPE2;
- REC3 : REC_TYPE2 (5) := (5, "WHERE");
- REC4 : REC_TYPE3;
- REC5 : REC_TYPE3 (1) := (1, A => (A => 5));
-
- PROCEDURE PROC (PREC1 : REC_TYPE2;
- PREC2 : IN OUT REC_TYPE2) IS
- BEGIN
- IF NOT (PREC1'CONSTRAINED) OR PREC2'CONSTRAINED THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 6");
- ELSIF PREC1 /= PREC2 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 6");
- END IF;
- PREC2.A := "WHO";
- END PROC;
-
- BEGIN
- REC2.A := "WHO";
- IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 1");
- ELSIF REC1 /= REC2 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 1");
- END IF;
-
- IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 2");
- ELSIF REC2 = REC3 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 2");
- END IF;
-
- REC2 := (5, "WHERE");
- IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 3");
- ELSIF REC2 /= REC3 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 3");
- END IF;
-
- REC4.A.A := 5;
- IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 4");
- ELSIF REC4 /= REC5 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 4");
- END IF;
-
- REC5.A := (A => 6);
- IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 5");
- ELSIF REC4 = REC5 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 5");
- END IF;
-
- REC1.A := "WHY";
- REC2 := (3, "WHY");
- PROC (REC1, REC2);
- IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN
- FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " &
- "ATTRIBUTE - 7");
- ELSIF REC1 = REC2 THEN
- FAILED ("INCORRECT RESULTS FOR RECORDS - 7");
- END IF;
- END;
-
- RESULT;
-END C45273A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274a.ada b/gcc/testsuite/ada/acats/tests/c4/c45274a.ada
deleted file mode 100644
index ea74731..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45274a.ada
+++ /dev/null
@@ -1,222 +0,0 @@
--- C45274A.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 MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS
--- YIELDS TRUE (RESP. FALSE ) FOR
---
--->> * RECORD TYPES WITHOUT DISCRIMINANTS;
--->> * PRIVATE TYPES WITHOUT DISCRIMINANTS;
--->> * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS;
--- * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS;
--- * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS;
--- * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS.
-
-
--- RM 3/01/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C45274A IS
-
-
-BEGIN
-
- TEST ( "C45274A" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " &
- " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" &
- " FOR RECORD TYPES WITHOUT DISCRIMINANTS," &
- " PRIVATE TYPES WITHOUT DISCRIMINANTS, AND" &
- " LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS");
-
-
- -------------------------------------------------------------------
- ----------------- RECORD TYPES WITHOUT DISCRIMINANTS ------------
-
- DECLARE
-
- TYPE REC IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
-
- X : REC := ( 19 , 91 );
-
- BEGIN
-
- IF X IN REC THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 1" );
- END IF;
-
- IF X NOT IN REC THEN
- FAILED( "WRONG VALUE: 'NOT IN', 1" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
- ----------------- PRIVATE TYPES WITHOUT DISCRIMINANTS -----------
-
- DECLARE
-
- PACKAGE P IS
- TYPE PRIV IS PRIVATE;
- PRIVATE
- TYPE PRIV IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- X : PRIV ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN PRIV THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 2" );
- END IF;
-
- IF X NOT IN PRIV THEN
- FAILED( "WRONG VALUE: 'NOT IN', 2" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
- -------------------------------------------------------------------
- --------- LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS -----------
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- X : LP ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN LP THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 3" );
- END IF;
-
- IF X NOT IN LP THEN
- FAILED( "WRONG VALUE: 'NOT IN', 3" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- Y : LP ;
-
- -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE
- BEGIN
-
- IF Y IN LP THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 3BIS" );
- END IF;
-
- IF Y NOT IN LP THEN
- FAILED( "WRONG VALUE: 'NOT IN', 3BIS" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " &
- "( 'NOT IN' ) RAISED AN EXCEPTION" );
-
- END;
-
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C45274A ;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274b.ada b/gcc/testsuite/ada/acats/tests/c4/c45274b.ada
deleted file mode 100644
index 4833b6d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45274b.ada
+++ /dev/null
@@ -1,229 +0,0 @@
--- C45274B.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 MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS
--- YIELDS TRUE (RESP. FALSE ) FOR
---
--- * RECORD TYPES WITHOUT DISCRIMINANTS;
--- * PRIVATE TYPES WITHOUT DISCRIMINANTS;
--- * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS;
--->> * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS;
--->> * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS;
--->> * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS.
-
-
--- RM 3/03/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C45274B IS
-
-
-BEGIN
-
- TEST ( "C45274B" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " &
- " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" &
- " FOR UNCONSTRAINED TYPES WITH DISCRIMINANTS" );
-
-
- -------------------------------------------------------------------
- -------- UNCONSTRAINED RECORD TYPES WITH DISCRIMINANTS ----------
-
- DECLARE
-
- TYPE REC ( DISCR : BOOLEAN ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
-
- X : REC(FALSE) := ( FALSE , 19 , 81 );
-
- TYPE REC0 ( DISCR : BOOLEAN := FALSE ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
-
- Y : REC0 := ( TRUE , 19 , 81 );
-
- BEGIN
-
- IF X IN REC THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 1A" );
- END IF;
-
- IF Y NOT IN REC0 THEN
- FAILED( "WRONG VALUE: 'NOT IN', 1B" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
- ------- UNCONSTRAINED PRIVATE TYPES WITH DISCRIMINANTS ----------
-
- DECLARE
-
- PACKAGE P IS
- TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE;
- PRIVATE
- TYPE PRIV ( DISCR : BOOLEAN ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- X : PRIV(FALSE) ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( FALSE , 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN PRIV THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 2" );
- END IF;
-
- IF X NOT IN PRIV THEN
- FAILED( "WRONG VALUE: 'NOT IN', 2" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
- --------- UNCONSTRAINED LIM. PRIV. TYPES WITH DISCRIM. ----------
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- X : LP(TRUE) ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( TRUE , 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN LP THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 3" );
- END IF;
-
- IF X NOT IN LP THEN
- FAILED( "WRONG VALUE: 'NOT IN', 3" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- Y : LP(TRUE) ;
-
- -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE
- BEGIN
-
- IF Y IN LP THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 3BIS" );
- END IF;
-
- IF Y NOT IN LP THEN
- FAILED( "WRONG VALUE: 'NOT IN', 3BIS" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " &
- "( 'NOT IN' ) RAISED AN EXCEPTION" );
-
- END;
-
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C45274B ;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274c.ada b/gcc/testsuite/ada/acats/tests/c4/c45274c.ada
deleted file mode 100644
index 6470897..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45274c.ada
+++ /dev/null
@@ -1,187 +0,0 @@
--- C45274C.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 MEMBERSHIP OPERATOR IN ( NOT IN )
--- YIELDS TRUE (RESP. FALSE ) IF THE DISCRIMINANTS OF THE LEFT
--- VALUE EQUAL THE DISCRIMINANTS OF THE SUBTYPE INDICATION.
---
---
--- * RECORD TYPES WITH DISCRIMINANTS;
--- * PRIVATE TYPES WITH DISCRIMINANTS;
--- * LIMITED PRIVATE TYPES WITH DISCRIMINANTS.
-
-
--- RM 3/01/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C45274C IS
-
-
-BEGIN
-
- TEST ( "C45274C" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " &
- " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" &
- " IF THE DISCRIMINANTS OF THE LEFT VALUE" &
- " EQUAL THE DISCRIMINANTS OF THE SUBTYPE" &
- " INDICATION" );
-
-
- -------------------------------------------------------------------
- ----------------- RECORD TYPES WITH DISCRIMINANTS ---------------
-
- DECLARE
-
- TYPE REC ( DISCR : BOOLEAN := FALSE ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
-
- SUBTYPE RECTRUE IS REC(TRUE) ;
-
- X : REC := ( TRUE , 19 , 91 );
-
- BEGIN
-
- IF X IN RECTRUE THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 1" );
- END IF;
-
- IF X NOT IN RECTRUE THEN
- FAILED( "WRONG VALUE: 'NOT IN', 1" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
- ----------------- PRIVATE TYPES WITH DISCRIMINANTS --------------
-
- DECLARE
-
- PACKAGE P IS
- TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE;
- PRIVATE
- TYPE PRIV ( DISCR : BOOLEAN ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- SUBTYPE PRIVTRUE IS PRIV( IDENT_BOOL(TRUE) );
-
- X : PRIV(TRUE) ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( TRUE , 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN PRIVTRUE THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'IN', 2" );
- END IF;
-
- IF X NOT IN PRIVTRUE THEN
- FAILED( "WRONG VALUE: 'NOT IN', 2" );
- ELSE
- NULL;
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
- -------------------------------------------------------------------
- --------- LIMITED PRIVATE TYPES WITH DISCRIMINANTS --------------
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP ( DISCR : BOOLEAN := FALSE ) IS
- RECORD
- A , B : INTEGER ;
- END RECORD ;
- END P ;
-
- USE P ;
-
- SUBTYPE LPFALSE IS LP(FALSE) ;
-
- X : LP(TRUE) ;
-
- PACKAGE BODY P IS
- BEGIN
- X := ( IDENT_BOOL(TRUE) , 19 , 91 );
- END P ;
-
- BEGIN
-
- IF X IN LPFALSE THEN
- FAILED( "WRONG VALUE: 'IN', 3" );
- ELSE
- NULL;
- END IF;
-
- IF X NOT IN LPFALSE THEN
- NULL;
- ELSE
- FAILED( "WRONG VALUE: 'NOT IN', 3" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION");
-
- END;
-
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C45274C ;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45281a.ada b/gcc/testsuite/ada/acats/tests/c4/c45281a.ada
deleted file mode 100644
index 24353f1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45281a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C45281A.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 EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR ACCESS
--- TYPES.
-
--- TBN 8/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45281A IS
-
- TYPE STR_NAME IS ACCESS STRING;
-
- TYPE GENDER IS (F, M);
- TYPE PERSON (SEX : GENDER) IS
- RECORD
- NAME : STRING (1..6) := "NONAME";
- END RECORD;
-
- TYPE PERSON_NAME IS ACCESS PERSON;
- SUBTYPE MALE IS PERSON_NAME (M);
- SUBTYPE FEMALE IS PERSON_NAME (F);
-
- S : STR_NAME (1..10) := NEW STRING'("0123456789");
- T : STR_NAME (1..10) := S;
- A : MALE;
- B : FEMALE;
- C : PERSON_NAME;
-
-BEGIN
- TEST ("C45281A", "CHECK THAT EQUALITY AND INEQUALITY ARE " &
- "EVALUATED CORRECTLY FOR ACCESS TYPES");
-
- IF "/=" (LEFT => S, RIGHT => T) THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 1");
- END IF;
- T := NEW STRING'("0123456789");
- IF "=" (S, T) THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 2");
- END IF;
-
- IF A /= B THEN
- FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 3");
- END IF;
- IF A /= C THEN
- FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 4");
- END IF;
-
- A := NEW PERSON'(M, "THOMAS");
- IF "=" (LEFT => A, RIGHT => B) THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 5");
- END IF;
- C := A;
- IF C /= A THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 6");
- END IF;
- C := NEW PERSON'(M, "THOMAS");
- IF A = C THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 7");
- END IF;
-
- RESULT;
-END C45281A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45282a.ada b/gcc/testsuite/ada/acats/tests/c4/c45282a.ada
deleted file mode 100644
index e248e3a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45282a.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C45282A.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 AND NOT IN ARE EVALUATED CORRECTLY FOR :
--- A) ACCESS TO SCALAR TYPES;
--- B) ACCESS TO ARRAY TYPES (CONSTRAINED AND UNCONSTRAINED);
--- C) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT
--- DISCRIMINANTS;
-
--- TBN 8/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45282A IS
-
- PACKAGE P IS
- TYPE KEY IS PRIVATE;
- FUNCTION INIT_KEY (X : NATURAL) RETURN KEY;
- TYPE NEWKEY IS LIMITED PRIVATE;
- TYPE ACC_NKEY IS ACCESS NEWKEY;
- PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY);
- PRIVATE
- TYPE KEY IS NEW NATURAL;
- TYPE NEWKEY IS NEW KEY;
- END P;
-
- USE P;
- SUBTYPE I IS INTEGER;
- TYPE ACC_INT IS ACCESS I;
- P_INT : ACC_INT;
- SUBTYPE INT IS INTEGER RANGE 1 .. 5;
- TYPE ARRAY_TYPE1 IS ARRAY (INT RANGE <>) OF INTEGER;
- TYPE ACC_ARA_1 IS ACCESS ARRAY_TYPE1;
- SUBTYPE ACC_ARA_2 IS ACC_ARA_1 (1 .. 2);
- SUBTYPE ACC_ARA_3 IS ACC_ARA_1 (1 .. 3);
- ARA1 : ACC_ARA_1;
- ARA2 : ACC_ARA_2;
- ARA3 : ACC_ARA_3;
- TYPE GREET IS
- RECORD
- NAME : STRING (1 .. 2);
- END RECORD;
- TYPE ACC_GREET IS ACCESS GREET;
- INTRO : ACC_GREET;
- TYPE ACC_KEY IS ACCESS KEY;
- KEY1 : ACC_KEY;
- KEY2 : ACC_NKEY;
-
- PACKAGE BODY P IS
- FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS
- BEGIN
- RETURN (KEY(X));
- END INIT_KEY;
-
- PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY) IS
- BEGIN
- Y.ALL := NEWKEY (1);
- END ASSIGN_NEWKEY;
- END P;
-
-BEGIN
-
- TEST ("C45282A", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " &
- "ACCESS TYPES TO SCALAR TYPES, ARRAY TYPES, " &
- "RECORD TYPES, PRIVATE TYPES, AND LIMITED " &
- "PRIVATE TYPES WITHOUT DISCRIMINANTS");
-
--- CASE A
- IF P_INT NOT IN ACC_INT THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1");
- END IF;
- P_INT := NEW INT'(5);
- IF P_INT IN ACC_INT THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2");
- END IF;
-
--- CASE B
- IF ARA1 NOT IN ACC_ARA_1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3");
- END IF;
- IF ARA1 NOT IN ACC_ARA_2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4");
- END IF;
- IF ARA1 IN ACC_ARA_3 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5");
- END IF;
- IF ARA2 IN ACC_ARA_1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6");
- END IF;
- IF ARA3 NOT IN ACC_ARA_1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7");
- END IF;
- ARA1 := NEW ARRAY_TYPE1'(1, 2, 3);
- IF ARA1 IN ACC_ARA_1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8");
- END IF;
- IF ARA1 IN ACC_ARA_2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9");
- END IF;
- IF ARA1 NOT IN ACC_ARA_3 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10");
- END IF;
- ARA2 := NEW ARRAY_TYPE1'(1, 2);
- IF ARA2 NOT IN ACC_ARA_1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11");
- END IF;
- IF ARA2 NOT IN ACC_ARA_2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12");
- END IF;
-
--- CASE C
- IF INTRO NOT IN ACC_GREET THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13");
- END IF;
- INTRO := NEW GREET'(NAME => "HI");
- IF INTRO IN ACC_GREET THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14");
- END IF;
- IF KEY1 NOT IN ACC_KEY THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15");
- END IF;
- KEY1 := NEW KEY'(INIT_KEY (1));
- IF KEY1 IN ACC_KEY THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16");
- END IF;
- IF KEY2 NOT IN ACC_NKEY THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17");
- END IF;
- KEY2 := NEW NEWKEY;
- ASSIGN_NEWKEY (KEY2);
- IF KEY2 IN ACC_NKEY THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18");
- END IF;
-
- RESULT;
-END C45282A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45282b.ada b/gcc/testsuite/ada/acats/tests/c4/c45282b.ada
deleted file mode 100644
index af3a2bf..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45282b.ada
+++ /dev/null
@@ -1,347 +0,0 @@
--- C45282B.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 AND NOT IN ARE EVALUATED CORRECTLY FOR :
--- D) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH
--- DISCRIMINANTS (WITH AND WITHOUT DEFAULT VALUES), WHERE THE
--- TYPE MARK DENOTES A CONSTRAINED AND UNCONSTRAINED TYPE;
--- E) ACCESS TO TASK TYPES.
-
--- TBN 8/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45282B IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 5;
-
- PACKAGE P IS
- TYPE PRI_REC1 (D : INT) IS PRIVATE;
- TYPE PRI_REC2 (D : INT := 2) IS PRIVATE;
- FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1;
- FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2;
- TYPE LIM_REC1 (D : INT) IS LIMITED PRIVATE;
- TYPE ACC_LIM1 IS ACCESS LIM_REC1;
- SUBTYPE ACC_SUB_LIM1 IS ACC_LIM1 (2);
- PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING);
- TYPE LIM_REC2 (D : INT := 2) IS LIMITED PRIVATE;
- TYPE ACC_LIM2 IS ACCESS LIM_REC2;
- SUBTYPE ACC_SUB_LIM2 IS ACC_LIM2 (2);
- PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING);
- PRIVATE
- TYPE PRI_REC1 (D : INT) IS
- RECORD
- STR : STRING (1 .. D);
- END RECORD;
- TYPE PRI_REC2 (D : INT := 2) IS
- RECORD
- STR : STRING (1 .. D);
- END RECORD;
- TYPE LIM_REC1 (D : INT) IS
- RECORD
- STR : STRING (1 .. D);
- END RECORD;
- TYPE LIM_REC2 (D : INT := 2) IS
- RECORD
- STR : STRING (1 .. D);
- END RECORD;
- END P;
-
- USE P;
-
- TYPE DIS_REC1 (D : INT) IS
- RECORD
- STR : STRING (1 .. D);
- END RECORD;
- TYPE DIS_REC2 (D : INT := 5) IS
- RECORD
- STR : STRING (D .. 8);
- END RECORD;
-
- TYPE ACC1_REC1 IS ACCESS DIS_REC1;
- SUBTYPE ACC2_REC1 IS ACC1_REC1 (2);
- TYPE ACC1_REC2 IS ACCESS DIS_REC2;
- SUBTYPE ACC2_REC2 IS ACC1_REC2 (2);
- REC1 : ACC1_REC1;
- REC2 : ACC2_REC1;
- REC3 : ACC1_REC2;
- REC4 : ACC2_REC2;
- TYPE ACC_PREC1 IS ACCESS PRI_REC1;
- SUBTYPE ACC_SREC1 IS ACC_PREC1 (2);
- REC5 : ACC_PREC1;
- REC6 : ACC_SREC1;
- TYPE ACC_PREC2 IS ACCESS PRI_REC2;
- SUBTYPE ACC_SREC2 IS ACC_PREC2 (2);
- REC7 : ACC_PREC2;
- REC8 : ACC_SREC2;
- REC9 : ACC_LIM1;
- REC10 : ACC_SUB_LIM1;
- REC11 : ACC_LIM2;
- REC12 : ACC_SUB_LIM2;
-
- TASK TYPE T IS
- ENTRY E (X : INTEGER);
- END T;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E (X : INTEGER) DO
- IF X /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE PASSED TO TASK");
- END IF;
- END E;
- END T;
-
- PACKAGE BODY P IS
- FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1 IS
- REC : PRI_REC1 (A);
- BEGIN
- REC := (A, B);
- RETURN (REC);
- END INIT_PREC1;
-
- FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2 IS
- REC : PRI_REC2;
- BEGIN
- REC := (A, B);
- RETURN (REC);
- END INIT_PREC2;
-
- PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING) IS
- BEGIN
- A.ALL := (B, C);
- END ASSIGN_LIM1;
-
- PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING) IS
- BEGIN
- A.ALL := (B, C);
- END ASSIGN_LIM2;
- END P;
-
-BEGIN
-
- TEST ("C45282B", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " &
- "ACCESS TYPES TO RECORD TYPES, PRIVATE TYPES, " &
- "LIMITED PRIVATE TYPES WITH DISCRIMINANTS, AND " &
- "TASK TYPES");
-
--- CASE D
-------------------------------------------------------------------------
- IF REC1 NOT IN ACC1_REC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1");
- END IF;
- IF REC1 IN ACC2_REC1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2");
- END IF;
- IF REC2 NOT IN ACC1_REC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3");
- END IF;
- REC1 := NEW DIS_REC1'(5, "12345");
- IF REC1 IN ACC1_REC1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4");
- END IF;
- IF REC1 IN ACC2_REC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5");
- END IF;
- REC2 := NEW DIS_REC1'(2, "HI");
- IF REC2 IN ACC1_REC1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6");
- END IF;
-
-------------------------------------------------------------------------
-
- IF REC3 IN ACC1_REC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7");
- END IF;
- IF REC3 NOT IN ACC2_REC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8");
- END IF;
- IF REC4 IN ACC1_REC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9");
- END IF;
- REC3 := NEW DIS_REC2'(5, "5678");
- IF REC3 IN ACC1_REC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10");
- END IF;
- IF REC3 IN ACC2_REC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11");
- END IF;
- REC4 := NEW DIS_REC2'(2, "2345678");
- IF REC4 IN ACC1_REC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12");
- END IF;
- IF REC4 NOT IN ACC2_REC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13");
- END IF;
-
-------------------------------------------------------------------------
-
- IF REC5 NOT IN ACC_PREC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14");
- END IF;
- IF REC5 NOT IN ACC_SREC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15");
- END IF;
- IF REC6 NOT IN ACC_PREC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16");
- END IF;
- REC5 := NEW PRI_REC1'(INIT_PREC1 (5, "12345"));
- IF REC5 IN ACC_PREC1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17");
- END IF;
- IF REC5 IN ACC_SREC1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18");
- END IF;
- REC6 := NEW PRI_REC1'(INIT_PREC1 (2, "HI"));
- IF REC6 IN ACC_PREC1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 19");
- END IF;
-
-------------------------------------------------------------------------
-
- IF REC7 NOT IN ACC_PREC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 20");
- END IF;
- IF REC7 NOT IN ACC_SREC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 21");
- END IF;
- IF REC8 NOT IN ACC_PREC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 22");
- END IF;
- REC7 := NEW PRI_REC2'(INIT_PREC2 (5, "12345"));
- IF REC7 IN ACC_PREC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 23");
- END IF;
- IF REC7 IN ACC_SREC2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 24");
- END IF;
- REC8 := NEW PRI_REC2'(INIT_PREC2 (2, "HI"));
- IF REC8 IN ACC_PREC2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 25");
- END IF;
-
-------------------------------------------------------------------------
-
- IF REC9 NOT IN ACC_LIM1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 26");
- END IF;
- IF REC9 NOT IN ACC_SUB_LIM1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 27");
- END IF;
- IF REC10 NOT IN ACC_LIM1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 28");
- END IF;
- REC9 := NEW LIM_REC1 (5);
- ASSIGN_LIM1 (REC9, 5, "12345");
- IF REC9 IN ACC_LIM1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 29");
- END IF;
- IF REC9 IN ACC_SUB_LIM1 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 30");
- END IF;
- REC10 := NEW LIM_REC1 (2);
- ASSIGN_LIM1 (REC10, 2, "12");
- IF REC10 IN ACC_LIM1 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 31");
- END IF;
-
-------------------------------------------------------------------------
-
- IF REC11 NOT IN ACC_LIM2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 32");
- END IF;
- IF REC11 NOT IN ACC_SUB_LIM2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 33");
- END IF;
- IF REC12 NOT IN ACC_LIM2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 34");
- END IF;
- REC11 := NEW LIM_REC2;
- IF REC11 NOT IN ACC_SUB_LIM2 THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 35");
- END IF;
- ASSIGN_LIM2 (REC11, 2, "12");
- IF REC11 IN ACC_LIM2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 36");
- END IF;
- IF REC11 IN ACC_SUB_LIM2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 37");
- END IF;
- REC12 := NEW LIM_REC2;
- ASSIGN_LIM2 (REC12, 2, "12");
- IF REC12 IN ACC_LIM2 THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38");
- END IF;
-
--- CASE E
-------------------------------------------------------------------------
- DECLARE
- TYPE ACC_TASK IS ACCESS T;
- T1 : ACC_TASK;
- BEGIN
- IF T1 NOT IN ACC_TASK THEN
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 39");
- END IF;
- T1 := NEW T;
- IF T1 IN ACC_TASK THEN
- NULL;
- ELSE
- FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38");
- END IF;
- T1.E (1);
- END;
-
- RESULT;
-END C45282B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45291a.ada b/gcc/testsuite/ada/acats/tests/c4/c45291a.ada
deleted file mode 100644
index 86c9eb2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45291a.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C45291A.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 MEMBERSHIP TESTS YIELD CORRECT RESULTS FOR TASK
--- TYPES, LIMITED PRIVATE TYPES, COMPOSITE LIMITED TYPES, AND
--- PRIVATE TYPES WITHOUT DISCRIMINANTS.
-
--- HISTORY:
--- JET 08/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45291A IS
-
- TASK TYPE TASK1 IS
- ENTRY E;
- END TASK1;
-
- PACKAGE PACK IS
- TYPE LIM_PRIV IS LIMITED PRIVATE;
- TYPE LIM_COMP IS ARRAY (1..10) OF LIM_PRIV;
- TYPE PRIV IS PRIVATE;
- PROCEDURE INIT(LP : OUT LIM_PRIV;
- LC : IN OUT LIM_COMP;
- P : OUT PRIV);
- PRIVATE
- TYPE LIM_PRIV IS RANGE -100..100;
- TYPE PRIV IS RECORD
- I : INTEGER;
- END RECORD;
- END PACK;
-
- SUBTYPE SUB_TASK1 IS TASK1;
- SUBTYPE SUB_LIM_PRIV IS PACK.LIM_PRIV;
- SUBTYPE SUB_LIM_COMP IS PACK.LIM_COMP;
- SUBTYPE SUB_PRIV IS PACK.PRIV;
-
- T1 : TASK1;
- LP : PACK.LIM_PRIV;
- LC : PACK.LIM_COMP;
- P : PACK.PRIV;
-
- TASK BODY TASK1 IS
- BEGIN
- ACCEPT E DO
- NULL;
- END E;
- END TASK1;
-
- PACKAGE BODY PACK IS
- PROCEDURE INIT (LP : OUT LIM_PRIV;
- LC : IN OUT LIM_COMP;
- P : OUT PRIV) IS
- BEGIN
- LP := 0;
- LC := (OTHERS => 0);
- P := (I => 0);
- END INIT;
- END PACK;
-
-BEGIN
- TEST ("C45291A", "CHECK THAT THE MEMBERSHIP TESTS YIELD CORRECT " &
- "RESULTS FOR TASK TYPES, LIMITED PRIVATE TYPES," &
- " COMPOSITE LIMITED TYPES, AND PRIVATE TYPES " &
- "WITHOUT DISCRIMINANTS");
-
- PACK.INIT(LP, LC, P);
-
- IF NOT IDENT_BOOL(T1 IN TASK1) THEN
- FAILED ("INCORRECT VALUE OF 'T1 IN TASK1'");
- END IF;
-
- IF IDENT_BOOL(T1 NOT IN TASK1) THEN
- FAILED ("INCORRECT VALUE OF 'T1 NOT IN TASK1'");
- END IF;
-
- IF NOT IDENT_BOOL(LP IN PACK.LIM_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'LP IN LIM_PRIV'");
- END IF;
-
- IF IDENT_BOOL(LP NOT IN PACK.LIM_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'LP NOT IN LIM_PRIV'");
- END IF;
-
- IF NOT IDENT_BOOL(LC IN PACK.LIM_COMP) THEN
- FAILED ("INCORRECT VALUE OF 'LC IN LIM_COMP'");
- END IF;
-
- IF IDENT_BOOL(LC NOT IN PACK.LIM_COMP) THEN
- FAILED ("INCORRECT VALUE OF 'LC NOT IN LIM_COMP'");
- END IF;
-
- IF NOT IDENT_BOOL(P IN PACK.PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'P IN PRIV'");
- END IF;
-
- IF IDENT_BOOL(P NOT IN PACK.PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'P NOT IN PRIV'");
- END IF;
-
- IF NOT IDENT_BOOL(T1 IN SUB_TASK1) THEN
- FAILED ("INCORRECT VALUE OF 'T1 IN SUB_TASK1'");
- END IF;
-
- IF IDENT_BOOL(T1 NOT IN SUB_TASK1) THEN
- FAILED ("INCORRECT VALUE OF 'T1 NOT IN SUB_TASK1'");
- END IF;
-
- IF NOT IDENT_BOOL(LP IN SUB_LIM_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'LP IN SUB_LIM_PRIV'");
- END IF;
-
- IF IDENT_BOOL(LP NOT IN SUB_LIM_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'LP NOT IN SUB_LIM_PRIV'");
- END IF;
-
- IF NOT IDENT_BOOL(LC IN SUB_LIM_COMP) THEN
- FAILED ("INCORRECT VALUE OF 'LC IN SUB_LIM_COMP'");
- END IF;
-
- IF IDENT_BOOL(LC NOT IN SUB_LIM_COMP) THEN
- FAILED ("INCORRECT VALUE OF 'LC NOT IN SUB_LIM_COMP'");
- END IF;
-
- IF NOT IDENT_BOOL(P IN SUB_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'P IN SUB_PRIV'");
- END IF;
-
- IF IDENT_BOOL(P NOT IN SUB_PRIV) THEN
- FAILED ("INCORRECT VALUE OF 'P NOT IN SUB_PRIV'");
- END IF;
-
- T1.E;
-
- RESULT;
-
-END C45291A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c453001.a b/gcc/testsuite/ada/acats/tests/c4/c453001.a
deleted file mode 100644
index 53f4584..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c453001.a
+++ /dev/null
@@ -1,236 +0,0 @@
--- C453001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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.
---
--- Notice
---
--- The ACAA has created and maintains the Ada Conformity Assessment Test
--- Suite for the purpose of conformity assessments conducted in accordance
--- with the International Standard ISO/IEC 18009 - Ada: Conformity
--- assessment of a language processor. This test suite should not be used
--- to make claims of conformance unless used in accordance with
--- ISO/IEC 18009 and any applicable ACAA procedures.
---*
--- OBJECTIVES:
--- Check that overflow checking is not performed for adding operators of
--- modular types.
---
--- TEST DESCRIPTION:
--- Check that Constraint_Error is not raised by + or - when the result
--- is out of the range of the base type.
--- Also check that assignment to values in the upper half of the range
--- does not raise Constraint_Error.
---
--- We define modular types of various common sizes. We cannot
--- assume a binary modulus greater than 2**16 is supported by 3.5.4(23),
--- so the DWord type might be smaller on some targets. We also try
--- a small prime number as a modulus (these are often used for hashing).
--- We also the language-defined types
--- System.Storage_Elements.Storage_Element, Ada.Streams.Stream_Element,
--- and Ada.Containers.Hash_Type.
---
--- CHANGE HISTORY:
--- 11 Feb 17 JAC Initial pre-release version.
--- 30 Mar 17 RLB Renamed, removed non-modular test cases, removed
--- types that aren't required to be supported, added
--- other language-defined types, added key to locate
--- failures, added additional test cases.
--- 03 Apr 17 RLB Removed Ada.Containers from the Ada 95 version of
--- this test.
---
---!
-with Report;
-with System.Storage_Elements;
-with Ada.Streams;
-
-procedure C453001 is
- type Unsigned_Byte_Type is mod 16#100#; -- 256;
-
- type Unsigned_Word_Type is mod 16#1_0000#; -- 65536;
-
- type Unsigned_DWord_Type is mod
- Natural'Min (2**32, System.Max_Binary_Modulus);
-
- type Unsigned_NBM_Type is mod System.Max_Nonbinary_Modulus;
-
- type Biggest_Unsigned_Type is mod System.Max_Binary_Modulus;
-
- type Prime_Type is mod 23; -- Prime number for hashing.
-
- generic
- type Mod_Type is mod <>; -- Assume this is a base type.
- Key : in String;
- procedure Test_Operators;
-
- procedure Test_Operators is
-
- function Ident_Mod (Val : in Mod_Type) return Mod_Type is
- -- Optimization breaker.
- begin
- if Report.Equal (4, 12) then -- Always False (but complex).
- return 1;
- else
- return Val;
- end if;
- end Ident_Mod;
-
- begin
- if Mod_Type'First /= 0 then -- The First of a base type is always 0.
- Report.Failed ("Not base type first - " & Key);
- end if;
- if Mod_Type'Last /= Mod_Type'Base'Last then
- Report.Failed ("Not base type last - " & Key);
- end if;
-
- -- Note: Mod_Type'First always is 0.
-
- -- Check addition
- declare
- M : constant Mod_Type := Mod_Type'Last;
- V : Mod_Type;
- begin
- V := M + 1; -- Should wrap around
- if Ident_Mod (V) /= 0 then
- Report.Failed ("Addition didn't wrap round - " & Key);
- end if;
- V := Ident_Mod (M - 2) + 5; -- Should wrap around
- if Ident_Mod (V) /= 2 then
- Report.Failed ("Addition didn't wrap round again - " & Key);
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised for addition - " & Key);
- when others =>
- Report.Failed
- ("Some even more unexpected exception raised for addition - " &
- Key);
- end;
-
- -- Check subtraction
- declare
- M : constant Mod_Type := 0;
- V : Mod_Type;
- begin
- V := M - 1; -- Should wrap around
- if Ident_Mod (V) /= Mod_Type'Last then
- Report.Failed ("Subtraction didn't wrap round - " & Key);
- end if;
- V := Ident_Mod (3) - 7; -- Should wrap around
- if Ident_Mod (V) /= Mod_Type'Last-3 then
- Report.Failed ("Subtraction didn't wrap round again - " & Key);
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised for subtraction - " & Key);
- when others =>
- Report.Failed
- ("Some even more unexpected exception raised for subtraction - " &
- Key);
- end;
-
- end Test_Operators;
-
- procedure Test_Unsigned_Byte_Operators is new Test_Operators
- (Unsigned_Byte_Type, "Byte");
-
- procedure Test_Unsigned_Word_Operators is new Test_Operators
- (Unsigned_Word_Type, "Word");
-
- procedure Test_Unsigned_DWord_Operators is new Test_Operators
- (Unsigned_DWord_Type, "DWord");
-
- procedure Test_Unsigned_NBM_Operators is new Test_Operators
- (Unsigned_NBM_Type, "NBM");
-
- procedure Test_Biggest_Unsigned_Operators is new Test_Operators
- (Biggest_Unsigned_Type, "Big");
-
- procedure Test_Prime_Operators is new Test_Operators (Prime_Type, "Prime");
-
- procedure Test_Storage_Element_Operators is new Test_Operators
- (System.Storage_Elements.Storage_Element, "Storage");
-
- procedure Test_Stream_Element_Operators is new Test_Operators
- (Ada.Streams.Stream_Element, "Stream");
-
-begin
-
- Report.Test
- ("C453001",
- "Check that overflow checking is not performed for adding operators " &
- "of modular types");
-
- -- Check assignment
- declare
- -- Define subtypes
- subtype My_Unsigned_Byte_Type is Unsigned_Byte_Type;
- subtype My_Unsigned_Word_Type is Unsigned_Word_Type;
- subtype My_Unsigned_DWord_Type is Unsigned_DWord_Type;
-
- -- Define constants in upper half of range
- C1 : constant Unsigned_Byte_Type := Unsigned_Byte_Type'Last;
- C2 : constant My_Unsigned_Byte_Type := 16#FE#;
- C3 : constant Unsigned_Word_Type := 16#FACE#;
- C4 : constant My_Unsigned_Word_Type := My_Unsigned_Word_Type'Last;
- C5 : constant Unsigned_DWord_Type := My_Unsigned_DWord_Type'Last;
-
- -- Define variables
- V1 : Unsigned_Byte_Type;
- V2 : My_Unsigned_Byte_Type;
- V3 : Unsigned_Word_Type;
- V4 : My_Unsigned_Word_Type;
- V5 : Unsigned_DWord_Type;
- begin
- V1 := C1;
- V1 := C2;
- V2 := C1;
- V2 := C2;
- V3 := C3;
- V3 := C4;
- V4 := C3;
- V4 := C4;
- V5 := C5;
- if V1 /= C2 or V2 /= C2 or V3 /= C4 or V4 /= C4 or V5 /= C5 then
- Report.Comment ("Don't optimize assignment!"); -- Optimization breaker
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised for assignment");
- when others =>
- Report.Failed ("Some even more unexpected exception raised " &
- "for assignment");
- end;
-
- Test_Unsigned_Byte_Operators;
- Test_Unsigned_Word_Operators;
- Test_Unsigned_DWord_Operators;
- Test_Unsigned_NBM_Operators;
- Test_Biggest_Unsigned_Operators;
- Test_Prime_Operators;
- Test_Storage_Element_Operators;
- Test_Stream_Element_Operators;
-
- Report.Result;
-
-end C453001;
-
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45303a.ada b/gcc/testsuite/ada/acats/tests/c4/c45303a.ada
deleted file mode 100644
index 01cd53d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45303a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C45303A.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 ADDITION AND SUBTRACTION YIELD RESULTS BELONGING TO THE
--- BASE TYPE.
-
--- JBG 2/24/84
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
--- JRL 10/13/96 Fixed static expressions which contained values outside
--- the base range.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45303A IS
-
- TYPE INT IS RANGE 1..10;
-
- X, Y : INT := INT(IDENT_INT(9));
-
-BEGIN
-
- TEST ("C45303A", "CHECK SUBTYPE OF INTEGER ADDITION/SUBTRACTION");
-
- BEGIN
-
- IF X + Y - 10 /= INT(IDENT_INT(8)) THEN
- FAILED ("INCORRECT RESULT - ADDITION");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- IF INT'POS(INT'BASE'LAST) >= 18 THEN
- FAILED ("ADDITION DOES NOT YIELD RESULT " &
- "BELONGING TO THE BASE TYPE");
- ELSE
- COMMENT ("BASE TYPE HAS RANGE LESS THAN 18 - ADD");
- END IF;
- END;
-
- BEGIN
-
- IF 2 - X - INT(IDENT_INT(1)) /= INT'VAL(IDENT_INT(-8)) THEN
- FAILED ("INCORRECT RESULT - SUBTRACTION");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- IF INT'POS(INT'BASE'FIRST) <= -8 THEN
- FAILED ("SUBTRACTION DOES NOT YIELD RESULT " &
- "BELONGING TO THE BASE TYPE");
- ELSE
- COMMENT ("BASE TYPE HAS RANGE GREATER THAN -8 - SUB");
- END IF;
- END;
-
- RESULT;
-
-END C45303A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304a.ada b/gcc/testsuite/ada/acats/tests/c4/c45304a.ada
deleted file mode 100644
index 8a5dfe9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45304a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C45304A.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 CONSTRAINT_ERROR IS RAISED BY
--- "+" AND "-" FOR PREDEFINED INTEGER WHEN THE RESULT IS OUTSIDE
--- THE RANGE OF THE BASE TYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- TBN 10/06/86 CREATED ORIGINAL TEST.
--- JET 12/29/87 FURTHER DEFEATED OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45304A IS
-
-BEGIN
- TEST ("C45304A", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " &
- "INTEGER WHEN THE RESULT IS OUTSIDE THE RANGE " &
- "OF THE BASE TYPE");
-
- DECLARE
- B : INTEGER := INTEGER'LAST;
- BEGIN
- IF EQUAL (IDENT_INT(B)+1, 0) THEN
- FAILED ("NO EXCEPTION FOR ADDITION -- ZERO RESULT");
- ELSE
- FAILED ("NO EXCEPTION FOR ADDITION -- NONZERO RESULT");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ADDITION");
- END;
-
- DECLARE
- B : INTEGER := INTEGER'FIRST;
- BEGIN
- IF EQUAL (IDENT_INT(B)-1, 0) THEN
- FAILED ("NO EXCEPTION FOR SUBTRACTION -- ZERO RESULT");
- ELSE
- FAILED ("NO EXCEPTION FOR SUBTRACTION -- " &
- "NONZERO RESULT");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR SUBTRACTION");
- END;
-
- RESULT;
-END C45304A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304b.dep b/gcc/testsuite/ada/acats/tests/c4/c45304b.dep
deleted file mode 100644
index 23620f8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45304b.dep
+++ /dev/null
@@ -1,111 +0,0 @@
--- C45304B.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED BY
--- "+" AND "-" FOR PREDEFINED SHORT_INTEGER WHEN THE RESULT IS
--- OUTSIDE THE RANGE OF THE BASE TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A
--- PREDEFINED TYPE SHORT_INTEGER.
-
--- IF SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "TEST_VAR" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- TBN 10/07/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45304B IS
-
- TEST_VAR : SHORT_INTEGER; -- N/A => ERROR.
-
- -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION.
-
- FUNCTION IDENT_SHORT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN (0);
- END IF;
- END IDENT_SHORT;
-
- FUNCTION SHORT_OK (X : SHORT_INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN EQUAL (INTEGER(X),INTEGER(X));
- END SHORT_OK;
-
-BEGIN
- TEST ("C45304B", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " &
- "SHORT_INTEGER WHEN THE RESULT IS OUTSIDE THE " &
- "RANGE OF THE BASE TYPE");
-
- DECLARE
- B : SHORT_INTEGER := SHORT_INTEGER'LAST;
- BEGIN
- IF SHORT_OK (B + IDENT_SHORT(1)) THEN
- FAILED ("NO EXCEPTION RAISED FOR ADDITION - " &
- "SHORT_OK RETURNS TRUE");
- ELSE
- FAILED ("NO EXCEPTION RAISED FOR ADDITION - " &
- "SHORT_OK RETURNS FALSE");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- DECLARE
- B : SHORT_INTEGER := SHORT_INTEGER'FIRST;
- BEGIN
-
- IF SHORT_OK (B - IDENT_SHORT(1)) THEN
- FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION- " &
- "SHORT_OK RETURNS TRUE");
- ELSE
- FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " &
- "SHORT_OK RETURNS FALSE");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- RESULT;
-END C45304B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304c.dep b/gcc/testsuite/ada/acats/tests/c4/c45304c.dep
deleted file mode 100644
index 9eaba63..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45304c.dep
+++ /dev/null
@@ -1,110 +0,0 @@
--- C45304C.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED BY
--- "+" AND "-" FOR PREDEFINED LONG_INTEGER WHEN THE RESULT IS
--- OUTSIDE THE RANGE OF THE BASE TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A
--- PREDEFINED TYPE LONG_INTEGER.
-
--- IF LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "TEST_VAR" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- TBN 10/07/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45304C IS
-
- TEST_VAR : LONG_INTEGER; -- N/A => ERROR.
-
- -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION.
-
- FUNCTION IDENT_LONG (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN 0;
- END IF;
- END IDENT_LONG;
-
- FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = IDENT_LONG(X);
- END LONG_OK;
-
-BEGIN
- TEST ("C45304C", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " &
- "LONG_INTEGER WHEN THE RESULT IS OUTSIDE THE " &
- "RANGE OF THE BASE TYPE");
-
- DECLARE
- B : LONG_INTEGER := LONG_INTEGER'LAST;
- BEGIN
- IF LONG_OK (B + IDENT_LONG(1)) THEN
- FAILED ("NO EXCEPTION RAISED FOR ADDITION - " &
- "LONG_OK RETURNS TRUE");
- ELSE
- FAILED ("NO EXCEPTION RAISED FOR ADDITION - " &
- "LONG_OK RETURNS FALSE");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- DECLARE
- B : LONG_INTEGER := LONG_INTEGER'FIRST;
- BEGIN
- IF LONG_OK (B - IDENT_LONG(1)) THEN
- FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " &
- "LONG_OK RETURNS TRUE");
- ELSE
- FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " &
- "LONG_OK RETURNS FALSE");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- RESULT;
-END C45304C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45322a.ada b/gcc/testsuite/ada/acats/tests/c4/c45322a.ada
deleted file mode 100644
index 8857c32..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45322a.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- C45322A.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 CONSTRAINT_ERROR IS RAISED IF
--- MACHINE_OVERFLOWS IS TRUE AND THE RESULT OF THE ADDITION OR
--- SUBTRACTION LIES OUTSIDE OF THE RANGE OF THE BASE TYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- NPL 09/01/90 CREATED ORIGINAL TEST.
--- LDC 10/09/90 CHANGED THE STYLE OF THE TEST TO THE STANDARD
--- ACVC FORMAT AND WRAPPED LINES WHICH WHERE LONGER
--- THAN 71 CHARACTERS.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45322A IS
-
- TYPE FLOAT5 IS DIGITS 5;
- F5 : FLOAT5;
-
- FUNCTION IDENT (F : FLOAT5) RETURN FLOAT5 IS
- BEGIN
- RETURN F * FLOAT5(IDENT_INT(1));
- END IDENT;
-
- FUNCTION EQUAL (F,G : FLOAT5) RETURN BOOLEAN IS
- BEGIN
- RETURN F = G + FLOAT5(IDENT_INT(0));
- END EQUAL;
-
-BEGIN
- TEST ("C45322A", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " &
- "THE RESULT OF THE ADDITION OR SUBTRACTION " &
- "LIES OUTSIDE OF THE RANGE OF THE BASE TYPE");
-
- IF NOT FLOAT5'MACHINE_OVERFLOWS THEN
- NOT_APPLICABLE("MACHINE_OVERFLOWS IS FALSE");
- ELSE
-
- BEGIN
- F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'LAST;
-
- FAILED("NO EXCEPTION RAISED BY LARGE '+'");
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '+'");
- END;
-
- -- AS ABOVE BUT INTERCHANGING '+' AND '-'
- BEGIN
- F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'LAST;
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR " &
- "RAISED BY INTERCHANGING LARGE '+'");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY " &
- "INTERCHANGING LARGE '+'");
- END;
-
- BEGIN
- F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'FIRST;
-
- FAILED("NO EXCEPTION RAISED BY SMALL '+'");
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '+'");
- END;
-
- -- AS ABOVE BUT INTERCHANGING '+' AND '-'
- BEGIN
- F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'FIRST;
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR " &
- "RAISED BY INTERCHANGING SMALL '+'");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY " &
- "INTERCHANGING SMALL '+'");
- END;
-
- BEGIN
- F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'FIRST;
-
- FAILED("NO EXCEPTION RAISED BY LARGE '-'");
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '-'");
- END;
-
- -- AS ABOVE BUT INTERCHANGING '+' AND '-'
- BEGIN
- F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'FIRST;
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR " &
- "RAISED BY INTERCHANGING LARGE '-'");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY " &
- "INTERCHANGING LARGE '-'");
- END;
-
- BEGIN
- F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'LAST;
-
- FAILED("NO EXCEPTION RAISED BY SMALL '-'");
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '-'");
- END;
-
- -- AS ABOVE BUT INTERCHANGING '+' AND '-'
- BEGIN
- F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'LAST;
-
- IF NOT EQUAL(F5, F5) THEN
- COMMENT("DON'T OPTIMIZE F5");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR " &
- "RAISED BY INTERCHANGING SMALL '-'");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BY " &
- "INTERCHANGING SMALL '-'");
- END;
-
- END IF;
-
- RESULT;
-
-END C45322A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45323a.ada b/gcc/testsuite/ada/acats/tests/c4/c45323a.ada
deleted file mode 100644
index 98c17d7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45323a.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- C45323A.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 NONASSOCIATIVITY OF REAL ARITHMETIC IS PRESERVED
--- FOR FLOATING POINT PRECISION 5, EVEN WHEN OPTIMIZATION WOULD
--- BENEFIT IF FLOATING POINT ADDITION WERE ASSOCIATIVE.
-
--- HISTORY:
--- JET 08/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45323A IS
-
- TYPE FLOAT5 IS DIGITS 5;
-
- A, B, C, D, E : FLOAT5;
-
- FUNCTION IDENT(F : FLOAT5) RETURN FLOAT5 IS
- BEGIN
- RETURN F * FLOAT5(IDENT_INT(1));
- END IDENT;
-
-BEGIN
- TEST ("C45323A", "CHECK THAT THE NONASSOCIATIVITY OF REAL " &
- "ARITHMETIC IS PRESERVED FOR FLOATING POINT " &
- "PRECISION 5, EVEN WHEN OPTIMIZATION WOULD " &
- "BENEFIT IF FLOATING POINT ADDITION WERE " &
- "ASSOCIATIVE");
-
- B := 2#0.1010_1010_1010_1010_10#E3;
- A := -B;
- C := 2#0.1000_0000_0000_0000_00#E-18;
- D := B + C;
- E := A + B + C;
-
- IF IDENT(A) + IDENT(B) /= 0.0 THEN
- FAILED("INCORRECT VALUE OF A + B");
- END IF;
-
- IF IDENT(E) /= IDENT(C) THEN
- FAILED("C DOES NOT EQUAL E");
- END IF;
-
- RESULT;
-END C45323A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45331a.ada b/gcc/testsuite/ada/acats/tests/c4/c45331a.ada
deleted file mode 100644
index bdbcd61..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45331a.ada
+++ /dev/null
@@ -1,357 +0,0 @@
--- C45331A.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 FIXED POINT TYPES THE OPERATORS "+" AND "-" PRODUCE
--- CORRECT RESULTS WHEN:
--- (A) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS.
--- (B) A IS A MODEL NUMBER BUT B, A+B, AND A-B ARE NOT.
--- (C) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS WITH DIFFERENT
--- SUBTYPES.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- WRG 8/27/86
--- KAS 11/14/95 REDUCE EXPECTATION FOR T'SMALL
--- KAS 11/30/95 ONE MORE CHANGE...
--- PWN 02/28/96 CLEANED COMMENTS FOR RELEASE
--- KAS 03/18/96 ELIDED TWO 'SMALL CASES FOR 2.1
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45331A IS
-
- TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
- -- 'MANTISSA = 23.
- SUBTYPE F IS LIKE_DURATION DELTA 0.25 RANGE -1000.0 .. 1000.0;
- SUBTYPE ST_F1 IS LIKE_DURATION DELTA 0.5 RANGE -4.0 .. 3.0;
- SUBTYPE ST_F2 IS LIKE_DURATION DELTA 1.0 / 16
- RANGE -13.0 / 16 .. 5.0 + 1.0 / 16;
-
-BEGIN
-
- TEST ("C45331A", "CHECK THAT FOR FIXED POINT TYPES THE " &
- "OPERATORS ""+"" AND ""-"" PRODUCE CORRECT " &
- "RESULTS - BASIC TYPES");
-
- -------------------------------------------------------------------
-
-A: DECLARE
- SMALL, MAX, MIN, ZERO : F := 0.5;
- X : F := 0.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- SMALL := F'SMALL;
- MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND F'LAST
- -- IS A MODEL NUMBER.
- MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER.
- ZERO := 0.0;
- END IF;
-
- -- CHECK SMALL + OR - ZERO = SMALL:
- IF "+"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR
- 0.0 + SMALL /= SMALL THEN
- FAILED ("F'SMALL + 0.0 /= F'SMALL");
- END IF;
- IF "-"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR
- SMALL - 0.0 /= SMALL THEN
- FAILED ("F'SMALL - 0.0 /= F'SMALL");
- END IF;
-
- -- CHECK MAX + OR - ZERO = MAX:
- IF MAX + ZERO /= MAX OR 0.0 + MAX /= MAX THEN
- FAILED ("F'LAST + 0.0 /= F'LAST");
- END IF;
- IF MAX - ZERO /= MAX OR MAX - 0.0 /= MAX THEN
- FAILED ("F'LAST - 0.0 /= F'LAST");
- END IF;
-
- -- CHECK SMALL - SMALL = 0.0:
- IF EQUAL (3, 3) THEN
- X := SMALL;
- END IF;
- IF SMALL - X /= 0.0 OR SMALL - SMALL /= 0.0 OR
- F'SMALL - F'SMALL /= 0.0 THEN
- FAILED ("F'SMALL - F'SMALL /= 0.0");
- END IF;
-
- -- CHECK MAX - MAX = 0.0:
- IF EQUAL (3, 3) THEN
- X := MAX;
- END IF;
- IF MAX - X /= 0.0 OR MAX - MAX /= 0.0 OR
- F'LAST - F'LAST /= 0.0 THEN
- FAILED ("F'LAST - F'LAST /= 0.0");
- END IF;
-
- -- CHECK ZERO - MAX = MIN, MIN - MIN = 0.0,
- -- AND MIN + MAX = 0.0:
- IF EQUAL (3, 3) THEN
- X := ZERO - MAX;
- END IF;
- IF X /= MIN THEN
- FAILED ("0.0 - 1000.0 /= -1000.0");
- END IF;
- IF EQUAL (3, 3) THEN
- X := MIN;
- END IF;
- IF MIN - X /= 0.0 OR MIN - MIN /= 0.0 OR
- F'FIRST - F'FIRST /= 0.0 THEN
- FAILED ("F'FIRST - F'FIRST /= 0.0");
- END IF;
- IF MIN + MAX /= 0.0 OR MAX + MIN /= 0.0 OR
- F'FIRST + F'LAST /= 0.0 THEN
- FAILED ("-1000.0 + 1000.0 /= 0.0");
- END IF;
-
- -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE
- -- NUMBERS:
- IF EQUAL (3, 3) THEN
- X := 100.75;
- END IF;
- IF (X + SMALL) /= (SMALL + X) OR
- (X + SMALL) > (X + 0.25) THEN -- X + SMALL SB <= X + DELTA
- FAILED("X + SMALL DELIVERED BAD RESULT");
- END IF;
-
- -- CHECK (MAX - SMALL) + SMALL = MAX:
- IF EQUAL (3, 3) THEN
- X := MAX - SMALL;
- END IF;
- IF X + SMALL /= MAX THEN
- FAILED("(MAX - SMALL) + SMALL /= MAX");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - A");
- END A;
-
- -------------------------------------------------------------------
-
-B: DECLARE
- NON_MODEL_CONST : CONSTANT := 2.0 / 3;
- NON_MODEL_VAR : F := 0.0;
-
- SMALL, MAX, MIN, ZERO : F := 0.5;
- X : F := 0.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- SMALL := F'SMALL;
- MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND
- -- F'LAST IS A MODEL NUMBER.
- MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER.
- ZERO := 0.0;
- NON_MODEL_VAR := NON_MODEL_CONST;
- END IF;
-
- -- CHECK VALUE OF NON_MODEL_VAR:
- IF NON_MODEL_VAR NOT IN 0.5 .. 0.75 THEN
- FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE");
- END IF;
-
- -- CHECK NON-MODEL VALUE + OR - ZERO:
- IF NON_MODEL_VAR + ZERO NOT IN 0.5 .. 0.75 OR
- F'(0.0) + NON_MODEL_CONST NOT IN 0.5 .. 0.75 THEN
- FAILED ("(2.0 / 3) + 0.0 NOT IN 0.5 .. 0.75");
- END IF;
- IF NON_MODEL_VAR - ZERO NOT IN 0.5 .. 0.75 OR
- NON_MODEL_CONST - F'(0.0) NOT IN 0.5 .. 0.75 THEN
- FAILED ("(2.0 / 3) - 0.0 NOT IN 0.5 .. 0.75");
- END IF;
-
- -- CHECK ZERO - NON-MODEL:
- IF F'(0.0) - NON_MODEL_CONST NOT IN -0.75 .. -0.5 THEN
- FAILED ("0.0 - (2.0 / 3) NOT IN -0.75 .. -0.5");
- END IF;
-
- IF F'(1.0) - NON_MODEL_CONST NOT IN 0.25 .. 0.5 THEN
- FAILED ("1.0 - (2.0 / 3) NOT IN 0.25 .. 0.5");
- END IF;
-
- -- CHECK ADDITION AND SUBTRACTION OF NON-MODEL NEAR MIN AND
- -- MAX:
- IF MIN + NON_MODEL_VAR NOT IN -999.5 .. -999.25 OR
- NON_MODEL_CONST + F'FIRST NOT IN -999.5 .. -999.25 THEN
- FAILED ("-1000.0 + (2.0 / 3) NOT IN -999.5 .. -999.25");
- END IF;
- IF MAX - NON_MODEL_VAR NOT IN 999.25 .. 999.5 OR
- F'LAST - NON_MODEL_CONST NOT IN 999.25 .. 999.5 THEN
- FAILED ("1000.0 - (2.0 / 3) NOT IN 999.25 .. 999.5");
- END IF;
-
- -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE
- -- MODEL NUMBER WITH NON-MODEL:
- IF EQUAL (3, 3) THEN
- X := -213.25;
- END IF;
- IF X + NON_MODEL_CONST NOT IN -212.75 .. -212.5 THEN
- FAILED ("-213.25 + (2.0 / 3) NOT IN -212.75 .. -212.5");
- END IF;
- IF NON_MODEL_VAR - X NOT IN 213.75 .. 214.0 THEN
- FAILED ("(2.0 / 3) - (-213.25) NOT IN 213.75 .. 214.0");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - B");
- END B;
-
- -------------------------------------------------------------------
-
-C: DECLARE
- A_SMALL, A_MAX, A_MIN : ST_F1 := 0.0;
- B_SMALL, B_MAX, B_MIN : ST_F2 := 0.0;
- X : F;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- A_SMALL := ST_F1'SMALL;
- A_MAX := ST_F1'LAST; -- BECAUSE 'LAST < 'LARGE AND
- -- 'LAST IS A MODEL NUMBER.
- A_MIN := ST_F1'FIRST; -- 'FIRST IS A MODEL NUMBER.
-
- B_SMALL := ST_F2'SMALL;
- B_MAX := ST_F2'LAST; -- BECAUSE 'LAST <= 'LARGE AND
- -- 'LAST IS A MODEL NUMBER.
- B_MIN := ST_F2'FIRST; -- 'FIRST IS A MODEL NUMBER.
- END IF;
-
- IF A_MIN + B_MIN /= -4.8125 THEN
- FAILED ("-4.0 + (-0.8125) /= -4.8125");
- END IF;
-
- IF A_MIN - B_MIN /= -3.1875 THEN
- FAILED ("-4.0 - (-0.8125) /= -3.1875");
- END IF;
-
- IF (A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375 THEN
- FAILED ("(A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375");
- END IF;
-
- IF (A_MIN - B_SMALL) NOT IN -4.0625 .. -4.0 THEN
- FAILED ("(A_MIN - B_SMALL) NOT IN -4.0 .. -4.0625");
- END IF;
-
- IF A_MIN + B_MAX /= 1.0625 THEN
- FAILED ("-4.0 + 5.0625 /= 1.0625");
- END IF;
-
- IF A_MIN - B_MAX /= -9.0625 THEN
- FAILED ("-4.0 - 5.0625 /= -9.0625");
- END IF;
-
- IF (A_SMALL + B_MIN) NOT IN B_MIN..-0.3125 THEN
- FAILED ("(A_SMALL + B_MIN) NOT IN B_MIN..-0.3125");
- END IF;
-
- IF (A_SMALL - B_MIN) NOT IN +0.8125 .. 1.3125 THEN
- FAILED ("(A_SMALL - B_MIN) NOT IN -0.8125 .. 1.3125");
- END IF;
-
-
-
- IF (A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625 THEN
- FAILED ("(A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625");
- END IF;
-
- IF (A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625 THEN
- FAILED ("(A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625");
- END IF;
-
- IF A_MAX + B_MIN /= 2.1875 THEN
- FAILED ("3.0 + (-0.8125) /= 2.1875");
- END IF;
-
- IF A_MAX - B_MIN /= 3.8125 THEN
- FAILED ("3.0 - (-0.8125) /= 3.8125");
- END IF;
-
- IF (A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625 THEN
- FAILED ("(A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625");
- END IF;
-
- IF (A_MAX - B_SMALL) NOT IN 2.9375..3.0 THEN
- FAILED ("(A_MAX - B_SMALL) NOT IN 2.9375..3.0");
- END IF;
-
- IF A_MAX + B_MAX /= 8.0625 THEN
- FAILED ("3.0 + 5.0625 /= 8.0625");
- END IF;
-
- IF A_MAX - B_MAX /= -2.0625 THEN
- FAILED ("3.0 - 5.0625 /= -2.0625");
- END IF;
-
- X := B_MIN - A_MIN;
- IF X NOT IN 3.0 .. 3.25 THEN
- FAILED ("-0.8125 - (-4.0) NOT IN RANGE");
- END IF;
-
- X := B_MIN - A_SMALL;
- IF X NOT IN -1.3125 .. -0.8125 THEN
- FAILED ("B_MIN - A_SMALL NOT IN RANGE");
- END IF;
-
- X := B_MIN - A_MAX;
- IF X NOT IN -4.0 .. -3.75 THEN
- FAILED ("-0.8125 - 3.0 NOT IN RANGE");
- END IF;
-
- X := B_SMALL - A_MIN;
- IF X NOT IN 4.0 .. 4.0625 THEN
- FAILED ("B_SMALL - A_MIN NOT IN RANGE");
- END IF;
-
-
- X := B_SMALL - A_MAX;
- IF X NOT IN -3.0 .. -2.75 THEN
- FAILED ("B_SMALL - A_MAX NOT IN RANGE");
- END IF;
-
- X := B_MAX - A_MIN;
- IF X NOT IN 9.0 .. 9.25 THEN
- FAILED ("5.0625 - (-4.0) NOT IN RANGE");
- END IF;
-
- X := B_MAX - A_SMALL;
- IF X NOT IN 4.56 .. 5.0625 THEN
- FAILED ("5.0625 - 0.5 NOT IN RANGE");
- END IF;
-
- X := B_MAX - A_MAX;
- IF X NOT IN 2.0 .. 2.25 THEN
- FAILED ("5.0625 - 3.0 NOT IN RANGE");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - C");
- END C;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C45331A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45342a.ada b/gcc/testsuite/ada/acats/tests/c4/c45342a.ada
deleted file mode 100644
index 73a0529..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45342a.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C45342A.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 CATENATION OF TWO OR MORE NON-NULL OPERANDS YIELDS THE
--- CORRECT RESULT, WITH THE CORRECT BOUNDS, WHETHER BOUNDS ARE STATIC OR
--- DYNAMIC.
-
--- BHS 6/27/84
-
-WITH REPORT;
-PROCEDURE C45342A IS
-
- USE REPORT;
-
- SUBTYPE S IS INTEGER RANGE 1..100;
- TYPE ARR IS ARRAY (S RANGE <>) OF INTEGER;
-
- A,B : ARR (2..9);
-
- FUNCTION F (AR_VAR1, AR_VAR2, AR_VAR3 : ARR) RETURN ARR IS
- BEGIN
- RETURN AR_VAR1 & AR_VAR2 & AR_VAR3;
- END F;
-
- PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS
- BEGIN
- IF A'FIRST /= I1 OR A'LAST /= I2 THEN
- FAILED ("INCORRECT CATENATION BOUNDS - " & NUM);
- END IF;
- END CAT;
-
-
-BEGIN
-
- TEST ("C45342A", "CHECK THAT CATENATION OF NON-NULL OPERANDS " &
- "YIELDS CORRECT RESULT WITH CORRECT BOUNDS");
-
- BEGIN
- A := (1,2,3,4,5,6,7,8);
- B := A(2..4) & A(2..5) & A(2..2);
- IF B /= (1,2,3,1,2,3,4,1) THEN
- FAILED ("INCORRECT CATENATION RESULT - 1");
- END IF;
-
- A := (8,7,6,5,4,3,2,1);
- IF F(A(2..3), A(2..4), A(2..4)) /= (8,7,8,7,6,8,7,6) THEN
- FAILED ("INCORRECT CATENATION RESULT - 2");
- END IF;
-
- CAT ( A(3..5) & A(2..3), 3, 7, '3' );
- END;
-
-
- DECLARE
- DYN2 : INTEGER := IDENT_INT(2);
- DYN3 : INTEGER := IDENT_INT(3);
- DYN4 : INTEGER := IDENT_INT(4);
- DYN6 : INTEGER := IDENT_INT(6);
-
- BEGIN
- A := (1,2,3,4,5,6,7,8);
- B := A(DYN2..DYN3) & A(DYN2..DYN4) & A(DYN2..DYN4);
- IF B /= (1,2,1,2,3,1,2,3) THEN
- FAILED ("INCORRECT CATENATION RESULT - 4");
- END IF;
-
- A := (8,7,6,5,4,3,2,1);
- IF F ( A(DYN2..DYN6), A(DYN2..DYN3), A(DYN2..DYN2) )
- /= (8,7,6,5,4,8,7,8) THEN
- FAILED ("INCORRECT CATENATION RESULT - 5");
- END IF;
-
- CAT ( A(DYN3..5) & A(2..3), 3, 7, '6');
- END;
-
- RESULT;
-
-END C45342A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45343a.ada b/gcc/testsuite/ada/acats/tests/c4/c45343a.ada
deleted file mode 100644
index a99db7f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45343a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C45343A.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 CATENATION OF NULL OPERANDS YIELDS THE CORRECT RESULT,
--- WITH THE CORRECT BOUNDS.
-
--- BHS 6/29/84
-
-WITH REPORT;
-PROCEDURE C45343A IS
-
- USE REPORT;
-
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE ARR_8 IS ARR (1..8);
- A1, A2 : ARR_8;
-
- PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS
- BEGIN
- IF A'FIRST /= I1 OR A'LAST /= I2 THEN
- FAILED ("INCORRECT CATENATION - " & NUM);
- END IF;
- END CAT;
-
-BEGIN
-
- TEST ("C45343A", "CATENATION OF NULL OPERANDS");
-
-
- A1 := (1,2,3,4,5,6,7,8);
- A2 := A1(1..0) & A1(6..5) & A1(1..8);
- IF A2 /= (1,2,3,4,5,6,7,8) THEN
- FAILED ("INCORRECT CATENATION RESULT - 1");
- END IF;
-
- A1 := (1,2,3,4,5,6,7,8);
- A2 := A1(2..8) & A1(1..0) & 9;
- IF A2 /= (2,3,4,5,6,7,8,9) THEN
- FAILED ("INCORRECT CATENATION RESULT - 2");
- END IF;
-
-
- CAT ( A1(1..0) & A1(IDENT_INT(2)..0), 2, 0, '3' );
- CAT ( A1(IDENT_INT(1)..0) & A2(2..0), 2, 0, '4' );
-
- CAT ( A1(1..0) & A1(6..5) & A1(2..8), 2, 8, '5' );
- CAT ( A1(2..8) & A1(1..0), 2, 8, '6' );
-
- CAT ( A2(1..0) & A2(6..5) & A2(IDENT_INT(2)..8), 2, 8, '7' );
- CAT ( A2(IDENT_INT(2)..8) & A2(1..0), 2, 8, '8' );
-
- RESULT;
-
-END C45343A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45344a.ada b/gcc/testsuite/ada/acats/tests/c4/c45344a.ada
deleted file mode 100644
index b75f2a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45344a.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C45344A.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 CORRECT RESULT IS PRODUCED WHEN A FUNCTION RETURNS
--- THE RESULT OF A CATENATION WHOSE BOUNDS ARE NOT DEFINED STATICALLY.
-
--- R.WILLIAMS 9/1/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45344A IS
-
-BEGIN
- TEST ( "C45344A", "CHECK THAT THE CORRECT RESULT IS PRODUCED " &
- "WHEN A FUNCTION RETURNS THE RESULT OF A " &
- "CATENATION WHOSE BOUNDS ARE NOT DEFINED " &
- "STATICALLY" );
-
- DECLARE
- SUBTYPE INT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (30);
-
- TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER;
- SUBTYPE CARR IS ARR (1 .. 9);
- C : CARR;
-
- AR1 : ARR (IDENT_INT (2) .. IDENT_INT (4)) :=
- (IDENT_INT (2) .. IDENT_INT (4) => 1);
-
- AR2 : ARR (IDENT_INT (6) .. IDENT_INT (6)) :=
- (IDENT_INT (6) .. IDENT_INT (6) => 2);
-
- AR3 : ARR (IDENT_INT (4) .. IDENT_INT (2));
-
- FUNCTION F (A, B : ARR; N : NATURAL) RETURN ARR IS
- BEGIN
- IF N = 0 THEN
- RETURN A & B;
- ELSE
- RETURN F (A & B, B, N - 1);
- END IF;
- END F;
-
- FUNCTION G (A : INTEGER; B : ARR; N : NATURAL) RETURN ARR IS
- BEGIN
- IF N = 0 THEN
- RETURN A & B;
- ELSE
- RETURN G (A, A & B, N - 1);
- END IF;
- END G;
-
- FUNCTION H (A : ARR; B : INTEGER; N : NATURAL) RETURN ARR IS
- BEGIN
- IF N = 0 THEN
- RETURN A & B;
- ELSE
- RETURN H (A & B, B, N - 1);
- END IF;
- END H;
-
- PROCEDURE CHECK (X, Y : ARR; F, L : INTEGER; STR : STRING) IS
- OK : BOOLEAN := TRUE;
- BEGIN
- IF X'FIRST /= F AND X'LAST /= L THEN
- FAILED ( "INCORRECT RANGE FOR " & STR);
- ELSE
- FOR I IN F .. L LOOP
- IF X (I) /= Y (I) THEN
- OK := FALSE;
- END IF;
- END LOOP;
-
- IF NOT OK THEN
- FAILED ( "INCORRECT VALUE FOR " & STR);
- END IF;
- END IF;
- END CHECK;
-
- BEGIN
- C := (1 .. 4 => 1, 5 .. 9 => 2);
- CHECK (F (AR1, AR2, IDENT_INT (3)), C, 2, 8, "F - 1" );
- CHECK (F (AR3, AR2, IDENT_INT (3)), C, 6, 9, "F - 2" );
- CHECK (F (AR2, AR3, IDENT_INT (3)), C, 6, 6, "F - 3" );
-
- C := (1 ..4 => 5, 5 .. 9 => 1);
- CHECK (G (5, AR1, IDENT_INT (3)), C, 1, 7, "G - 1" );
- CHECK (G (5, AR3, IDENT_INT (3)), C, 1, 4, "G - 2" );
-
- CHECK (H (AR3, 5, IDENT_INT (3)), C, 1, 4, "H - 1" );
-
- C := (1 ..4 => 1, 5 .. 9 => 5);
- CHECK (H (AR1, 5, IDENT_INT (3)), C, 2, 8, "H - 2" );
- END;
-
- RESULT;
-END C45344A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45345b.ada b/gcc/testsuite/ada/acats/tests/c4/c45345b.ada
deleted file mode 100644
index e4b31ec..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45345b.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- C45345B.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 IF THE RESULT OF
--- CATENATION HAS PRECISELY THE MAXIMUM LENGTH PERMITTED BY THE
--- INDEX SUBTYPE.
-
-
--- RM 2/26/82
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C45345B IS
-
-
-BEGIN
-
- TEST ( "C45345B" , "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" &
- " IF THE RESULT OF CATENATION HAS PRECISELY" &
- " THE MAXIMUM LENGTH PERMITTED BY THE" &
- " INDEX SUBTYPE" );
-
-
- -------------------------------------------------------------------
- ----------------- STRG_VAR := STRG_LIT & STRG_LIT ---------------
-
- DECLARE
-
- X : STRING(1..5) ;
-
- BEGIN
-
- X := "ABCD" & "E" ;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " );
-
- WHEN OTHERS =>
- FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" );
-
- END;
-
-
- -------------------------------------------------------------------
- ----------------- STRG_VAR := STRG_LIT & CHARACTER --------------
-
- DECLARE
-
- X : STRING(1..5) ;
-
- BEGIN
-
- X := "ABCD" & 'E' ;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " );
-
- WHEN OTHERS =>
- FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" );
-
- END;
-
- -------------------------------------------------------------------
- ----------------- STRG_VAR := STRG_VAR & STRG_VAR ---------------
-
- DECLARE
-
- X : STRING(1..5) ;
- A : CONSTANT STRING := "A" ;
- B : STRING(1..4) := IDENT_STR("BCDE") ;
-
- BEGIN
-
- X := A & B ;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " );
-
- WHEN OTHERS =>
- FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" );
-
- END;
-
- -------------------------------------------------------------------
-
-
- RESULT;
-
-
-END C45345B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347a.ada b/gcc/testsuite/ada/acats/tests/c4/c45347a.ada
deleted file mode 100644
index a93ae87..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45347a.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C45347A.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 CATENATION IS DEFINED FOR RECORD TYPES AS COMPONENT TYPES.
-
--- JWC 11/15/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45347A IS
-
-BEGIN
-
- TEST ("C45347A", "CHECK THAT CATENATION IS DEFINED " &
- "FOR RECORD TYPES AS COMPONENT TYPES");
-
- DECLARE
-
- TYPE REC IS
- RECORD
- X : INTEGER;
- END RECORD;
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 4;
- TYPE A IS ARRAY ( INT RANGE <>) OF REC;
-
- R1 : REC := (X => 4);
- R2 : REC := (X => 1);
-
- A1 : A(1 .. 2) := ((X => 1), (X => 2));
- A2 : A(1 .. 2) := ((X => 3), (X => 4));
- A3 : A(1 .. 4) := ((X => 1), (X => 2), (X => 3), (X => 4));
- A4 : A(1 .. 4);
- A5 : A(1 .. 4) := ((X => 4), (X => 3), (X => 2), (X => 1));
-
- BEGIN
-
- A4 := A1 & A2;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " &
- "RECORDS");
- END IF;
-
- A4 := A5;
-
- A4 := A1 & A2(1) & R1;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAY OF RECORD, " &
- "AND RECORDS");
- END IF;
-
- A4 := A5;
-
- A4 := R2 & (A1(2) & A2);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR RECORDS, " &
- "AND ARRAY OF RECORDS");
- END IF;
-
- A4 := A5;
-
- A4 := R2 & A1(2) & (A2(1) & R1);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR RECORDS");
- END IF;
-
- END;
-
- RESULT;
-
-END C45347A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347b.ada b/gcc/testsuite/ada/acats/tests/c4/c45347b.ada
deleted file mode 100644
index 220100b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45347b.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C45347B.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 CATENATION IS DEFINED FOR ARRAY TYPES AS COMPONENT TYPES.
-
--- JWC 11/15/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45347B IS
-
-BEGIN
-
- TEST ("C45347B", "CHECK THAT CATENATION IS DEFINED " &
- "FOR ARRAY TYPES AS COMPONENT TYPES");
-
- DECLARE
-
- TYPE ARR IS ARRAY (1 .. 2) OF INTEGER;
- TYPE A IS ARRAY ( INTEGER RANGE <>) OF ARR;
-
- AR1 : ARR := (4,1);
- AR2 : ARR := (1,1);
-
- A1 : A(1 .. 2) := ((1,1), (2,1));
- A2 : A(1 .. 2) := ((3,1), (4,1));
- A3 : A(1 .. 4) := ((1,1), (2,1), (3,1), (4,1));
- A4 : A(1 .. 4);
- A5 : A(1 .. 4) := ((4,1), (3,1), (2,1), (1,1));
-
- BEGIN
-
- A4 := A1 & A2;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAYS OF ARRAYS");
- END IF;
-
- A4 := A5;
-
- A4 := A1 & A2(1) & AR1;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAY OF ARRAYS " &
- "WITH ARRAYS");
- END IF;
-
- A4 := A5;
-
- A4 := AR2 & (A1(2) & A2);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAYS WITH ARRAYS " &
- "OF ARRAYS");
- END IF;
-
- A4 := A5;
-
- A4 := A'(AR2 & A1(2)) & A'(A2(1) & AR1);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAYS");
- END IF;
-
- END;
-
- RESULT;
-
-END C45347B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347c.ada b/gcc/testsuite/ada/acats/tests/c4/c45347c.ada
deleted file mode 100644
index 0ad23a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45347c.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- C45347C.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 CATENATION IS DEFINED FOR PRIVATE TYPES AS COMPONENT
--- TYPES.
-
--- JWC 11/15/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45347C IS
-
-BEGIN
-
- TEST ("C45347C", "CHECK THAT CATENATION IS DEFINED " &
- "FOR PRIVATE TYPES AS COMPONENT TYPES");
-
- DECLARE
-
- PACKAGE PKG IS
- TYPE PRIV IS PRIVATE;
- ONE : CONSTANT PRIV;
- TWO : CONSTANT PRIV;
- THREE : CONSTANT PRIV;
- FOUR : CONSTANT PRIV;
- PRIVATE
- TYPE PRIV IS NEW INTEGER;
- ONE : CONSTANT PRIV := 1;
- TWO : CONSTANT PRIV := 2;
- THREE : CONSTANT PRIV := 3;
- FOUR : CONSTANT PRIV := 4;
- END PKG;
-
- USE PKG;
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 4;
- TYPE A IS ARRAY ( INT RANGE <>) OF PRIV;
-
- P1 : PRIV := FOUR;
- P2 : PRIV := ONE;
-
- A1 : A(1 .. 2) := (ONE, TWO);
- A2 : A(1 .. 2) := (THREE, FOUR);
- A3 : A(1 .. 4) := (ONE, TWO, THREE, FOUR);
- A4 : A(1 .. 4);
- A5 : A(1 .. 4) := (FOUR, THREE, TWO, ONE);
-
- BEGIN
-
- A4 := A1 & A2;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " &
- "PRIVATE");
- END IF;
-
- A4 := A5;
-
- A4 := A1 & A2(1) & P1;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAY OF PRIVATE, " &
- "AND PRIVATE");
- END IF;
-
- A4 := A5;
-
- A4 := P2 & (A1(2) & A2);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR PRIVATE, AND ARRAY " &
- "OF PRIVATE");
- END IF;
-
- A4 := A5;
-
- A4 := P2 & A1(2) & (A2(1) & P1);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR PRIVATE");
- END IF;
-
- END;
-
- RESULT;
-
-END C45347C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347d.ada b/gcc/testsuite/ada/acats/tests/c4/c45347d.ada
deleted file mode 100644
index 0791be1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45347d.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- C45347D.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 CATENATION IS DEFINED FOR ACCESS TYPES AS COMPONENT TYPES.
-
--- JWC 11/15/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45347D IS
-
-BEGIN
-
- TEST ("C45347D", "CHECK THAT CATENATION IS DEFINED " &
- "FOR ACCESS TYPES AS COMPONENT TYPES");
-
- DECLARE
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 4;
- TYPE ACC IS ACCESS INT;
- TYPE A IS ARRAY ( INT RANGE <>) OF ACC;
-
- AC1 : ACC := NEW INT'(1);
- AC2 : ACC := NEW INT'(2);
- AC3 : ACC := NEW INT'(3);
- AC4 : ACC := NEW INT'(4);
-
- A1 : A(1 .. 2) := (AC1, AC2);
- A2 : A(1 .. 2) := (AC3, AC4);
- A3 : A(1 .. 4) := (AC1, AC2, AC3, AC4);
- A4 : A(1 .. 4);
- A5 : A(1 .. 4) := (AC4, AC3, AC2, AC1);
-
- BEGIN
-
- A4 := A1 & A2;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF ACCESS");
- END IF;
-
- A4 := A5;
-
- A4 := A1 & A2(1) & AC4;
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ARRAY OF ACCESS, " &
- "AND ACCESS");
- END IF;
-
- A4 := A5;
-
- A4 := AC1 & (A1(2) & A2);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ACCESS, AND ARRAY " &
- "OF ACCESS");
- END IF;
-
- A4 := A5;
-
- A4 := AC1 & A1(2) & (A2(1) & AC4);
-
- IF A3 /= A4 THEN
- FAILED ("INCORRECT CATENATION FOR ACCESS");
- END IF;
-
- END;
-
- RESULT;
-
-END C45347D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411a.ada b/gcc/testsuite/ada/acats/tests/c4/c45411a.ada
deleted file mode 100644
index 0ac3b10..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45411a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C45411A.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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR
--- PREDEFINED INTEGER OPERANDS.
-
--- HISTORY:
--- JET 01/25/88 CREATED ORIGINAL TEST.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45411A IS
-
- TYPE DT IS NEW INTEGER RANGE -3..3;
- I1 : INTEGER := 1;
- D1 : DT := 1;
-
-BEGIN
- TEST ("C45411A", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " &
- "CORRECT RESULTS FOR PREDEFINED INTEGER " &
- "OPERANDS");
-
- FOR I IN (1-2)..INTEGER(1) LOOP
- IF "-"(RIGHT => I1) /= IDENT_INT(I) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- INTEGER'IMAGE(I+2));
- END IF;
-
- IF +I1 /= IDENT_INT(I1) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- INTEGER'IMAGE(I+2));
- END IF;
- I1 := I1 - 1;
- END LOOP;
-
- FOR I IN (1-2)..INTEGER(1) LOOP
- IF -I /= IDENT_INT(0)-I THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- INTEGER'IMAGE(I+5));
- END IF;
-
- IF "+"(RIGHT => IDENT_INT(I)) /= I THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- INTEGER'IMAGE(I+5));
- END IF;
- END LOOP;
-
- IF -1 /= IDENT_INT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 7");
- END IF;
-
- IF "-"(RIGHT => 0) /= IDENT_INT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 8");
- END IF;
-
- IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 9");
- END IF;
-
- IF "+"(RIGHT => 1) /= IDENT_INT(2)-1 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 7");
- END IF;
-
- IF +0 /= IDENT_INT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 8");
- END IF;
-
- IF +(-1) /= IDENT_INT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 9");
- END IF;
-
- FOR I IN (1-2)..INTEGER(1) LOOP
- IF "-"(RIGHT => D1) /= DT(IDENT_INT(I)) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- INTEGER'IMAGE(I+11));
- END IF;
-
- IF +D1 /= DT(IDENT_INT(INTEGER(D1))) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- INTEGER'IMAGE(I+11));
- END IF;
- D1 := D1 - 1;
- END LOOP;
-
- IF INTEGER'LAST + INTEGER'FIRST = 0 THEN
- IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST THEN
- FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST");
- END IF;
- ELSE
- IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST+1 THEN
- FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST+1");
- END IF;
- END IF;
-
- RESULT;
-
-END C45411A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411b.dep b/gcc/testsuite/ada/acats/tests/c4/c45411b.dep
deleted file mode 100644
index faae4b1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45411b.dep
+++ /dev/null
@@ -1,123 +0,0 @@
--- C45411B.DEP
-
--- 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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR
--- PREDEFINED SHORT_INTEGER OPERANDS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE PREDEFINED SHORT_INTEGER TYPE.
-
--- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION
--- OF TYPE "DT" MUST BE REJECTED.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
--- KAS 01/12/95 DELETED INCOMPATIBLE SUBTEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45411B IS
-
- TYPE DT IS NEW SHORT_INTEGER RANGE -3..3; -- N/A => ERROR.
- I1 : SHORT_INTEGER := 1;
- D1 : DT := 1;
-
- FUNCTION IDENT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN A * SHORT_INTEGER(IDENT_INT(1));
- END;
-
-BEGIN
- TEST ("C45411B", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " &
- "CORRECT RESULTS FOR PREDEFINED SHORT_INTEGER " &
- "OPERANDS");
-
- FOR I IN (1-2)..SHORT_INTEGER(1) LOOP
- IF "-"(RIGHT => I1) /= IDENT(I) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- SHORT_INTEGER'IMAGE(I+2));
- END IF;
-
- IF +I1 /= IDENT(I1) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- SHORT_INTEGER'IMAGE(I+2));
- END IF;
- I1 := I1 - 1;
- END LOOP;
-
- FOR I IN (1-2)..SHORT_INTEGER(1) LOOP
- IF -I /= IDENT(0)-I THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- SHORT_INTEGER'IMAGE(I+5));
- END IF;
-
- IF "+"(RIGHT => IDENT(I)) /= I THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- SHORT_INTEGER'IMAGE(I+5));
- END IF;
- END LOOP;
-
- IF -1 /= IDENT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 7");
- END IF;
-
- IF "-"(RIGHT => 0) /= IDENT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 8");
- END IF;
-
- IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 9");
- END IF;
-
- IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 7");
- END IF;
-
- IF +0 /= IDENT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 8");
- END IF;
-
- IF +(-1) /= IDENT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 9");
- END IF;
-
- FOR I IN (1-2)..SHORT_INTEGER(1) LOOP
- IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- SHORT_INTEGER'IMAGE(I+11));
- END IF;
-
- IF +D1 /= DT(IDENT(SHORT_INTEGER(D1))) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- SHORT_INTEGER'IMAGE(I+11));
- END IF;
- D1 := D1 - 1;
- END LOOP;
-
-
- RESULT;
-
-END C45411B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411c.dep b/gcc/testsuite/ada/acats/tests/c4/c45411c.dep
deleted file mode 100644
index eaa4723..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45411c.dep
+++ /dev/null
@@ -1,123 +0,0 @@
--- C45411C.DEP
-
--- 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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR
--- PREDEFINED LONG_INTEGER OPERANDS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE PREDEFINED LONG_INTEGER TYPE.
-
--- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION
--- OF TYPE "DT" MUST BE REJECTED.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
--- KAS 01/12/95 REMOVED INCOMPATIBLE SUBTEST
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45411C IS
-
- TYPE DT IS NEW LONG_INTEGER RANGE -3..3; -- N/A => ERROR.
- I1 : LONG_INTEGER := 1;
- D1 : DT := 1;
-
- FUNCTION IDENT (A : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- RETURN A * LONG_INTEGER(IDENT_INT(1));
- END;
-
-BEGIN
- TEST ("C45411C", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " &
- "CORRECT RESULTS FOR PREDEFINED LONG_INTEGER " &
- "OPERANDS");
-
- FOR I IN (1-2)..LONG_INTEGER(1) LOOP
- IF "-"(RIGHT => I1) /= IDENT(I) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- LONG_INTEGER'IMAGE(I+2));
- END IF;
-
- IF +I1 /= IDENT(I1) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- LONG_INTEGER'IMAGE(I+2));
- END IF;
- I1 := I1 - 1;
- END LOOP;
-
- FOR I IN (1-2)..LONG_INTEGER(1) LOOP
- IF -I /= IDENT(0)-I THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- LONG_INTEGER'IMAGE(I+5));
- END IF;
-
- IF "+"(RIGHT => IDENT(I)) /= I THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- LONG_INTEGER'IMAGE(I+5));
- END IF;
- END LOOP;
-
- IF -1 /= IDENT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 7");
- END IF;
-
- IF "-"(RIGHT => 0) /= IDENT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 8");
- END IF;
-
- IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" - 9");
- END IF;
-
- IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 7");
- END IF;
-
- IF +0 /= IDENT(0) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 8");
- END IF;
-
- IF +(-1) /= IDENT(1)-2 THEN
- FAILED ("INCORRECT RESULT FOR ""+"" - 9");
- END IF;
-
- FOR I IN (1-2)..LONG_INTEGER(1) LOOP
- IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" -" &
- LONG_INTEGER'IMAGE(I+11));
- END IF;
-
- IF +D1 /= DT(IDENT(LONG_INTEGER(D1))) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" -" &
- LONG_INTEGER'IMAGE(I+11));
- END IF;
- D1 := D1 - 1;
- END LOOP;
-
-
- RESULT;
-
-END C45411C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411d.ada b/gcc/testsuite/ada/acats/tests/c4/c45411d.ada
deleted file mode 100644
index 23adcbd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45411d.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C45411D.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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR
--- OPERANDS OF DERIVED INTEGER TYPES.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45411D IS
-
- TYPE INT IS RANGE -100..100;
-
- TYPE DT1 IS NEW INTEGER;
- TYPE DT2 IS NEW INT;
-
- D1 : DT1 := 1;
- D2 : DT2 := 1;
-
- FUNCTION IDENT (A : DT1) RETURN DT1 IS
- BEGIN
- RETURN A * DT1(IDENT_INT(1));
- END IDENT;
-
- FUNCTION IDENT (A : DT2) RETURN DT2 IS
- BEGIN
- RETURN A * DT2(IDENT_INT(1));
- END IDENT;
-
-BEGIN
- TEST ("C45411D", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " &
- "CORRECT RESULTS FOR OPERANDS OF DERIVED " &
- "INTEGER TYPES");
-
- FOR I IN DT1'(1-2)..DT1'(1) LOOP
- IF "-"(RIGHT => D1) /= IDENT(I) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" DT1 -" &
- DT1'IMAGE(I+2));
- END IF;
-
- IF +D1 /= IDENT(D1) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" DT1 -" &
- DT1'IMAGE(I+2));
- END IF;
- D1 := D1 - 1;
- END LOOP;
-
- IF DT1'LAST + DT1'FIRST = 0 THEN
- IF IDENT(-DT1'LAST) /= DT1'FIRST THEN
- FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST");
- END IF;
- ELSE
- IF IDENT(-DT1'LAST) /= DT1'FIRST+1 THEN
- FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST+1");
- END IF;
- END IF;
-
- FOR I IN DT2'(1-2)..DT2'(1) LOOP
- IF -D2 /= IDENT(I) THEN
- FAILED ("INCORRECT RESULT FOR ""-"" DT2 -" &
- DT2'IMAGE(I+2));
- END IF;
-
- IF "+"(RIGHT => D2) /= IDENT(D2) THEN
- FAILED ("INCORRECT RESULT FOR ""+"" DT2 -" &
- DT2'IMAGE(I+2));
- END IF;
- D2 := D2 - 1;
- END LOOP;
-
- RESULT;
-
-END C45411D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45413a.ada b/gcc/testsuite/ada/acats/tests/c4/c45413a.ada
deleted file mode 100644
index 4683323..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45413a.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C45413A.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 UNARY MINUS YIELDS AND ACCEPTS RESULTS BELONGING TO
--- THE BASE TYPE.
-
--- JBG 2/24/84
--- JRL 10/13/96 Removed static expressions which contained values outside
--- the base range.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45413A IS
-
- TYPE INT IS RANGE 1..10;
-
- X : INT := INT(IDENT_INT(9));
-
-BEGIN
-
- TEST ("C45413A", "CHECK SUBTYPE OF UNARY PLUS/MINUS");
-
- BEGIN
-
- IF -X /= INT'VAL(-9) THEN
- FAILED ("INCORRECT RESULT - UNARY MINUS");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("UNARY MINUS DOES NOT YIELD RESULT " &
- "BELONGING TO THE BASE TYPE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
- END;
-
- BEGIN
-
- IF -(INT'VAL(-9)) /= 9 THEN
- FAILED ("WRONG RESULT - UNARY MINUS");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("UNARY MINUS ARGUMENT NOT IN BASE TYPE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 2");
- END;
-
- RESULT;
-
-END C45413A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45431a.ada b/gcc/testsuite/ada/acats/tests/c4/c45431a.ada
deleted file mode 100644
index d66e890..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45431a.ada
+++ /dev/null
@@ -1,212 +0,0 @@
--- C45431A.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 FIXED POINT TYPES +A = A AND THAT, FOR MODEL NUMBERS,
--- -(-A) = A.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE.
-
--- WRG 8/28/86
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45431A IS
-
-BEGIN
-
- TEST ("C45431A", "CHECK THAT FOR FIXED POINT TYPES +A = A AND " &
- "THAT, FOR MODEL NUMBERS, -(-A) = A " &
- "-- BASIC TYPES");
-
- -------------------------------------------------------------------
-
-A: DECLARE
- TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0;
-
- NON_MODEL_CONST : CONSTANT := 2.0 / 3;
- NON_MODEL_VAR : LIKE_DURATION := 0.0;
-
- SMALL, MAX, MIN, ZERO : LIKE_DURATION := 0.5;
- X : LIKE_DURATION := 0.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- NON_MODEL_VAR := NON_MODEL_CONST;
- SMALL := LIKE_DURATION'SMALL;
- MAX := LIKE_DURATION'LAST;
- MIN := LIKE_DURATION'FIRST;
- ZERO := 0.0;
- END IF;
-
- -- CHECK + OR - ZERO = ZERO:
- IF "+"(RIGHT => ZERO) /= 0.0 OR
- +LIKE_DURATION'(0.0) /= ZERO THEN
- FAILED ("+0.0 /= 0.0");
- END IF;
- IF "-"(RIGHT => ZERO) /= 0.0 OR
- -LIKE_DURATION'(0.0) /= ZERO THEN
- FAILED ("-0.0 /= 0.0");
- END IF;
- IF -(-ZERO) /= 0.0 THEN
- FAILED ("-(-0.0) /= 0.0");
- END IF;
-
- -- CHECK + AND - MAX:
- IF EQUAL (3, 3) THEN
- X := MAX;
- END IF;
- IF +X /= MAX OR +LIKE_DURATION'LAST /= MAX THEN
- FAILED ("+LIKE_DURATION'LAST /= LIKE_DURATION'LAST");
- END IF;
- IF -(-X) /= MAX OR -(-LIKE_DURATION'LAST) /= MAX THEN
- FAILED ("-(-LIKE_DURATION'LAST) /= LIKE_DURATION'LAST");
- END IF;
-
- -- CHECK + AND - MIN:
- IF EQUAL (3, 3) THEN
- X := MIN;
- END IF;
- IF +X /= MIN OR +LIKE_DURATION'FIRST /= MIN THEN
- FAILED ("+LIKE_DURATION'FIRST /= LIKE_DURATION'FIRST");
- END IF;
- IF -(-X) /= MIN OR -(-LIKE_DURATION'FIRST) /= MIN THEN
- FAILED("-(-LIKE_DURATION'FIRST) /= LIKE_DURATION'FIRST");
- END IF;
-
- -- CHECK + AND - SMALL:
- IF EQUAL (3, 3) THEN
- X := SMALL;
- END IF;
- IF +X /= SMALL OR +LIKE_DURATION'SMALL /= SMALL THEN
- FAILED ("+LIKE_DURATION'SMALL /= LIKE_DURATION'SMALL");
- END IF;
- IF -(-X) /= SMALL OR -(-LIKE_DURATION'SMALL) /= SMALL THEN
- FAILED("-(-LIKE_DURATION'SMALL) /= LIKE_DURATION'SMALL");
- END IF;
-
- -- CHECK ARBITRARY MID-RANGE NUMBERS:
- IF EQUAL (3, 3) THEN
- X := 1000.984_375;
- END IF;
- IF +X /= 1000.984_375 OR +1000.984_375 /= X THEN
- FAILED ("+1000.984_375 /= 1000.984_375");
- END IF;
- IF -(-X) /= 1000.984_375 OR -(-1000.984_375) /= X THEN
- FAILED ("-(-1000.984_375) /= 1000.984_375");
- END IF;
-
- -- CHECK "+" AND "-" FOR NON-MODEL NUMBER:
- IF +LIKE_DURATION'(NON_MODEL_CONST) NOT IN 0.656_25 ..
- 0.671_875 OR
- +NON_MODEL_VAR NOT IN 0.656_25 .. 0.671_875 THEN
- FAILED ("+LIKE_DURATION'(2.0 / 3) NOT IN 0.656_25 .. " &
- "0.671_875");
- END IF;
- IF -LIKE_DURATION'(NON_MODEL_CONST) NOT IN -0.671_875 ..
- -0.656_25 OR
- -NON_MODEL_VAR NOT IN -0.671_875 .. -0.656_25 THEN
- FAILED ("-LIKE_DURATION'(2.0 / 3) NOT IN -0.671_875 " &
- ".. -0.656_25");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED -- A");
- END A;
-
- -------------------------------------------------------------------
-
-B: DECLARE
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
-
- NON_MODEL_CONST : CONSTANT := 2.0 / 3;
- NON_MODEL_VAR : DECIMAL_M4 := 0.0;
-
- SMALL, MAX, MIN, ZERO : DECIMAL_M4 := -128.0;
- X : DECIMAL_M4 := 0.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- NON_MODEL_VAR := NON_MODEL_CONST;
- SMALL := DECIMAL_M4'SMALL;
- ZERO := 0.0;
- END IF;
-
- -- CHECK + OR - ZERO = ZERO:
- IF +ZERO /= 0.0 OR +DECIMAL_M4'(0.0) /= ZERO THEN
- FAILED ("+0.0 /= 0.0");
- END IF;
- IF -ZERO /= 0.0 OR -DECIMAL_M4'(0.0) /= ZERO THEN
- FAILED ("-0.0 /= 0.0");
- END IF;
- IF -(-ZERO) /= 0.0 THEN
- FAILED ("-(-0.0) /= 0.0");
- END IF;
-
- -- CHECK + AND - MAX:
- IF EQUAL (3, 3) THEN
- X := MAX;
- END IF;
- -- CHECK + AND - SMALL:
- IF EQUAL (3, 3) THEN
- X := SMALL;
- END IF;
- IF +X /= SMALL OR +DECIMAL_M4'SMALL /= SMALL THEN
- FAILED ("+DECIMAL_M4'SMALL /= DECIMAL_M4'SMALL");
- END IF;
- IF -(-X) /= SMALL OR -(-DECIMAL_M4'SMALL) /= SMALL THEN
- FAILED ("-(-DECIMAL_M4'SMALL) /= DECIMAL_M4'SMALL");
- END IF;
-
- -- CHECK ARBITRARY MID-RANGE NUMBERS:
- IF EQUAL (3, 3) THEN
- X := 256.0;
- END IF;
- IF +X /= 256.0 OR +256.0 /= X THEN
- FAILED ("+256.0 /= 256.0");
- END IF;
- IF -(-X) /= 256.0 OR -(-256.0) /= X THEN
- FAILED ("-(-256.0) /= 256.0");
- END IF;
-
- -- CHECK "+" AND "-" FOR NON-MODEL NUMBER:
- IF +DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 OR
- +NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN
- FAILED ("+DECIMAL_M4'(2.0 / 3) NOT IN 0.0 .. 64.0");
- END IF;
- IF -DECIMAL_M4'(NON_MODEL_CONST) NOT IN -64.0 .. 0.0 OR
- -NON_MODEL_VAR NOT IN -64.0 .. 0.0 THEN
- FAILED ("-DECIMAL_M4'(2.0 / 3) NOT IN -64.0 .. 0.0");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED -- B");
- END B;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C45431A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c455001.a b/gcc/testsuite/ada/acats/tests/c4/c455001.a
deleted file mode 100644
index 8685e1b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c455001.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- C455001.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 WHATSOVER, 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 universal fixed multiplying operators can be used without
--- a conversion in contexts where the result type is determined.
---
--- Note: This is intended to check the changes made to these operators
--- in Ada 95; legacy tests should cover cases from Ada 83.
---
--- CHANGE HISTORY:
--- 18 MAR 99 RLB Initial version
---
---!
-
-with Report; use Report;
-
-procedure C455001 is
-
- type F1 is delta 2.0**(-1) range 0.0 .. 8.0;
-
- type F2 is delta 2.0**(-2) range 0.0 .. 4.0;
-
- type F3 is delta 2.0**(-3) range 0.0 .. 2.0;
-
- A : F1;
- B : F2;
- C : F3;
-
- type Fixed_Record is record
- D : F1;
- E : F2;
- end record;
-
- R : Fixed_Record;
-
- function Ident_Fix (X : F3) return F3 is
- begin
- if Equal(3,3) then
- return X;
- else
- return 0.0;
- end if;
- end Ident_Fix;
-
-begin
- Test ("C455001", "Check that universal fixed multiplying operators " &
- "can be used without a conversion in contexts where " &
- "the result type is determined.");
-
- A := 1.0; B := 1.0;
- C := A * B; -- Assignment context.
-
- if C /= Ident_Fix(1.0) then
- Failed ("Incorrect results for multiplication (1) - result is " &
- F3'Image(C));
- end if;
-
- C := A / B;
-
- if C /= Ident_Fix(1.0) then
- Failed ("Incorrect results for division (1) - result is " &
- F3'Image(C));
- end if;
-
- A := 2.5;
- C := A * 0.25;
-
- if C /= Ident_Fix(0.625) then
- Failed ("Incorrect results for multiplication (2) - result is " &
- F3'Image(C));
- end if;
-
- C := A / 4.0;
-
- if C /= Ident_Fix(0.625) then
- Failed ("Incorrect results for division (2) - result is " &
- F3'Image(C));
- end if;
-
- C := Ident_Fix(0.75);
- C := C * 0.5;
-
- if C /= Ident_Fix(0.375) then
- Failed ("Incorrect results for multiplication (3) - result is " &
- F3'Image(C));
- end if;
-
- C := Ident_Fix(0.75);
- C := C / 0.5;
-
- if C /= Ident_Fix(1.5) then
- Failed ("Incorrect results for division (3) - result is " &
- F3'Image(C));
- end if;
-
- A := 0.5; B := 0.3; -- Function parameter context.
- if Ident_Fix(A * B) not in Ident_Fix(0.125) .. Ident_Fix(0.25) then
- Failed ("Incorrect results for multiplication (4) - result is " &
- F3'Image(A * B)); -- Exact = 0.15
- end if;
-
- B := 0.8;
- if Ident_Fix(A / B) not in Ident_Fix(0.5) .. Ident_Fix(0.75) then
- Failed ("Incorrect results for division (4) - result is " &
- F3'Image(A / B));
- -- Exact = 0.625..., but B is only restricted to the range
- -- 0.75 .. 1.0, so the result can be anywhere in the range
- -- 0.5 .. 0.75.
- end if;
-
- C := 0.875; B := 1.5;
- R := (D => C * 4.0, E => B / 0.5); -- Aggregate context.
-
- if R.D /= 3.5 then
- Failed ("Incorrect results for multiplication (5) - result is " &
- F1'Image(R.D));
- end if;
-
- if R.E /= 3.0 then
- Failed ("Incorrect results for division (5) - result is " &
- F2'Image(R.E));
- end if;
-
- A := 0.5;
- C := A * F1'(B * 2.0); -- Qualified expression context.
-
- if C /= Ident_Fix(1.5) then
- Failed ("Incorrect results for multiplication (6) - result is " &
- F3'Image(C));
- end if;
-
- A := 4.0;
- C := F1'(B / 0.5) / A;
-
- if C /= Ident_Fix(0.75) then
- Failed ("Incorrect results for division (6) - result is " &
- F3'Image(C));
- end if;
-
- Result;
-
-end C455001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45502b.dep b/gcc/testsuite/ada/acats/tests/c4/c45502b.dep
deleted file mode 100644
index a8bd24c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45502b.dep
+++ /dev/null
@@ -1,291 +0,0 @@
--- C45502B.DEP
-
--- 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 MULTIPLICATION AND DIVISION YIELD CORRECT RESULTS WHEN
--- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45502B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S)));
- END IDENT;
-
-BEGIN
- TEST ( "C45502B", "CHECK THAT MULTIPLICATION AND DIVISION " &
- "YIELD CORRECT RESULTS WHEN THE OPERANDS " &
- "ARE OF PREDEFINED TYPE SHORT_INTEGER" );
-
- DECLARE
- I0 : SHORT_INTEGER := 0;
- I1 : SHORT_INTEGER := 1;
- I2 : SHORT_INTEGER := 2;
- I3 : SHORT_INTEGER := 3;
- I5 : SHORT_INTEGER := 5;
- I10 : SHORT_INTEGER := 10;
- I11 : SHORT_INTEGER := 11;
- I12 : SHORT_INTEGER := 12;
- I13 : SHORT_INTEGER := 13;
- I14 : SHORT_INTEGER := 14;
- N1 : SHORT_INTEGER := -1;
- N2 : SHORT_INTEGER := -2;
- N5 : SHORT_INTEGER := -5;
- N10 : SHORT_INTEGER := -10;
- N11 : SHORT_INTEGER := -11;
- N12 : SHORT_INTEGER := -12;
- N13 : SHORT_INTEGER := -13;
- N14 : SHORT_INTEGER := -14;
- N50 : SHORT_INTEGER := -50;
-
- BEGIN
- IF I0 * SHORT_INTEGER'FIRST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR I0 * " &
- "SHORT_INTEGER'FIRST" );
- END IF;
-
- IF I0 * SHORT_INTEGER'LAST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR I0 * " &
- "SHORT_INTEGER'LAST" );
- END IF;
-
- IF N1 * SHORT_INTEGER'LAST + SHORT_INTEGER'LAST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR N1 * " &
- "SHORT_INTEGER'LAST" );
- END IF;
-
- IF I3 * I1 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR I3 * I1" );
- END IF;
-
- IF IDENT (I3) * IDENT (I1) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " &
- "IDENT (I1)" );
- END IF;
-
- IF I2 * N1 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I2 * N1" );
- END IF;
-
- IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " &
- "RIGHT => N1)" );
- END IF;
-
- IF IDENT (I2) * IDENT (N1) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " &
- "IDENT (N1)" );
- END IF;
-
- IF I5 * I2 * N5 /= N50 THEN
- FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" );
- END IF;
-
- IF IDENT (N1) * IDENT (N5) /= I5 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " &
- "IDENT (N5)" );
- END IF;
-
- IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /=
- I5 THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " &
- "IDENT (N1), RIGHT => IDENT (N5))" );
- END IF;
-
- IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10
- THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " &
- "IDENT (I2) * IDENT (N5)" );
- END IF;
-
- IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " &
- "IDENT (I10)" );
- END IF;
-
- IF I0 * I10 /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR I0 * I10" );
- END IF;
-
- IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " &
- "RIGHT => I10)" );
- END IF;
-
- IF IDENT (I10) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF I11 / I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I11 / I5" );
- END IF;
-
- IF IDENT (I12) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /=
- I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (I12), RIGHT => IDENT (I5))" );
- END IF;
-
- IF I13 / I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I13 / I5" );
- END IF;
-
- IF IDENT (I14) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF I10 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I10 / N5" );
- END IF;
-
- IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I11) / IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF I12 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 / N5" );
- END IF;
-
- IF IDENT (I13) / IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF I14 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I14 / N5" );
- END IF;
-
- IF IDENT (N10) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /=
- N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (N10), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N11 / I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N11 / I5" );
- END IF;
-
- IF IDENT (N12) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF N13 / I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N13 / I5" );
- END IF;
-
- IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N14) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF N10 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N10 / N5" );
- END IF;
-
- IF IDENT (N11) / IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /=
- I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N12 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N12 / N5" );
- END IF;
-
-
- IF IDENT (N13) / IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF N14 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N14 / N5" );
- END IF;
-
- IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " &
- "RIGHT => N5)" );
- END IF;
-
- IF I0 / I5 /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR I0 / I5" );
- END IF;
-
- IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " &
- "RIGHT => I5)" );
- END IF;
-
- IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " &
- "IDENT (I5)" );
- END IF;
-
- END;
-
- RESULT;
-END C45502B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45502c.dep b/gcc/testsuite/ada/acats/tests/c4/c45502c.dep
deleted file mode 100644
index 96d0212..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45502c.dep
+++ /dev/null
@@ -1,295 +0,0 @@
--- C45502C.DEP
-
--- 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 MULTIPLICATION AND DIVISION YIELD CORRECT RESULTS WHEN
--- THE OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 09/01/86
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45502C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (S : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN S;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
-BEGIN
- TEST ( "C45502C", "CHECK THAT MULTIPLICATION AND DIVISION " &
- "YIELD CORRECT RESULTS WHEN THE OPERANDS " &
- "ARE OF PREDEFINED TYPE LONG_INTEGER" );
-
- DECLARE
- I0 : LONG_INTEGER := 0;
- I1 : LONG_INTEGER := 1;
- I2 : LONG_INTEGER := 2;
- I3 : LONG_INTEGER := 3;
- I5 : LONG_INTEGER := 5;
- I10 : LONG_INTEGER := 10;
- I11 : LONG_INTEGER := 11;
- I12 : LONG_INTEGER := 12;
- I13 : LONG_INTEGER := 13;
- I14 : LONG_INTEGER := 14;
- N1 : LONG_INTEGER := -1;
- N2 : LONG_INTEGER := -2;
- N5 : LONG_INTEGER := -5;
- N10 : LONG_INTEGER := -10;
- N11 : LONG_INTEGER := -11;
- N12 : LONG_INTEGER := -12;
- N13 : LONG_INTEGER := -13;
- N14 : LONG_INTEGER := -14;
- N50 : LONG_INTEGER := -50;
-
- BEGIN
- IF I0 * LONG_INTEGER'FIRST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR I0 * " &
- "LONG_INTEGER'FIRST" );
- END IF;
-
- IF I0 * LONG_INTEGER'LAST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR I0 * " &
- "LONG_INTEGER'LAST" );
- END IF;
-
- IF N1 * LONG_INTEGER'LAST + LONG_INTEGER'LAST /= 0 THEN
- FAILED ( "INCORRECT RESULT FOR N1 * " &
- "LONG_INTEGER'LAST" );
- END IF;
-
- IF I3 * I1 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR I3 * I1" );
- END IF;
-
- IF IDENT (I3) * IDENT (I1) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " &
- "IDENT (I1)" );
- END IF;
-
- IF I2 * N1 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I2 * N1" );
- END IF;
-
- IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " &
- "RIGHT => N1)" );
- END IF;
-
- IF IDENT (I2) * IDENT (N1) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " &
- "IDENT (N1)" );
- END IF;
-
- IF I5 * I2 * N5 /= N50 THEN
- FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" );
- END IF;
-
- IF IDENT (N1) * IDENT (N5) /= I5 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " &
- "IDENT (N5)" );
- END IF;
-
- IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /=
- I5 THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " &
- "IDENT (N1), RIGHT => IDENT (N5))" );
- END IF;
-
- IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10
- THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " &
- "IDENT (I2) * IDENT (N5)" );
- END IF;
-
- IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " &
- "IDENT (I10)" );
- END IF;
-
- IF I0 * I10 /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR I0 * I10" );
- END IF;
-
- IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " &
- "RIGHT => I10)" );
- END IF;
-
- IF IDENT (I10) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF I11 / I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I11 / I5" );
- END IF;
-
- IF IDENT (I12) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /=
- I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (I12), RIGHT => IDENT (I5))" );
- END IF;
-
- IF I13 / I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I13 / I5" );
- END IF;
-
- IF IDENT (I14) / IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF I10 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I10 / N5" );
- END IF;
-
- IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I11) / IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF I12 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 / N5" );
- END IF;
-
- IF IDENT (I13) / IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF I14 / N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I14 / N5" );
- END IF;
-
- IF IDENT (N10) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /=
- N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (N10), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N11 / I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N11 / I5" );
- END IF;
-
- IF IDENT (N12) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF N13 / I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N13 / I5" );
- END IF;
-
- IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N14) / IDENT (I5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) " &
- "/ IDENT (I5)" );
- END IF;
-
- IF N10 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N10 / N5" );
- END IF;
-
- IF IDENT (N11) / IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /=
- I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N12 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N12 / N5" );
- END IF;
-
-
- IF IDENT (N13) / IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) " &
- "/ IDENT (N5)" );
- END IF;
-
- IF N14 / N5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR N14 / N5" );
- END IF;
-
- IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " &
- "RIGHT => N5)" );
- END IF;
-
- IF I0 / I5 /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR I0 / I5" );
- END IF;
-
- IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN
- FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " &
- "RIGHT => I5)" );
- END IF;
-
- IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " &
- "IDENT (I5)" );
- END IF;
-
- END;
-
- RESULT;
-END C45502C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503a.ada b/gcc/testsuite/ada/acats/tests/c4/c45503a.ada
deleted file mode 100644
index 0461b01..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45503a.ada
+++ /dev/null
@@ -1,310 +0,0 @@
--- C45503A.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 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE OPERANDS
--- ARE OF PREDEFINED TYPE INTEGER.
-
--- R.WILLIAMS 9/1/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45503A IS
-
-BEGIN
- TEST ( "C45503A", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " &
- "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " &
- "TYPE INTEGER" );
-
- DECLARE
- I0 : INTEGER := 0;
- I1 : INTEGER := 1;
- I2 : INTEGER := 2;
- I3 : INTEGER := 3;
- I4 : INTEGER := 4;
- I5 : INTEGER := 5;
- I10 : INTEGER := 10;
- I11 : INTEGER := 11;
- I12 : INTEGER := 12;
- I13 : INTEGER := 13;
- I14 : INTEGER := 14;
- N1 : INTEGER := -1;
- N2 : INTEGER := -2;
- N3 : INTEGER := -3;
- N4 : INTEGER := -4;
- N5 : INTEGER := -5;
- N10 : INTEGER := -10;
- N11 : INTEGER := -11;
- N12 : INTEGER := -12;
- N13 : INTEGER := -13;
- N14 : INTEGER := -14;
-
- BEGIN
- IF I10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 REM I5" );
- END IF;
-
- IF IDENT_INT (I11) REM IDENT_INT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) REM " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF I12 REM I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 REM I5" );
- END IF;
-
- IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT_INT (I13) REM IDENT_INT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) REM " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF I14 REM I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 REM I5" );
- END IF;
-
- IF IDENT_INT (I10) REM IDENT_INT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" );
- END IF;
-
- IF I11 REM N5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR I11 REM N5" );
- END IF;
-
- IF IDENT_INT (I12) REM IDENT_INT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF I13 REM N5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR I13 REM N5" );
- END IF;
-
- IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT_INT (I14) REM IDENT_INT (N5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF N10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 REM I5" );
- END IF;
-
- IF IDENT_INT (N11) REM IDENT_INT (I5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) REM " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5))
- /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" );
- END IF;
-
- IF N12 REM I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N12 REM I5" );
- END IF;
-
- IF IDENT_INT (N13) REM IDENT_INT (I5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) REM " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF N14 REM I5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR N14 REM I5" );
- END IF;
-
- IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT_INT (N10) REM IDENT_INT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF N11 REM N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 REM N5" );
- END IF;
-
- IF IDENT_INT (N12) REM IDENT_INT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" );
- END IF;
-
- IF N13 REM N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 REM N5" );
- END IF;
-
- IF IDENT_INT (N14) REM IDENT_INT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) REM " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF I10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 MOD I5" );
- END IF;
-
- IF IDENT_INT (I11) MOD IDENT_INT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) MOD " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF I12 MOD I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT_INT (I13) MOD IDENT_INT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) MOD " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF I14 MOD I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 MOD I5" );
- END IF;
-
- IF IDENT_INT (I10) MOD IDENT_INT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) MOD " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" );
- END IF;
-
- IF I11 MOD N5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR I11 MOD N5" );
- END IF;
-
- IF IDENT_INT (I12) MOD IDENT_INT (N5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) MOD " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF I13 MOD N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I13 MOD N5" );
- END IF;
-
- IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT_INT (I14) MOD IDENT_INT (N5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) MOD " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF N10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 MOD I5" );
- END IF;
-
- IF IDENT_INT (N11) MOD IDENT_INT (I5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) MOD " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5))
- /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" );
- END IF;
-
- IF N12 MOD I5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR N12 MOD I5" );
- END IF;
-
- IF IDENT_INT (N13) MOD IDENT_INT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) MOD " &
- "IDENT_INT (I5)" );
- END IF;
-
- IF N14 MOD I5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR N14 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT_INT (N10) MOD IDENT_INT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) MOD " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF N11 MOD N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 MOD N5" );
- END IF;
-
- IF IDENT_INT (N12) MOD IDENT_INT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) MOD " &
- "IDENT_INT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" );
- END IF;
-
- IF N13 MOD N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 MOD N5" );
- END IF;
-
- IF IDENT_INT (N14) MOD IDENT_INT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) MOD " &
- "IDENT_INT (N5)" );
- END IF;
- END;
-
- RESULT;
-END C45503A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503b.dep b/gcc/testsuite/ada/acats/tests/c4/c45503b.dep
deleted file mode 100644
index 570c529..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45503b.dep
+++ /dev/null
@@ -1,327 +0,0 @@
--- C45503B.DEP
-
--- 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 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE
--- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45503B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S)));
- END IDENT;
-
-BEGIN
- TEST ( "C45503B", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " &
- "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " &
- "TYPE SHORT_INTEGER" );
-
- DECLARE
- I0 : SHORT_INTEGER := 0;
- I1 : SHORT_INTEGER := 1;
- I2 : SHORT_INTEGER := 2;
- I3 : SHORT_INTEGER := 3;
- I4 : SHORT_INTEGER := 4;
- I5 : SHORT_INTEGER := 5;
- I10 : SHORT_INTEGER := 10;
- I11 : SHORT_INTEGER := 11;
- I12 : SHORT_INTEGER := 12;
- I13 : SHORT_INTEGER := 13;
- I14 : SHORT_INTEGER := 14;
- N1 : SHORT_INTEGER := -1;
- N2 : SHORT_INTEGER := -2;
- N3 : SHORT_INTEGER := -3;
- N4 : SHORT_INTEGER := -4;
- N5 : SHORT_INTEGER := -5;
- N10 : SHORT_INTEGER := -10;
- N11 : SHORT_INTEGER := -11;
- N12 : SHORT_INTEGER := -12;
- N13 : SHORT_INTEGER := -13;
- N14 : SHORT_INTEGER := -14;
-
- BEGIN
- IF I10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 REM I5" );
- END IF;
-
- IF IDENT (I11) REM IDENT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF I12 REM I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 REM I5" );
- END IF;
-
- IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (I13) REM IDENT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF I14 REM I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 REM I5" );
- END IF;
-
- IF IDENT (I10) REM IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (I10), RIGHT => IDENT (N5))" );
- END IF;
-
- IF I11 REM N5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR I11 REM N5" );
- END IF;
-
- IF IDENT (I12) REM IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF I13 REM N5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR I13 REM N5" );
- END IF;
-
- IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I14) REM IDENT (N5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF N10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 REM I5" );
- END IF;
-
- IF IDENT (N11) REM IDENT (I5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5))
- /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N12 REM I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N12 REM I5" );
- END IF;
-
- IF IDENT (N13) REM IDENT (I5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF N14 REM I5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR N14 REM I5" );
- END IF;
-
- IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N10) REM IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF N11 REM N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 REM N5" );
- END IF;
-
- IF IDENT (N12) REM IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (N12), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N13 REM N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 REM N5" );
- END IF;
-
- IF IDENT (N14) REM IDENT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF I10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 MOD I5" );
- END IF;
-
- IF IDENT (I11) MOD IDENT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF I12 MOD I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (I13) MOD IDENT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF I14 MOD I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 MOD I5" );
- END IF;
-
- IF IDENT (I10) MOD IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (I10), RIGHT => IDENT (N5))" );
- END IF;
-
- IF I11 MOD N5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR I11 MOD N5" );
- END IF;
-
- IF IDENT (I12) MOD IDENT (N5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF I13 MOD N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I13 MOD N5" );
- END IF;
-
- IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I14) MOD IDENT (N5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF N10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 MOD I5" );
- END IF;
-
- IF IDENT (N11) MOD IDENT (I5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5))
- /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N12 MOD I5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR N12 MOD I5" );
- END IF;
-
- IF IDENT (N13) MOD IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF N14 MOD I5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR N14 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N10) MOD IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF N11 MOD N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 MOD N5" );
- END IF;
-
- IF IDENT (N12) MOD IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (N12), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N13 MOD N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 MOD N5" );
- END IF;
-
- IF IDENT (N14) MOD IDENT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " &
- "IDENT (N5)" );
- END IF;
- END;
-
- RESULT;
-END C45503B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503c.dep b/gcc/testsuite/ada/acats/tests/c4/c45503c.dep
deleted file mode 100644
index 9a66c35..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45503c.dep
+++ /dev/null
@@ -1,331 +0,0 @@
--- C45503C.DEP
-
--- 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 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE
--- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45503C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (L : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN L;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
-BEGIN
- TEST ( "C45503C", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " &
- "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " &
- "TYPE LONG_INTEGER" );
-
- DECLARE
- I0 : LONG_INTEGER := 0;
- I1 : LONG_INTEGER := 1;
- I2 : LONG_INTEGER := 2;
- I3 : LONG_INTEGER := 3;
- I4 : LONG_INTEGER := 4;
- I5 : LONG_INTEGER := 5;
- I10 : LONG_INTEGER := 10;
- I11 : LONG_INTEGER := 11;
- I12 : LONG_INTEGER := 12;
- I13 : LONG_INTEGER := 13;
- I14 : LONG_INTEGER := 14;
- N1 : LONG_INTEGER := -1;
- N2 : LONG_INTEGER := -2;
- N3 : LONG_INTEGER := -3;
- N4 : LONG_INTEGER := -4;
- N5 : LONG_INTEGER := -5;
- N10 : LONG_INTEGER := -10;
- N11 : LONG_INTEGER := -11;
- N12 : LONG_INTEGER := -12;
- N13 : LONG_INTEGER := -13;
- N14 : LONG_INTEGER := -14;
-
- BEGIN
- IF I10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 REM I5" );
- END IF;
-
- IF IDENT (I11) REM IDENT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF I12 REM I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 REM I5" );
- END IF;
-
- IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (I13) REM IDENT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF I14 REM I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 REM I5" );
- END IF;
-
- IF IDENT (I10) REM IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (I10), RIGHT => IDENT (N5))" );
- END IF;
-
- IF I11 REM N5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR I11 REM N5" );
- END IF;
-
- IF IDENT (I12) REM IDENT (N5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF I13 REM N5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR I13 REM N5" );
- END IF;
-
- IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I14) REM IDENT (N5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF N10 REM I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 REM I5" );
- END IF;
-
- IF IDENT (N11) REM IDENT (I5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5))
- /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N12 REM I5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR N12 REM I5" );
- END IF;
-
- IF IDENT (N13) REM IDENT (I5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " &
- "IDENT (I5)" );
- END IF;
-
- IF N14 REM I5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR N14 REM I5" );
- END IF;
-
- IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N10) REM IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF N11 REM N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 REM N5" );
- END IF;
-
- IF IDENT (N12) REM IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " &
- "IDENT (N12), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N13 REM N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 REM N5" );
- END IF;
-
- IF IDENT (N14) REM IDENT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " &
- "IDENT (N5)" );
- END IF;
-
- IF I10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR I10 MOD I5" );
- END IF;
-
- IF IDENT (I11) MOD IDENT (I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF I12 MOD I5 /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR I12 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (I13) MOD IDENT (I5) /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF I14 MOD I5 /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR I14 MOD I5" );
- END IF;
-
- IF IDENT (I10) MOD IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5))
- /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (I10), RIGHT => IDENT (N5))" );
- END IF;
-
- IF I11 MOD N5 /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR I11 MOD N5" );
- END IF;
-
- IF IDENT (I12) MOD IDENT (N5) /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF I13 MOD N5 /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR I13 MOD N5" );
- END IF;
-
- IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " &
- "RIGHT => N5)" );
- END IF;
-
- IF IDENT (I14) MOD IDENT (N5) /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF N10 MOD I5 /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR N10 MOD I5" );
- END IF;
-
- IF IDENT (N11) MOD IDENT (I5) /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5))
- /= I4 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (N11), RIGHT => IDENT (I5))" );
- END IF;
-
- IF N12 MOD I5 /= I3 THEN
- FAILED ( "INCORRECT RESULT FOR N12 MOD I5" );
- END IF;
-
- IF IDENT (N13) MOD IDENT (I5) /= I2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " &
- "IDENT (I5)" );
- END IF;
-
- IF N14 MOD I5 /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR N14 MOD I5" );
- END IF;
-
- IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " &
- "RIGHT => I5)" );
- END IF;
-
- IF IDENT (N10) MOD IDENT (N5) /= I0 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF N11 MOD N5 /= N1 THEN
- FAILED ( "INCORRECT RESULT FOR N11 MOD N5" );
- END IF;
-
- IF IDENT (N12) MOD IDENT (N5) /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " &
- "IDENT (N5)" );
- END IF;
-
- IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5))
- /= N2 THEN
- FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " &
- "IDENT (N12), RIGHT => IDENT (N5))" );
- END IF;
-
- IF N13 MOD N5 /= N3 THEN
- FAILED ( "INCORRECT RESULT FOR N13 MOD N5" );
- END IF;
-
- IF IDENT (N14) MOD IDENT (N5) /= N4 THEN
- FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " &
- "IDENT (N5)" );
- END IF;
- END;
-
- RESULT;
-END C45503C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504a.ada b/gcc/testsuite/ada/acats/tests/c4/c45504a.ada
deleted file mode 100644
index 7cc4af4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504a.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C45504A.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 CONSTRAINT_ERROR IS RAISED WHEN A
--- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE
--- OPERANDS ARE OF PREDEFINED TYPE INTEGER.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504A IS
-
- F : INTEGER := IDENT_INT (INTEGER'FIRST);
- L : INTEGER := IDENT_INT (INTEGER'LAST);
-
-BEGIN
- TEST ( "C45504A", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " &
- "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " &
- "OF PREDEFINED TYPE INTEGER" );
-
- BEGIN
- IF EQUAL (F*L,-100) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" );
- END;
-
- BEGIN
- IF EQUAL (F*F,100) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" );
- END;
-
- BEGIN
- IF EQUAL (L*L,100) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" );
- END;
-
- RESULT;
-END C45504A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504b.dep b/gcc/testsuite/ada/acats/tests/c4/c45504b.dep
deleted file mode 100644
index 2307505..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504b.dep
+++ /dev/null
@@ -1,117 +0,0 @@
--- C45504B.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED WHEN
--- A PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF
--- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE PREDEFINED TYPE "SHORT_INTEGER".
-
--- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF
--- THE VARIABLE "F" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO
--- DEFEAT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504B IS
-
- F : SHORT_INTEGER; -- N/A => ERROR.
- L : SHORT_INTEGER;
-
- FUNCTION IDENT_SHORT(A : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN A;
- ELSE
- RETURN 0;
- END IF;
- END IDENT_SHORT;
-
- FUNCTION SHORT_OK(X : SHORT_INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = IDENT_SHORT(X);
- END SHORT_OK;
-
-BEGIN
- TEST ( "C45504B", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " &
- "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " &
- "OF PREDEFINED TYPE SHORT_INTEGER" );
-
- F := IDENT_SHORT(SHORT_INTEGER'FIRST);
- L := IDENT_SHORT(SHORT_INTEGER'LAST);
-
- BEGIN
- IF SHORT_OK (F*L) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" );
- END;
-
- BEGIN
- IF SHORT_OK (F * F) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" );
- END;
-
- BEGIN
- IF SHORT_OK (L * L) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" );
- END;
-
- RESULT;
-
-END C45504B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504c.dep b/gcc/testsuite/ada/acats/tests/c4/c45504c.dep
deleted file mode 100644
index d39ee63..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504c.dep
+++ /dev/null
@@ -1,119 +0,0 @@
--- C45504C.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED WHEN A
--- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE
--- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE PREDEFINED TYPE "LONG_INTEGER".
-
--- IF SUCH A TYPE IS NOT SUPPORTED THEN THE DECLARATION OF THE
--- VARIABLE "F" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT AND DEFEATED OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504C IS
-
- F : LONG_INTEGER; -- N/A => ERROR.
- L : LONG_INTEGER;
-
- FUNCTION IDENT_LONG(A : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN A;
- ELSE
- RETURN 0;
- END IF;
- END IDENT_LONG;
-
- FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = IDENT_LONG(X);
- END;
-
-BEGIN
- TEST ( "C45504C", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " &
- "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " &
- "OF PREDEFINED TYPE LONG_INTEGER" );
-
- F := IDENT_LONG(LONG_INTEGER'FIRST);
- L := IDENT_LONG(LONG_INTEGER'LAST);
-
- BEGIN
- IF LONG_OK (F * L) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" );
- END;
-
- BEGIN
- IF LONG_OK (F * F) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" );
- END;
-
- BEGIN
- IF LONG_OK (L * L) THEN
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" );
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" );
- END;
-
- RESULT;
-
-END C45504C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504d.ada b/gcc/testsuite/ada/acats/tests/c4/c45504d.ada
deleted file mode 100644
index 0b37b13..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504d.ada
+++ /dev/null
@@ -1,214 +0,0 @@
--- C45504D.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 WHEN THE SECOND
--- OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE OPERANDS ARE OF
--- PREDEFINED TYPE INTEGER.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- R.WILLIAMS 9/1/86
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504D IS
-
- I0 : INTEGER := IDENT_INT (0);
- I5 : INTEGER := IDENT_INT (5);
- N5 : INTEGER := IDENT_INT (-5);
-
-BEGIN
- TEST ( "C45504D", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN THE SECOND OPERAND OF '/', " &
- "'MOD', OR 'REM' EQUALS ZERO, IF THE " &
- "OPERANDS ARE OF PREDEFINED TYPE INTEGER" );
-
- BEGIN
- IF I5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" );
- END;
-
- BEGIN
- IF N5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" );
- END;
-
- BEGIN
- IF I0 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" );
- END;
-
- BEGIN
- IF I5 / I0 * I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" );
- END;
-
- BEGIN
- IF N5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" );
- END;
-
- BEGIN
- IF I0 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = (I5 + I0) MOD I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- END;
-
- BEGIN
- IF I5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" );
- END;
-
- BEGIN
- IF N5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" );
- END;
-
- BEGIN
- IF I0 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" );
- END;
-
- BEGIN
- IF I5 REM (-I0) = I5 REM I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " &
- "= I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0'" );
- END;
-
- RESULT;
-END C45504D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504e.dep b/gcc/testsuite/ada/acats/tests/c4/c45504e.dep
deleted file mode 100644
index 8ad4e59..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504e.dep
+++ /dev/null
@@ -1,234 +0,0 @@
--- C45504E.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED WHEN THE
--- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE
--- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504E IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- I0 : SHORT_INTEGER := 1;
- I5 : SHORT_INTEGER := 2;
- N5 : SHORT_INTEGER := 3;
-
-BEGIN
- TEST ( "C45504E", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN THE SECOND OPERAND OF '/', " &
- "'MOD', OR 'REM' EQUALS ZERO, IF THE " &
- "OPERANDS ARE OF PREDEFINED TYPE " &
- "SHORT_INTEGER" );
-
- IF EQUAL (3, 3) THEN
- I0 := 0;
- I5 := 5;
- N5 := -5;
- END IF;
-
- BEGIN
- IF I5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" );
- END;
-
- BEGIN
- IF N5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" );
- END;
-
- BEGIN
- IF I0 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" );
- END;
-
- BEGIN
- IF I5 / I0 * I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" );
- END;
-
- BEGIN
- IF N5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" );
- END;
-
- BEGIN
- IF I0 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = (I5 + I0) MOD I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- END;
-
- BEGIN
- IF I5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" );
- END;
-
- BEGIN
- IF N5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" );
- END;
-
- BEGIN
- IF I0 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" );
- END;
-
- BEGIN
- IF I5 REM (-I0) = I5 REM I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " &
- "= I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0'" );
- END;
-
- RESULT;
-END C45504E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504f.dep b/gcc/testsuite/ada/acats/tests/c4/c45504f.dep
deleted file mode 100644
index 81ea6c1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45504f.dep
+++ /dev/null
@@ -1,234 +0,0 @@
--- C45504F.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED WHEN THE
--- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE
--- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- HISTORY:
--- RJW 09/01/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION.
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45504F IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- I0 : LONG_INTEGER := 1;
- I5 : LONG_INTEGER := 2;
- N5 : LONG_INTEGER := 3;
-
-BEGIN
- TEST ( "C45504F", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED WHEN THE SECOND OPERAND OF '/', " &
- "'MOD', OR 'REM' EQUALS ZERO, IF THE " &
- "OPERANDS ARE OF PREDEFINED TYPE " &
- "LONG_INTEGER" );
-
- IF EQUAL (3, 3) THEN
- I0 := 0;
- I5 := 5;
- N5 := -5;
- END IF;
-
- BEGIN
- IF I5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" );
- END;
-
- BEGIN
- IF N5 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" );
- END;
-
- BEGIN
- IF I0 / I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" );
- END;
-
- BEGIN
- IF I5 / I0 * I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" );
- END;
-
- BEGIN
- IF N5 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" );
- END;
-
- BEGIN
- IF I0 MOD I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" );
- END;
-
- BEGIN
- IF I5 MOD I0 = (I5 + I0) MOD I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " &
- "(I5 + I0) MOD I0'" );
- END;
-
- BEGIN
- IF I5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" );
- END;
-
- BEGIN
- IF N5 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" );
- END;
-
- BEGIN
- IF I0 REM I0 = 0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" );
- END;
-
- BEGIN
- IF I5 REM (-I0) = I5 REM I0 THEN
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " &
- "= I5 REM I0'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " &
- "I5 REM I0'" );
- END;
-
- RESULT;
-END C45504F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45505a.ada b/gcc/testsuite/ada/acats/tests/c4/c45505a.ada
deleted file mode 100644
index 747d34b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45505a.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C45505A.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 MULTIPLICATION FOR INTEGER SUBTYPES YIELDS A RESULT
--- BELONGING TO THE BASE TYPE.
-
--- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
--- *** remove incompatibilities associated with the transition -- 9X
--- *** to Ada 9X. -- 9X
-
--- JBG 2/24/84
--- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45505A IS
-
- TYPE INT IS RANGE 1..10;
-
- X, Y : INT := INT(IDENT_INT(5));
-
-BEGIN
-
- TEST ("C45505A", "CHECK SUBTYPE OF INTEGER MULTIPLICATION");
-
- BEGIN
-
- IF X * Y / 5 /= INT(IDENT_INT(5)) THEN
- FAILED ("INCORRECT RESULT");
- END IF;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- IF INT'BASE'LAST >= INT'VAL(25) THEN
- FAILED ("MULTIPLICATION DOES NOT YIELD RESULT " &
- "BELONGING TO THE BASE TYPE");
- ELSE
- COMMENT ("BASE TYPE HAS RANGE LESS THAN 25");
- END IF;
- END;
-
- RESULT;
-
-END C45505A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45523a.ada b/gcc/testsuite/ada/acats/tests/c4/c45523a.ada
deleted file mode 100644
index ff78eab..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45523a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C45523A.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:
--- FOR FLOATING POINT TYPES, IF MACHINE_OVERFLOWS IS TRUE AND
--- EITHER THE RESULT OF MULTIPLICATION LIES OUTSIDE THE RANGE OF THE
--- BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY ZERO, THEN
--- CONSTRAINT_ERROR IS RAISED. THIS TESTS
--- DIGITS 5.
-
-
--- *** 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:
--- BCB 02/09/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
--- KAS 11/14/95 DELETED USAGE OF 'SAFE_LARGE
--- KAS 11/30/95 GOT IT RIGHT THIS TIME
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45523A IS
-
- TYPE FLT IS DIGITS 5;
-
- F : FLT;
-
- FUNCTION IDENT_FLT(X : FLT) RETURN FLT IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FLT;
-
- FUNCTION EQUAL_FLT(ONE, TWO : FLT) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = TWO * FLT (IDENT_INT(1));
- END EQUAL_FLT;
-
-BEGIN
- TEST ("C45523A", "FOR FLOATING POINT TYPES, IF MACHINE_" &
- "OVERFLOWS IS TRUE AND EITHER THE RESULT OF " &
- "MULTIPLICATION LIES OUTSIDE THE RANGE OF THE " &
- "BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY " &
- "ZERO, THEN CONSTRAINT_ERROR IS RAISED." &
- "THIS TESTS DIGITS 5");
-
-
- IF FLT'MACHINE_OVERFLOWS THEN
- BEGIN
- F := (FLT'BASE'LAST) * IDENT_FLT (2.0);
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR MULTIPLICATION");
- IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " &
- "MULTIPLICATION");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN " &
- "CONSTRAINT_ERROR WAS RAISED FOR " &
- "MULTIPLICATION");
- END;
- BEGIN
- F := (FLT'LAST) / IDENT_FLT (0.0);
- FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR DIVISION BY ZERO");
- IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN
- COMMENT ("DON'T OPTIMIZE F");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " &
- "DIVISION BY ZERO");
- WHEN OTHERS =>
- FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
- "WAS RAISED FOR DIVISION BY ZERO");
- END;
- ELSE
- NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " &
- "MACHINE_OVERFLOWS BEING FALSE");
- END IF;
-
- RESULT;
-END C45523A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531a.ada b/gcc/testsuite/ada/acats/tests/c4/c45531a.ada
deleted file mode 100644
index 6a77909..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531a.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- C45531A.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531A IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531A", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (0.125); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.125); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_2 (DEL4 * FORTH + DEL1 );
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_2 (DEL4 * FORTH + DEL1 );
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531b.ada b/gcc/testsuite/ada/acats/tests/c4/c45531b.ada
deleted file mode 100644
index 74ac115..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531b.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45531B.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531B IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL2 : CONSTANT := 2.0 * DEL1;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531B", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER
- A := FX_1 (DEL2 * (3 * FORTH + 1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_2 (3 * (DEL4 * FORTH + DEL1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531c.ada b/gcc/testsuite/ada/acats/tests/c4/c45531c.ada
deleted file mode 100644
index a864dec..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531c.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- C45531C.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531C IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531C", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (2.5); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_RNG1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_RNG1 (RNG1 * FORTH + 0.5);
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_RNG1 (RNG1 * FORTH + 0.5);
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531d.ada b/gcc/testsuite/ada/acats/tests/c4/c45531d.ada
deleted file mode 100644
index 2c2eb87..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531d.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45531D.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531D IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531D", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (7.5); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH + 1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531e.ada b/gcc/testsuite/ada/acats/tests/c4/c45531e.ada
deleted file mode 100644
index f05ef92..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531e.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- C45531E.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531E IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531E", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (0.125); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.125); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_2 (DEL4 * FORTH + DEL1 );
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_2 (DEL4 * FORTH + DEL1 );
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531f.ada b/gcc/testsuite/ada/acats/tests/c4/c45531f.ada
deleted file mode 100644
index 65b1f18..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531f.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45531F.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531F IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL2 : CONSTANT := 2.0 * DEL1;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531F", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER
- A := FX_1 (DEL2 * (3 * FORTH + 1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_2 (3 * (DEL4 * FORTH + DEL1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531g.ada b/gcc/testsuite/ada/acats/tests/c4/c45531g.ada
deleted file mode 100644
index b6146ab..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531g.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- C45531G.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531G IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531G", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (2.5); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_RNG1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_RNG1 (RNG1 * FORTH + 0.5);
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_RNG1 (RNG1 * FORTH + 0.5);
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531h.ada b/gcc/testsuite/ada/acats/tests/c4/c45531h.ada
deleted file mode 100644
index e135158..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531h.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45531H.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531H IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531H", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (7.5); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH + 1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531H;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531i.ada b/gcc/testsuite/ada/acats/tests/c4/c45531i.ada
deleted file mode 100644
index ff47658..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531i.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- C45531I.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531I IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531I", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (0.125); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.125); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_2 (DEL4 * FORTH + DEL1 );
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_2 (DEL4 * FORTH + DEL1 );
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531j.ada b/gcc/testsuite/ada/acats/tests/c4/c45531j.ada
deleted file mode 100644
index 7279dd9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531j.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- C45531J.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45531J IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL2 : CONSTANT := 2.0 * DEL1;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531J", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER
- A := FX_1 (DEL2 * (3 * FORTH + 1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_2 (3 * (DEL4 * FORTH + DEL1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531J;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531k.ada b/gcc/testsuite/ada/acats/tests/c4/c45531k.ada
deleted file mode 100644
index 2e70d17..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531k.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- C45531K.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT;
-PROCEDURE C45531K IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531K", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (2.5); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_RNG1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_RNG1 (RNG1 * FORTH + 0.5);
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_RNG1 (RNG1 * FORTH + 0.5);
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531K;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531l.ada b/gcc/testsuite/ada/acats/tests/c4/c45531l.ada
deleted file mode 100644
index 97a6f8d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531l.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- C45531L.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT;
-PROCEDURE C45531L IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531L", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (7.5); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH + 1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531L;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531m.dep b/gcc/testsuite/ada/acats/tests/c4/c45531m.dep
deleted file mode 100644
index 25ded1f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531m.dep
+++ /dev/null
@@ -1,189 +0,0 @@
--- C45531M.DEP
-
--- 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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-
-WITH REPORT;
-PROCEDURE C45531M IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531M", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (0.125); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.125); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_2 (DEL4 * FORTH + DEL1 );
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_2 (DEL4 * FORTH + DEL1 );
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531M;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531n.dep b/gcc/testsuite/ada/acats/tests/c4/c45531n.dep
deleted file mode 100644
index f461ba0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531n.dep
+++ /dev/null
@@ -1,160 +0,0 @@
--- C45531N.DEP
-
--- 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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-
-WITH REPORT;
-PROCEDURE C45531N IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- DEL2 : CONSTANT := 2.0 * DEL1;
- DEL4 : CONSTANT := 4.0 * DEL1;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45531N", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR RANGE <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (DEL2 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER
- A := FX_1 (DEL2 * (3 * FORTH + 1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_2 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (DEL4 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_2 (3 * (DEL4 * FORTH + DEL1) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531N;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531o.dep b/gcc/testsuite/ada/acats/tests/c4/c45531o.dep
deleted file mode 100644
index ae8c395..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531o.dep
+++ /dev/null
@@ -1,189 +0,0 @@
--- C45531O.DEP
-
--- 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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
--- D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45531O IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531O", "MIXED FIXED POINT AND INTEGER ""*"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : INTEGER := 0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := 3;
- B := FX_0P5 (2.5); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER
- B := 6;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS.
-
-C: DECLARE
- A : INTEGER := 0;
- B : FX_RNG1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER
- A := 3;
- B := FX_RNG1 (RNG1 * FORTH + 0.5);
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS");
-
- END IF;
- END C;
-
- --------------------------------------------------
-
- -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS.
-
-D: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := (3 * (FORTH + 0) );
- HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) );
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER
- A := FX_RNG1 (RNG1 * FORTH + 0.5);
- B := 3;
- END IF;
-
- RESULT_VALUE := A * B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END D;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531O;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531p.dep b/gcc/testsuite/ada/acats/tests/c4/c45531p.dep
deleted file mode 100644
index e4b6ce9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45531p.dep
+++ /dev/null
@@ -1,159 +0,0 @@
--- C45531P.DEP
-
--- 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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
--- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT.
--- C) FIXED / INTEGER FOR NON-MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- BCB 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45531P IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45531P", "MIXED FIXED POINT AND INTEGER ""/"" "
- & "FOR DELTA <, =, > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (7.5); -- A MODEL NUMBER
- B := 5;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER "
- & "WHEN ALL VALUES ARE MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT
-
-B: DECLARE
- A : FX_1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (FORTH + 1);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER WITH NUMERATOR MODEL "
- & "NUMBER, RESULT NOT");
-
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : INTEGER := 0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * FORTH );
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * (FORTH + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER
- A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) );
- B := 3;
- END IF;
-
- RESULT_VALUE := A / B;
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45531P;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532a.ada b/gcc/testsuite/ada/acats/tests/c4/c45532a.ada
deleted file mode 100644
index 8ebbc0a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532a.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C45532A.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532A IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532A", "FIXED POINT OPERATOR ""*"" "
- & "FOR RANGE <, =, AND > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.25); -- A MODEL NUMBER
- B := FX_2 (0.50); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 64;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532b.ada b/gcc/testsuite/ada/acats/tests/c4/c45532b.ada
deleted file mode 100644
index 5077477..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532b.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- C45532B.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532B IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12; -- MUST BE EVEN & >= 6
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 ..
- 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 ..
- 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 ..
- 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532B", "FIXED POINT OPERATOR ""/"" "
- & "FOR RANGE <, =, AND > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.125); -- A MODEL NUMBER
- B := FX_1 (0.25); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER
- B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOW_COUNT : CONSTANT := 2 * A_THIRD;
- -- := (2 * FULL_SCALE * (2 * FORTH + 0))
- -- / (6 * FORTH + 2);
- HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4;
- -- := (2 * FULL_SCALE * (2 * FORTH + 2))
- -- / (6 * FORTH + 0);
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * HIGH_COUNT );
- BEGIN
- IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS
- A := FX_1 (DEL1 * (2 * FORTH + 1));
- B := FX_1 (DEL1 * (6 * FORTH + 1));
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532c.ada b/gcc/testsuite/ada/acats/tests/c4/c45532c.ada
deleted file mode 100644
index 9e9aaa2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532c.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C45532C.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532C IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532C", "FIXED POINT OPERATOR ""*"" "
- & "FOR DELTA <, =, AND > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- HIGHEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- B := FX_1 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 16;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532d.ada b/gcc/testsuite/ada/acats/tests/c4/c45532d.ada
deleted file mode 100644
index 51923df..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532d.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C45532D.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 12.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532D IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 12;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532D", "FIXED POINT OPERATOR ""/"" "
- & "FOR DELTA <, =, AND > 1.0");
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER
- B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1); -- A MODEL NUMBER
- B := FX_1 (3.0); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 - 3.0);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 + 4.0);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER
- B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532e.ada b/gcc/testsuite/ada/acats/tests/c4/c45532e.ada
deleted file mode 100644
index 42989f1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532e.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- C45532E.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532E IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532E", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.25); -- A MODEL NUMBER
- B := FX_2 (0.50); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 64;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532f.ada b/gcc/testsuite/ada/acats/tests/c4/c45532f.ada
deleted file mode 100644
index 59a9e25..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532f.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C45532F.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532F IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16; -- MUST BE EVEN & >= 6
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 ..
- 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 ..
- 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 ..
- 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532F", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.125); -- A MODEL NUMBER
- B := FX_1 (0.25); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER
- B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOW_COUNT : CONSTANT := 2 * A_THIRD;
- -- := (2 * FULL_SCALE * (2 * FORTH + 0))
- -- / (6 * FORTH + 2);
- HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4;
- -- := (2 * FULL_SCALE * (2 * FORTH + 2))
- -- / (6 * FORTH + 0);
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * HIGH_COUNT );
- BEGIN
- IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS
- A := FX_1 (DEL1 * (2 * FORTH + 1));
- B := FX_1 (DEL1 * (6 * FORTH + 1));
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532g.ada b/gcc/testsuite/ada/acats/tests/c4/c45532g.ada
deleted file mode 100644
index c9d8f00..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532g.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- C45532G.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532G IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532G", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- HIGHEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- B := FX_1 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 16;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532h.ada b/gcc/testsuite/ada/acats/tests/c4/c45532h.ada
deleted file mode 100644
index ea1d961..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532h.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- C45532H.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 16.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532H IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 16;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532H", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER
- B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1); -- A MODEL NUMBER
- B := FX_1 (3.0); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 - 3.0);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 + 4.0);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER
- B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532H;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532i.ada b/gcc/testsuite/ada/acats/tests/c4/c45532i.ada
deleted file mode 100644
index 60a7dfe..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532i.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- C45532I.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT;
-PROCEDURE C45532I IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532I", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.25); -- A MODEL NUMBER
- B := FX_2 (0.50); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 64;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532j.ada b/gcc/testsuite/ada/acats/tests/c4/c45532j.ada
deleted file mode 100644
index a50906c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532j.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C45532J.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT;
-PROCEDURE C45532J IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32; -- MUST BE EVEN & >= 6
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 ..
- 0.5 - DEL1 * 1;
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 ..
- 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 ..
- 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532J", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.125); -- A MODEL NUMBER
- B := FX_1 (0.25); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER
- B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOW_COUNT : CONSTANT := 2 * A_THIRD;
- -- := (2 * FULL_SCALE * (2 * FORTH + 0))
- -- / (6 * FORTH + 2);
- HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4;
- -- := (2 * FULL_SCALE * (2 * FORTH + 2))
- -- / (6 * FORTH + 0);
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * HIGH_COUNT );
- BEGIN
- IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS
- A := FX_1 (DEL1 * (2 * FORTH + 1));
- B := FX_1 (DEL1 * (6 * FORTH + 1));
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532J;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532k.ada b/gcc/testsuite/ada/acats/tests/c4/c45532k.ada
deleted file mode 100644
index 1f2bd71..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532k.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C45532K.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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT;
-PROCEDURE C45532K IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532K", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- HIGHEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- B := FX_1 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 16;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532K;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532l.ada b/gcc/testsuite/ada/acats/tests/c4/c45532l.ada
deleted file mode 100644
index 2ea7fea..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532l.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C45532L.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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 32.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
--- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR
--- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT;
-PROCEDURE C45532L IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 32;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532L", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER
- B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1); -- A MODEL NUMBER
- B := FX_1 (3.0); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 - 3.0);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 + 4.0);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER
- B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532L;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532m.dep b/gcc/testsuite/ada/acats/tests/c4/c45532m.dep
deleted file mode 100644
index b4001af..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532m.dep
+++ /dev/null
@@ -1,157 +0,0 @@
--- C45532M.DEP
-
--- 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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45532M IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2;
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4;
-
-BEGIN TEST ("C45532M", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_2 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.25); -- A MODEL NUMBER
- B := FX_2 (0.50); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 64;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_2
- := FX_2 (4 * DEL1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532M;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532n.dep b/gcc/testsuite/ada/acats/tests/c4/c45532n.dep
deleted file mode 100644
index 9315c68..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532n.dep
+++ /dev/null
@@ -1,163 +0,0 @@
--- C45532N.DEP
-
--- 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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45532N IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48; -- MUST BE EVEN & >= 6
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- DEL1 : CONSTANT := 0.5 / FULL_SCALE;
- TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 ..
- 0.5 - DEL1 * 1; -- N/A => ERROR.
- TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 ..
- 1.0 - DEL1 * 2; -- N/A => ERROR.
- TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 ..
- 2.0 - DEL1 * 4; -- N/A => ERROR.
-
-BEGIN TEST ("C45532N", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_2 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.125); -- A MODEL NUMBER
- B := FX_1 (0.25); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_2 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 (2 * DEL1 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER
- B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOW_COUNT : CONSTANT := 2 * A_THIRD;
- -- := (2 * FULL_SCALE * (2 * FORTH + 0))
- -- / (6 * FORTH + 2);
- HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4;
- -- := (2 * FULL_SCALE * (2 * FORTH + 2))
- -- / (6 * FORTH + 0);
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * LOW_COUNT );
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (DEL1 * HIGH_COUNT );
- BEGIN
- IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS
- A := FX_1 (DEL1 * (2 * FORTH + 1));
- B := FX_1 (DEL1 * (6 * FORTH + 1));
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532N;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532o.dep b/gcc/testsuite/ada/acats/tests/c4/c45532o.dep
deleted file mode 100644
index b0126df..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532o.dep
+++ /dev/null
@@ -1,161 +0,0 @@
--- C45532O.DEP
-
--- 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 OPERATOR "*" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
--- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
--- C) THE OPERATOR *, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45532O IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- FORTH : CONSTANT := FULL_SCALE / 4;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532O", "FIXED POINT OPERATOR ""*""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- HIGHEST_ACCEPTABLE_VALUE
- : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- B := FX_1 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT.
-
-B: DECLARE
- A : FX_0P5 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 16;
- HIGH_COUNT : CONSTANT := LOW_COUNT + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER
- B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A * B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_RNG1 := 0.0;
- LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1;
- HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1;
- LOWEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * LOW_COUNT);
- HIGHEST_ACCEPTABLE_VALUE : FX_RNG1
- := FX_RNG1 (RNG1 * HIGH_COUNT);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER
- B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_RNG1 (A * B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532O;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532p.dep b/gcc/testsuite/ada/acats/tests/c4/c45532p.dep
deleted file mode 100644
index cab5031..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45532p.dep
+++ /dev/null
@@ -1,155 +0,0 @@
--- C45532P.DEP
-
--- 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 OPERATOR "/" PRODUCES CORRECT RESULTS
--- FOR FIXED POINT TYPES USING 3 SUBTESTS.
--- THIS TEST REQUIRES MIN_WORD_LENGTH = 48.
--- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR
--- EQUAL TO 0.5.
---
--- TEST CASES ARE:
--- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
--- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
--- C) THE OPERATOR /, USING NO MODEL NUMBERS.
---
--- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48,
--- WITH RANGE <, =, AND > THAN 1.0 AND
--- WITH DELTA <, =, AND > THAN 1.0.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A
--- 'MAX_MANTISSA OF 47 OR GREATER.
-
--- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF
--- 'TYPE FX_OP5' MUST BE REJECTED.
-
--- HISTORY:
--- NTW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/05/86 REVISED COMMENTS.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- RDH 04/27/90 REVISED APPLICABILITY CRITERIA.
-
-WITH REPORT;
-PROCEDURE C45532P IS
-
- USE REPORT;
-
- MIN_WORD_LENGTH : CONSTANT := 48;
- FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1);
- A_THIRD : CONSTANT := FULL_SCALE / 3;
- RNG1 : CONSTANT := FULL_SCALE * 0.5;
- TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5;
- -- N/A => ERROR.
- TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0;
- TYPE FX_RNG1 IS DELTA RNG1
- RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1);
-
-BEGIN TEST ("C45532P", "FIXED POINT OPERATOR ""/""" );
-
- --------------------------------------------------
-
- -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS.
-
-A: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_0P5 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER
- B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS");
- END IF;
- END A;
-
- --------------------------------------------------
-
- -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT.
-
-B: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_0P5 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * A_THIRD);
- HIGHEST_ACCEPTABLE_VALUE : FX_0P5
- := FX_0P5 (0.5 * (A_THIRD + 1) );
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1); -- A MODEL NUMBER
- B := FX_1 (3.0); -- A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_0P5 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN A, B MODEL NUMBERS A / B NOT");
- END IF;
- END B;
-
- --------------------------------------------------
-
- -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS
-
-C: DECLARE
- A : FX_RNG1 := 0.0;
- B : FX_1 := 0.0;
- RESULT_VALUE : FX_1 := 0.0;
- LOWEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 - 3.0);
- HIGHEST_ACCEPTABLE_VALUE : FX_1
- := FX_1 ( RNG1 + 4.0);
- BEGIN
- IF EQUAL (3, 3) THEN
- A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER
- B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER
- END IF;
-
- RESULT_VALUE := FX_1 (A / B);
-
- IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE)
- OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN
- FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL "
- & "WHEN USING NO MODEL NUMBERS");
- END IF;
- END C;
-
- --------------------------------------------------
-
-
- RESULT;
-
-END C45532P;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45534b.ada b/gcc/testsuite/ada/acats/tests/c4/c45534b.ada
deleted file mode 100644
index 6c087c3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45534b.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C45534B.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 CONSTRAINT_ERROR IS RAISED WHEN A
--- FIXED POINT VALUE IS DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR
--- A FIXED POINT ZERO).
-
-
--- *** 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:
--- BCB 07/14/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X CONSISTENCY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45534B IS
-
- TYPE FIX IS DELTA 2.0**(-1) RANGE -2.0 .. 2.0;
- TYPE FIX2 IS DELTA 2.0**(-1) RANGE -3.0 .. 3.0;
-
- A : FIX := 1.0;
- B : FIX;
- ZERO : FIX := 0.0;
- ZERO2 : FIX2 := 0.0;
-
- FUNCTION IDENT_FLT (ONE, TWO : FIX) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = FIX (TWO * FIX (IDENT_INT(1)));
- END IDENT_FLT;
-
-BEGIN
- TEST ("C45534B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "A FIXED POINT VALUE IS " &
- "DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR A " &
- "FIXED POINT ZERO)");
-
- BEGIN
- B := A / IDENT_INT (0);
- FAILED ("NO EXCEPTION RAISED FOR DIVISION BY INTEGER ZERO");
- IF IDENT_FLT (B,B) THEN
- COMMENT ("DON'T OPTIMIZE B");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END;
-
- BEGIN
- B := FIX (A / ZERO);
- FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " &
- "ZERO - 1");
- IF IDENT_FLT (B,B) THEN
- COMMENT ("DON'T OPTIMIZE B");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END;
-
- BEGIN
- B := FIX (A / ZERO2);
- FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " &
- "ZERO - 2");
- IF IDENT_FLT (B,B) THEN
- COMMENT ("DON'T OPTIMIZE B");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED");
- END;
-
- RESULT;
-END C45534B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45536a.dep b/gcc/testsuite/ada/acats/tests/c4/c45536a.dep
deleted file mode 100644
index 760d430..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45536a.dep
+++ /dev/null
@@ -1,158 +0,0 @@
--- C45536A.DEP
-
--- 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 FIXED POINT MULTIPLICATION AND DIVISION WHEN 'SMALL OF
--- THE OPERANDS ARE NOT BOTH POWERS OF THE SAME BASE VALUE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- REPRESENTATION CLAUSES FOR 'SMALL WHICH ARE NOT POWERS OF TWO.
-
--- IF SUCH REPRESENTATION CLAUSES ARE NOT SUPPORTED, THEN THE
--- REPRESENTATION CLAUSE FOR CHECK_TYPE MUST BE REJECTED.
-
--- HISTORY:
--- BCB 02/02/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45536A IS
-
- TYPE CHECK_TYPE IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0;
- FOR CHECK_TYPE'SMALL USE 0.2; -- N/A => ERROR.
-
- TYPE F1 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0;
- FOR F1'SMALL USE 0.5;
-
- TYPE F2 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0;
- FOR F2'SMALL USE 0.2;
-
- TYPE F3 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0;
- FOR F3'SMALL USE 0.1;
-
- A : F1;
- B : F2;
- C : F3;
-
- FUNCTION IDENT_FIX(X : F3) RETURN F3 IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FIX;
-
-BEGIN
- TEST ("C45536A", "CHECK FIXED POINT MULTIPLICATION AND DIVISION " &
- "WHEN 'SMALL OF THE OPERANDS ARE NOT BOTH " &
- "POWERS OF THE SAME BASE VALUE");
-
- A := 1.0; B := 1.0; C := F3(A * B);
-
- IF C /= IDENT_FIX(1.0) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 1");
- END IF;
-
- C := F3(A / B);
-
- IF C /= IDENT_FIX(1.0) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 1");
- END IF;
-
- A := 1.0; B := 0.3; C := F3(A * B);
-
- IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 2");
- END IF;
-
- B := 0.25; C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(2.5) .. IDENT_FIX(5.0) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 2");
- END IF;
-
- A := 0.5; B := 0.3; C := F3(A * B);
-
- IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.2) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 3");
- END IF;
-
- C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 3");
- END IF;
-
- B := 0.3; C := 0.2; A := F1(B * C);
-
- IF A NOT IN F1(IDENT_FIX(0.0)) .. F1(IDENT_FIX(0.5)) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 4");
- END IF;
-
- A := 1.0; B := 1.6; C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(0.6) .. IDENT_FIX(0.7) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 4");
- END IF;
-
- A := 0.75; B := 0.4; C := F3(A * B);
-
- IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 5");
- END IF;
-
- A := 0.8; C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 5");
- END IF;
-
- A := 0.8; B := 0.4; C := F3(A * B);
-
- IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 6");
- END IF;
-
- A := 0.75; C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 6");
- END IF;
-
- A := 0.7; B := 0.3; C := F3(A * B);
-
- IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.4) THEN
- FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 7");
- END IF;
-
- C := F3(A / B);
-
- IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(5.0) THEN
- FAILED ("IMPROPER RESULTS FOR DIVISION - 7");
- END IF;
-
- RESULT;
-END C45536A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c456001.a b/gcc/testsuite/ada/acats/tests/c4/c456001.a
deleted file mode 100644
index 9062f93..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c456001.a
+++ /dev/null
@@ -1,91 +0,0 @@
--- C456001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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.
---
--- Notice
---
--- The ACAA has created and maintains the Ada Conformity Assessment Test
--- Suite for the purpose of conformity assessments conducted in accordance
--- with the International Standard ISO/IEC 18009 - Ada: Conformity
--- assessment of a language processor. This test suite should not be used
--- to make claims of conformance unless used in accordance with
--- ISO/IEC 18009 and any applicable ACAA procedures.
---
---*
--- OBJECTIVE:
--- For exponentiation of floating point types, check that
--- Constraint_Error is raised (or, if no exception is raised and
--- Machine_Overflows is False, that a result is produced) if the
--- result is outside of the range of the base type.
--- This tests digits 5.
-
--- HISTORY:
--- 04/30/03 RLB Created test from old C45622A and C45624A.
-
-with Report;
-
-procedure C456001 is
-
- type Flt is digits 5;
-
- F : Flt;
-
- function Equal_Flt (One, Two : Flt) return Boolean is
- -- Break optimization.
- begin
- return One = Two * Flt (Report.Ident_Int(1));
- end Equal_Flt;
-
-begin
- Report.Test ("C456001", "For exponentiation of floating point types, " &
- "check that Constraint_Error is raised (or, if " &
- "if no exception is raised and Machine_Overflows is " &
- "False, that a result is produced) if the result is " &
- "outside of the range of the base type.");
-
- begin
- F := (Flt'Base'Last)**Report.Ident_Int (2);
- if Flt'Machine_Overflows Then
- Report.Failed ("Constraint_Error was not raised for " &
- "exponentiation");
- else
- -- RM95 3.5.6(7) allows disobeying RM95 4.5(10) if
- -- Machine_Overflows is False.
- Report.Comment ("Constraint_Error was not raised for " &
- "exponentiation and Machine_Overflows is False");
- end if;
- if not Equal_Flt (F, F) then
- -- Optimization breaker, F must be evaluated.
- Report.Comment ("Don't optimize F");
- end if;
- exception
- when Constraint_Error =>
- Report.Comment ("Constraint_Error was raised for " &
- "exponentiation");
- when others =>
- Report.Failed ("An exception other than Constraint_Error " &
- "was raised for exponentiation");
- end;
-
- Report.Result;
-end C456001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611a.ada b/gcc/testsuite/ada/acats/tests/c4/c45611a.ada
deleted file mode 100644
index 3f7a690..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45611a.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- C45611A.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 EXPONENTIATION OF AN INTEGER TO AN INTEGER VALUE IS
--- CORRECTLY EVALUATED.
-
--- H. TILTON 9/23/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45611A IS
-
- I1,INT : INTEGER;
-
- BEGIN
-
-
- TEST ("C45611A", "CHECK THAT EXPONENTIATION OF AN INTEGER " &
- "VALUE IS CORRECTLY EVALUATED");
-
- I1 := IDENT_INT(0) ** IDENT_INT(0);
-
- IF IDENT_INT(I1) /= IDENT_INT(1) THEN
- FAILED( "INCORRECT RESULT FOR '0**0'" );
- END IF;
-
- INT := "**" (IDENT_INT(0),IDENT_INT(1));
-
- IF IDENT_INT(INT) /= IDENT_INT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**1'" );
- END IF;
-
- I1 := IDENT_INT(6) ** IDENT_INT(0);
-
- IF IDENT_INT(I1) /= IDENT_INT(1) THEN
- FAILED( "INCORRECT RESULT FOR '6**0'" );
- END IF;
-
- INT := IDENT_INT(156) ** IDENT_INT(1);
-
- IF IDENT_INT(INT) /= IDENT_INT(156) THEN
- FAILED( "INCORRECT RESULT FOR '156**1'" );
- END IF;
-
- I1 := IDENT_INT(-3) ** IDENT_INT(0);
-
- IF IDENT_INT(I1) /= IDENT_INT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-3)**0'" );
- END IF;
-
- INT := "**" (IDENT_INT(-7),IDENT_INT(1));
-
- IF IDENT_INT(INT) /= IDENT_INT(-7) THEN
- FAILED( "INCORRECT RESULT FOR '(-7)**1'" );
- END IF;
-
- I1 := "**" (IDENT_INT(-1),IDENT_INT(2));
-
- IF IDENT_INT(I1) /= IDENT_INT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**2'" );
- END IF;
-
-
- INT := IDENT_INT(-1) ** 3;
-
- IF IDENT_INT(INT) /= IDENT_INT(-1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**3'" );
- END IF;
-
- INT := "**" (IDENT_INT(0),IDENT_INT(2));
-
- IF IDENT_INT(INT) /= IDENT_INT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**2'" );
- END IF;
-
- INT := IDENT_INT(0) ** IDENT_INT(10);
-
- IF IDENT_INT(INT) /= IDENT_INT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**10'" );
- END IF;
-
- INT := "**" (IDENT_INT(6),IDENT_INT(2));
-
- IF IDENT_INT(INT) /= IDENT_INT(36) THEN
- FAILED( "INCORRECT RESULT FOR '6**2'" );
- END IF;
-
- INT := "**" (IDENT_INT(2),IDENT_INT(2));
-
- IF IDENT_INT(INT) /= IDENT_INT(4) THEN
- FAILED( "INCORRECT RESULT FOR '2**2'" );
- END IF;
-
- I1 := "**" (IDENT_INT(1),IDENT_INT(10));
-
- IF IDENT_INT(I1) /= IDENT_INT(1) THEN
- FAILED( "INCORRECT RESULT FOR '1**10'" );
- END IF;
-
- RESULT;
-
- END C45611A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611b.dep b/gcc/testsuite/ada/acats/tests/c4/c45611b.dep
deleted file mode 100644
index fb63ef8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45611b.dep
+++ /dev/null
@@ -1,141 +0,0 @@
--- C45611B.DEP
-
--- 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 EXPONENTIATION OF A SHORT_INTEGER TO AN INTEGER VALUE
--- IS CORRECTLY EVALUATED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- HTG 09/23/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45611B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- I1,INT : SHORT_INTEGER;
-
- FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
- BEGIN
-
-
- TEST ("C45611B", "CHECK THAT EXPONENTIATION OF A " &
- "SHORT_INTEGER VALUE IS CORRECTLY " &
- "EVALUATED");
-
- I1 := IDENT(0) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '0**0'" );
- END IF;
-
- INT := "**" (IDENT(0),IDENT_INT(1));
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**1'" );
- END IF;
-
- I1 := IDENT(6) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '6**0'" );
- END IF;
-
- INT := IDENT(15) ** IDENT_INT(1);
-
- IF IDENT(INT) /= IDENT(15) THEN
- FAILED( "INCORRECT RESULT FOR '15**1'" );
- END IF;
-
- I1 := IDENT(-3) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-3)**0'" );
- END IF;
-
- INT := "**" (IDENT(-7),IDENT_INT(1));
-
- IF IDENT(INT) /= IDENT(-7) THEN
- FAILED( "INCORRECT RESULT FOR '(-7)**1'" );
- END IF;
-
- I1 := "**" (IDENT(-1),IDENT_INT(2));
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**2'" );
- END IF;
-
-
- INT := IDENT(-1) ** IDENT_INT(3);
-
- IF IDENT(INT) /= IDENT(-1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**3'" );
- END IF;
-
- INT := "**" (IDENT(0),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**2'" );
- END IF;
-
- INT := IDENT(0) ** IDENT_INT(10);
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**10'" );
- END IF;
-
- INT := "**" (IDENT(6),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(36) THEN
- FAILED( "INCORRECT RESULT FOR '6**2'" );
- END IF;
-
- INT := "**" (IDENT(2),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(4) THEN
- FAILED( "INCORRECT RESULT FOR '2**2'" );
- END IF;
-
- I1 := "**" (IDENT(1),IDENT_INT(10));
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '1**10'" );
- END IF;
-
- RESULT;
-
- END C45611B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611c.dep b/gcc/testsuite/ada/acats/tests/c4/c45611c.dep
deleted file mode 100644
index 0687d3a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45611c.dep
+++ /dev/null
@@ -1,141 +0,0 @@
--- C45611C.DEP
-
--- 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 EXPONENTIATION OF A LONG_INTEGER TO AN INTEGER VALUE
--- IS CORRECTLY EVALUATED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- HISTORY:
--- HTG 09/23/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45611C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- I1,INT : LONG_INTEGER;
-
- FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- RETURN LONG_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
- BEGIN
-
-
- TEST ("C45611C", "CHECK THAT EXPONENTIATION OF A " &
- "LONG_INTEGER VALUE IS CORRECTLY " &
- "EVALUATED");
-
- I1 := IDENT(0) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '0**0'" );
- END IF;
-
- INT := "**" (IDENT(0),IDENT_INT(1));
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**1'" );
- END IF;
-
- I1 := IDENT(6) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '6**0'" );
- END IF;
-
- INT := IDENT(156) ** IDENT_INT(1);
-
- IF IDENT(INT) /= IDENT(156) THEN
- FAILED( "INCORRECT RESULT FOR '156**1'" );
- END IF;
-
- I1 := IDENT(-3) ** IDENT_INT(0);
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-3)**0'" );
- END IF;
-
- INT := "**" (IDENT(-7),IDENT_INT(1));
-
- IF IDENT(INT) /= IDENT(-7) THEN
- FAILED( "INCORRECT RESULT FOR '(-7)**1'" );
- END IF;
-
- I1 := "**" (IDENT(-1),IDENT_INT(2));
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**2'" );
- END IF;
-
-
- INT := IDENT(-1) ** IDENT_INT(3);
-
- IF IDENT(INT) /= IDENT(-1) THEN
- FAILED( "INCORRECT RESULT FOR '(-1)**3'" );
- END IF;
-
- INT := "**" (IDENT(0),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**2'" );
- END IF;
-
- INT := IDENT(0) ** IDENT_INT(10);
-
- IF IDENT(INT) /= IDENT(0) THEN
- FAILED( "INCORRECT RESULT FOR '0**10'" );
- END IF;
-
- INT := "**" (IDENT(6),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(36) THEN
- FAILED( "INCORRECT RESULT FOR '6**2'" );
- END IF;
-
- INT := "**" (IDENT(2),IDENT_INT(2));
-
- IF IDENT(INT) /= IDENT(4) THEN
- FAILED( "INCORRECT RESULT FOR '2**2'" );
- END IF;
-
- I1 := "**" (IDENT(1),IDENT_INT(10));
-
- IF IDENT(I1) /= IDENT(1) THEN
- FAILED( "INCORRECT RESULT FOR '1**10'" );
- END IF;
-
- RESULT;
-
- END C45611C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613a.ada b/gcc/testsuite/ada/acats/tests/c4/c45613a.ada
deleted file mode 100644
index b539018..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45613a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C45613A.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
--- BY "**" FOR INTEGERS WHEN THE RESULT EXCEEDS THE RANGE
--- OF THE BASE TYPE.
-
-
--- *** 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
-
--- H. TILTON 10/06/86
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45613A IS
-
-BEGIN
- TEST ("C45613A","CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""**"" FOR INTEGERS WHEN THE " &
- "RESULT EXCEEDS THE RANGE OF THE BASE TYPE");
-
- DECLARE
- INT : INTEGER;
- BEGIN
- INT := IDENT_INT(INTEGER'LAST ** IDENT_INT(2));
- FAILED ("NO EXCEPTION FOR SECOND POWER OF INTEGER'LAST");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "SECOND POWER OF " &
- "INTEGER'LAST");
- END;
-
- DECLARE
- INT : INTEGER;
- BEGIN
- INT := IDENT_INT(INTEGER'FIRST ** IDENT_INT(3));
- FAILED ("NO EXCEPTION FOR THIRD POWER OF INTEGER'FIRST");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "THIRD POWER OF " &
- "INTEGER'FIRST");
-
- END;
-
- RESULT;
-
-END C45613A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613b.dep b/gcc/testsuite/ada/acats/tests/c4/c45613b.dep
deleted file mode 100644
index 4ce07cd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45613b.dep
+++ /dev/null
@@ -1,97 +0,0 @@
--- C45613B.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED
--- BY "**" FOR SHORT_INTEGER WHEN THE RESULT EXCEEDS THE RANGE
--- OF THE BASE TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- *** 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:
--- HTG 10/06/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45613B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
- TEST ("C45613B","CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""**"" FOR SHORT_INTEGER WHEN " &
- "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE");
-
- DECLARE
- INT : SHORT_INTEGER;
- BEGIN
- INT := IDENT(SHORT_INTEGER'LAST ** IDENT_INT(2));
- FAILED ("NO EXCEPTION FOR SECOND POWER OF " &
- "SHORT_INTEGER'LAST");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "SECOND POWER OF " &
- "SHORT_INTEGER'LAST");
- END;
-
- DECLARE
- INT : SHORT_INTEGER;
- BEGIN
- INT := IDENT(SHORT_INTEGER'FIRST ** IDENT_INT(3));
- FAILED ("NO EXCEPTION FOR THIRD POWER OF " &
- "SHORT_INTEGER'FIRST");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "THIRD POWER OF " &
- "SHORT_INTEGER'FIRST");
-
- END;
-
- RESULT;
-
-END C45613B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613c.dep b/gcc/testsuite/ada/acats/tests/c4/c45613c.dep
deleted file mode 100644
index 074d2b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45613c.dep
+++ /dev/null
@@ -1,97 +0,0 @@
--- C45613C.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED
--- BY "**" FOR LONG_INTEGER WHEN THE RESULT EXCEEDS THE RANGE
--- OF THE BASE TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
-
--- *** 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:
--- HTG 10/06/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45613C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- RETURN LONG_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
- TEST ("C45613C","CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED BY ""**"" FOR LONG_INTEGER WHEN " &
- "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE");
-
- DECLARE
- INT : LONG_INTEGER;
- BEGIN
- INT := IDENT(LONG_INTEGER'LAST ** IDENT_INT(2));
- FAILED ("NO EXCEPTION FOR SECOND POWER OF " &
- "LONG_INTEGER'LAST");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "SECOND POWER OF " &
- "LONG_INTEGER'LAST");
- END;
-
- DECLARE
- INT : LONG_INTEGER;
- BEGIN
- INT := IDENT(LONG_INTEGER'FIRST ** IDENT_INT(3));
- FAILED ("NO EXCEPTION FOR THIRD POWER OF " &
- "LONG_INTEGER'FIRST");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "THIRD POWER OF " &
- "LONG_INTEGER'FIRST");
-
- END;
-
- RESULT;
-
-END C45613C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614a.ada b/gcc/testsuite/ada/acats/tests/c4/c45614a.ada
deleted file mode 100644
index 9a0d835..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45614a.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C45614A.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 IF THE EXPONENT VALUE IN
--- AN INTEGER EXPONENTIATION IS NEGATIVE.
--- CHECK BOTH STATIC AND NONSTATIC EXPONENT VALUES.
-
--- AH 9/29/86
--- EDS 7/15/98 AVOID OPTIMIZATION
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45614A IS
- INT : INTEGER :=1;
- RES : INTEGER :=0;
-BEGIN
- TEST ("C45614A", "CONSTRAINT_ERROR IS RAISED FOR INTEGERS " &
- "HAVING A NEGATIVE EXPONENT");
-
- DECLARE
- E1 : CONSTANT INTEGER := -5;
- BEGIN
- RES := INT ** E1;
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E1A " &
- INTEGER'IMAGE(RES));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E1B");
- END;
-
- DECLARE
- E2 : INTEGER := 5;
- BEGIN
- RES := INT ** (-E2);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E2A " &
- INTEGER'IMAGE(RES));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E2B");
- END;
-
- DECLARE
- E3 : INTEGER;
- BEGIN
- E3 := IDENT_INT(-5);
- RES := INT ** E3;
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E3A " &
- INTEGER'IMAGE(RES));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E3B");
- END;
-
- DECLARE
- BEGIN
- RES := INT ** IDENT_INT(-5);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E4A " &
- INTEGER'IMAGE(RES));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("CONSTRAINT_ERROR NOT RAISED - E4B");
- END;
-
- RES := IDENT_INT(2);
- RES := IDENT_INT(RES);
- RESULT;
-END C45614A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614b.dep b/gcc/testsuite/ada/acats/tests/c4/c45614b.dep
deleted file mode 100644
index c96ab33..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45614b.dep
+++ /dev/null
@@ -1,128 +0,0 @@
--- C45614B.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED BY PREDEFINED SHORT_INTEGER
--- "**" IF THE SECOND OPERAND HAS A NEGATIVE VALUE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- HTG 10/07/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45614B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ("C45614B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "PREDEFINED SHORT_INTEGER ""**"" IF THE " &
- "SECOND OPERAND HAS A NEGATIVE VALUE");
-
- DECLARE
- A : INTEGER := -2;
- B : SHORT_INTEGER := 3;
- INT : SHORT_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(A));
- FAILED ("NO EXCEPTION FOR '3**(-2)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'");
- END;
-
- DECLARE
- A : INTEGER := -3;
- B : SHORT_INTEGER := -5;
- INT : SHORT_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(A));
- FAILED ("NO EXCEPTION FOR '(-5)**(-3)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'");
- END;
-
- DECLARE
- B : SHORT_INTEGER := 0;
- INT : SHORT_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(-3));
- FAILED ("NO EXCEPTION FOR '0**(-3)");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'");
- END;
-
- DECLARE
- INT : SHORT_INTEGER := 0;
- BEGIN
- INT := IDENT(-10 ** IDENT_INT(-2));
- FAILED ("NO EXCEPTION FOR '(-10)**(-2)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'");
- END;
-
- DECLARE
- INT : SHORT_INTEGER := 0;
- BEGIN
- INT := IDENT(6 ** IDENT_INT(-4));
- FAILED ("NO EXCEPTION FOR '6**(-4)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'");
- END;
-
- RESULT;
-
-END C45614B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614c.dep b/gcc/testsuite/ada/acats/tests/c4/c45614c.dep
deleted file mode 100644
index 0a60a13..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45614c.dep
+++ /dev/null
@@ -1,125 +0,0 @@
--- C45614C.DEP
-
--- 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 CONSTRAINT_ERROR IS RAISED BY PREDEFINED
--- LONG_INTEGER "**" IF THE SECOND OPERAND HAS A NEGATIVE
--- VALUE.
-
--- APPLICABILITY CRITERIA:
--- IN ORDER FOR THIS TEST TO BE NOT-APPLICABLE THE COMPILER
--- MUST REJECT THE USE OF "LONG_INTEGER" AS AN UNDECLARED
--- IDENTIFIER.
-
--- HISTORY:
--- HT 10/07/86 CREATED ORIGINAL TEST.
--- JET 08/06/87 REMOVED BUG FROM FUNCTION IDENT (X).
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45614C IS
-
- FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- RETURN LONG_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ("C45614C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " &
- "PREDEFINED LONG_INTEGER ""**"" IF THE SECOND " &
- "OPERAND HAS A NEGATIVE VALUE");
-
- DECLARE
- A : INTEGER := -2;
- B : LONG_INTEGER := 3;
- INT : LONG_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(A));
- FAILED ("NO EXCEPTION FOR '3**(-2)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'");
- END;
-
- DECLARE
- A : INTEGER := -3;
- B : LONG_INTEGER := -5;
- INT : LONG_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(A));
- FAILED ("NO EXCEPTION FOR '(-5)**(-3)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'");
- END;
-
- DECLARE
- B : LONG_INTEGER := 0;
- INT : LONG_INTEGER := 0;
- BEGIN
- INT := IDENT(B ** IDENT_INT(-3));
- FAILED ("NO EXCEPTION FOR '0**(-3)");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'");
- END;
-
- DECLARE
- INT : LONG_INTEGER := 0;
- BEGIN
- INT := IDENT(-10 ** IDENT_INT(-2));
- FAILED ("NO EXCEPTION FOR '(-10)**(-2)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'");
- END;
-
- DECLARE
- INT : LONG_INTEGER := 0;
- BEGIN
- INT := IDENT(6 ** IDENT_INT(-4));
- FAILED ("NO EXCEPTION FOR '6**(-4)'");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'");
- END;
-
- RESULT;
-
-END C45614C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631a.ada b/gcc/testsuite/ada/acats/tests/c4/c45631a.ada
deleted file mode 100644
index 43f794a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45631a.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C45631A.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 TYPE INTEGER 'ABS A' EQUALS A IF A IS POSITIVE AND
--- EQUALS -A IF A IS NEGATIVE.
-
--- RJW 2/10/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45631A IS
-
-BEGIN
-
- TEST ( "C45631A", "CHECK THAT FOR TYPE INTEGER 'ABS A' " &
- "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " &
- "A IS NEGATIVE" );
-
- DECLARE
-
- P : INTEGER := IDENT_INT (1);
- N : INTEGER := IDENT_INT (-1);
- Z : INTEGER := IDENT_INT (0);
- BEGIN
-
- IF ABS P = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 1" );
- END IF;
-
- IF ABS N = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 1" );
- END IF;
-
- IF ABS Z = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 1" );
- END IF;
-
- IF ABS (Z) = -Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 2");
- END IF;
-
- IF "ABS" (RIGHT => P) = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 2" );
- END IF;
-
- IF "ABS" (N) = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 2 " );
- END IF;
-
- IF "ABS" (Z) = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR Z - 3" );
- END IF;
-
- IF ABS (IDENT_INT (-INTEGER'LAST)) = INTEGER'LAST THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR -INTEGER'LAST" );
- END IF;
- END;
-
- RESULT;
-
-END C45631A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631b.dep b/gcc/testsuite/ada/acats/tests/c4/c45631b.dep
deleted file mode 100644
index 750ea21..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45631b.dep
+++ /dev/null
@@ -1,116 +0,0 @@
--- C45631B.DEP
-
--- 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 TYPE SHORT_INTEGER 'ABS A' EQUALS A IF A IS
--- POSITIVE AND EQUALS -A IF A IS NEGATIVE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- SHORT_INTEGER.
-
--- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_SHORT" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 02/26/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45631B IS
-
- CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X)));
- END IDENT;
-
-BEGIN
-
- TEST ( "C45631B", "CHECK THAT FOR TYPE SHORT_INTEGER 'ABS A' " &
- "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " &
- "A IS NEGATIVE" );
-
- DECLARE
-
- P : SHORT_INTEGER := IDENT (1);
- N : SHORT_INTEGER := IDENT (-1);
- Z : SHORT_INTEGER := IDENT (0);
- BEGIN
-
- IF ABS P = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 1" );
- END IF;
-
- IF ABS N = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 1" );
- END IF;
-
- IF ABS Z = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 1" );
- END IF;
-
- IF ABS (Z) = -Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 2");
- END IF;
-
- IF "ABS" (RIGHT => P) = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 2" );
- END IF;
-
- IF "ABS" (N) = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 2 " );
- END IF;
-
- IF "ABS" (Z) = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR Z - 3" );
- END IF;
-
- IF ABS (IDENT (-SHORT_INTEGER'LAST)) = SHORT_INTEGER'LAST
- THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR -SHORT_INTEGER'LAST" );
- END IF;
- END;
-
- RESULT;
-
-END C45631B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631c.dep b/gcc/testsuite/ada/acats/tests/c4/c45631c.dep
deleted file mode 100644
index 2d47637..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45631c.dep
+++ /dev/null
@@ -1,122 +0,0 @@
--- C45631C.DEP
-
--- 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 TYPE LONG_INTEGER 'ABS A' EQUALS A IF A IS
--- POSITIVE AND EQUALS -A IF A IS NEGATIVE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT
--- LONG_INTEGER.
-
--- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF
--- "CHECK_LONG" MUST BE REJECTED.
-
--- HISTORY:
--- RJW 02/26/86 CREATED ORIGINAL TEST.
--- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45631C IS
-
- CHECK_LONG : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF X >= LONG_INTEGER (INTEGER'FIRST) AND
- X <= LONG_INTEGER (INTEGER'LAST) THEN
- RETURN LONG_INTEGER (IDENT_INT (INTEGER (X)));
- ELSIF EQUAL (3, 3) THEN
- RETURN X;
- END IF;
- RETURN 0;
- END IDENT;
-
-BEGIN
-
- TEST ( "C45631C", "CHECK THAT FOR TYPE LONG_INTEGER 'ABS A' " &
- "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " &
- "A IS NEGATIVE" );
-
- DECLARE
-
- P : LONG_INTEGER := IDENT (1);
- N : LONG_INTEGER := IDENT (-1);
- Z : LONG_INTEGER := IDENT (0);
- BEGIN
-
- IF ABS P = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 1" );
- END IF;
-
- IF ABS N = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 1" );
- END IF;
-
- IF ABS Z = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 1" );
- END IF;
-
- IF ABS (Z) = -Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS TEST FOR Z - 2");
- END IF;
-
- IF "ABS" (RIGHT => P) = P THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR P - 2" );
- END IF;
-
- IF "ABS" (N) = -N THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR N - 2 " );
- END IF;
-
- IF "ABS" (Z) = Z THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR Z - 3" );
- END IF;
-
- IF ABS (IDENT (-LONG_INTEGER'LAST)) = LONG_INTEGER'LAST
- THEN
- NULL;
- ELSE
- FAILED ( "'ABS' TEST FOR -LONG_INTEGER'LAST" );
- END IF;
- END;
-
- RESULT;
-
-END C45631C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632a.ada b/gcc/testsuite/ada/acats/tests/c4/c45632a.ada
deleted file mode 100644
index 399188e..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45632a.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- C45632A.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 PREDEFINED TYPE INTEGER, CONSTRAINT_ERROR
--- IS RAISED FOR ABS (INTEGER'FIRST) IF
--- -INTEGER'LAST > INTEGER'FIRST.
-
--- *** 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:
--- RJW 02/10/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45632A IS
-
- I : INTEGER := IDENT_INT (INTEGER'FIRST);
-
-BEGIN
-
- TEST ( "C45632A", "CHECK THAT FOR PREDEFINED TYPE INTEGER " &
- "CONSTRAINT_ERROR IS RAISED " &
- "FOR ABS (INTEGER'FIRST) IF -INTEGER'LAST > " &
- "INTEGER'FIRST" );
-
- BEGIN
- IF - INTEGER'LAST > INTEGER'FIRST THEN
- BEGIN
- IF EQUAL (ABS I, I) THEN
- NULL;
- ELSE
- FAILED ( "WRONG RESULT FOR ABS" );
- END IF;
- FAILED ( "EXCEPTION NOT RAISED" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED" );
- END;
- ELSE
- COMMENT ( "-INTEGER'LAST <= INTEGER'FIRST" );
- END IF;
- END;
-
- RESULT;
-
-END C45632A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632b.dep b/gcc/testsuite/ada/acats/tests/c4/c45632b.dep
deleted file mode 100644
index fdf3371..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45632b.dep
+++ /dev/null
@@ -1,94 +0,0 @@
--- C45632B.DEP
-
--- 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 PREDEFINED TYPE SHORT_INTEGER,
--- CONSTRAINT_ERROR IS RAISED FOR ABS (SHORT_INTEGER'FIRST)
--- IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE PREDEFINED TYPE "SHORT_INTEGER".
-
--- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE
--- VARIABLE "TEST_VAR" MUST BE REJECTED.
-
--- *** 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:
--- RJW 02/20/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT
--- OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45632B IS
-
- TEST_VAR : SHORT_INTEGER; -- N/A => ERROR.
- I : SHORT_INTEGER;
-
- FUNCTION IDENT_SHORT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN A;
- ELSE
- RETURN 0;
- END IF;
- END IDENT_SHORT;
-
-BEGIN
-
- TEST ( "C45632B", "CHECK THAT FOR PREDEFINED TYPE " &
- "SHORT_INTEGER CONSTRAINT_ERROR IS RAISED FOR " &
- "ABS (SHORT_INTEGER'FIRST) IF " &
- "-SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST");
-
- BEGIN
- I := IDENT_SHORT (SHORT_INTEGER'FIRST);
-
- IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST THEN
- BEGIN
- IF IDENT_SHORT (ABS I) = IDENT_SHORT (I) THEN
- FAILED ("NO EXCEPTION -- EQUALITY TRUE");
- ELSE
- FAILED ("NO EXCEPTION -- EQUALITY FALSE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED" );
- END;
- ELSE
- COMMENT ( "-SHORT_INTEGER'LAST <= SHORT_INTEGER'FIRST");
- END IF;
- END;
-
- RESULT;
-
-END C45632B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632c.dep b/gcc/testsuite/ada/acats/tests/c4/c45632c.dep
deleted file mode 100644
index 72564bf..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45632c.dep
+++ /dev/null
@@ -1,94 +0,0 @@
--- C45632C.DEP
-
--- 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 PREDEFINED TYPE LONG_INTEGER,
--- CONSTRAINT_ERROR IS RAISED FOR ABS (LONG_INTEGER'FIRST)
--- IF -LONG_INTEGER'LAST > LONG_INTEGER'FIRST.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE USE OF "LONG_INTEGER" AS A PREDEFINED DATA TYPE.
-
--- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE
--- VARIABLE "TEST_VAR" MUST BE REJECTED.
-
--- *** 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:
--- RJW 02/20/86 CREATED ORIGINAL TEST.
--- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT
--- OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C45632C IS
-
- TEST_VAR : LONG_INTEGER; -- N/A => ERROR.
-
- FUNCTION IDENT_LONG (A : LONG_INTEGER) RETURN LONG_INTEGER IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN A;
- ELSE
- RETURN 0;
- END IF;
- END IDENT_LONG;
-
-BEGIN
-
- TEST ( "C45632C", "CHECK THAT FOR PREDEFINED TYPE " &
- "LONG_INTEGER CONSTRAINT_ERROR IS RAISED FOR " &
- "ABS (LONG_INTEGER'FIRST) IF " &
- "-LONG_INTEGER'LAST > LONG_INTEGER'FIRST" );
-
- BEGIN
- IF - LONG_INTEGER'LAST > LONG_INTEGER'FIRST THEN
- DECLARE
- I : LONG_INTEGER := IDENT_LONG(LONG_INTEGER'FIRST);
- BEGIN
- IF IDENT_LONG(ABS I) = IDENT_LONG(I) THEN
- FAILED ("NO EXCEPTION -- EQUALITY TRUE");
- ELSE
- FAILED ("NO EXCEPTION -- EQUALITY FALSE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED" );
- END;
- ELSE
- COMMENT ( "-LONG_INTEGER'LAST <= " &
- "LONG_INTEGER'FIRST" );
- END IF;
- END;
-
- RESULT;
-
-END C45632C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45651a.ada b/gcc/testsuite/ada/acats/tests/c4/c45651a.ada
deleted file mode 100644
index c568b84..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45651a.ada
+++ /dev/null
@@ -1,246 +0,0 @@
--- C45651A.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:
--- FOR FIXED POINT TYPES, CHECK:
--- (A) FOR MODEL NUMBERS A >= 0.0, THAT ABS A = A.
--- (B) FOR MODEL NUMBERS A <= 0.0. THAT ABS A = -A.
--- (C) FOR NON-MODEL NUMBERS A > 0.0, THAT ABS A VALUES ARE
--- WITHIN THE APPROPRIATE MODEL INTERVAL.
--- (D) FOR NON-MODEL NUMBERS A < 0.0, THAT ABS A VALUES ARE
--- WITHIN THE APPROPRIATE MODEL INTERVAL.
-
--- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF
--- DURATION'BASE.
-
--- HISTORY:
--- WRG 9/11/86
--- PWB 3/31/88 CHANGED RANGE FOR MEMBERSHIP TEST INVOLVING
--- ABS (DECIMAL_M4'FIRST + DECIMAL_M4'SMALL / 2).
--- RJW 8/21/89 REMOVED CHECKS INVOLVING HARD-CODED FIXED-POINT
--- UPPER BOUNDS WHICH WERE INCORRECT FOR SOME
--- IMPLEMENTATIONS. REVISED HEADER.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--- KAS 11/14/95 REMOVED CASES THAT DEPEND ON SPECIFIC VALUE FOR 'SMALL
--- TMB 11/19/94 REMOVED CASES RELATING TO 3.5.9(8) RULES - SMALL
--- MAY BE LESS THAN OR EQUAL TO DELTA FOR FIXED POINT.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45651A IS
-
- -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S
- -- 'MANTISSA VALUE.
-
-BEGIN
-
- TEST ("C45651A", "CHECK THAT, FOR FIXED POINT TYPES, THE ABS " &
- "OPERATOR PRODUCES CORRECT RESULTS - BASIC " &
- "TYPES");
-
- -------------------------------------------------------------------
-
-A: DECLARE
- TYPE LIKE_DURATION_M23 IS DELTA 0.020
- RANGE -86_400.0 .. 86_400.0;
-
- NON_MODEL_CONST : CONSTANT := 2.0 / 3;
- NON_MODEL_VAR : LIKE_DURATION_M23 := 0.0;
-
- SMALL, MAX, MIN, ZERO : LIKE_DURATION_M23 := 0.5;
- X : LIKE_DURATION_M23 := 1.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- SMALL := LIKE_DURATION_M23'SMALL;
- MAX := LIKE_DURATION_M23'LAST;
- MIN := LIKE_DURATION_M23'FIRST;
- ZERO := 0.0;
- NON_MODEL_VAR := NON_MODEL_CONST;
- END IF;
-
- -- (A)
- IF EQUAL (3, 3) THEN
- X := SMALL;
- END IF;
- IF ABS X /= SMALL OR X /= ABS LIKE_DURATION_M23'SMALL THEN
- FAILED ("ABS (1.0 / 64) /= (1.0 / 64)");
- END IF;
- IF EQUAL (3, 3) THEN
- X := MAX;
- END IF;
- IF ABS X /= MAX OR X /= ABS LIKE_DURATION_M23'LAST THEN
- FAILED ("ABS 86_400.0 /= 86_400.0");
- END IF;
-
- -- (B)
- IF EQUAL (3, 3) THEN
- X := -SMALL;
- END IF;
- IF ABS X /= SMALL OR
- ABS (-LIKE_DURATION_M23'SMALL) /= SMALL THEN
- FAILED ("ABS -(1.0 / 64) /= (1.0 / 64)");
- END IF;
- IF EQUAL (3, 3) THEN
- X := MIN;
- END IF;
- IF ABS X /= MAX OR ABS LIKE_DURATION_M23'FIRST /= MAX THEN
- FAILED ("ABS -86_400.0 /= 86_400.0");
- END IF;
-
- -- (A) AND (B)
- IF EQUAL (3, 3) THEN
- X := 0.0;
- END IF;
- IF "ABS" (RIGHT => X) /= ZERO OR X /= ABS 0.0 THEN
- FAILED ("ABS 0.0 /= 0.0 -- (LIKE_DURATION_M23)");
- END IF;
-
- -- CHECK THAT VALUE OF NON_MODEL_VAR IS IN THE RANGE
- -- 42 * 'SMALL .. 43 * 'SMALL:
- IF NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 THEN
- FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " &
- "- A");
- END IF;
-
- -- (C)
- IF ABS NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 OR
- ABS LIKE_DURATION_M23'(NON_MODEL_CONST) NOT IN
- 0.65625 .. 0.671875 THEN
- FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - A");
- END IF;
- IF EQUAL (3, 3) THEN
- X := 86_399.992_187_5; -- LIKE_DURATION_M23'LAST -
- -- 1.0 / 128.
- END IF;
- IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR
- ABS (LIKE_DURATION_M23'LAST - LIKE_DURATION_M23'SMALL / 2)
- NOT IN 86_399.984_375 .. 86_400.0 THEN
- FAILED ("ABS (LIKE_DURATION_M23'LAST - " &
- "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " &
- "RANGE");
- END IF;
-
- -- (D)
- IF EQUAL (3, 3) THEN
- X := -NON_MODEL_CONST;
- END IF;
- IF ABS X NOT IN 0.65625 .. 0.671875 OR
- ABS (-LIKE_DURATION_M23'(NON_MODEL_CONST)) NOT IN
- 0.65625 .. 0.671875 THEN
- FAILED ("ABS (-2.0 / 3) NOT IN CORRECT RANGE - A");
- END IF;
- IF EQUAL (3, 3) THEN
- X := -86_399.992_187_5; -- LIKE_DURATION_M23'FIRST +
- -- 1.0 / 128.
- END IF;
- IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR
- ABS (LIKE_DURATION_M23'FIRST + LIKE_DURATION_M23'SMALL / 2)
- NOT IN 86_399.984_375 .. 86_400.0 THEN
- FAILED ("ABS (LIKE_DURATION_M23'FIRST +" &
- "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " &
- "RANGE");
- END IF;
- END A;
-
- -------------------------------------------------------------------
-
-B: DECLARE
- TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0;
-
- NON_MODEL_CONST : CONSTANT := 2.0 / 3;
- NON_MODEL_VAR : DECIMAL_M4 := 0.0;
-
- SMALL, MAX, MIN, ZERO : DECIMAL_M4 := 128.0;
- X : DECIMAL_M4 := 0.0;
- BEGIN
- -- INITIALIZE "CONSTANTS":
- IF EQUAL (3, 3) THEN
- SMALL := DECIMAL_M4'SMALL;
- ZERO := 0.0;
- NON_MODEL_VAR := NON_MODEL_CONST;
- END IF;
-
- -- (A)
- IF EQUAL (3, 3) THEN
- X := SMALL;
- END IF;
- IF ABS X /= SMALL OR X /= ABS DECIMAL_M4'SMALL THEN
- FAILED ("ABS 64.0 /= 64.0");
- END IF;
-
- -- (B)
- IF EQUAL (3, 3) THEN
- X := -SMALL;
- END IF;
- IF ABS X /= SMALL OR ABS (-DECIMAL_M4'SMALL) /= SMALL THEN
- FAILED ("ABS -64.0 /= 64.0");
- END IF;
-
- -- (A) AND (B)
- IF EQUAL (3, 3) THEN
- X := 0.0;
- END IF;
- IF ABS X /= ZERO OR X /= ABS 0.0 THEN
- FAILED ("ABS 0.0 /= 0.0 -- (DECIMAL_M4)");
- END IF;
-
- -- CHECK THE VALUE OF NON_MODEL_VAR:
- IF NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN
- FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " &
- "- B");
- END IF;
-
- -- (C)
- IF ABS NON_MODEL_VAR NOT IN 0.0 .. 64.0 OR
- ABS DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 THEN
- FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - B");
- END IF;
- IF EQUAL (3, 3) THEN
- X := 37.0; -- INTERVAL IS 0.0 .. 64.0.
- END IF;
- IF EQUAL (3, 3) THEN
- X := 928.0;
- END IF;
-
- -- (D)
- IF EQUAL (3, 3) THEN
- X := -NON_MODEL_CONST;
- END IF;
- IF ABS X NOT IN 0.0 .. 64.0 OR
- ABS (-DECIMAL_M4'(NON_MODEL_CONST)) NOT IN 0.0 .. 64.0 THEN
- FAILED ("ABS -(2.0 / 3) NOT IN CORRECT RANGE - B");
- END IF;
- IF EQUAL (3, 3) THEN
- X := -37.0; -- INTERVAL IS -SMALL .. 0.0.
- END IF;
- IF EQUAL (3, 3) THEN
- X := -928.0;
- END IF;
- END B;
-
- -------------------------------------------------------------------
-
- RESULT;
-
-END C45651A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45662a.ada b/gcc/testsuite/ada/acats/tests/c4/c45662a.ada
deleted file mode 100644
index bf23598..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45662a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C45662A.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 TRUTH TABLE FOR 'NOT' .
-
--- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED
--- IN C45101(A,G).
-
-
--- RM 28 OCTOBER 1980
--- TBN 10/21/85 RENAMED FROM C45401A.ADA.
-
-
-WITH REPORT ;
-PROCEDURE C45662A IS
-
- USE REPORT;
-
- TVAR , FVAR , CVAR : BOOLEAN := FALSE ; -- INITIAL VALUE IRRELEVANT
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
-BEGIN
-
- TEST( "C45662A" , "CHECK THE TRUTH TABLE FOR 'NOT'" ) ;
-
- FOR A IN BOOLEAN LOOP
-
- CVAR := NOT A ;
-
- IF NOT A THEN
- IF A THEN BUMP ;
- END IF ;
- END IF;
-
- IF CVAR THEN
- IF A THEN BUMP ;
- END IF ;
- END IF;
-
- IF NOT( NOT( NOT( NOT( CVAR ))))
- THEN
- IF A THEN BUMP ;
- END IF ;
- END IF;
-
- END LOOP ;
-
- FOR I IN 1..2 LOOP
-
- CVAR := NOT ( I > 1 ) ;
-
- IF NOT ( I > 1 ) THEN
- IF I>1 THEN BUMP ;
- END IF ;
- END IF;
-
- IF CVAR THEN
- IF I>1 THEN BUMP ;
- END IF ;
- END IF;
-
- END LOOP ;
-
- IF NOT TRUE THEN BUMP ; END IF ;
- IF NOT FALSE THEN NULL ; ELSE BUMP ; END IF ;
-
- TVAR := IDENT_BOOL( TRUE );
- FVAR := IDENT_BOOL( FALSE );
-
- IF NOT TVAR THEN BUMP ; END IF ;
- IF NOT FVAR THEN NULL ; ELSE BUMP ; END IF ;
-
-
- IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" );
- END IF ;
-
- RESULT;
-
-END C45662A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45662b.ada b/gcc/testsuite/ada/acats/tests/c4/c45662b.ada
deleted file mode 100644
index 7feb6a6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45662b.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C45662B.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 TRUTH TABLE FOR 'NOT' ON DERIVED-BOOLEAN-TYPE OPERANDS.
-
--- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED
--- IN C45101K.
-
-
--- RM 28 OCTOBER 1980
--- TBN 10/21/85 RENAMED FROM C45401B-AB.ADA. REMOVED DUPLICATED
--- CODE NEAR END.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C45662B IS
-
- TYPE NB IS NEW BOOLEAN ;
-
- TVAR , FVAR , CVAR : NB := NB'(FALSE) ; -- INITIAL VALUE IRRELEVANT
- ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL
-
- PROCEDURE BUMP IS
- BEGIN
- ERROR_COUNT := ERROR_COUNT + 1 ;
- END BUMP ;
-
- FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS
- BEGIN
- IF EQUAL(2,2) THEN RETURN THE_ARGUMENT;
- ELSE RETURN NB'(FALSE) ;
- END IF;
- END ;
-
-
-BEGIN
-
- TEST( "C45662B" , "CHECK THE TRUTH TABLE FOR 'NOT'" &
- " ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ;
-
- FOR A IN NB LOOP
-
- CVAR := NOT A ;
-
- IF BOOLEAN( NOT A ) THEN
- IF BOOLEAN( A ) THEN BUMP ;
- END IF ;
- END IF;
-
- IF BOOLEAN( CVAR ) THEN
- IF BOOLEAN( A ) THEN BUMP ;
- END IF ;
- END IF;
-
- IF BOOLEAN(
-
- NOT( NOT( NOT( NOT( NOT(
- NOT( NOT( NOT( NOT( NOT(
- NOT( NOT( NOT( NOT( NOT(
- NOT( NOT( NOT( NOT( NOT( CVAR ))))) ))))) ))))) )))))
- )
- THEN
- IF BOOLEAN( A ) THEN BUMP ;
- END IF ;
- END IF;
-
- END LOOP ;
-
- FOR I IN 1..2 LOOP
-
- CVAR := NOT( NB( I > 1 ) ) ;
-
- IF BOOLEAN( NOT( NB( I > 1 ))) THEN
- IF I>1 THEN BUMP ;
- END IF ;
- END IF;
-
- IF BOOLEAN( CVAR ) THEN
- IF I>1 THEN BUMP ;
- END IF ;
- END IF;
-
- END LOOP ;
-
- IF BOOLEAN( NOT( NB'(TRUE ))) THEN BUMP ; END IF ;
- IF BOOLEAN( NOT( NB'(FALSE))) THEN NULL ; ELSE BUMP ; END IF ;
-
-
- TVAR := IDENT_NEW_BOOL( NB'(TRUE ) );
- FVAR := IDENT_NEW_BOOL( NB'(FALSE) );
-
- IF BOOLEAN( NOT TVAR ) THEN BUMP ; END IF ;
- IF BOOLEAN( NOT FVAR ) THEN NULL ; ELSE BUMP ; END IF ;
-
- IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" );
- END IF ;
-
- RESULT;
-
-END C45662B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c45672a.ada b/gcc/testsuite/ada/acats/tests/c4/c45672a.ada
deleted file mode 100644
index 1e54055..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c45672a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C45672A.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 "NOT" YIELDS THE CORRECT RESULTS WHEN APPLIED TO
--- ONE-DIMENSIONAL BOOLEAN ARRAYS.
-
--- JWC 11/15/85
-
-WITH REPORT;USE REPORT;
-
-PROCEDURE C45672A IS
-BEGIN
-
- TEST ("C45672A", "CHECK THE UNARY OPERATOR 'NOT' APPLIED TO " &
- "ONE-DIMENSIONAL BOOLEAN ARRAYS");
-
- DECLARE
-
- TYPE ARR1 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN;
- TYPE ARR2 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN;
- TYPE ARR3 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- TYPE ARR4 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN;
- TYPE ARR5 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN;
-
- PRAGMA PACK (ARR4);
- PRAGMA PACK (ARR5);
-
- A1 : ARR1 := ARR1'(1 | 3 => TRUE, OTHERS => FALSE);
- A2 : ARR2 := ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE,
- OTHERS => FALSE);
- A3 : ARR3(IDENT_INT(3) .. IDENT_INT(4)) := ARR3'(TRUE, FALSE);
- A4 : ARR4 := ARR4'(1 | 3 => TRUE, OTHERS => FALSE);
- A5 : ARR5 := ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE,
- OTHERS => FALSE);
- A6 : ARR3 (IDENT_INT(9) .. IDENT_INT(7));
-
- PROCEDURE P (A : ARR3; F : INTEGER; L : INTEGER) IS
- BEGIN
- IF A'FIRST /= F OR A'LAST /= L THEN
- FAILED ("'NOT' YIELDED THE WRONG BOUNDS");
- END IF;
- END P;
-
- BEGIN
-
- P (NOT A3, 3, 4);
- P (NOT A6, 9, 7);
-
- IF NOT A1 /= ARR1'(1 | 3 => FALSE, OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " &
- "TO SMALL ARRAY");
- END IF;
-
- IF NOT A2 /= ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37
- => FALSE, OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " &
- "TO LARGE ARRAY");
- END IF;
-
- IF NOT A4 /= ARR4'(1 | 3 => FALSE, OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " &
- "TO SMALL PACKED ARRAY");
- END IF;
-
- IF NOT A5 /= ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37
- => FALSE, OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " &
- "TO LARGE PACKED ARRAY");
- END IF;
-
- IF "NOT" (RIGHT => A1) /= ARR1'(1 | 3 => FALSE,
- OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " &
- "TO SMALL ARRAY USING NAMED NOTATION");
- END IF;
-
- IF "NOT" (RIGHT => A5) /= ARR5'(1 | 14 .. 18 | 30 .. 33 |
- 35 .. 37 => FALSE,
- OTHERS => TRUE) THEN
- FAILED ("WRONG RESULT WHEN 'NOT' APPLIED TO LARGE " &
- "PACKED ARRAY USING NAMED NOTATION");
- END IF;
-
- END;
-
- RESULT;
-
-END C45672A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460001.a b/gcc/testsuite/ada/acats/tests/c4/c460001.a
deleted file mode 100644
index 907b856..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460001.a
+++ /dev/null
@@ -1,300 +0,0 @@
--- C460001.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 target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level
--- of the operand type is deeper than that of the target type.
--- Check for the case where the operand is an access parameter.
---
--- Check for cases where the actual corresponding to the access
--- parameter is:
--- (a) An allocator.
--- (b) An expression of a named access type.
--- (c) Obj'Access.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type
--- must be at the same or a less deep nesting level than the target
--- type -- the operand type must "live" as long as the target type.
--- Nesting levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- a type conversion is attempted on the access parameter to an access
--- type A declared at some nesting level. The test verifies that
--- Program_Error is raised if the actual corresponding to the access
--- parameter is:
---
--- (1) an allocator, and the accessibility level of the execution
--- of the called subprogram is deeper than that of the access
--- type A.
---
--- (2) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (3) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the target type -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := A(X); -- Check should never fail.
--- begin null; end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- P (Actual'Access);
--- end;
---
--- For the execution of P, the accessibility level of type A will
--- always be deeper than that of Actual, so there is no danger of a
--- dangling reference arising from the assignment to Acc. Thus, the
--- type conversion is safe, even though the static nesting level of
--- Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C460001_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig; -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0 (X: access Desig; R : out Result_Kind);
- procedure Never_Fails (X: access Desig; R : out Result_Kind);
-
-end C460001_0;
-
-
- --==================================================================--
-
-
-package body C460001_0 is
-
- procedure Target_Is_Level_0 (X : access Desig;
- R : out Result_Kind) is
- begin
- -- The accessibility level of type Acc_L0 is 0.
- A0 := Acc_L0(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Target_Is_Level_0;
-
- -----------------------------------------------
- procedure Never_Fails (X: access Desig;
- R : out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Local will always be deeper than or the same as that
- -- of the actual corresponding to X.
- AL := Acc_Local(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Never_Fails;
-
-end C460001_0;
-
-
- --==================================================================--
-
-
-with C460001_0;
-with Report;
-
-procedure C460001 is
-
- X1 : aliased C460001_0.Desig; -- Level = 1.
-
- type Acc_L1 is access all C460001_0.Desig; -- Level = 1.
- A1 : Acc_L1;
-
- Expr_L0 : C460001_0.Acc_L0 := C460001_0.X0'Access;
- Expr_L1 : Acc_L1 := X1'Access;
-
- Res : C460001_0.Result_Kind;
-
- use type C460001_0.Result_Kind;
-
- -----------------------------------------------
- procedure Target_Is_Level_1 (X : access C460001_0.Desig;
- R : out C460001_0.Result_Kind) is
- begin
- -- The accessibility level of type Acc_L1 is 1.
- A1 := Acc_L1(X);
- R := C460001_0.OK;
- exception
- when Program_Error =>
- R := C460001_0.P_E;
- when others =>
- R := C460001_0.O_E;
- end Target_Is_Level_1;
-
- -----------------------------------------------
- procedure Display_Results (Result : in C460001_0.Result_Kind;
- Expected: in C460001_0.Result_Kind;
- Message : in String) is
- begin
- if Result /= Expected then
- case Result is
- when C460001_0.OK => Report.Failed ("No exception raised: " &
- Message);
- when C460001_0.P_E => Report.Failed ("Program_Error raised: " &
- Message);
- when C460001_0.O_E => Report.Failed ("Unexpected exception " &
- "raised: " & Message);
- end case;
- end if;
- end Display_Results;
-
-begin -- C460001
-
- Report.Test ("C460001", "Check that if the target type of a type " &
- "conversion is a general access type, Program_Error is " &
- "raised if the accessibility level of the operand type " &
- "is deeper than that of the target type: operand is an " &
- "access parameter; corresponding actual is an allocator, " &
- "expression of a named access type, Obj'Access");
-
-
- -- Actual is X'Access:
-
- C460001_0.Never_Fails (X1'Access, Res);
- Display_Results (Res, C460001_0.OK, "X1'Access, local access type");
-
- C460001_0.Target_Is_Level_0 (X1'Access, Res);
- Display_Results (Res, C460001_0.P_E, "X1'Access, level 0 access type");
-
- Target_Is_Level_1 (C460001_0.X0'Access, Res);
- Display_Results (Res, C460001_0.OK, "X0'Access, level 1 access type");
-
- Target_Is_Level_1 (X1'Access, Res);
- Display_Results (Res, C460001_0.OK, "X1'Access, level 1 access type");
-
- C460001_0.Target_Is_Level_0 (C460001_0.X0'Access, Res);
- Display_Results (Res, C460001_0.OK, "X0'Access, level 0 access type");
-
-
- -- Actual is expression of a named access type:
-
- C460001_0.Never_Fails (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, local access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, level 0 access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L1, Res);
- Display_Results (Res, C460001_0.P_E, "Expr_L1, level 0 access type");
-
- Target_Is_Level_1 (Expr_L1, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L1, level 1 access type");
-
- Target_Is_Level_1 (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, level 1 access type");
-
- -- Actual is allocator (level of execution = 2):
-
- C460001_0.Never_Fails (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.OK, "Allocator level 2, " &
- "local access type");
-
- C460001_0.Target_Is_Level_0 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 2, " &
- "level 0 access type");
-
- Target_Is_Level_1 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 2, " &
- "level 1 access type");
-
-
- Block_L2:
- declare
- X2 : aliased C460001_0.Desig; -- Level = 2.
- type Acc_L2 is access all C460001_0.Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X1'Access;
- begin
-
- -- Actual is X'Access:
-
- C460001_0.Never_Fails (X2'Access, Res);
- Display_Results (Res, C460001_0.OK, "X2'Access, local access type");
-
- Target_Is_Level_1 (X2'Access, Res);
- Display_Results (Res, C460001_0.P_E, "X2'Access, level 1 access type");
-
- -- Actual is expression of a named access type:
-
- C460001_0.Never_Fails (Expr_L2, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L2, local access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L2, Res);
- Display_Results (Res, C460001_0.P_E, "Expr_L2, level 0 access type");
-
-
- -- Actual is allocator (level of execution = 3):
-
- C460001_0.Never_Fails (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.OK, "Allocator level 3, " &
- "local access type");
-
- Target_Is_Level_1 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 3, " &
- "level 1 access type");
-
- end Block_L2;
-
- Report.Result;
-
-end C460001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460002.a b/gcc/testsuite/ada/acats/tests/c4/c460002.a
deleted file mode 100644
index 945dd56..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460002.a
+++ /dev/null
@@ -1,330 +0,0 @@
--- C460002.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 target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level
--- of the operand type is deeper than that of the target type.
--- Check for the case where the operand is an access parameter,
--- and the actual corresponding to the access parameter is another
--- access parameter.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type
--- must be at the same or a less deep nesting level than the target
--- type -- the operand type must "live" as long as the target type.
--- Nesting levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- a type conversion is attempted on the access parameter to an access
--- type A declared at some nesting level. The test verifies that
--- Program_Error is raised if the actual corresponding to the access
--- parameter is another access parameter, and the actual corresponding
--- to this second access parameter is:
---
--- (1) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (2) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the target type -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := A(X); -- Check should never fail.
--- begin null; end;
--- . . .
--- procedure Q (Y: access T) is
--- begin
--- P(Y);
--- end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- Q (Actual'Access);
--- end;
---
--- For the execution of Q (and hence P), the accessibility level of
--- type A will always be deeper than that of Actual, so there is no
--- danger of a dangling reference arising from the assignment to
--- Acc. Thus, the type conversion is safe, even though the static
--- nesting level of Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Changed maintenance documentation.
--- 15 Jul 98 EDS Avoid Optimization
--- 28 Jun 02 RLB Added pragma Elaborate_All.
---!
-
-with Report; use Report; pragma Elaborate_All (Report);
-package C460002_0 is
-
- type Component is array (1 .. 10) of Natural;
-
- type Desig is record
- C: Component;
- end record;
-
- X0 : aliased Desig := (C=>(others => Ident_Int(3))); -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind);
-
-end C460002_0;
-
-
- --==================================================================--
-
-
-package body C460002_0 is
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
-
- procedure Nested (X: access Desig; R: out Result_Kind) is
- -- This procedure attempts a type conversion on the access parameter to
- -- an access type declared at some nesting level. Program_Error is
- -- raised if the accessibility level of the operand type is deeper than
- -- that of the target type.
-
- begin
- -- The accessibility level of type Acc_L0 is 0.
- A0 := Acc_L0(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Nested;
-
- begin
- Nested (Y, S);
- end Target_Is_Level_0_Nest;
-
- -------------------------------------------------------------
-
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
-
- type Acc_Deeper is access all Desig;
- AD : Acc_Deeper;
-
- function Nested (X: access Desig) return Result_Kind is
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Deeper will always be deeper than or the same as that
- -- of the actual corresponding to Y.
- AD := Acc_Deeper(X);
- if Natural(Ident_Int(AD.C(1))) /= 3 then --Avoid Optimization of AD
- Report.Failed ("Initial Values not correct.");
- end if;
- return OK;
- exception
- when Program_Error =>
- return P_E;
- when others =>
- return O_E;
- end Nested;
-
- begin
- S := Nested (Y);
- end Never_Fails_Nest;
-
- -------------------------------------------------------------
-
- procedure Called_By_Never_Fails_Same
- (X: access Desig; R: out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Local will always be deeper than or the same as that
- -- of the actual corresponding to X.
- AL := Acc_Local(X);
- if Natural(Ident_Int(AL.C(1))) /= 3 then --Avoid Optimization of AL
- Report.Failed ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Never_Fails_Same;
-
- -------------------------------------------------------------
-
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
- begin
- Called_By_Never_Fails_Same (Y, S);
- end Never_Fails_Same;
-
-end C460002_0;
-
-
- --==================================================================--
-
-
-with C460002_0;
-use C460002_0;
-
-with Report; use Report;
-
-procedure C460002 is
-
- type Acc_L1 is access all Desig; -- Level = 1.
- A1 : Acc_L1;
- X1 : aliased Desig := (C=>(others => Ident_Int(3)));
- Res : Result_Kind;
-
-
-
- procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
- begin
- -- The accessibility level of type Acc_L1 is 1.
- A1 := Acc_L1(X);
- if Natural(Ident_Int(A1.C(1))) /= 3 then --Avoid Optimization of A1
- Report.Failed ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Target_L1;
-
- -------------------------------------------------------------
-
- function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
- S : Result_Kind;
- begin
- Called_By_Target_L1 (Y, S);
- return S;
- end Target_Is_Level_1_Same;
-
- -------------------------------------------------------------
-
- procedure Display_Results (Result : in Result_Kind;
- Expected: in Result_Kind;
- Msg : in String) is
- begin
- if Result /= Expected then
- case Result is
- when OK => Report.Failed ("No exception raised: " & Msg);
- when P_E => Report.Failed ("Program_Error raised: " & Msg);
- when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
- end case;
- end if;
- end Display_Results;
-
-begin -- C460002.
-
- Report.Test ("C460002", "Check that if the target type of a type " &
- "conversion is a general access type, Program_Error is " &
- "raised if the accessibility level of the operand type " &
- "is deeper than that of the target type: operand is an " &
- "access parameter; corresponding actual is another " &
- "access parameter");
-
-
- -- Accessibility level of actual is 0 (actual is X'Access):
-
- Never_Fails_Same (X0'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 0 actual");
-
- Never_Fails_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 0 actual");
-
- Target_Is_Level_0_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L0_Nest, level 0 actual");
-
- Res := Target_Is_Level_1_Same (X0'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 0 actual");
-
-
- -- Accessibility level of actual is 1 (actual is X'Access):
-
- Never_Fails_Same (X1'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 1 actual");
-
- Never_Fails_Nest (X1'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 1 actual");
-
- Target_Is_Level_0_Nest (X1'Access, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual");
-
- Res := Target_Is_Level_1_Same (X1'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 1 actual");
-
-
- Block_L2:
- declare
- X2 : aliased Desig := (C=>(others => Ident_Int(3)));
- type Acc_L2 is access all Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X2'Access;
- begin
-
- -- Accessibility level of actual is 2 (actual is expression of named
- -- access type):
-
- Never_Fails_Same (Expr_L2, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 2 actual");
-
- Never_Fails_Nest (Expr_L2, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 2 actual");
-
- Target_Is_Level_0_Nest (Expr_L2, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual");
-
- Res := Target_Is_Level_1_Same (Expr_L2);
- Display_Results (Res, P_E, "Target_L1_Same, level 2 actual");
-
- end Block_L2;
-
-
- Report.Result;
-
-end C460002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460004.a b/gcc/testsuite/ada/acats/tests/c4/c460004.a
deleted file mode 100644
index b004281..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460004.a
+++ /dev/null
@@ -1,335 +0,0 @@
--- C460004.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 operand type of a type conversion is class-wide,
--- Constraint_Error is raised if the tag of the operand does not
--- identify a specific type that is covered by or descended from the
--- target type.
---
--- TEST DESCRIPTION:
--- View conversions of class-wide operands to specific types are
--- placed on the right and left sides of assignment statements, and
--- conversions of class-wide operands to class-wide types are used
--- as actual parameters to dispatching operations. In all cases, a
--- check is made that Constraint_Error is raised if the tag of the
--- operand does not identify a specific type covered by or descended
--- from the target type, and not raised otherwise.
---
--- A specific type is descended from itself and from those types it is
--- directly or indirectly derived from. A specific type is covered by
--- itself and each class-wide type to whose class it belongs.
---
--- A class-wide type T'Class is descended from T and those types which
--- T is descended from. A class-wide type is covered by each class-wide
--- type to whose class it belongs.
---
---
--- CHANGE HISTORY:
--- 19 Jul 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag.
---
---!
-package C460004_0 is
-
- type Tag_Type is tagged record
- C1 : Natural;
- end record;
-
- procedure Proc (X : in out Tag_Type);
-
-
- type DTag_Type is new Tag_Type with record
- C2 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DTag_Type);
-
-
- type DDTag_Type is new DTag_Type with record
- C3 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DDTag_Type);
-
- procedure NewProc (X : in DDTag_Type);
-
- function CWFunc (X : Tag_Type'Class) return Tag_Type'Class;
-
-end C460004_0;
-
-
- --==================================================================--
-
-with Report;
-package body C460004_0 is
-
- procedure Proc (X : in out Tag_Type) is
- begin
- X.C1 := 25;
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DTag_Type) is
- begin
- Proc ( Tag_Type(X) );
- X.C2 := "Earth";
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DDTag_Type) is
- begin
- Proc ( DTag_Type(X) );
- X.C3 := "Orbit";
- end Proc;
-
- -----------------------------------------
- procedure NewProc (X : in DDTag_Type) is
- Y : DDTag_Type := X;
- begin
- Proc (Y);
- exception
- when others =>
- Report.Failed ("Unexpected exception in NewProc");
- end NewProc;
-
- -----------------------------------------
- function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is
- Y : Tag_Type'Class := X;
- begin
- Proc (Y);
- return Y;
- end CWFunc;
-
-end C460004_0;
-
-
- --==================================================================--
-
-
-with C460004_0;
-use C460004_0;
-
-with Report;
-procedure C460004 is
-
- Tag_Type_Init : constant Tag_Type := (C1 => 0);
- DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello");
- DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World");
-
- Tag_Type_Value : constant Tag_Type := (C1 => 25);
- DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth");
- DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit");
-
-begin
-
- Report.Test ("C460004", "Check that for a view conversion of a " &
- "class-wide operand, Constraint_Error is raised if the " &
- "tag of the operand does not identify a specific type " &
- "covered by or descended from the target type");
-
---
--- View conversion to specific type:
---
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Target : Tag_Type := Tag_Type_Init;
- begin
- Target := Tag_Type(P);
- if (Target /= Tag_Type_Value) then
- Report.Failed ("Target has wrong value: #01");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #01");
- when others =>
- Report.Failed ("Unexpected exception: #01");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Value);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- Target : DTag_Type := DTag_Type_Init;
- begin
- Target := DTag_Type(CWFunc(DDTag_Type_Value));
- if (Target /= DTag_Type_Value) then
- Report.Failed ("Target has wrong value: #02");
- end if;
- exception
- when Constraint_Error => Report.Failed ("Constraint_Error raised: #02");
- when others => Report.Failed ("Unexpected exception: #02");
- end;
-
- ----------------------------------------------------------------------
-
- declare
- Target : DDTag_Type;
- begin
- Target := DDTag_Type(CWFunc(Tag_Type_Value));
- -- CWFunc returns a Tag_Type; its tag is preserved through
- -- the view conversion. Constraint_Error should be raised.
-
- Report.Failed ("Constraint_Error not raised: #03");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #03");
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- begin
- NewProc (DDTag_Type(P));
- Report.Failed ("Constraint_Error not raised: #04");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #04");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Value);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Target : DDTag_Type := DDTag_Type_Init;
- begin
- Target := DDTag_Type(P);
- if (Target /= DDTag_Type_Value) then
- Report.Failed ("Target has wrong value: #05");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #05");
- when others
- => Report.Failed ("Unexpected exception: #05");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Value);
- end;
-
-
---
--- View conversion to class-wide type:
---
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DTag_Type'Class(Operand) );
- Report.Failed ("Constraint_Error not raised: #06");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #06");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DDTag_Type'Class(Operand) );
- Report.Failed ("Constraint_Error not raised: #07");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #07");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DTag_Type'Class(Operand) );
- if Operand not in DTag_Type then
- Report.Failed ("Operand has wrong tag: #08");
- elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #08");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #08");
- when others =>
- Report.Failed ("Unexpected exception: #08");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( Tag_Type'Class(Operand) );
- if Operand not in DDTag_Type then
- Report.Failed ("Operand has wrong tag: #09");
- elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #09");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #09");
- when others =>
- Report.Failed ("Unexpected exception: #09");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Init);
- end;
-
-
- Report.Result;
-
-end C460004;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460005.a b/gcc/testsuite/ada/acats/tests/c4/c460005.a
deleted file mode 100644
index 95b14a9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460005.a
+++ /dev/null
@@ -1,260 +0,0 @@
--- C460005.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, for a view conversion of a tagged type that is the left
--- side of an assignment statement, the assignment assigns to the
--- corresponding part of the object denoted by the operand.
---
--- TEST DESCRIPTION:
--- View conversions of class-wide operands to specific types are
--- placed on the right and left sides of assignment statements, and
--- conversions of class-wide operands to class-wide types are used
--- as actual parameters to dispatching operations. In all cases, a
--- check is made that Constraint_Error is raised if the tag of the
--- operand does not identify a specific type covered by or descended
--- from the target type, and not raised otherwise.
---
--- For the cases where the view conversion is the left side of an
--- assignment statement, and Constraint_Error should not be raised,
--- an additional check is made that only the corresponding portion
--- of the operand is updated by the assignment. For example:
---
--- type T is tagged record
--- C1 : Integer := 0;
--- end record;
---
--- type DT is new T with record
--- C2 : Integer := 0;
--- end record;
---
--- A : T := (C1 => 5);
--- B : DT := (C1 => 0, C2 => 10);
--- CWDT : T'Class := B;
---
--- T(CWDT) := A; -- Updates component C1; C2 remains unchanged.
--- -- Value of CWDT is (C1 => 5, C2 => 10).
---
---
--- CHANGE HISTORY:
--- 31 Jul 95 SAIC Initial prerelease version.
--- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag.
--- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test.
---
---!
-
-package C460005_0 is
-
- type Tag_Type is tagged record
- C1 : Natural;
- end record;
-
- procedure Proc (X : in out Tag_Type);
-
-
- type DTag_Type is new Tag_Type with record
- C2 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DTag_Type);
-
-
- type DDTag_Type is new DTag_Type with record
- C3 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DDTag_Type);
-
-end C460005_0;
-
-
- --==================================================================--
-
-
-package body C460005_0 is
-
- procedure Proc (X : in out Tag_Type) is
- begin
- X.C1 := 25;
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DTag_Type) is
- begin
- Proc ( Tag_Type(X) );
- X.C2 := "Earth";
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DDTag_Type) is
- begin
- Proc ( DTag_Type(X) );
- X.C3 := "Orbit";
- end Proc;
-
-end C460005_0;
-
-
- --==================================================================--
-
-
-with C460005_0;
-use C460005_0;
-
-with Report;
-procedure C460005 is
-
- Tag_Type_Init : constant Tag_Type := (C1 => 0);
- DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello");
- DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World");
-
- Tag_Type_Value : constant Tag_Type := (C1 => 25);
- DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth");
- DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit");
-
- Tag_Type_Res : constant Tag_Type := (C1 => 25);
- DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello");
- DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World");
-
-begin
-
- Report.Test ("C460005", "Check that, for a view conversion of a tagged " &
- "type that is the left side of an assignment statement, " &
- "the assignment assigns to the corresponding part of the " &
- "object denoted by the operand");
-
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if (Operand /= Tag_Type'Class (Tag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #01");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #01");
- when others =>
- Report.Failed ("Unexpected exception: #01");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- DTag_Type(Operand) := DTag_Type_Value;
- Report.Failed ("Constraint_Error not raised: #02");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #02");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- DDTag_Type(Operand) := DDTag_Type_Value;
- Report.Failed ("Constraint_Error not raised: #03");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #03");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if Operand not in DTag_Type then
- Report.Failed ("Operand has wrong tag: #04");
- elsif (Operand /= Tag_Type'Class (DTag_Type_Res))
- then -- Check to make
- Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was
- end if; -- not modified.
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #04");
- when others =>
- Report.Failed ("Unexpected exception: #04");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if Operand not in DDTag_Type then
- Report.Failed ("Operand has wrong tag: #05");
- elsif (Operand /= Tag_Type'Class (DDTag_Type_Res))
- then -- Check to make
- Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3
- end if; -- were not changed.
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #05");
- when others =>
- Report.Failed ("Unexpected exception: #05");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Init);
- end;
-
- Report.Result;
-
-end C460005;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc/testsuite/ada/acats/tests/c4/c460006.a
deleted file mode 100644
index 9996884..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460006.a
+++ /dev/null
@@ -1,378 +0,0 @@
--- C460006.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 view conversion to a tagged type is permitted in the
--- prefix of a selected component, an object renaming declaration, and
--- (if the operand is a variable) on the left side of an assignment
--- statement. Check that such a renaming or assignment does not change
--- the tag of the operand.
---
--- Check that, for a view conversion of a tagged type, each
--- nondiscriminant component of the new view denotes the matching
--- component of the operand object. Check that reading the value of the
--- view yields the result of converting the value of the operand object
--- to the target subtype.
---
--- TEST DESCRIPTION:
--- The fact that the tag of an object is not changed is verified by
--- making calls to primitive operations which in turn make (re)dispatching
--- calls, and confirming that the proper bodies are executed.
---
--- Selected components are checked in three contexts: as the object name
--- in an object renaming declaration, as the left operand of an inequality
--- operation, and as the left side of an assignment statement.
---
--- View conversions of an object of a 2nd level type extension are
--- renamed as objects of an ancestor type and of a class-wide type. In
--- one case the operand of the conversion is itself a renaming of an
--- object.
---
--- View conversions of an object of a 2nd level type extension are
--- checked for equality with record aggregates of various ancestor types.
--- In one case, the view conversion is to a class-wide type, and it is
--- checked for equality with the result of a class-wide function with
--- the following structure:
---
--- function F return T'Class is
--- A : DDT := Expected_Value;
--- X : T'Class := T(A);
--- begin
--- return X;
---
--- end F;
---
--- ...
---
--- Var : DDT := Expected_Value;
---
--- if (T'Class(Var) /= F) then -- Condition should yield FALSE.
--- FAIL;
--- end if;
---
--- The view conversion to which X is initialized does not affect the
--- value or tag of the operand; the tag of X is that of type DDT (not T),
--- and the components are those of A. The result of this function
--- should equal the value of an object of type DDT initialized to the
--- same value as F.A.
---
--- To check that assignment to a view conversion does not change the tag
--- of the operand, an assignment is made to a conversion of an object,
--- and the object is then passed as an actual to a dispatching operation.
--- Conversions to both specific and class-wide types are checked.
---
---
--- CHANGE HISTORY:
--- 20 Jul 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Added type conversions.
---
---!
-
-package C460006_0 is
-
- type Call_ID_Kind is (None, Parent_Outer, Parent_Inner,
- Child_Outer, Child_Inner,
- Grandchild_Outer, Grandchild_Inner);
-
- type Root_Type is abstract tagged record
- First_Call : Call_ID_Kind := None;
- Second_Call : Call_ID_Kind := None;
- end record;
-
- procedure Inner_Proc (X : in out Root_Type) is abstract;
- procedure Outer_Proc (X : in out Root_Type) is abstract;
-
-end C460006_0;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1 is
-
- type Parent_Type is new Root_Type with record
- C1 : Integer := 0;
- end record;
-
- procedure Inner_Proc (X : in out Parent_Type);
- procedure Outer_Proc (X : in out Parent_Type);
-
-end C460006_0.C460006_1;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1 is
-
- procedure Inner_Proc (X : in out Parent_Type) is
- begin
- X.Second_Call := Parent_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Parent_Type) is
- begin
- X.First_Call := Parent_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
-end C460006_0.C460006_1;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1.C460006_2 is
-
- type Child_Type is new Parent_Type with record
- C2 : String(1 .. 5) := "-----";
- end record;
-
- procedure Inner_Proc (X : in out Child_Type);
- procedure Outer_Proc (X : in out Child_Type);
-
-end C460006_0.C460006_1.C460006_2;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1.C460006_2 is
-
- procedure Inner_Proc (X : in out Child_Type) is
- begin
- X.Second_Call := Child_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Child_Type) is
- begin
- X.First_Call := Child_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
-end C460006_0.C460006_1.C460006_2;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1.C460006_2.C460006_3 is
-
- type Grandchild_Type is new Child_Type with record
- C3: String(1 .. 5) := "-----";
- end record;
-
- procedure Inner_Proc (X : in out Grandchild_Type);
- procedure Outer_Proc (X : in out Grandchild_Type);
-
-
- function ClassWide_Func return Parent_Type'Class;
-
-
- Grandchild_Value : constant Grandchild_Type := (First_Call => None,
- Second_Call => None,
- C1 => 15,
- C2 => "Hello",
- C3 => "World");
-
-end C460006_0.C460006_1.C460006_2.C460006_3;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1.C460006_2.C460006_3 is
-
- procedure Inner_Proc (X : in out Grandchild_Type) is
- begin
- X.Second_Call := Grandchild_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Grandchild_Type) is
- begin
- X.First_Call := Grandchild_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
- -------------------------------------------------
- function ClassWide_Func return Parent_Type'Class is
- A : Grandchild_Type := Grandchild_Value;
- X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
- begin
- return X;
- end ClassWide_Func;
-
-end C460006_0.C460006_1.C460006_2.C460006_3;
-
-
- --==================================================================--
-
-
-with C460006_0.C460006_1.C460006_2.C460006_3;
-
-with Report;
-procedure C460006 is
-
- package Root_Package renames C460006_0;
- package Parent_Package renames C460006_0.C460006_1;
- package Child_Package renames C460006_0.C460006_1.C460006_2;
- package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;
-
-begin
- Report.Test ("C460006", "Check that a view conversion to a tagged type " &
- "is permitted in the prefix of a selected component, an " &
- "object renaming declaration, and (if the operand is a " &
- "variable) on the left side of an assignment statement. " &
- "Check that such a renaming or assignment does not change " &
- " the tag of the operand");
-
-
- --
- -- Check conversion as prefix of selected component:
- --
-
- Selected_Component_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- CW_Var : Parent_Type'Class := Var;
-
- Ren : Integer renames Parent_Type(Var).C1;
-
- begin
- if Ren /= 15 then
- Report.Failed ("Wrong value: selected component in renaming");
- end if;
-
- if Child_Type(Var).C2 /= "Hello" then
- Report.Failed ("Wrong value: selected component in IF");
- end if;
-
- Grandchild_Type(CW_Var).C3(2..4) := "eir";
- if CW_Var /= Parent_Type'Class
- (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
- then
- Report.Failed ("Wrong value: selected component in assignment");
- end if;
- end Selected_Component_Subtest;
-
-
- --
- -- Check conversion in object renaming:
- --
-
- Object_Renaming_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- Ren1 : Parent_Type renames Parent_Type(Var);
- Ren2 : Child_Type renames Child_Type(Var);
- Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
- Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename.
- begin
- Outer_Proc (Ren1);
- if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
- Report.Failed ("Value or tag not preserved by object renaming: Ren1");
- end if;
-
- Outer_Proc (Ren2);
- if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
- Report.Failed ("Value or tag not preserved by object renaming: Ren2");
- end if;
-
- Outer_Proc (Ren3);
- if Ren3 /= Parent_Type'Class
- (Grandchild_Type'(Grandchild_Outer,
- Grandchild_Inner,
- 15,
- "Hello",
- "World"))
- then
- Report.Failed ("Value or tag not preserved by object renaming: Ren3");
- end if;
-
- Outer_Proc (Ren4);
- if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
- Report.Failed ("Value or tag not preserved by object renaming: Ren4");
- end if;
- end Object_Renaming_Subtest;
-
-
- --
- -- Check reading view conversion, and conversion as left side of assignment:
- --
-
- View_Conversion_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- Specific : Child_Type;
- ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag.
- begin
- if Parent_Type(Var) /= (None, None, 15) then
- Report.Failed ("View has wrong value: #1");
- end if;
-
- if Child_Type(Var) /= (None, None, 15, "Hello") then
- Report.Failed ("View has wrong value: #2");
- end if;
-
- if Parent_Type'Class(Var) /= ClassWide_Func then
- Report.Failed ("Upward view conversion did not preserve " &
- "extension's components");
- end if;
-
-
- Parent_Type(Specific) := (None, None, 26); -- Assign to view.
- Outer_Proc (Specific); -- Call dispatching op.
-
- if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
- Report.Failed ("Value or tag not preserved by assignment: Specific");
- end if;
-
-
- Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
- Outer_Proc (ClassWide); -- Call dispatching op.
-
- if ClassWide /= Parent_Type'Class
- (Grandchild_Type'(Grandchild_Outer,
- Grandchild_Inner,
- 44,
- "Hello",
- "World"))
- then
- Report.Failed ("Value or tag not preserved by assignment: ClassWide");
- end if;
- end View_Conversion_Subtest;
-
- Report.Result;
-
-end C460006;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460007.a b/gcc/testsuite/ada/acats/tests/c4/c460007.a
deleted file mode 100644
index fdcc1ad..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460007.a
+++ /dev/null
@@ -1,239 +0,0 @@
--- C460007.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 a numeric type conversion, if the target type is an
--- integer type and the operand type is real, the result is rounded
--- to the nearest integer, and away from zero if the result is exactly
--- halfway between two integers. Check for static and non-static type
--- conversions.
---
--- TEST DESCRIPTION:
--- The following cases are considered:
---
--- X.5 X.5 + delta -X.5 + delta
--- -X.5 X.5 - delta -X.5 - delta
---
--- Both zero and non-zero values are used for X. The value of delta is
--- chosen to be a very small increment (on the order of 1.0E-10). For
--- fixed and floating point cases, the value of delta is chosen such that
--- "(-)X.5 +(-) delta" is a multiple of the small, or a machine number,
--- respectively.
---
--- The following type conversions are performed:
---
--- ID Real operand Cases Target integer subtype
--- ------------------------------------------------------------------
--- 1 Real named number X.5 Nonstatic
--- 2 X.5 - delta Nonstatic
--- 3 -X.5 - delta Static
--- 4 Real literal -X.5 Static
--- 5 X.5 + delta Static
--- 6 -X.5 + delta Nonstatic
--- 7 Floating point object -X.5 - delta Nonstatic
--- 8 X.5 - delta Static
--- 9 Fixed point object X.5 Static
--- 10 X.5 + delta Static
--- 11 -X.5 + delta Nonstatic
--- The conversion is either assigned to a variable of the target subtype
--- or passed as a parameter to a subprogram (both nonstatic contexts).
---
--- The subprogram Equal is used to circumvent potential optimizations.
---
---
--- CHANGE HISTORY:
--- 03 Oct 95 SAIC Initial prerelease version.
---
---!
-
-with System;
-package C460007_0 is
-
---
--- Target integer subtype (static):
---
-
- type Static_Integer_Subtype is range -32_000 .. 32_000;
-
- Static_Target : Static_Integer_Subtype;
-
- function Equal (L, R: Static_Integer_Subtype) return Boolean;
-
-
---
--- Named numbers:
---
-
- NN_Half : constant := 0.5000000000;
- NN_Less_Half : constant := 126.4999999999;
- NN_More_Half : constant := -NN_Half - 0.0000000001;
-
-
---
--- Floating point:
---
-
- type My_Float is digits System.Max_Digits;
-
- Flt_Rnd_Toward_Zero : My_Float := My_Float'Pred(NN_Half);
- Flt_Rnd_Away_Zero : constant My_Float := My_Float'Pred(-113.5);
-
-
---
--- Fixed point:
---
-
- type My_Fixed is delta 0.1 range -5.0 .. 5.0;
-
- Fix_Half : My_Fixed := 0.5;
- Fix_Rnd_Away_Zero : My_Fixed := Fix_Half + My_Fixed'Small;
- Fix_Rnd_Toward_Zero : constant My_Fixed := -3.5 + My_Fixed'Small;
-
-end C460007_0;
-
-
- --==================================================================--
-
-
-package body C460007_0 is
-
- function Equal (L, R: Static_Integer_Subtype) return Boolean is
- begin
- return (L = R);
- end Equal;
-
-end C460007_0;
-
-
- --==================================================================--
-
-
-with C460007_0;
-use C460007_0;
-
-with Report;
-procedure C460007 is
-
---
--- Target integer subtype (nonstatic):
---
-
- Limit : Static_Integer_Subtype :=
- Static_Integer_Subtype(Report.Ident_Int(128));
-
- subtype Nonstatic_Integer_Subtype is Static_Integer_Subtype
- range -Limit .. Limit;
-
- Nonstatic_Target : Static_Integer_Subtype;
-
-begin
-
- Report.Test ("C460007", "Rounding for type conversions of real operand " &
- "to integer target");
-
-
- -- --------------------------
- -- Named number/literal cases:
- -- --------------------------
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(NN_Half);
-
- if not Equal(Nonstatic_Target, 1) then -- Case 1.
- Report.Failed ("Wrong result for named number operand" &
- "(case 1), nonstatic target subtype");
- end if;
-
- if not Equal(Nonstatic_Integer_Subtype(NN_Less_Half), 126) then -- Case 2.
- Report.Failed ("Wrong result for named number operand" &
- "(case 2), nonstatic target subtype");
- end if;
-
- Static_Target := Static_Integer_Subtype(NN_More_Half);
-
- if not Equal(Static_Target, -1) then -- Case 3.
- Report.Failed ("Wrong result for named number operand" &
- "(case 3), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(-0.50), -1) then -- Case 4.
- Report.Failed ("Wrong result for literal operand" &
- "(case 4), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(29_546.5001), 29_547) then -- Case 5.
- Report.Failed ("Wrong result for literal operand" &
- "(case 5), static target subtype");
- end if;
-
- if not Equal(Nonstatic_Integer_Subtype(-66.499), -66) then -- Case 6.
- Report.Failed ("Wrong result for literal operand" &
- "(case 6), nonstatic target subtype");
- end if;
-
-
- -- --------------------
- -- Floating point cases:
- -- --------------------
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(Flt_Rnd_Away_Zero);
-
- if not Equal(Nonstatic_Target, -114) then -- Case 7.
- Report.Failed ("Wrong result for floating point operand" &
- "(case 7), nonstatic target subtype");
- end if;
- -- Case 8.
- if not Equal(Static_Integer_Subtype(Flt_Rnd_Toward_Zero), 0) then
- Report.Failed ("Wrong result for floating point operand" &
- "(case 8), static target subtype");
- end if;
-
-
- -- -----------------
- -- Fixed point cases:
- -- -----------------
-
- Static_Target := Static_Integer_Subtype(Fix_Half);
-
- if not Equal(Static_Target, 1) then -- Case 9.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 9), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(Fix_Rnd_Away_Zero), 1) then -- Case 10.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 10), static target subtype");
- end if;
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(Fix_Rnd_Toward_Zero);
-
- if not Equal(Nonstatic_Target, -3) then -- Case 11.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 11), nonstatic target subtype");
- end if;
-
-
- Report.Result;
-
-end C460007;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460008.a b/gcc/testsuite/ada/acats/tests/c4/c460008.a
deleted file mode 100644
index 29d48ec..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460008.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- C460008.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 conversion to a modular type raises Constraint_Error
--- when the operand value is outside the base range of the modular type.
---
--- TEST DESCRIPTION:
--- Test conversion from integer, float, fixed and decimal types to
--- modular types. Test conversion to mod 255, mod 256 and mod 258
--- to test the boundaries of 8 bit (+/-) unsigned numbers.
--- Test operand values that are negative, the value of the mod,
--- and greater than the value of the mod.
--- Declare a generic test procedure and instantiate it for each of the
--- unsigned types for each operand type.
---
---
--- CHANGE HISTORY:
--- 04 OCT 95 SAIC Initial version
--- 15 MAY 96 SAIC Revised for 2.1
--- 24 NOV 98 RLB Moved decimal cases into new test, C460011, to
--- prevent this test from being inapplicable to
--- implementations not supporting decimal types.
---
---!
-
-------------------------------------------------------------------- C460008
-
-with Report;
-
-procedure C460008 is
-
- Shy_By_One : constant := 2**8-1;
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
- type Unsigned_8_Bit is mod 2**8;
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- NPC : constant String := " not properly converted";
-
- procedure Assert( Truth: Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed(Message);
- end if;
- end Assert;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is range <>;
- type Target is mod <>;
- procedure Integer_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Integer_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Int expected Constraint_Error " & Message);
- -- the call to Comment is to make the otherwise dead assignment to
- -- Item live.
- -- To avoid invoking C_E on a call to 'Image in Report.Failed that
- -- could cause a false pass
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Int Raised wrong exception " & Message);
- end Integer_Conversion_Check;
-
- procedure Int_To_Short is
- new Integer_Conversion_Check( Integer, Unsigned_Edge_8 );
-
- procedure Int_To_Eight is
- new Integer_Conversion_Check( Integer, Unsigned_8_Bit );
-
- procedure Int_To_Wide is
- new Integer_Conversion_Check( Integer, Unsigned_Over_8 );
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is digits <>;
- type Target is mod <>;
- procedure Float_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Float_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Flt expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Flt raised wrong exception " & Message);
- end Float_Conversion_Check;
-
- procedure Float_To_Short is
- new Float_Conversion_Check( Float, Unsigned_Edge_8 );
-
- procedure Float_To_Eight is
- new Float_Conversion_Check( Float, Unsigned_8_Bit );
-
- procedure Float_To_Wide is
- new Float_Conversion_Check( Float, Unsigned_Over_8 );
-
- function Identity( Root_Beer: Float ) return Float is
- -- a knockoff of Report.Ident_Int for type Float
- Nothing : constant Float := 0.0;
- begin
- if Report.Ident_Bool( Root_Beer = Nothing ) then
- return Nothing;
- else
- return Root_Beer;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is delta <>;
- type Target is mod <>;
- procedure Fixed_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Fixed_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Fix expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Fix raised wrong exception " & Message);
- end Fixed_Conversion_Check;
-
- procedure Fixed_To_Short is
- new Fixed_Conversion_Check( Duration, Unsigned_Edge_8 );
-
- procedure Fixed_To_Eight is
- new Fixed_Conversion_Check( Duration, Unsigned_8_Bit );
-
- procedure Fixed_To_Wide is
- new Fixed_Conversion_Check( Duration, Unsigned_Over_8 );
-
- function Identity( A_Stitch: Duration ) return Duration is
- Threadbare : constant Duration := 0.0;
- begin
- if Report.Ident_Bool( A_Stitch = Threadbare ) then
- return Threadbare;
- else
- return A_Stitch;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C460008", "Check that conversion to " &
- "a modular type raises Constraint_Error when " &
- "the operand value is outside the base range " &
- "of the modular type" );
-
-
- -- Integer Error cases
-
- Int_To_Short( Report.Ident_Int( -1 ), "I2S Dynamic, Negative" );
- Int_To_Short( Report.Ident_Int( Shy_By_One ), "I2S Dynamic, At_Mod" );
- Int_To_Short( Report.Ident_Int( Heavy_By_Two+1 ), "I2S Dynamic, Over_Mod" );
-
- Int_To_Eight( -Shy_By_One, "I28 Static, Negative" );
- Int_To_Eight( 2**8, "I28 Static, At_Mod" );
- Int_To_Eight( Heavy_By_Two+1, "I28 Static, Over_Mod" );
-
- Int_To_Wide ( Report.Ident_Int( -(Heavy_By_Two*2) ),
- "I2W Dynamic, Negative" );
- Int_To_Wide ( Heavy_By_Two, "I2W Static, At_Mod" );
- Int_To_Wide ( Report.Ident_Int( Heavy_By_Two*2 ), "I2W Dynamic, Over_Mod" );
-
- -- Float Error cases
-
- Float_To_Short( -13.31, "F2S Static, Negative" );
- Float_To_Short( Identity ( Float(Shy_By_One)), "F2S Dynamic, At_Mod" );
- Float_To_Short( 6378.388, "F2S Static, Over_Mod" );
-
- Float_To_Eight( Identity( -99.3574 ), "F28 Dynamic, Negative" );
- Float_To_Eight( 2.0**8, "F28 Static, At_Mod" );
- Float_To_Eight( 2.0**9, "F28 Static, Over_Mod" );
-
- Float_To_Wide ( -0.54953_93129_81644, "FTW Static, Negative" );
- Float_To_Wide ( Identity( 2.0**8 +2.0 ), "FTW Dynamic, At_Mod" );
- Float_To_Wide ( Identity( 2.0**8 +2.5001 ), "FTW Dynamic, Over_Mod" );
- Float_To_Wide ( Identity( Float'Last ), "FTW Dynamic, Over_Mod" );
-
- -- Fixed Error cases
-
- Fixed_To_Short( Identity( -5.00 ), "D2S Dynamic, Negative" );
- Fixed_To_Short( Shy_By_One * 1.0, "D2S Static, At_Mod" );
- Fixed_To_Short( 1995.9, "D2S Static, Over_Mod" );
-
- Fixed_To_Eight( -0.5, "D28 Static, Negative" );
- Fixed_To_Eight( 2.0*128, "D28 Static, At_Mod" );
- Fixed_To_Eight( Identity( 2001.2 ), "D28 Dynamic, Over_Mod" );
-
- Fixed_To_Wide ( Duration'First, "D2W Static, Negative" );
- Fixed_To_Wide ( Identity( 2*128.0 +2.0 ), "D2W Dynamic, At_Mod" );
- Fixed_To_Wide ( Duration'Last, "D2W Static, Over_Mod" );
-
- -- having made it this far, the rest is downhill...
- -- check a few, correct, edge cases, and we're done
-
- Eye_Dew: declare
- A_Float : Float := 0.0;
- Your_Time : Duration := 0.0;
- Number : Integer := 0;
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- begin
- Little := Unsigned_Edge_8(A_Float);
- Assert( Little = 0, "Float => Little, 0");
-
-
- Moderate := Unsigned_8_Bit (Your_Time);
- Assert( Moderate = 0, "Your_Time => Moderate, 0");
-
- Big := Unsigned_Over_8 (Number);
- Assert( Big = 0, "Number => Big, 0");
-
- A_Float := 2.0**8-2.0;
- Your_Time := 2.0*128-2.0;
- Number := 2**8;
-
- Little := Unsigned_Edge_8(A_Float);
- Assert( Little = 254, "Float => Little, 254");
-
- Little := Unsigned_Edge_8(Your_Time);
- Assert( Little = 254, "Your_Time => Little, 254");
-
- Big := Unsigned_Over_8 (A_Float + 2.0);
- Assert( Big = 256, "Sense => Big, 256");
-
- Big := Unsigned_Over_8 (Number);
- Assert( Big = 256, "Number => Big, 256");
-
- end Eye_Dew;
-
- Report.Result;
-
-end C460008;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460009.a b/gcc/testsuite/ada/acats/tests/c4/c460009.a
deleted file mode 100644
index 62dbd47..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460009.a
+++ /dev/null
@@ -1,467 +0,0 @@
--- C460009.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 Constraint_Error is raised in cases of null arrays when:
--- 1. an assignment is made to a null array if the length of each
--- dimension of the operand does not match the length of
--- the corresponding dimension of the target subtype.
--- 2. an array actual parameter does not match the length of
--- corresponding dimensions of the formal in out parameter where
--- the actual parameter has the form of a type conversion.
--- 3. an array actual parameter does not match the length of
--- corresponding dimensions of the formal out parameter where
--- the actual parameter has the form of a type conversion.
---
--- TEST DESCRIPTION:
--- This transition test creates examples where array of null ranges
--- raises Constraint_Error if any of the lengths mismatch.
---
--- Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA.
---
---
--- CHANGE HISTORY:
--- 21 Mar 96 SAIC Initial version for ACVC 2.1.
--- 21 Sep 96 SAIC ACVC 2.1: Added new case.
---
---!
-
-with Report;
-
-procedure C460009 is
-
- subtype Int is Integer range 1 .. 3;
-
-begin
-
- Report.Test("C460009","Check that Constraint_Error is raised in " &
- "cases of null arrays if any of the lengths mismatch " &
- "in assignments and parameter passing");
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int1 is array (Int range <>) of Integer;
- Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1)); -- null array object
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj1 => " &
- Integer'Image (Arr_Obj1'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj1 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj1 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int2 is array (Int range <>, Int range <>) of Integer;
- Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 =>
- (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
- Report.Ident_Int(1)));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj2 => " &
- Integer'Image (Arr_Obj2'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj2 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj2 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int3 is array (Int range <>, Int range <>) of Integer;
- Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
-
- begin
-
- -- Lengths mismatch, Constraint_Error raised.
- Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 =>
- (Report.Ident_Int(1) .. Report.Ident_Int(3) =>
- Report.Ident_Int(1)));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj3 => " &
- Integer'Image (Arr_Obj3'Last));
-
- Report.Failed ("Constraint_Error not raised in Arr_Obj3");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj3 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of
- Integer;
- Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(1) .. Report.Ident_Int(3),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
- begin
-
- -- Lengths mismatch, Constraint_Error raised.
- Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 =>
- (Report.Ident_Int(1) .. Report.Ident_Int(2) =>
- (Report.Ident_Int(3) .. Report.Ident_Int(2) =>
- Report.Ident_Int(1))));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj4 => " &
- Integer'Image (Arr_Obj4'Last));
-
- Report.Failed ("Constraint_Error not raised in Arr_Obj4");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj4 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int5 is array (Int range <>) of Integer;
- Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1)); -- null array object
-
- begin
-
- -- Only lengths of two null ranges are different, no Constraint_Error
- -- raised.
- Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj5 => " &
- Integer'Image (Arr_Obj5'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj5 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj5 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
- subtype Str is String (Report.Ident_Int(5) .. 4);
- -- null string
- Str_Obj : Str;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z');
- Str_Obj(2 .. 1) := "";
- Str_Obj(4 .. 2) := (others => 'X');
- Str_Obj(Report.Ident_Int(6) .. 3) := "";
- Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y');
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Str_Obj - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Str_Obj - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Char5 is array (Int range <>, Int range <>) of Character;
- subtype Formal is Arr_Char5
- (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
- Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1),
- Report.Ident_Int(1) .. Report.Ident_Int(2))
- := (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
- (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' '));
-
- procedure Proc5 (P : in out Formal) is
- begin
- Report.Failed ("No exception raised in Proc5");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc5");
- when others =>
- Report.Failed ("Others exception raised in Proc5");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc5 (Formal(Arr_Obj5));
-
- Report.Failed ("Constraint_Error not raised in the call Proc5");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj5 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array
- (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
-
- type Actual is array
- (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
-
- Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' '));
-
- procedure Proc6 (P : in out Formal) is
- begin
- Report.Failed ("No exception raised in Proc6");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc6");
- when others =>
- Report.Failed ("Others exception raised in Proc6");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc6 (Formal(Arr_Obj6));
-
- Report.Failed ("Constraint_Error not raised in the call Proc6");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj6 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array (Int range <>, Int range <>) of Character;
- type Actual is array (Positive range 5 .. 2,
- Positive range 1 .. 3) of Character;
-
- Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' '));
-
- procedure Proc7 (P : in out Formal) is
- begin
- if P'Last /= 2 and P'Last(2) /= 3 then
- Report.Failed ("Wrong bounds passed for Arr_Obj7");
- end if;
-
- -- Lengths mismatch, Constraint_Error raised.
- P := (1 .. 3 => (3 .. 0 => ' '));
-
- Report.Comment ("Dead assignment prevention in Proc7 => " &
- Integer'Image (P'Last));
-
- Report.Failed ("No exception raised in Proc7");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Others exception raised in Proc7");
- end;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Proc7 (Formal(Arr_Obj7));
-
- if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then
- Report.Failed ("Bounds changed for Arr_Obj7");
- end if;
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised after call Proc7");
- when others =>
- Report.Failed ("Arr_Obj7 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Char8 is array (Int range <>, Int range <>) of Character;
- subtype Formal is Arr_Char8
- (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
- Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1),
- Report.Ident_Int(1) .. Report.Ident_Int(2));
-
- procedure Proc8 (P : out Formal) is
- begin
- Report.Failed ("No exception raised in Proc8");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc8");
- when others =>
- Report.Failed ("Others exception raised in Proc8");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc8 (Formal(Arr_Obj8));
-
- Report.Failed ("Constraint_Error not raised in the call Proc8");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj8 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array
- (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
-
- type Actual is array
- (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
-
- Arr_Obj9 : Actual;
-
- procedure Proc9 (P : out Formal) is
- begin
- Report.Failed ("No exception raised in Proc9");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc9");
- when others =>
- Report.Failed ("Others exception raised in Proc9");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc9 (Formal(Arr_Obj9));
-
- Report.Failed ("Constraint_Error not raised in the call Proc9");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj9 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array (Int range <>, Int range <>) of Character;
- type Actual is array (Positive range 5 .. 2,
- Positive range 1 .. 3) of Character;
-
- Arr_Obj10 : Actual;
-
- procedure Proc10 (P : out Formal) is
- begin
- if P'Last /= 2 and P'Last(2) /= 3 then
- Report.Failed ("Wrong bounds passed for Arr_Obj10");
- end if;
-
- -- Lengths mismatch, Constraint_Error raised.
- P := (1 .. 3 => (3 .. 1 => ' '));
-
- Report.Comment ("Dead assignment prevention in Proc10 => " &
- Integer'Image (P'Last));
-
- Report.Failed ("No exception raised in Proc10");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Others exception raised in Proc10");
- end;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Proc10 (Formal(Arr_Obj10));
-
- if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then
- Report.Failed ("Bounds changed for Arr_Obj10");
- end if;
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised after call Proc10");
- when others =>
- Report.Failed ("Arr_Obj10 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- Report.Result;
-
-end C460009;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460010.a b/gcc/testsuite/ada/acats/tests/c4/c460010.a
deleted file mode 100644
index 790a8c3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460010.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- C460010.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, for an array aggregate without an others choice assigned
--- to an object of a constrained array subtype, Constraint_Error is not
--- raised if the length of each dimension of the aggregate equals the
--- length of the corresponding dimension of the target object, even if
--- the bounds of the corresponding index ranges do not match.
---
--- TEST DESCRIPTION:
--- The test verifies that sliding of array bounds is performed on array
--- aggregates that are part of a larger aggregate, where the bounds of
--- the corresponding index ranges do not match but the lengths of the
--- corresponding dimensions are the same. Both aggregates containing
--- named associations and positional associations are checked. Cases
--- involving static and nonstatic index constraints, as well as pre-
--- defined and modular integer index subtypes, are included.
---
---
--- CHANGE HISTORY:
--- 15 Apr 96 SAIC Prerelease version for ACVC 2.1.
--- 20 Oct 96 SAIC Removed unnecessary parentheses and type
--- conversions.
---
---!
-
-with Report;
-pragma Elaborate (Report);
-
-package C460010_0 is
-
- type Modular_Type is mod 10; -- Range 0 .. 9.
-
-
- Two : Modular_Type := Modular_Type (Report.Ident_Int(2));
- Four : Modular_Type := Modular_Type (Report.Ident_Int(4));
-
- type Array_Modular_Index is array (Modular_Type range <>) of Integer;
-
- subtype Array_Static_Modular_Constraint is Array_Modular_Index(2..4);
- subtype Array_Nonstatic_Modular_Constraint is Array_Modular_Index(Two..Four);
-
-end C460010_0;
-
-
- --==================================================================--
-
-
-with Report;
-pragma Elaborate (Report);
-
-package C460010_1 is
-
- One : Integer := Report.Ident_Int(1);
- Ten : Integer := Report.Ident_Int(10);
-
- subtype Integer_Subtype is Integer range One .. Ten;
-
-
- Two : Integer := Report.Ident_Int(2);
- Four : Integer := Report.Ident_Int(4);
-
- type Array_Integer_Index is array (Integer_Subtype range <>) of Boolean;
-
- subtype Array_Static_Integer_Constraint is Array_Integer_Index(2..4);
- subtype Array_Nonstatic_Integer_Constraint is Array_Integer_Index(Two..Four);
-
-end C460010_1;
-
-
- --==================================================================--
-
-
--- Generic equality function:
-
-generic
- type Operand_Type is private;
-function C460010_2 (L, R : Operand_Type) return Boolean;
-
-
-function C460010_2 (L, R : Operand_Type) return Boolean is
-begin
- return L = R;
-end C460010_2;
-
-
- --==================================================================--
-
-
-with C460010_0;
-with C460010_1;
-with C460010_2;
-
-with Report;
-
-procedure C460010 is
-
- generic function Generic_Equality renames C460010_2;
-
-begin
- Report.Test ("C460010", "Check that Constraint_Error is not raised if " &
- "an array aggregate without an others choice is assigned " &
- "to an object of a constrained array subtype, and the " &
- "length of each dimension of the aggregate equals the " &
- "length of the corresponding dimension of the target object");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_0.Array_Static_Modular_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_1:
- begin
- Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 1");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 1");
- end CASE_1;
-
- ---=---=---=---=---=---=---
-
- CASE_2:
- begin
- Target := (1 => (5, 10, 15)); -- Positional associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 2");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 2");
- end CASE_2;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Rec (Disc : C460010_0.Modular_Type := 4) is record
- Arr : C460010_0.Array_Modular_Index(2 .. Disc);
- end record;
-
- function Equals is new Generic_Equality (Rec);
- Target : Rec;
- begin
- ---=---=---=---=---=---=---
- CASE_3:
- begin
- Target := (Disc => 4, Arr => (1 => 1, 2 => 2, 3 => 3)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 3");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 3");
- end CASE_3;
-
- ---=---=---=---=---=---=---
-
- CASE_4:
- begin
- Target := (Disc => 4, Arr => (1 ,2, 3)); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 4");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 4");
- end CASE_4;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_0.Array_Nonstatic_Modular_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_5:
- begin
- Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 5");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 5");
- end CASE_5;
-
- ---=---=---=---=---=---=---
-
- CASE_6:
- begin
- Target := (1 => ((5, 10, 15))); -- Positional associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 6");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 6");
- end CASE_6;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_1.Array_Static_Integer_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_7:
- begin
- Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 7");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 7");
- end CASE_7;
-
- ---=---=---=---=---=---=---
-
- CASE_8:
- begin
- Target := (1 => ((False, False, True))); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 8");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 8");
- end CASE_8;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_1.Array_Nonstatic_Integer_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_9:
- begin
- Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 9");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 9");
- end CASE_9;
-
- ---=---=---=---=---=---=---
-
- CASE_10:
- begin
- Target := (1 => (False, False, True)); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 10");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 10");
- end CASE_10;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end C460010;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460011.a b/gcc/testsuite/ada/acats/tests/c4/c460011.a
deleted file mode 100644
index 78038a2..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460011.a
+++ /dev/null
@@ -1,210 +0,0 @@
--- C460011.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 conversion of a decimal type to a modular type raises
--- Constraint_Error when the operand value is outside the base range
--- of the modular type.
--- Check that a conversion of a decimal type to an integer type
--- rounds correctly.
---
--- TEST DESCRIPTION:
--- Test conversion from decimal types to modular types. Test
--- conversion to mod 255, mod 256 and mod 258 to test the boundaries
--- of 8 bit (+/-) unsigned numbers.
--- Test operand values that are negative, the value of the mod,
--- and greater than the value of the mod.
--- Declare a generic test procedure and instantiate it for each of the
--- unsigned types for each operand type.
--- Check that the operand is properly rounded during the conversion.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations which support
--- decimal types.
---
--- CHANGE HISTORY:
--- 24 NOV 98 RLB Split decimal cases from C460008 into this
--- test, added conversions to integer types.
--- 18 JAN 99 RLB Repaired errors in test.
---
---!
-
-------------------------------------------------------------------- C460011
-
-with Report;
-
-procedure C460011 is
-
- Shy_By_One : constant := 2**8-1;
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
- type Unsigned_8_Bit is mod 2**8;
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- type Signed_8_Bit is range -128 .. 127;
- type Signed_Over_8 is range -200 .. 200;
-
- NPC : constant String := " not properly converted";
-
- procedure Assert( Truth: Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed(Message);
- end if;
- end Assert;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- type Decim is delta 0.1 digits 5; -- N/A => ERROR.
-
- generic
- type Source is delta <> digits <>;
- type Target is mod <>;
- procedure Decimal_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Decimal_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Deci expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Deci raised wrong exception " & Message);
- end Decimal_Conversion_Check;
-
- procedure Decim_To_Short is
- new Decimal_Conversion_Check( Decim, Unsigned_Edge_8 );
-
- procedure Decim_To_Eight is
- new Decimal_Conversion_Check( Decim, Unsigned_8_Bit );
-
- procedure Decim_To_Wide is
- new Decimal_Conversion_Check( Decim, Unsigned_Over_8 );
-
- function Identity( Launder: Decim ) return Decim is
- Flat_Broke : constant Decim := 0.0;
- begin
- if Report.Ident_Bool( Launder = Flat_Broke ) then
- return Flat_Broke;
- else
- return Launder;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C460011", "Check that conversion to " &
- "a modular type raises Constraint_Error when " &
- "the operand value is outside the base range " &
- "of the modular type" );
-
- -- Decimal Error cases
-
- Decim_To_Short( Identity( -5.00 ), "M2S Dynamic, Negative" );
- Decim_To_Short( Shy_By_One * 1.0, "M2S Static, At_Mod" );
- Decim_To_Short( 1995.9, "M2S Static, Over_Mod" );
-
- Decim_To_Eight( -0.5, "M28 Static, Negative" );
- Decim_To_Eight( 2.0*128, "M28 Static, At_Mod" );
- Decim_To_Eight( Identity( 2001.2 ), "M28 Dynamic, Over_Mod" );
-
- Decim_To_Wide ( Decim'First, "M2W Static, Negative" );
- Decim_To_Wide ( Identity( 2*128.0 +2.0 ), "M2W Dynamic, At_Mod" );
- Decim_To_Wide ( Decim'Last, "M2W Static, Over_Mod" );
-
- -- Check a few, correct, edge cases, for modular types.
-
- Eye_Dew: declare
- Sense : Decim := 0.00;
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- begin
- Moderate := Unsigned_8_Bit (Sense);
- Assert( Moderate = 0, "Sense => Moderate, 0");
-
- Sense := 2*128.0;
-
- Big := Unsigned_Over_8 (Sense);
- Assert( Big = 256, "Sense => Big, 256");
-
- end Eye_Dew;
-
- Rounding: declare
- Easy : Decim := Identity ( 2.0);
- Simple : Decim := Identity ( 2.1);
- Halfway : Decim := Identity ( 2.5);
- Upward : Decim := Identity ( 2.8);
- Chop : Decim := Identity (-2.2);
- Neg_Half : Decim := Identity (-2.5);
- Downward : Decim := Identity (-2.7);
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- Also_Little:Signed_8_Bit;
- Also_Big : Signed_Over_8;
-
- begin
- Little := Unsigned_Edge_8 (Easy);
- Assert( Little = 2, "Easy => Little, 2");
-
- Moderate := Unsigned_8_Bit (Simple);
- Assert( Moderate = 2, "Simple => Moderate, 2");
-
- Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33).
- Assert( Big = 3, "Halfway => Big, 3");
-
- Little := Unsigned_Edge_8 (Upward);
- Assert( Little = 3, "Upward => Little, 3");
-
- Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33).
- Assert( Also_Big = 3, "Halfway => Also_Big, 3");
-
- Also_Little := Signed_8_Bit (Chop);
- Assert( Also_Little = -2, "Chop => Also_Little, -2");
-
- Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33).
- Assert( Also_Big = -3, "Halfway => Also_Big, -3");
-
- Also_Little := Signed_8_Bit (Downward);
- Assert( Also_Little = -3, "Downward => Also_Little, -3");
-
- end Rounding;
-
-
- Report.Result;
-
-end C460011;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460012.a b/gcc/testsuite/ada/acats/tests/c4/c460012.a
deleted file mode 100644
index 0fb3206..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460012.a
+++ /dev/null
@@ -1,93 +0,0 @@
--- C460012.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 view created by a view conversion is constrained if the
--- target subtype is indefinite. (Defect Report 8652/0017, Technical
--- Corrigendum 4.6(54/1)).
---
--- CHANGE HISTORY:
--- 25 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking.
--- 02 JUL 2001 RLB Fixed discriminant reference.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C460012 is
-
- subtype Index is Positive range 1 .. 10;
-
- type Definite_Parent (D1 : Index := 6) is
- record
- F : String (1 .. D1) := (others => 'a');
- end record;
-
- type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2);
-
- Y : Definite_Parent;
-
- procedure P (X : in out Indefinite_Child) is
- C : Character renames X.F (3);
- begin
- X := (1, "a");
- if C /= 'a' then
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, value of C changed");
- elsif X.D2 /= 1 then
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, discriminant not " &
- "changed");
- -- This check primarily exists to prevent X from being optimized by
- -- 11.6 permissions, or the Failed call being made before the assignment.
- else
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, discriminant changed");
- end if;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Wrong exception " & Exception_Name (E) & " raised - " &
- Exception_Message (E));
- end P;
-
-begin
- Test ("C460012",
- "Check that the view created by a view conversion " &
- "is constrained if the target subtype is indefinite");
-
- P (Indefinite_Child (Y));
-
- if Y.D1 /= Ident_Int(6) then
- Failed ("Discriminant of indefinite view changed");
- -- This check exists mainly to prevent Y from being optimized away.
- end if;
-
- Result;
-end C460012;
-
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460013.a b/gcc/testsuite/ada/acats/tests/c4/c460013.a
deleted file mode 100644
index 7644f88..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460013.a
+++ /dev/null
@@ -1,188 +0,0 @@
--- C460013.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 target subtype excludes null, the value is not
--- null. Check access parameters, which null-excluding if:
--- (1) not null is given in their definition;
--- (2) the access parameter is controlling;
--- (3) an Ada 95 compiler is in use.
---
--- Note that the not null syntax is required even for Ada 95 compilers
--- (see AI95-00447).
---
--- CHANGE HISTORY:
--- 18 DEC 2006 RLB Initial version.
--- 05 JAN 2007 RLB Corrected syntax error.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C460013 is
-
-
- package Nest1 is
- type Doggie is tagged record
- Cnt : Natural;
- end record;
- type Doggie_Access is access all Doggie;
-
- procedure Controlled (P : access Doggie); -- Always null-excluding.
- end Nest1;
-
- package Nest2 is
- type Kitty is record
- Cnt : Natural;
- end record;
- type Kitty_Access is access all Kitty;
-
- procedure Include (P : access Kitty); -- Null-excluding only in Ada 95.
- procedure Exclude (P : not null access Kitty); -- Always null-excluding.
- end Nest2;
-
-
- package body Nest1 is
- procedure Controlled (P : access Doggie) is
- begin
- if P.Cnt /= Ident_Int(4) then
- Failed ("Bad value in null-excluding controlling parameter");
- -- else OK
- end if;
- exception
- when Constraint_Error => -- Dereference of null
- Failed ("Null allowed in null-excluding controlling parameter");
- end Controlled;
- end Nest1;
-
- package body Nest2 is
- procedure Include (P : access Kitty) is
- begin
- if P.Cnt /= Ident_Int(31) then
- Failed ("Bad value in access parameter");
- -- else OK
- end if;
- exception
- when Constraint_Error => -- Dereference of null
- null;
- --Comment ("Null allowed in access parameter - Ada 2005 semantics");
- end Include;
-
- procedure Exclude (P : not null access Kitty) is
- begin
- if P.Cnt /= Ident_Int(80) then
- Failed ("Bad value in explicit null-excluding parameter");
- -- else OK
- end if;
- exception
- when Constraint_Error => -- Dereference of null
- Failed ("Null allowed in explicit null-excluding parameter");
- end Exclude;
- end Nest2;
-
- Shep : aliased Nest1.Doggie := (Cnt => 4);
- Frisky : aliased Nest2.Kitty := (Cnt => 80);
- Snuggles : aliased Nest2.Kitty := (Cnt => 31);
-
-begin
- Test ("C460013",
- "Check that if the target subtype excludes null, the value is not" &
- " null - access parameter cases");
-
- declare
- Ptr : Nest1.Doggie_Access := Shep'Access;
- begin
- begin
- Nest1.Controlled (Ptr); -- OK.
- exception
- when A: others =>
- Failed ("Unexpected exception " & Exception_Name (A) &
- " raised (1A) - " & Exception_Message (A));
- end;
- Ptr := null;
- begin
- Nest1.Controlled (Ptr);
- Failed ("Null allowed for null-excluding controlling access parameter (1)");
- exception
- when Constraint_Error =>
- null;
- when B: others =>
- Failed ("Unexpected exception " & Exception_Name (B) &
- " raised (1B) - " & Exception_Message (B));
- end;
- end;
-
- declare
- Ptr : Nest2.Kitty_Access := Frisky'Access;
- begin
- begin
- Nest2.Exclude (Ptr); -- OK.
- exception
- when C: others =>
- Failed ("Unexpected exception " & Exception_Name (C) &
- " raised (2A) - " & Exception_Message (C));
- end;
- Ptr := null;
- begin
- Nest2.Exclude (Ptr);
- Failed ("Null allowed for null-excluding access parameter (2)");
- exception
- when Constraint_Error =>
- null;
- when D: others =>
- Failed ("Unexpected exception " & Exception_Name (D) &
- " raised (2B) - " & Exception_Message (D));
- end;
- end;
-
- declare
- Ptr : Nest2.Kitty_Access := Snuggles'Access;
- begin
- begin
- Nest2.Include (Ptr); -- OK.
- exception
- when E: others =>
- Failed ("Unexpected exception " & Exception_Name (E) &
- " raised (3A) - " & Exception_Message (E));
- end;
- Ptr := null;
- begin
- Nest2.Include (Ptr);
- Comment ("Null allowed for normal access parameter - " &
- "Ada 2005 semantics");
- exception
- when Constraint_Error =>
- Comment ("Null not allowed for normal access parameter - " &
- "Ada 95 semantics");
- when F: others =>
- Failed ("Unexpected exception " & Exception_Name (F) &
- " raised (3B) - " & Exception_Message (F));
- end;
- end;
-
- Result;
-end C460013;
-
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460014.a b/gcc/testsuite/ada/acats/tests/c4/c460014.a
deleted file mode 100644
index 59a95d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460014.a
+++ /dev/null
@@ -1,289 +0,0 @@
--- C460014.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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.
---
--- Notice
---
--- The ACAA has created and maintains the Ada Conformity Assessment Test
--- Suite for the purpose of conformity assessments conducted in accordance
--- with the International Standard ISO/IEC 18009 - Ada: Conformity
--- assessment of a language processor. This test suite should not be used
--- to make claims of conformance unless used in accordance with
--- ISO/IEC 18009 and any applicable ACAA procedures.
---*
--- OBJECTIVES:
--- Check that if the operand type of a type conversion is
--- access-to-class-wide, Constraint_Error is raised if the tag of the
--- object designated by the operand does not identify a specific type
--- that is covered by or descended from the target type.
---
--- TEST DESCRIPTION:
--- Attempt to convert a parameter of a type that designates a class-wide
--- type to an object of a type that designates a specific member of that
--- class, for both an actual with a different tag and an actual with a
--- matching tag.
---
--- This test checks 4.6(42) as required by 4.6(50).
---
--- CHANGE HISTORY:
--- 19 Aug 16 JAC Initial pre-release version.
--- 19 Jan 17 RLB Readied for release: replaced objective, renamed
--- to appropriate number, added class-wide cases,
--- eliminated 11.6 problems, added third level of
--- types, and checks on null.
---
---!
-package C460014_1 is
- type Root_Facade_Type is tagged record
- Error_Code : Integer;
- end record;
-
- type Root_Facade_Ptr_Type is access all Root_Facade_Type;
-
- type Facade_Class_Ptr_Type is access all Root_Facade_Type'Class;
-
- type Data_A_Type is
- record
- A : Boolean;
- end record;
-
- type Facade_A_Type is new Root_Facade_Type with
- record
- Data_A : Data_A_Type;
- end record;
-
- type Facade_A_Ptr_Type is access all Facade_A_Type;
-
- type Facade_A_Class_Ptr_Type is access all Facade_A_Type'Class;
-
- type Facade_B_Type is new Facade_A_Type with
- record
- B : Character;
- end record;
-
- type Facade_B_Ptr_Type is access all Facade_B_Type;
-
- type Facade_B_Class_Ptr_Type is access all Facade_B_Type'Class;
-
- procedure Define_Construct
- (Facade_Class_Ptr : in Facade_Class_Ptr_Type);
-
- procedure Define_Class_Construct
- (Facade_Class_Ptr : in Facade_Class_Ptr_Type);
-
- function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type;
-
- function Init_Facade_A_Ptr return Facade_A_Ptr_Type;
-
- function Init_Facade_B_Ptr return Facade_B_Ptr_Type;
-
- function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type;
-
- function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type;
-
- function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type;
-
-end C460014_1;
-
-with Report;
-package body C460014_1 is
-
- procedure Define_Construct
- (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is
-
- Facade_A_Ptr : constant Facade_A_Ptr_Type :=
- Facade_A_Ptr_Type (Facade_Class_Ptr);
-
- My_A : Data_A_Type renames Facade_A_Ptr.Data_A;
- begin
- if not My_A.A then
- Report.Comment ("Wrong value"); -- So My_A is not dead by 11.6(5).
- end if;
- end Define_Construct;
-
- procedure Define_Class_Construct
- (Facade_Class_Ptr : in Facade_Class_Ptr_Type) is
-
- Facade_Class_A_Ptr : constant Facade_A_Class_Ptr_Type :=
- Facade_A_Class_Ptr_Type (Facade_Class_Ptr);
-
- begin
- if Facade_Class_A_Ptr /= null and then
- (not Facade_Class_A_Ptr.Data_A.A) then
- Report.Comment ("Wrong value"); -- So the ptr is not dead by 11.6(5).
- end if;
- end Define_Class_Construct;
-
- Dummy_Root_Facade : aliased Root_Facade_Type := (Error_Code => 123);
-
- function Init_Root_Facade_Ptr return Root_Facade_Ptr_Type is
- begin
- return Dummy_Root_Facade'Access;
- end Init_Root_Facade_Ptr;
-
- Dummy_Facade_A : aliased Facade_A_Type := (Error_Code => 123,
- Data_A => (A => True));
-
- function Init_Facade_A_Ptr return Facade_A_Ptr_Type is
- begin
- return Dummy_Facade_A'Access;
- end Init_Facade_A_Ptr;
-
- Dummy_Facade_B : aliased Facade_B_Type := (Error_Code => 234,
- Data_A => (A => True),
- B => 'P');
-
- function Init_Facade_B_Ptr return Facade_B_Ptr_Type is
- begin
- return Dummy_Facade_B'Access;
- end Init_Facade_B_Ptr;
-
- function Init_Facade_Class_Ptr_with_Root return Facade_Class_Ptr_Type is
- begin
- return Dummy_Root_Facade'Access;
- end Init_Facade_Class_Ptr_with_Root;
-
- function Init_Facade_Class_Ptr_with_A return Facade_Class_Ptr_Type is
- begin
- return Dummy_Facade_A'Access;
- end Init_Facade_Class_Ptr_with_A;
-
- function Init_Facade_Class_Ptr_with_B return Facade_Class_Ptr_Type is
- begin
- return Dummy_Facade_B'Access;
- end Init_Facade_Class_Ptr_with_B;
-
-end C460014_1;
-
-
-with C460014_1;
-with Report;
-
-procedure C460014 is
-
- My_Root_Facade_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
- C460014_1.Init_Facade_Class_Ptr_with_Root;
-
- My_Facade_A_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
- C460014_1.Init_Facade_Class_Ptr_with_A;
-
- My_Facade_B_Ptr : constant C460014_1.Facade_Class_Ptr_Type :=
- C460014_1.Init_Facade_Class_Ptr_with_B;
-
- My_Null_Facade_B_Ptr : constant C460014_1.Facade_B_Ptr_Type := null;
-
- Constraint_Error_Raised : Boolean;
-
- procedure Test_Define_Construct
- (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
- begin
- Constraint_Error_Raised := False;
- -- Should fail Tag_Check and therefore raise Constraint_Error if
- -- parameter doesn't designate an object of Facade_A_Type
- -- or Facade_B_Type.
- C460014_1.Define_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
- exception
- when Constraint_Error =>
- Constraint_Error_Raised := True;
- end Test_Define_Construct;
-
-
- procedure Test_Define_Class_Construct
- (Facade_Class_Ptr : in C460014_1.Facade_Class_Ptr_Type) is
- begin
- Constraint_Error_Raised := False;
- -- Should fail Tag_Check and therefore raise Constraint_Error if
- -- parameter doesn't designate an object of Facade_A_Type
- -- or Facade_B_Type.
- C460014_1.Define_Class_Construct (Facade_Class_Ptr => Facade_Class_Ptr);
- exception
- when Constraint_Error =>
- Constraint_Error_Raised := True;
- end Test_Define_Class_Construct;
-
-begin
-
- Report.Test
- ("C460014",
- "Check that if the operand type of a type conversion is " &
- "access-to-class-wide, Constraint_Error is raised if the tag of the " &
- "object designated by the operand does not identify a specific type " &
- "that is covered by or descended from the target type");
-
- Test_Define_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);
-
- if not Constraint_Error_Raised then
- Report.Failed ("Didn't get expected Constraint_Error (1)");
- end if;
-
- Test_Define_Construct
- (Facade_Class_Ptr => My_Facade_A_Ptr);
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (2)");
- end if;
-
- Test_Define_Construct
- (Facade_Class_Ptr => My_Facade_B_Ptr);
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (3)");
- end if;
-
- Test_Define_Class_Construct (Facade_Class_Ptr => My_Root_Facade_Ptr);
-
- if not Constraint_Error_Raised then
- Report.Failed ("Didn't get expected Constraint_Error (4)");
- end if;
-
- Test_Define_Class_Construct
- (Facade_Class_Ptr => My_Facade_A_Ptr);
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (5)");
- end if;
-
- Test_Define_Class_Construct
- (Facade_Class_Ptr => My_Facade_B_Ptr);
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (6)");
- end if;
-
- -- Check that it is OK to pass null and that does not cause some failure.
- Test_Define_Class_Construct (Facade_Class_Ptr => null);
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (7)");
- end if;
-
- Test_Define_Class_Construct (Facade_Class_Ptr =>
- C460014_1.Facade_Class_Ptr_Type (My_Null_Facade_B_Ptr));
-
- if Constraint_Error_Raised then
- Report.Failed ("Unexpected Constraint_Error (8)");
- end if;
-
- Report.Result;
-
-end C460014;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46011a.ada b/gcc/testsuite/ada/acats/tests/c4/c46011a.ada
deleted file mode 100644
index 16a1df6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46011a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C46011A.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 INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE
--- TARGET AND OPERAND TYPES ARE BOTH INTEGER TYPES.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46011A IS
-
- TYPE INT1 IS RANGE -100 .. 100;
- I1 : INT1 := INT1'VAL (IDENT_INT (10));
- F1 : INT1 := INT1'VAL (IDENT_INT (-100));
- L1 : INT1 := INT1'VAL (IDENT_INT (100));
-
- TYPE INT2 IS RANGE -100 .. 100;
- I2 : INT2 := INT2'VAL (IDENT_INT (10));
- F2 : INT2 := INT2'VAL (IDENT_INT (-100));
- L2 : INT2 := INT2'VAL (IDENT_INT (100));
-
-
- TYPE NEWINTEGER IS NEW INTEGER;
- N1 : NEWINTEGER :=
- NEWINTEGER'VAL (IDENT_INT (10));
-
- T1 : INTEGER := IDENT_INT (10);
-
- U1 : CONSTANT := INTEGER'POS (10);
-BEGIN
- TEST ( "C46011A", "CHECK THAT INTEGER CONVERSIONS ARE " &
- "PERFORMED CORRECTLY WHEN THE TARGET AND " &
- "OPERAND TYPES ARE BOTH INTEGER TYPES" );
-
- IF INT1 (U1) /= U1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (U1)'" );
- END IF;
-
- IF INT1 (I1) /= I1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (I1)'" );
- END IF;
-
- IF INT1 (N1) /= I1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (N1)'" );
- END IF;
-
- IF INT1 (10) /= I1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (10)'" );
- END IF;
-
- IF INT1 (T1) /= I1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (T1)'" );
- END IF;
-
- IF INT1 (F2) /= F1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (F2)'" );
- END IF;
-
- IF INT1 (L2) /= L1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT1 (L2)'" );
- END IF;
-
- IF INT2 (I1) /= I2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT2 (I1)'" );
- END IF;
-
- IF INT2 (T1) /= 10 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT2 (T1)'" );
- END IF;
-
- IF INT2 (F1) /= -100 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT2 (F1)'" );
- END IF;
-
- IF INT2 (L1) /= 100 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INT2 (L1)'" );
- END IF;
-
- IF NEWINTEGER (I1) /= N1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (I1)'" );
- END IF;
-
- IF NEWINTEGER (N1) /= N1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (N1)'" );
- END IF;
-
- IF NEWINTEGER (T1) /= N1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (T1)'" );
- END IF;
-
- IF NEWINTEGER (INTEGER (N1)) /= N1 THEN
- FAILED ( "INCORRECT CONVERSION OF " &
- "'NEWINTEGER (INTEGER (N1))'" );
- END IF;
-
- IF NEWINTEGER (INTEGER (N1 + 1)) /= 11 THEN
- FAILED ( "INCORRECT CONVERSION OF " &
- "'NEWINTEGER (INTEGER (N1 + 1))'" );
- END IF;
-
- IF INTEGER (10) /= T1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INTEGER (10)'" );
- END IF;
-
- IF INTEGER (N1) /= 10 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INTEGER (N1)'" );
- END IF;
-
- IF INTEGER (I1) /= T1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1)'" );
- END IF;
-
- IF INTEGER (INT1 (NEWINTEGER (INT1 (I1)))) /= T1 THEN
- FAILED ( "INCORRECT CONVERSION OF " &
- "'INTEGER (INT1 (NEWINTEGER (INT1 (I1)))'" );
- END IF;
-
-
- IF INTEGER (I1 + 1) /= 11 THEN
- FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1 + 1)'" );
- END IF;
-
- RESULT;
-END C46011A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46013a.ada b/gcc/testsuite/ada/acats/tests/c4/c46013a.ada
deleted file mode 100644
index b9fa7d0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46013a.ada
+++ /dev/null
@@ -1,260 +0,0 @@
--- C46013A.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 INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE
--- OPERAND TYPE IS A FIXED POINT TYPE.
-
--- HISTORY:
--- JET 02/09/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C46013A IS
-
- TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#;
- TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#;
- TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#;
- TYPE FIX4 IS NEW FIX1;
-
- F1 : FIX1 := 7.75;
- F2 : FIX2 := -111.25;
- F3 : FIX3 := 0.875;
- F4 : FIX4 := -15.25;
-
- TYPE INT IS RANGE -512 .. 512;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- RETURN I * INT(IDENT_INT(1));
- END IDENT;
-
-BEGIN
- TEST ("C46013A", "CHECK THAT INTEGER CONVERSIONS ARE PERFORMED " &
- "CORRECTLY WHEN THE OPERAND TYPE IS A FIXED " &
- "POINT TYPE");
-
- IF INTEGER(FIX1'(-7.25)) /= IDENT_INT(-7) THEN
- FAILED ("INCORRECT VALUE (1)");
- END IF;
-
- IF INTEGER(FIX1'(6.75)) /= IDENT_INT(7) THEN
- FAILED ("INCORRECT VALUE (2)");
- END IF;
-
- IF INTEGER(F1) /= IDENT_INT(8) THEN
- FAILED ("INCORRECT VALUE (3)");
- END IF;
-
- IF INT(FIX1'(-7.25)) /= IDENT(-7) THEN
- FAILED ("INCORRECT VALUE (4)");
- END IF;
-
- IF INTEGER(FIX1'(3.33)) /= IDENT_INT(3) AND
- INTEGER(FIX1'(3.33)) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE (5)");
- END IF;
-
- IF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX1 HALF VALUES ROUND UP");
- ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX1 HALF VALUES ROUND DOWN");
- ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX1 HALF VALUES ROUND TO EVEN");
- ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX1 HALF VALUES ROUND TOWARD ZERO");
- ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX1 HALF VALUES ROUND AWAY FROM ZERO");
- ELSE
- COMMENT ("FIX1 HALF VALUES ROUND ERRATICALLY");
- END IF;
-
- IF INTEGER(FIX2'(-127.9375)) /= IDENT_INT(-128) THEN
- FAILED ("INCORRECT VALUE (6)");
- END IF;
-
- IF INTEGER(FIX2'(127.0625)) /= IDENT_INT(127) THEN
- FAILED ("INCORRECT VALUE (7)");
- END IF;
-
- IF INTEGER(F2) /= IDENT_INT(-111) THEN
- FAILED ("INCORRECT VALUE (8)");
- END IF;
-
- IF INT(FIX2'(-0.25)) /= IDENT(0) THEN
- FAILED ("INCORRECT VALUE (9)");
- END IF;
-
- IF INTEGER(FIX2'(66.67)) /= IDENT_INT(67) AND
- INTEGER(FIX2'(66.67)) /= IDENT_INT(66) THEN
- FAILED ("INCORRECT VALUE (10)");
- END IF;
-
- IF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX2 HALF VALUES ROUND UP");
- ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX2 HALF VALUES ROUND DOWN");
- ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX2 HALF VALUES ROUND TO EVEN");
- ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX2 HALF VALUES ROUND TOWARD ZERO");
- ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX2 HALF VALUES ROUND AWAY FROM ZERO");
- ELSE
- COMMENT ("FIX2 HALF VALUES ROUND ERRATICALLY");
- END IF;
-
- IF INTEGER(FIX3'(-0.25)) /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE (11)");
- END IF;
-
- IF INTEGER(FIX3'(511.75)) /= IDENT_INT(512) THEN
- FAILED ("INCORRECT VALUE (12)");
- END IF;
-
- IF INTEGER(F3) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE (13)");
- END IF;
-
- IF INT(FIX3'(-7.0)) /= IDENT(-7) THEN
- FAILED ("INCORRECT VALUE (14)");
- END IF;
-
- IF INTEGER(FIX3'(-66.67)) /= IDENT_INT(-67) AND
- INTEGER(FIX3'(-66.67)) /= IDENT_INT(-66) THEN
- FAILED ("INCORRECT VALUE (15)");
- END IF;
-
- IF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX3 HALF VALUES ROUND UP");
- ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX3 HALF VALUES ROUND DOWN");
- ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX3 HALF VALUES ROUND TO EVEN");
- ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX3 HALF VALUES ROUND TOWARD ZERO");
- ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX3 HALF VALUES ROUND AWAY FROM ZERO");
- ELSE
- COMMENT ("FIX3 HALF VALUES ROUND ERRATICALLY");
- END IF;
-
- IF INTEGER(FIX4'(-7.25)) /= IDENT_INT(-7) THEN
- FAILED ("INCORRECT VALUE (16)");
- END IF;
-
- IF INTEGER(FIX4'(6.75)) /= IDENT_INT(7) THEN
- FAILED ("INCORRECT VALUE (17)");
- END IF;
-
- IF INTEGER(F4) /= IDENT_INT(-15) THEN
- FAILED ("INCORRECT VALUE (18)");
- END IF;
-
- IF INT(FIX4'(-31.75)) /= IDENT(-32) THEN
- FAILED ("INCORRECT VALUE (19)");
- END IF;
-
- IF INTEGER(FIX4'(3.33)) /= IDENT_INT(3) AND
- INTEGER(FIX4'(3.33)) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE (20)");
- END IF;
-
- IF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX4 HALF VALUES ROUND UP");
- ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX4 HALF VALUES ROUND DOWN");
- ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX4 HALF VALUES ROUND TO EVEN");
- ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND
- INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND
- INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN
- COMMENT ("FIX4 HALF VALUES ROUND TOWARD ZERO");
- ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND
- INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND
- INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND
- INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN
- COMMENT ("FIX4 HALF VALUES ROUND AWAY FROM ZERO");
- ELSE
- COMMENT ("FIX4 HALF VALUES ROUND ERRATICALLY");
- END IF;
-
- RESULT;
-
-END C46013A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46014a.ada b/gcc/testsuite/ada/acats/tests/c4/c46014a.ada
deleted file mode 100644
index 9f47479..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46014a.ada
+++ /dev/null
@@ -1,287 +0,0 @@
--- C46014A.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:
--- FOR PREDEFINED TYPE INTEGER, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED IF THE OPERAND VALUE OF A
--- CONVERSION LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S BASE
--- TYPE. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE
--- OPERAND VALUE LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S
--- SUBTYPE BUT WITHIN THE RANGE OF THE BASE TYPE.
-
--- HISTORY:
--- RJW 09/08/86 CREATED ORIGINAL TEST.
--- RJW 11/13/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION.
--- JET 12/30/87 ADDED MORE CODE TO PREVENT OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
--- JRL 12/08/96 Changed usages of System.Max_Int and System.Min_Int to
--- Integer'Base'Last and Integer'Base'First in first two
--- subtests.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46014A IS
-
- SUBTYPE SMALL IS INTEGER RANGE -100 .. 100;
- S1 : SMALL;
-
- TYPE INT IS RANGE -100 .. 100;
- T1 : INT;
-
- TYPE NEWINTEGER IS NEW INTEGER;
- N1 : NEWINTEGER;
-
- SUBTYPE SUBNEW IS NEWINTEGER RANGE -100 .. 100;
- SN : SUBNEW;
-
- I1 : INTEGER;
- P1 : POSITIVE;
- L1 : NATURAL;
-
- FUNCTION IDENT (I : INTEGER) RETURN INT IS
- BEGIN
- RETURN INT'VAL (IDENT_INT (I));
- END IDENT;
-
- FUNCTION IDENT (I : NEWINTEGER) RETURN NEWINTEGER IS
- BEGIN
- RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (I)));
- END IDENT;
-
-BEGIN
- TEST ( "C46014A", "FOR PREDEFINED TYPE INTEGER, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED IF " &
- "THE OPERAND VALUE OF A CONVERSION LIES " &
- "OUTSIDE OF THE RANGE OF THE TARGET TYPE'S " &
- "BASE TYPE. ALSO, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED IF THE OPERAND " &
- "VALUE LIES OUTSIDE OF THE RANGE OF THE " &
- "TARGET TYPE'S SUBTYPE BUT WITHIN THE " &
- "RANGE OF THE BASE TYPE" );
-
- BEGIN
- I1 := Integer'Base'Last + Ident_Int(1);
- Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1");
- IF EQUAL (I1, I1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'LAST + 1");
- WHEN OTHERS =>
- Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1");
- END;
-
- BEGIN
- I1 := Integer'Base'First - Ident_Int(1);
- Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1");
- IF EQUAL (I1, I1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'FIRST - 1");
- WHEN OTHERS =>
- Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1");
- END;
-
- BEGIN
- I1 := INTEGER (IDENT_INT (INTEGER'FIRST) - 1);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "INTEGER (IDENT_INT (INTEGER'FIRST) - 1)" );
- IF EQUAL (I1, I1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED FOR " &
- "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" );
- END;
-
- BEGIN
- N1 := NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1)" );
- IF EQUAL (INTEGER (N1), INTEGER (N1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED FOR " &
- "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" );
- END;
-
- BEGIN
- T1 := INT (INT'BASE'FIRST - IDENT (1));
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "INT (INT'BASE'FIRST - IDENT (1))" );
- IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ( "CONSTRAINT_ERROR RAISED FOR " &
- "INT (INT'BASE'FIRST - IDENT (1))" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "INT (INT'BASE'FIRST - IDENT (1))" );
- END;
-
- BEGIN
- T1 := IDENT (-101);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "T1 := -101" );
- IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "T1 := -101" );
- END;
-
- BEGIN
- T1 := INTEGER'POS (IDENT_INT (101));
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "T1 := INTEGER'POS (IDENT_INT (101))" );
- IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "T1 := INTEGER'POS (IDENT_INT (101));" );
- END;
-
- BEGIN
- T1 := INT (IDENT (INTEGER (INT'FIRST)) - 1);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "INT (INT'FIRST - 1)" );
- IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "INT (INT'FIRST - 1)" );
- END;
-
- BEGIN
- T1 := INT (IDENT_INT (101));
- FAILED ( "NO EXCEPTION RAISED FOR INT (101)" );
- IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INT (101)" );
- END;
-
- BEGIN
- S1 := SMALL (IDENT_INT (101));
- FAILED ( "NO EXCEPTION RAISED FOR SMALL (101)" );
- IF EQUAL (S1, S1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR SMALL (101)" );
- END;
-
- BEGIN
- SN := SUBNEW (IDENT_INT (-101));
- FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (-101)" );
- IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (-101)" );
- END;
-
- BEGIN
- P1 := IDENT_INT (101);
- SN := SUBNEW (P1);
- FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (P1)" );
- IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (P1)" );
- END;
-
- BEGIN
- SN := IDENT (0);
- P1 := POSITIVE (SN);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "POSITIVE (SN)" );
- IF EQUAL (P1, P1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "POSITIVE (SN)" );
- END;
-
- BEGIN
- N1 := IDENT (-1);
- L1 := NATURAL (N1);
- FAILED ( "NO EXCEPTION RAISED FOR " &
- "NATURAL (N1)" );
- IF EQUAL (L1, L1) THEN
- COMMENT ("SHOULDN'T GET HERE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- "NATURAL (N1)" );
- END;
-
- RESULT;
-END C46014A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46021a.ada b/gcc/testsuite/ada/acats/tests/c4/c46021a.ada
deleted file mode 100644
index 198fc7c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46021a.ada
+++ /dev/null
@@ -1,210 +0,0 @@
--- C46021A.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 FLOATING POINT CONVERSIONS ARE PERFORMED CORRECTLY
--- WHEN THE OPERAND TYPE IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION.
-
--- HISTORY:
--- JET 02/12/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C46021A IS
-
- TYPE FLOAT5 IS DIGITS 5;
- TYPE INT IS RANGE -32768..32767;
-
- TYPE NFLOAT5 IS NEW FLOAT5;
-
- FUNCTION IDENT (A : FLOAT5) RETURN FLOAT5 IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN A;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- FUNCTION IDENT (A : NFLOAT5) RETURN NFLOAT5 IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN A;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
-BEGIN
- TEST ("C46021A", "CHECK THAT FLOATING POINT CONVERSIONS ARE " &
- "PERFORMED CORRECTLY WHEN THE OPERAND TYPE " &
- "IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION");
-
- IF FLOAT5(IDENT_INT(-7)) /= -7.0 THEN
- FAILED ("INCORRECT VALUE (1)");
- END IF;
-
- IF FLOAT5(IDENT_INT(3)) /= 3.0 THEN
- FAILED ("INCORRECT VALUE (2)");
- END IF;
-
- IF FLOAT5(IDENT_INT(-999)) /= -999.0 THEN
- FAILED ("INCORRECT VALUE (3)");
- END IF;
-
- IF FLOAT5(IDENT_INT(101)) /= 101.0 THEN
- FAILED ("INCORRECT VALUE (4)");
- END IF;
-
- IF FLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN
- FAILED ("INCORRECT VALUE (5)");
- END IF;
-
- IF FLOAT5(IDENT_INT(32767)) /= 32767.0 THEN
- FAILED ("INCORRECT VALUE (6)");
- END IF;
-
- IF FLOAT5(-7) /= IDENT(-7.0) THEN
- FAILED ("INCORRECT VALUE (7)");
- END IF;
-
- IF FLOAT5(3) /= IDENT(3.0) THEN
- FAILED ("INCORRECT VALUE (8)");
- END IF;
-
- IF FLOAT5(-999) /= IDENT(-999.0) THEN
- FAILED ("INCORRECT VALUE (9)");
- END IF;
-
- IF FLOAT5(101) /= IDENT(101.0) THEN
- FAILED ("INCORRECT VALUE (10)");
- END IF;
-
- IF FLOAT5(-32767) /= IDENT(-32767.0) THEN
- FAILED ("INCORRECT VALUE (11)");
- END IF;
-
- IF FLOAT5(32767) /= IDENT(32767.0) THEN
- FAILED ("INCORRECT VALUE (12)");
- END IF;
-
- IF FLOAT5(INT'(-7)) /= IDENT(-7.0) THEN
- FAILED ("INCORRECT VALUE (13)");
- END IF;
-
- IF FLOAT5(INT'(3)) /= IDENT(3.0) THEN
- FAILED ("INCORRECT VALUE (14)");
- END IF;
-
- IF FLOAT5(INT'(-999)) /= IDENT(-999.0) THEN
- FAILED ("INCORRECT VALUE (15)");
- END IF;
-
- IF FLOAT5(INT'(101)) /= IDENT(101.0) THEN
- FAILED ("INCORRECT VALUE (16)");
- END IF;
-
- IF FLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN
- FAILED ("INCORRECT VALUE (17)");
- END IF;
-
- IF FLOAT5(INT'(32767)) /= IDENT(32767.0) THEN
- FAILED ("INCORRECT VALUE (18)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(-7)) /= -7.0 THEN
- FAILED ("INCORRECT VALUE (19)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(3)) /= 3.0 THEN
- FAILED ("INCORRECT VALUE (20)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(-999)) /= -999.0 THEN
- FAILED ("INCORRECT VALUE (21)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(101)) /= 101.0 THEN
- FAILED ("INCORRECT VALUE (22)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN
- FAILED ("INCORRECT VALUE (23)");
- END IF;
-
- IF NFLOAT5(IDENT_INT(32767)) /= 32767.0 THEN
- FAILED ("INCORRECT VALUE (24)");
- END IF;
-
- IF NFLOAT5(-7) /= IDENT(-7.0) THEN
- FAILED ("INCORRECT VALUE (25)");
- END IF;
-
- IF NFLOAT5(3) /= IDENT(3.0) THEN
- FAILED ("INCORRECT VALUE (26)");
- END IF;
-
- IF NFLOAT5(-999) /= IDENT(-999.0) THEN
- FAILED ("INCORRECT VALUE (27)");
- END IF;
-
- IF NFLOAT5(101) /= IDENT(101.0) THEN
- FAILED ("INCORRECT VALUE (28)");
- END IF;
-
- IF NFLOAT5(-32767) /= IDENT(-32767.0) THEN
- FAILED ("INCORRECT VALUE (29)");
- END IF;
-
- IF NFLOAT5(32767) /= IDENT(32767.0) THEN
- FAILED ("INCORRECT VALUE (30)");
- END IF;
-
- IF NFLOAT5(INT'(-7)) /= IDENT(-7.0) THEN
- FAILED ("INCORRECT VALUE (31)");
- END IF;
-
- IF NFLOAT5(INT'(3)) /= IDENT(3.0) THEN
- FAILED ("INCORRECT VALUE (32)");
- END IF;
-
- IF NFLOAT5(INT'(-999)) /= IDENT(-999.0) THEN
- FAILED ("INCORRECT VALUE (33)");
- END IF;
-
- IF NFLOAT5(INT'(101)) /= IDENT(101.0) THEN
- FAILED ("INCORRECT VALUE (34)");
- END IF;
-
- IF NFLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN
- FAILED ("INCORRECT VALUE (35)");
- END IF;
-
- IF NFLOAT5(INT'(32767)) /= IDENT(32767.0) THEN
- FAILED ("INCORRECT VALUE (36)");
- END IF;
-
- RESULT;
-
-END C46021A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46024a.ada b/gcc/testsuite/ada/acats/tests/c4/c46024a.ada
deleted file mode 100644
index 6f0714f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46024a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C46024A.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 FLOATING POINT CONVERSIONS WHEN THE TARGET TYPE IS A
--- FIXED POINT TYPE, FOR DIGITS 5.
-
--- HISTORY:
--- JET 02/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C46024A IS
-
- TYPE FLOAT5 IS DIGITS 5;
- TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#;
- TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#;
- TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#;
-
- F5, F5A, F5B : FLOAT5;
-
- GENERIC
- TYPE F IS DELTA <>;
- FUNCTION IDENTG (A : F) RETURN F;
-
- FUNCTION IDENTG (A : F) RETURN F IS
- BEGIN
- RETURN A + F(IDENT_INT(0));
- END IDENTG;
-
- FUNCTION IDENT1 IS NEW IDENTG(FIX1);
- FUNCTION IDENT2 IS NEW IDENTG(FIX2);
- FUNCTION IDENT3 IS NEW IDENTG(FIX3);
-
-BEGIN
- TEST ("C46024A", "CHECK FLOATING POINT CONVERSIONS WHEN THE " &
- "TARGET TYPE IS A FIXED POINT TYPE, FOR " &
- "5-DIGIT PRECISION");
-
- IF FIX1(FLOAT5'(2#0.1000_0000_0000_0000_00#E-1)) /=
- IDENT1(2#0.01#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (1)");
- END IF;
-
- IF FIX1(FLOAT5'(-2#0.1111_1110_0000_0000_00#E5)) /=
- IDENT1(-2#1_1111.11#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (2)");
- END IF;
-
- IF FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) <
- IDENT1(-2#1010.10#) OR
- FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) >
- IDENT1(-2#1010.01#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (3)");
- END IF;
-
- IF FIX2(FLOAT5'(-2#0.1000_0000_0000_0000_00#E-3)) /=
- IDENT2(-2#0.0001#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (4)");
- END IF;
-
- IF FIX2(FLOAT5'(2#0.1111_1111_1110_0000_00#E7)) /=
- IDENT2(2#111_1111.1111#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (5)");
- END IF;
-
- F5 := 2#0.1010_1010_1010_1010_10#E5;
- IF FIX2(F5) < IDENT2(2#1_0101.0101#) OR
- FIX2(F5) > IDENT2(2#1_0101.0110#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (6)");
- END IF;
-
- IF FIX3(FLOAT5'(2#0.1000_0000_0000_0000_00#E-5)) /=
- IDENT3(2#0.000001#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (7)");
- END IF;
-
- IF FIX3(FLOAT5'(-2#0.1111_1111_1111_1110_00#E9)) /=
- IDENT3(-2#1_1111_1111.1111_11#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (8)");
- END IF;
-
- F5 := -2#0.1010_1010_1010_1010_10#E8;
- IF FIX3(F5) < IDENT3(-2#1010_1010.1010_11#) OR
- FIX3(F5) > IDENT3(-2#1010_1010.1010_10#) THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (9)");
- END IF;
-
- F5A := 2#0.1010_1010_1010_1010_10#E4;
- F5B := 2#0.1010_1010_1010_1010_10#E5;
-
- IF FIX1(F5A) = IDENT1(2#1010.11#) AND
- FIX1(-F5A) = IDENT1(-2#1010.11#) AND
- FIX1(F5B) = IDENT1(2#1_0101.01#) AND
- FIX1(-F5B) = IDENT1(-2#1_0101.01#) THEN
- COMMENT ("CONVERSION ROUNDS TO NEAREST");
- ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND
- FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN
- COMMENT ("CONVERSION ROUNDS TO LEAST FIXED-POINT VALUE");
- ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND
- FIX1(-F5A) = IDENT1(-2#1010.10#) THEN
- COMMENT ("CONVERSION ROUNDS TO GREATEST FIXED-POINT VALUE");
- ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND
- FIX1(-F5A) = IDENT1(-2#1010.10#) THEN
- COMMENT ("CONVERSION ROUNDS TOWARD ZERO");
- ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND
- FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN
- COMMENT ("CONVERSION ROUNDS AWAY FROM ZERO");
- ELSE
- COMMENT ("UNABLE TO DETERMINE CONVERSION PATTERN");
- END IF;
-
- RESULT;
-
-END C46024A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46031a.ada b/gcc/testsuite/ada/acats/tests/c4/c46031a.ada
deleted file mode 100644
index 589833c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46031a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- C46031A.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 CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE
--- IS AN INTEGER TYPE.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46031A IS
-
- TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#;
- TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#;
- TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#;
-
- TYPE NEW_INT IS NEW INTEGER RANGE -16#200# .. 16#200#;
-
- I : INTEGER;
- J : NEW_INT;
-
- FUNCTION IDENT_NEW (X : NEW_INT) RETURN NEW_INT IS
- BEGIN
- RETURN X * NEW_INT(IDENT_INT(1));
- END IDENT_NEW;
-
-BEGIN
- TEST ("C46031A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " &
- "THE OPERAND TYPE IS AN INTEGER TYPE");
-
- I := IDENT_INT(-16#1F#);
- IF FIX1(I) /= -16#1F.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (1)");
- END IF;
-
- J := IDENT_NEW(0);
- IF FIX1(J) /= 0.0 THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (2)");
- END IF;
-
- I := IDENT_INT(16#7F#);
- IF FIX2(I) /= 16#7F.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (3)");
- END IF;
-
- J := IDENT_NEW(16#1#);
- IF FIX2(J) /= 16#1.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (4)");
- END IF;
-
- I := IDENT_INT(-16#55#);
- IF FIX3(I) /= -16#55.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (5)");
- END IF;
-
- J := IDENT_NEW(-16#1#);
- IF FIX3(J) /= -16#1.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (6)");
- END IF;
-
- RESULT;
-
-END C46031A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46032a.ada b/gcc/testsuite/ada/acats/tests/c4/c46032a.ada
deleted file mode 100644
index a89e115..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46032a.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- C46032A.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 CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE
--- IS A FLOATING POINT TYPE OF 5 DIGITS PRECISION.
-
--- HISTORY:
--- JET 07/11/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46032A IS
-
- TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#;
- TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#;
- TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#;
-
- TYPE FLOAT5 IS DIGITS 5;
-
- F5 : FLOAT5;
-
- FUNCTION IDENT5 (X : FLOAT5) RETURN FLOAT5 IS
- BEGIN
- RETURN X * FLOAT5(IDENT_INT(1));
- END IDENT5;
-
-BEGIN
- TEST ("C46032A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " &
- "THE OPERAND TYPE IS A FLOATING POINT TYPE " &
- "OF 5 DIGITS PRECISION");
-
- F5 := IDENT5(2#0.1100_0000_0000_0000_00#E0);
- IF FIX1(F5) /= 16#0.C# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (1)");
- END IF;
-
- F5 := IDENT5(2#0.1111_1110_0000_0000_00#E5);
- IF FIX1(F5) /= 16#1F.C# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (2)");
- END IF;
-
- F5 := IDENT5(-2#0.1010_1010_1010_1010_10#E2);
- IF FIX1(F5) < -16#2.C# OR
- FIX1(F5) > -16#2.8# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (3)");
- END IF;
-
- F5 := IDENT5(2#0.1111_0000_0000_0000_00#E0);
- IF FIX2(F5) /= 16#0.F# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (4)");
- END IF;
-
- F5 := IDENT5(-2#0.1111_1110_0000_0000_00#E7);
- IF FIX2(F5) /= -16#7F.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (5)");
- END IF;
-
- F5 := IDENT5(2#0.1111_1111_1101_0000_00#E7);
- IF FIX2(F5) < 16#7F.E# OR
- FIX2(F5) > 16#7F.F# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (6)");
- END IF;
-
- F5 := IDENT5(2#0.1000_0000_0000_0000_00#E-5);
- IF FIX3(F5) /= 16#0.04# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (7)");
- END IF;
-
- F5 := -IDENT5(2#0.1010_1010_1010_1010_00#E9);
- IF FIX3(F5) /= -16#155.54# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (8)");
- END IF;
-
- F5 := IDENT5(2#0.1000_0000_0000_0010_11#E9);
- IF FIX3(F5) < 16#100.04# OR
- FIX3(F5) > 16#100.08# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (9)");
- END IF;
-
- RESULT;
-
-END C46032A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46033a.ada b/gcc/testsuite/ada/acats/tests/c4/c46033a.ada
deleted file mode 100644
index 7657854..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46033a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C46033A.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 CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE
--- IS ANOTHER FIXED POINT TYPE.
-
--- HISTORY:
--- JET 07/12/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46033A IS
-
- TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#;
- TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#;
- TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#;
-
- F1 : FIX1;
- F2 : FIX2;
- F3 : FIX3;
-
- GENERIC
- TYPE F IS DELTA <>;
- FUNCTION IDENT_G (X : F) RETURN F;
-
- FUNCTION IDENT_G (X : F) RETURN F IS
- BEGIN
- RETURN X + F(IDENT_INT(0));
- END IDENT_G;
-
- FUNCTION IDENT IS NEW IDENT_G(FIX1);
- FUNCTION IDENT IS NEW IDENT_G(FIX2);
- FUNCTION IDENT IS NEW IDENT_G(FIX3);
-
-BEGIN
- TEST ("C46033A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " &
- "THE OPERAND TYPE IS ANOTHER FIXED POINT TYPE");
-
- F1 := IDENT(-16#1F.C#);
- IF FIX1(F1) /= -16#1F.C# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (1)");
- END IF;
-
- F1 := IDENT(16#0.4#);
- IF FIX2(F1) /= 16#0.4# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (2)");
- END IF;
-
- F1 := IDENT(-16#10.4#);
- IF FIX3(F1) /= -16#10.4# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (3)");
- END IF;
-
- F2 := IDENT(16#3.3#);
- IF FIX1(F2) < 16#3.0# OR
- FIX1(F2) > 16#3.4# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (4)");
- END IF;
-
- F2 := IDENT(-16#40.1#);
- IF FIX2(F2) /= -16#40.1# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (5)");
- END IF;
-
- F2 := IDENT(16#0.0#);
- IF FIX3(F2) /= 16#0.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (6)");
- END IF;
-
- F3 := IDENT(-16#0.04#);
- IF FIX1(F3) < -16#0.4# OR
- FIX1(F3) > -16#0.0# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (7)");
- END IF;
-
- F3 := -IDENT(16#55.A8#);
- IF FIX2(F3) < -16#55.B# OR
- FIX2(F3) > -16#55.A# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (8)");
- END IF;
-
- F3 := IDENT(16#101.84#);
- IF FIX3(F3) /= 16#101.84# THEN
- FAILED ("INCORRECT RESULT FROM CONVERSION (9)");
- END IF;
-
- RESULT;
-
-END C46033A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46041a.ada b/gcc/testsuite/ada/acats/tests/c4/c46041a.ada
deleted file mode 100644
index a9fd5d7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46041a.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- C46041A.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 ARRAY CONVERSIONS WHEN THE TARGET TYPE IS AN UNCONSTRAINED
--- ARRAY TYPE AND THE OPERAND TYPE REQUIRES CONVERSION OF THE INDEX
--- BOUNDS.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46041A IS
-
- TYPE INT IS RANGE -100 .. 100;
- TYPE NEWINTEGER IS NEW INTEGER;
-
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
-
- TYPE NDAY1 IS NEW DAY RANGE SUN .. FRI;
- TYPE NDAY2 IS NEW DAY RANGE MON .. SAT;
-
- TYPE NNDAY1 IS NEW NDAY1;
-
- FUNCTION IDENT (X : INT) RETURN INT IS
- BEGIN
- RETURN INT'VAL (IDENT_INT (INT'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS
- BEGIN
- RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS
- BEGIN
- RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS
- BEGIN
- RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS
- BEGIN
- RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X)));
- END IDENT;
-
-BEGIN
- TEST ( "C46041A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " &
- "TYPE IS AN UNCONSTRAINED ARRAY TYPE AND " &
- "THE OPERAND TYPE REQUIRES CONVERSION OF " &
- "THE INDEX BOUNDS" );
-
- DECLARE
-
- TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>)
- OF INTEGER;
-
- TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER;
- A1 : ARR1 (IDENT (11) .. IDENT (20)) :=
- (IDENT (11) .. IDENT (20) => 0);
-
- TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>)
- OF INTEGER;
- A2 : ARR2 (IDENT (11) .. IDENT (20),
- IDENT (TUE) .. IDENT (THU)) :=
- (IDENT (11) .. IDENT (20) =>
- (IDENT (TUE) .. IDENT (THU) => 0));
-
- TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>)
- OF INTEGER;
- A3 : ARR3 (IDENT (11) .. IDENT (20),
- IDENT (TUE) .. IDENT (THU)) :=
- (IDENT (11) .. IDENT (20) =>
- (IDENT (TUE) .. IDENT (THU) => 0));
-
- PROCEDURE CHECK (A : UNARR1) IS
- BEGIN
- IF A'FIRST /= 11 OR A'LAST /= 20 THEN
- FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" );
- END IF;
- END CHECK;
-
- PROCEDURE CHECK (A : UNARR2; STR : STRING) IS
- BEGIN
- IF A'FIRST (1) /= 11 OR A'LAST /= 20 OR
- A'FIRST (2) /= TUE OR A'LAST (2) /= THU THEN
- FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" &
- STR & ")" );
- END IF;
- END CHECK;
-
- BEGIN
- BEGIN
- CHECK (UNARR1 (A1));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'UNARR1 (A1)'" );
- END;
-
- BEGIN
- CHECK (UNARR2 (A2), "2");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A2)'" );
- END;
-
- BEGIN
- CHECK (UNARR2 (A3), "3");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A3)'" );
- END;
-
- END;
-
- RESULT;
-END C46041A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46042a.ada b/gcc/testsuite/ada/acats/tests/c4/c46042a.ada
deleted file mode 100644
index 2099ca6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46042a.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C46042A.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 ARRAY CONVERSIONS WHEN THE TARGET TYPE IS A CONSTRAINED
--- ARRAY TYPE AND THE OPERAND TYPE HAS BOUNDS THAT DO NOT BELONG TO
--- THE BASE TYPE OF THE TARGET TYPE'S INDEX SUBTYPE.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46042A IS
-
- TYPE INT IS RANGE -100 .. 100;
-
- TYPE NEWINTEGER IS NEW INTEGER;
-
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
-
- TYPE NDAY1 IS NEW DAY RANGE MON .. FRI;
- TYPE NDAY2 IS NEW DAY RANGE MON .. FRI;
-
- TYPE NNDAY1 IS NEW NDAY1;
-
- FUNCTION IDENT (X : INT) RETURN INT IS
- BEGIN
- RETURN INT'VAL (IDENT_INT (INT'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS
- BEGIN
- RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS
- BEGIN
- RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS
- BEGIN
- RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X)));
- END IDENT;
-
- FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS
- BEGIN
- RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X)));
- END IDENT;
-
-BEGIN
- TEST ( "C46042A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " &
- "TYPE IS A CONSTRAINED ARRAY TYPE AND THE " &
- "OPERAND TYPE HAS BOUNDS THAT DO NOT " &
- "BELONG TO THE BASE TYPE OF THE TARGET " &
- "TYPE'S INDEX SUBTYPE" );
-
- DECLARE
-
- TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE CONARR1 IS UNARR1 (IDENT_INT (1) .. IDENT_INT (10));
-
- TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>)
- OF INTEGER;
- SUBTYPE CONARR2 IS UNARR2 (IDENT_INT (1) .. IDENT_INT (10),
- IDENT (MON) .. IDENT (TUE));
-
- TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER;
- A1 : ARR1 (IDENT (11) .. IDENT (20)) :=
- (IDENT (11) .. IDENT (20) => 0);
-
- TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>)
- OF INTEGER;
- A2 : ARR2 (IDENT (11) .. IDENT (20),
- IDENT (WED) .. IDENT (THU)) :=
- (IDENT (11) .. IDENT (20) =>
- (IDENT (WED) .. IDENT (THU) => 0));
-
- TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>)
- OF INTEGER;
- A3 : ARR3 (IDENT (11) .. IDENT (20),
- IDENT (WED) .. IDENT (THU)) :=
- (IDENT (11) .. IDENT (20) =>
- (IDENT (WED) .. IDENT (THU) => 0));
-
- PROCEDURE CHECK (A : UNARR1) IS
- BEGIN
- IF A'FIRST /= 1 OR A'LAST /= 10 THEN
- FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" );
- END IF;
- END CHECK;
-
- PROCEDURE CHECK (A : UNARR2; STR : STRING) IS
- BEGIN
- IF A'FIRST (1) /= 1 OR A'LAST /= 10 OR
- A'FIRST (2) /= MON OR A'LAST (2) /= TUE THEN
- FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" &
- STR & ")" );
- END IF;
- END CHECK;
-
- BEGIN
- BEGIN
- CHECK (CONARR1 (A1));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'CONARR1 (A1)'" );
- END;
-
- BEGIN
- CHECK (CONARR2 (A2), "2");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A2)'" );
- END;
-
- BEGIN
- CHECK (CONARR2 (A3), "3");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A3)'" );
- END;
-
- END;
-
- RESULT;
-END C46042A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46043b.ada b/gcc/testsuite/ada/acats/tests/c4/c46043b.ada
deleted file mode 100644
index ee973a6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46043b.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- C46043B.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 CONVERSION TO AN
--- UNCONSTRAINED ARRAY TYPE IF, FOR A NON-NULL DIMENSION OF THE
--- OPERAND TYPE, ONE BOUND DOES NOT BELONG TO THE CORRESPONDING INDEX
--- SUBTYPE OF THE TARGET TYPE.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46043B IS
-
- SUBTYPE SUBINT IS INTEGER RANGE IDENT_INT (0) .. IDENT_INT (9);
-
-BEGIN
- TEST ( "C46043B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "CONVERSION TO AN UNCONSTRAINED ARRAY TYPE " &
- "IF, FOR A NON-NULL DIMENSION OF THE OPERAND " &
- "TYPE, ONE BOUND DOES NOT BELONG TO THE " &
- "CORRESPONDING INDEX SUBTYPE OF THE TARGET " &
- "TYPE" );
-
- DECLARE
- TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10));
-
- TYPE ARR2 IS ARRAY (SUBINT RANGE <>) OF INTEGER;
-
- PROCEDURE CHECK (A : ARR2) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED WITH ONE DIMENSIONAL " &
- "ARRAYS" );
- END CHECK;
-
- BEGIN
- A1 := (A1'RANGE => 0);
- CHECK (ARR2 (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH ONE " &
- "DIMENSIONAL ARRAYS" );
- END;
-
- DECLARE
- TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
- A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
- IDENT_INT (1) .. IDENT_INT (1));
-
- TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
-
- PROCEDURE CHECK (A : ARR2) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED WITH TWO DIMENSIONAL " &
- "ARRAYS" );
- END CHECK;
-
- BEGIN
- A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
- CHECK (ARR2 (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH TWO " &
- "DIMENSIONAL ARRAYS" );
- END;
-
- DECLARE
- TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
- A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
- IDENT_INT (1) .. IDENT_INT (0));
-
- TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
-
- PROCEDURE CHECK (A : ARR2) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 1" );
- END CHECK;
-
- BEGIN
- A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
- CHECK (ARR2 (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "WITH NULL ARRAYS - 1" );
- END;
-
- DECLARE
- TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
- A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
- IDENT_INT (1) .. IDENT_INT (0));
-
- SUBTYPE NOINT IS INTEGER
- RANGE IDENT_INT (1) .. IDENT_INT (0);
-
- TYPE ARR2 IS ARRAY (SUBINT RANGE <>, NOINT RANGE <>) OF
- INTEGER;
-
- PROCEDURE CHECK (A : ARR2) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 2" );
- END CHECK;
-
- BEGIN
- A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
- CHECK (ARR2 (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED " &
- "WITH NULL ARRAYS - 2" );
- END;
-
- RESULT;
-END C46043B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46044b.ada b/gcc/testsuite/ada/acats/tests/c4/c46044b.ada
deleted file mode 100644
index 90ea0e4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46044b.ada
+++ /dev/null
@@ -1,235 +0,0 @@
--- C46044B.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 CONVERSION TO A
--- CONSTRAINED ARRAY TYPE IF THE TARGET TYPE IS NON-NULL AND
--- CORRESPONDING DIMENSIONS OF THE TARGET AND OPERAND DO NOT HAVE
--- THE SAME LENGTH. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF
--- THE TARGET TYPE IS NULL AND THE OPERAND TYPE IS NON-NULL.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46044B IS
-
- TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- SUBTYPE CARR1A IS ARR1 (IDENT_INT (1) .. IDENT_INT (6));
- C1A : CARR1A := (CARR1A'RANGE => 0);
-
- SUBTYPE CARR1B IS ARR1 (IDENT_INT (2) .. IDENT_INT (5));
- C1B : CARR1B := (CARR1B'RANGE => 0);
-
- SUBTYPE CARR1N IS ARR1 (IDENT_INT (1) .. IDENT_INT (0));
- C1N : CARR1N := (CARR1N'RANGE => 0);
-
- TYPE ARR2 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
-
- SUBTYPE CARR2A IS ARR2 (IDENT_INT (1) .. IDENT_INT (2),
- IDENT_INT (1) .. IDENT_INT (2));
- C2A : CARR2A := (CARR2A'RANGE (1) => (CARR2A'RANGE (2) => 0));
-
- SUBTYPE CARR2B IS ARR2 (IDENT_INT (0) .. IDENT_INT (2),
- IDENT_INT (0) .. IDENT_INT (2));
- C2B : CARR2B := (CARR2B'RANGE (1) => (CARR2B'RANGE (2) => 0));
-
- SUBTYPE CARR2N IS ARR2 (IDENT_INT (2) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (2));
- C2N : CARR2N := (CARR2N'RANGE (1) => (CARR2N'RANGE (2) => 0));
-
- PROCEDURE CHECK1 (A : ARR1; STR : STRING) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED - " & STR );
- END CHECK1;
-
- PROCEDURE CHECK2 (A : ARR2; STR : STRING) IS
- BEGIN
- FAILED ( "NO EXCEPTION RAISED - " & STR );
- END CHECK2;
-
-BEGIN
- TEST ( "C46044B", "CHECK THAT CONSTRAINT ERROR IS RAISED FOR " &
- "CONVERSION TO A CONSTRAINED ARRAY TYPE " &
- "IF THE TARGET TYPE IS NON-NULL AND " &
- "CORRESPONDING DIMENSIONS OF THE TARGET AND " &
- "OPERAND DO NOT HAVE THE SAME LENGTH. " &
- "ALSO, CHECK THAT CONSTRAINT_ERROR IS " &
- "RAISED IF THE TARGET TYPE IS NULL AND " &
- "THE OPERAND TYPE IS NON-NULL" );
-
- BEGIN -- (A).
- C1A := C1B;
- CHECK1 (C1A, "(A)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (A)" );
- END;
-
- BEGIN -- (B).
- CHECK1 (CARR1A (C1B), "(B)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (B)" );
- END;
-
- BEGIN -- (C).
- C1B := C1A;
- CHECK1 (C1B, "(C)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (C)" );
- END;
-
- BEGIN -- (D).
- CHECK1 (CARR1B (C1A), "(D)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (D)" );
- END;
-
- BEGIN -- (E).
- C1A := C1N;
- CHECK1 (C1A, "(E)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (E)" );
- END;
-
- BEGIN -- (F).
- CHECK1 (CARR1A (C1N), "(F)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (F)" );
- END;
-
- BEGIN -- (G).
- C2A := C2B;
- CHECK2 (C2A, "(G)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (G)" );
- END;
-
- BEGIN -- (H).
- CHECK2 (CARR2A (C2B), "(H)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (H)" );
- END;
-
- BEGIN -- (I).
- C2B := C2A;
- CHECK2 (C2B, "(I)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (I)" );
- END;
-
- BEGIN -- (J).
- CHECK2 (CARR2A (C2B), "(J)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (J)" );
- END;
-
- BEGIN -- (K).
- C2A := C2N;
- CHECK2 (C2A, "(K)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (K)" );
- END;
-
- BEGIN -- (L).
- CHECK2 (CARR2A (C2N), "(L)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (L)" );
- END;
-
- BEGIN -- (M).
- C1N := C1A;
- CHECK1 (C1N, "(M)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (M)" );
- END;
-
- BEGIN -- (N).
- CHECK1 (CARR1N (C1A), "(N)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (N)" );
- END;
-
- BEGIN -- (O).
- C2N := C2A;
- CHECK2 (C2N, "(O)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (O)" );
- END;
-
- BEGIN -- (P).
- CHECK2 (CARR2N (C2A), "(P)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED - (P)" );
- END;
-
- RESULT;
-END C46044B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051a.ada b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada
deleted file mode 100644
index 9468e8f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46051a.ada
+++ /dev/null
@@ -1,414 +0,0 @@
--- C46051A.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 ENUMERATION, RECORD, ACCESS, PRIVATE, AND TASK VALUES CAN
--- BE CONVERTED IF THE OPERAND AND TARGET TYPES ARE RELATED BY
--- DERIVATION.
-
--- R.WILLIAMS 9/8/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46051A IS
-
-BEGIN
- TEST ( "C46051A", "CHECK THAT ENUMERATION, RECORD, ACCESS, " &
- "PRIVATE, AND TASK VALUES CAN BE CONVERTED " &
- "IF THE OPERAND AND TARGET TYPES ARE " &
- "RELATED BY DERIVATION" );
-
- DECLARE
- TYPE ENUM IS (A, AB, ABC, ABCD);
- E : ENUM := ABC;
-
- TYPE ENUM1 IS NEW ENUM;
- E1 : ENUM1 := ENUM1'VAL (IDENT_INT (2));
-
- TYPE ENUM2 IS NEW ENUM;
- E2 : ENUM2 := ABC;
-
- TYPE NENUM1 IS NEW ENUM1;
- NE : NENUM1 := NENUM1'VAL (IDENT_INT (2));
- BEGIN
- IF ENUM (E) /= E THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" );
- END IF;
-
- IF ENUM (E1) /= E THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" );
- END IF;
-
- IF ENUM1 (E2) /= E1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" );
- END IF;
-
- IF ENUM2 (NE) /= E2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (NE)'" );
- END IF;
-
- IF NENUM1 (E) /= NE THEN
- FAILED ( "INCORRECT CONVERSION OF 'NENUM (E)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "ENUMERATION TYPES" );
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- NULL;
- END RECORD;
-
- R : REC;
-
- TYPE REC1 IS NEW REC;
- R1 : REC1;
-
- TYPE REC2 IS NEW REC;
- R2 : REC2;
-
- TYPE NREC1 IS NEW REC1;
- NR : NREC1;
- BEGIN
- IF REC (R) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" );
- END IF;
-
- IF REC (R1) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" );
- END IF;
-
- IF REC1 (R2) /= R1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" );
- END IF;
-
- IF REC2 (NR) /= R2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC2 (NR)'" );
- END IF;
-
- IF NREC1 (R) /= NR THEN
- FAILED ( "INCORRECT CONVERSION OF 'NREC (R)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "RECORD TYPES" );
- END;
-
- DECLARE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE CREC IS REC (3);
- R : CREC;
-
- TYPE CREC1 IS NEW REC (3);
- R1 : CREC1;
-
- TYPE CREC2 IS NEW REC (3);
- R2 : CREC2;
-
- TYPE NCREC1 IS NEW CREC1;
- NR : NCREC1;
- BEGIN
- IF CREC (R) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'CREC (R)'" );
- END IF;
-
- IF CREC (R1) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'CREC (R1)'" );
- END IF;
-
- IF CREC1 (R2) /= R1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CREC1 (R2)'" );
- END IF;
-
- IF CREC2 (NR) /= R2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CREC2 (NR)'" );
- END IF;
-
- IF NCREC1 (R) /= NR THEN
- FAILED ( "INCORRECT CONVERSION OF 'NCREC (R)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "RECORD TYPES WITH DISCRIMINANTS" );
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCREC IS ACCESS REC;
- AR : ACCREC;
-
- TYPE ACCREC1 IS NEW ACCREC;
- AR1 : ACCREC1;
-
- TYPE ACCREC2 IS NEW ACCREC;
- AR2 : ACCREC2;
-
- TYPE NACCREC1 IS NEW ACCREC1;
- NAR : NACCREC1;
-
- FUNCTION F (A : ACCREC) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (0);
- END F;
-
- FUNCTION F (A : ACCREC1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (1);
- END F;
-
- FUNCTION F (A : ACCREC2) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (2);
- END F;
-
- FUNCTION F (A : NACCREC1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (3);
- END F;
-
- BEGIN
- IF F (ACCREC (AR)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR)'" );
- END IF;
-
- IF F (ACCREC (AR1)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR1)'" );
- END IF;
-
- IF F (ACCREC1 (AR2)) /= 1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ACCREC1 (AR2)'" );
- END IF;
-
- IF F (ACCREC2 (NAR)) /= 2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'ACCREC2 (NAR)'" );
- END IF;
-
- IF F (NACCREC1 (AR)) /= 3 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NACCREC (AR)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "ACCESS TYPES" );
- END;
-
- DECLARE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCR IS ACCESS REC;
-
- SUBTYPE CACCR IS ACCR (3);
- AR : CACCR;
-
- TYPE CACCR1 IS NEW ACCR (3);
- AR1 : CACCR1;
-
- TYPE CACCR2 IS NEW ACCR (3);
- AR2 : CACCR2;
-
- TYPE NCACCR1 IS NEW CACCR1;
- NAR : NCACCR1;
-
- FUNCTION F (A : CACCR) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (0);
- END F;
-
- FUNCTION F (A : CACCR1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (1);
- END F;
-
- FUNCTION F (A : CACCR2) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (2);
- END F;
-
- FUNCTION F (A : NCACCR1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (3);
- END F;
-
- BEGIN
- IF F (CACCR (AR)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR)'" );
- END IF;
-
- IF F (CACCR (AR1)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR1)'" );
- END IF;
-
- IF F (CACCR1 (AR2)) /= 1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CACCR1 (AR2)'" );
- END IF;
-
- IF F (CACCR2 (NAR)) /= 2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'CACCR2 (NAR)'" );
- END IF;
-
- IF F (NCACCR1 (AR)) /= 3 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NCACCR (AR)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "CONSTRAINED ACCESS TYPES" );
- END;
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE PRIV IS PRIVATE;
- PRIVATE
- TYPE PRIV IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- USE PKG1;
-
- PACKAGE PKG2 IS
- R : PRIV;
-
- TYPE PRIV1 IS NEW PRIV;
- R1 : PRIV1;
-
- TYPE PRIV2 IS NEW PRIV;
- R2 : PRIV2;
- END PKG2;
-
- USE PKG2;
-
- PACKAGE PKG3 IS
- TYPE NPRIV1 IS NEW PRIV1;
- NR : NPRIV1;
- END PKG3;
-
- USE PKG3;
- BEGIN
- IF PRIV (R) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'PRIV (R)'" );
- END IF;
-
- IF PRIV (R1) /= R THEN
- FAILED ( "INCORRECT CONVERSION OF 'PRIV (R1)'" );
- END IF;
-
- IF PRIV1 (R2) /= R1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'PRIV1 (R2)'" );
- END IF;
-
- IF PRIV2 (NR) /= R2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'PRIV2 (NR)'" );
- END IF;
-
- IF NPRIV1 (R) /= NR THEN
- FAILED ( "INCORRECT CONVERSION OF 'NPRIV (R)'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "PRIVATE TYPES" );
- END;
-
- DECLARE
- TASK TYPE TK;
- T : TK;
-
- TYPE TK1 IS NEW TK;
- T1 : TK1;
-
- TYPE TK2 IS NEW TK;
- T2 : TK2;
-
- TYPE NTK1 IS NEW TK1;
- NT : NTK1;
-
- TASK BODY TK IS
- BEGIN
- NULL;
- END;
-
- FUNCTION F (T : TK) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (0);
- END F;
-
- FUNCTION F (T : TK1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (1);
- END F;
-
- FUNCTION F (T : TK2) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (2);
- END F;
-
- FUNCTION F (T : NTK1) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT (3);
- END F;
-
- BEGIN
- IF F (TK (T)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'TK (T))'" );
- END IF;
-
- IF F (TK (T1)) /= 0 THEN
- FAILED ( "INCORRECT CONVERSION OF 'TK (T1))'" );
- END IF;
-
- IF F (TK1 (T2)) /= 1 THEN
- FAILED ( "INCORRECT CONVERSION OF 'TK1 (T2))'" );
- END IF;
-
- IF F (TK2 (NT)) /= 2 THEN
- FAILED ( "INCORRECT CONVERSION OF 'TK2 (NT))'" );
- END IF;
-
- IF F (NTK1 (T)) /= 3 THEN
- FAILED ( "INCORRECT CONVERSION OF 'NTK (T))'" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "TASK TYPES" );
- END;
-
- RESULT;
-END C46051A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051b.ada b/gcc/testsuite/ada/acats/tests/c4/c46051b.ada
deleted file mode 100644
index 402992d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46051b.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C46051B.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 ENUMERATION VALUES CAN BE CONVERTED IF THE OPERAND
--- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND
--- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS.
-
--- HISTORY:
--- JET 07/13/88 CREATED ORIGINAL TEST.
--- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED
--- EXTENSION TO 'ADA'. CHANGED THE CODES IN SECOND
--- ENUMERATION REPRESENTATION CLAUSE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46051B IS
-
- TYPE ENUM IS (WE, LOVE, WRITING, TESTS);
-
- TYPE ENUM1 IS NEW ENUM;
- FOR ENUM1 USE
- (WE => -1, LOVE => 0, WRITING => 3, TESTS => 9);
-
- TYPE ENUM2 IS NEW ENUM;
- FOR ENUM2 USE
- (WE => 10, LOVE => 15, WRITING => 16, TESTS => 19);
-
- TYPE ENUM3 IS NEW ENUM1;
-
- E : ENUM := ENUM'VAL (IDENT_INT (0));
- E1 : ENUM1 := ENUM1'VAL (IDENT_INT (1));
- E2 : ENUM2 := ENUM2'VAL (IDENT_INT (2));
- E3 : ENUM3 := ENUM3'VAL (IDENT_INT (3));
-
-BEGIN
- TEST ( "C46051B", "CHECK THAT ENUMERATION VALUES CAN BE " &
- "CONVERTED IF THE OPERAND AND TARGET TYPES " &
- "ARE RELATED BY DERIVATION, EVEN IF THE " &
- "OPERAND AND TARGET TYPES HAVE DIFFERENT " &
- "REPRESENTATIONS");
-
- IF ENUM1 (E) /= WE THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E)'" );
- END IF;
-
- IF ENUM (E1) /= LOVE THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" );
- END IF;
-
- IF ENUM1 (E2) /= WRITING THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" );
- END IF;
-
- IF ENUM2 (E3) /= TESTS THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E3)'" );
- END IF;
-
- IF ENUM (E) /= WE THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" );
- END IF;
-
- IF ENUM2 (E1) /= LOVE THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E1)'" );
- END IF;
-
- IF ENUM3 (E2) /= WRITING THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM3 (E2)'" );
- END IF;
-
- IF ENUM (E3) /= TESTS THEN
- FAILED ( "INCORRECT CONVERSION OF 'ENUM (E3)'" );
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "ENUMERATION TYPES" );
- RESULT;
-END C46051B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051c.ada b/gcc/testsuite/ada/acats/tests/c4/c46051c.ada
deleted file mode 100644
index c5cfd8f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46051c.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C46051C.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 RECORD VALUES CAN BE CONVERTED IF THE OPERAND
--- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND
--- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS.
-
--- HISTORY:
--- JET 07/13/88 CREATED ORIGINAL TEST.
--- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED
--- EXTENSION TO 'ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-
-PROCEDURE C46051C IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE+SYSTEM.STORAGE_UNIT-1) / SYSTEM.STORAGE_UNIT;
-
- TYPE ARR IS ARRAY (1..2) OF INTEGER;
-
- TYPE REC IS RECORD
- F1 : INTEGER;
- F2 : INTEGER;
- F3 : INTEGER;
- END RECORD;
-
- TYPE REC1 IS NEW REC;
- FOR REC1 USE
- RECORD
- F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1;
- F2 AT 1*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1;
- F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1;
- END RECORD;
-
- TYPE REC2 IS NEW REC;
- FOR REC2 USE
- RECORD
- F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1;
- F2 AT 2*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1;
- F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1;
- END RECORD;
-
- TYPE REC3 IS NEW REC1;
-
- R : REC := (IDENT_INT (0), 1, 2);
- R1 : REC1 := (IDENT_INT (1), 2, 3);
- R2 : REC2 := (IDENT_INT (2), 3, 4);
- R3 : REC3 := (IDENT_INT (3), 4, 5);
-
-BEGIN
- TEST ( "C46051C", "CHECK THAT RECORD VALUES CAN BE " &
- "CONVERTED IF THE OPERAND AND TARGET TYPES " &
- "ARE RELATED BY DERIVATION, EVEN IF THE " &
- "OPERAND AND TARGET TYPES HAVE DIFFERENT " &
- "REPRESENTATIONS");
-
- IF REC1(R) /= (0,1,2) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC1 (R)'" );
- END IF;
-
- IF REC (R1) /= (1,2,3) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" );
- END IF;
-
- IF REC1 (R2) /= (2,3,4) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" );
- END IF;
-
- IF REC2 (R3) /= (3,4,5) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC2 (R3)'" );
- END IF;
-
- IF REC (R) /= (0,1,2) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" );
- END IF;
-
- IF REC2 (R1) /= (1,2,3) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC2 (R1)'" );
- END IF;
-
- IF REC3 (R2) /= (2,3,4) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC3 (R2)'" );
- END IF;
-
- IF REC (R3) /= (3,4,5) THEN
- FAILED ( "INCORRECT CONVERSION OF 'REC (R3)'" );
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " &
- "RECORD TYPES" );
- RESULT;
-END C46051C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46052a.ada b/gcc/testsuite/ada/acats/tests/c4/c46052a.ada
deleted file mode 100644
index 7e69844..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46052a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C46052A.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 CONVERSION TO AN
--- ENUMERATION TYPE IF THE VALUE OF THE OPERAND DOES NOT BELONG TO THE
--- RANGE OF ENUMERATION VALUES FOR THE TARGET SUBTYPE.
-
--- R.WILLIAMS 9/9/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46052A IS
-
- TYPE ENUM IS (A, AB, ABC, ABCD);
- E : ENUM := ENUM'VAL (IDENT_INT (0));
-
- FUNCTION IDENT (E : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (IDENT_INT (ENUM'POS (E)));
- END IDENT;
-
-BEGIN
- TEST ( "C46052A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "CONVERSION TO AN ENUMERATION TYPE IF THE " &
- "VALUE OF THE OPERAND DOES NOT BELONG TO " &
- "THE RANGE OF ENUMERATION VALUES FOR THE " &
- "TARGET SUBTYPE" );
-
- DECLARE
- SUBTYPE SENUM IS ENUM RANGE AB .. ABCD;
- BEGIN
- E := IDENT (SENUM (E));
- FAILED ( "NO EXCEPTION RAISED FOR 'SENUM (E)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'SENUM (E)'" );
- END;
-
- DECLARE
- SUBTYPE NOENUM IS ENUM RANGE ABCD .. AB;
- BEGIN
- E := IDENT (NOENUM (E));
- FAILED ( "NO EXCEPTION RAISED FOR 'NOENUM (E)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'NOENUM (E)'" );
- END;
-
- DECLARE
- SUBTYPE SCHAR IS CHARACTER RANGE 'C' .. 'R';
- A : CHARACTER := IDENT_CHAR ('A');
- BEGIN
- A := IDENT_CHAR (SCHAR (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'SCHAR (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'SCHAR (A)'" );
- END;
-
- DECLARE
- SUBTYPE FRANGE IS BOOLEAN RANGE FALSE .. FALSE;
- T : BOOLEAN := IDENT_BOOL (TRUE);
- BEGIN
- T := IDENT_BOOL (FRANGE (T));
- FAILED ( "NO EXCEPTION RAISED FOR 'FRANGE (T)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'FRANGE (T)'" );
- END;
-
- RESULT;
-END C46052A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46053a.ada b/gcc/testsuite/ada/acats/tests/c4/c46053a.ada
deleted file mode 100644
index 53c17c4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46053a.ada
+++ /dev/null
@@ -1,139 +0,0 @@
--- C46053A.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 CONVERSION TO A
--- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE SUBTYPE IF THE
--- DISCRIMINANTS OF THE TARGET SUBTYPE DO NOT EQUAL THOSE OF THE
--- OPERAND.
-
--- R.WILLIAMS 9/9/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46053A IS
-
-BEGIN
- TEST ( "C46053A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "CONVERSION TO A CONSTRAINED RECORD, " &
- "PRIVATE, OR LIMITED PRIVATE SUBTYPE IF " &
- "THE DISCRIMINANTS OF THE TARGET SUBTYPE DO " &
- "NOT EQUAL THOSE OF THE OPERAND" );
-
- DECLARE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE REC3 IS REC (IDENT_INT (3));
- R : REC (IDENT_INT (1));
-
- PROCEDURE PROC (R : REC) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (R.D);
- END PROC;
-
- BEGIN
- PROC (REC3 (R));
- FAILED ( "NO EXCEPTION RAISED FOR 'REC3 (R)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'REC3 (R)'" );
- END;
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE PRIV (D : INTEGER) IS PRIVATE;
- SUBTYPE PRIV3 IS PRIV (IDENT_INT (3));
- PRIVATE
- TYPE PRIV (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- USE PKG1;
-
- PACKAGE PKG2 IS
- P : PRIV (IDENT_INT (0));
- END PKG2;
-
- USE PKG2;
-
- PROCEDURE PROC (P : PRIV) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (P.D);
- END PROC;
-
- BEGIN
- PROC (PRIV3 (P));
- FAILED ( "NO EXCEPTION RAISED FOR 'PRIV3 (P)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'PRIV3 (P)'" );
- END;
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE LIM (D : INTEGER) IS LIMITED PRIVATE;
- SUBTYPE LIM3 IS LIM (IDENT_INT (3));
- PRIVATE
- TYPE LIM (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- USE PKG1;
-
- PACKAGE PKG2 IS
- L : LIM (IDENT_INT (0));
- I : INTEGER;
- END PKG2;
-
- USE PKG2;
-
- PROCEDURE PROC (L : LIM) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (L.D);
- END PROC;
-
- BEGIN
- PROC (LIM3 (L));
- FAILED ( "NO EXCEPTION RAISED FOR 'LIM3 (L)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'LIM3 (L)'" );
- END;
-
- RESULT;
-END C46053A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c46054a.ada b/gcc/testsuite/ada/acats/tests/c4/c46054a.ada
deleted file mode 100644
index f87cfa4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c46054a.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C46054A.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 CONVERSION TO AN
--- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE
--- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT
--- MATCH THOSE OF THE TARGET TYPE.
-
--- R.WILLIAMS 9/9/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C46054A IS
-
-BEGIN
- TEST ( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
- "CONVERSION TO AN ACCESS SUBTYPE IF THE " &
- "OPERAND VALUE IS NOT NULL AND THE " &
- "DISCRIMINANTS OR INDEX BOUNDS OF THE " &
- "DESIGNATED OBJECT DO NOT MATCH THOSE OF " &
- "THE TARGET TYPE" );
-
- DECLARE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACREC IS ACCESS REC;
- A : ACREC (IDENT_INT (0)) := NEW REC (IDENT_INT (0));
-
- SUBTYPE ACREC3 IS ACREC (IDENT_INT (3));
-
- PROCEDURE PROC (A : ACREC) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (A.D);
- END PROC;
-
- BEGIN
- PROC (ACREC3 (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" );
- END;
-
- DECLARE
- TYPE REC (D1, D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACREC IS ACCESS REC;
-
- A : ACREC (IDENT_INT (3), IDENT_INT (1)) :=
- NEW REC (IDENT_INT (3), IDENT_INT (1));
-
- SUBTYPE ACREC13 IS ACREC (IDENT_INT (1), IDENT_INT (3));
-
- PROCEDURE PROC (A : ACREC) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (A.D1);
- END PROC;
-
- BEGIN
- PROC (ACREC13 (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" );
- END;
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- TYPE ACARR IS ACCESS ARR;
- A : ACARR (IDENT_INT (0) .. IDENT_INT (1)) :=
- NEW ARR'(IDENT_INT (0) .. IDENT_INT (1) => 0);
-
- SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2));
-
- PROCEDURE PROC (A : ACARR) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (A'LAST);
- END PROC;
-
- BEGIN
- PROC (ACARR02 (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02 (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02 (A)'" );
- END;
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
-
- TYPE ACARR IS ACCESS ARR;
- A : ACARR (IDENT_INT (1) .. IDENT_INT (0),
- IDENT_INT (4) .. IDENT_INT (5)) :=
- NEW ARR'(IDENT_INT (1) .. IDENT_INT (0) =>
- (IDENT_INT (4) .. IDENT_INT (5) => 0));
-
- SUBTYPE NACARR IS ACARR (IDENT_INT (0) .. IDENT_INT (1),
- IDENT_INT (5) .. IDENT_INT (4));
-
- PROCEDURE PROC (A : NACARR) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (A'LAST (1));
- END PROC;
-
- BEGIN
- PROC (NACARR (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'NACARR (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" );
- END;
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE PRIV (D : INTEGER) IS PRIVATE;
- TYPE ACPRV IS ACCESS PRIV;
- SUBTYPE ACPRV3 IS ACPRV (IDENT_INT (3));
-
- PRIVATE
- TYPE PRIV (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- USE PKG1;
-
- PACKAGE PKG2 IS
- A : ACPRV (IDENT_INT (0)) := NEW PRIV (IDENT_INT (0));
- END PKG2;
-
- USE PKG2;
-
- PROCEDURE PROC (A : ACPRV) IS
- I : INTEGER;
- BEGIN
- I := IDENT_INT (A.D);
- END PROC;
-
- BEGIN
- PROC (ACPRV3 (A));
- FAILED ( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" );
- END;
-
- RESULT;
-END C46054A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a01.a b/gcc/testsuite/ada/acats/tests/c4/c460a01.a
deleted file mode 100644
index 2d58370..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460a01.a
+++ /dev/null
@@ -1,408 +0,0 @@
--- C460A01.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 target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level of
--- the operand type is deeper than that of the target type. Check for
--- cases where the type conversion occurs in an instance body, and
--- the operand type is passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type must
--- be at the same or a less deep nesting level than the target type -- the
--- operand type must "live" as long as the target type. Nesting levels
--- are the run-time nestings of masters: block statements; subprogram,
--- task, and entry bodies; and accept statements. Packages are invisible
--- to accessibility rules.
---
--- This test checks for cases where the operand is a subprogram formal
--- parameter.
---
--- The test declares three generic packages, each containing an access
--- type conversion in which the operand type is a formal type:
---
--- (1) One in which the target type is declared within the
--- specification, and the conversion occurs within a nested
--- function.
---
--- (2) One in which the target type is also a formal type, and
--- the conversion occurs within a nested function.
---
--- (3) One in which the target type is declared outside the
--- generic, and the conversion occurs within a nested
--- procedure.
---
--- The test verifies the following:
---
--- For (1), Program_Error is not raised when the nested function is
--- called. Since the actual corresponding to the formal operand type
--- must always have the same or a less deep level than the target
--- type declared within the instance, the access type conversion is
--- always safe.
---
--- For (2), Program_Error is raised when the nested function is
--- called if the operand type passed as an actual during instantiation
--- has an accessibility level deeper than that of the target type
--- passed as an actual, and that no exception is raised otherwise.
--- The exception is propagated to the innermost enclosing master.
---
--- For (3), Program_Error is raised when the nested procedure is
--- called if the operand type passed as an actual during instantiation
--- has an accessibility level deeper than that of the target type.
--- The exception is handled within the nested procedure.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F460A00.A
--- => C460A01.A
---
---
--- CHANGE HISTORY:
--- 09 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Added code to avoid dead variable optimization.
--- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342.
---!
-
-generic
- type Designated_Type is tagged private;
- type Operand_Type is access Designated_Type;
-package C460A01_0 is
- type Target_Type is access all Designated_Type;
- function Convert (P : Operand_Type) return Target_Type;
-end C460A01_0;
-
-
- --==================================================================--
-
-
-package body C460A01_0 is
- function Convert (P : Operand_Type) return Target_Type is
- begin
- return Target_Type(P); -- Never fails.
- end Convert;
-end C460A01_0;
-
-
- --==================================================================--
-
-
-generic
- type Designated_Type is tagged private;
- type Operand_Type is access all Designated_Type;
- type Target_Type is access all Designated_Type;
-package C460A01_1 is
- function Convert (P : Operand_Type) return Target_Type;
-end C460A01_1;
-
-
- --==================================================================--
-
-
-package body C460A01_1 is
- function Convert (P : Operand_Type) return Target_Type is
- begin
- return Target_Type(P);
- end Convert;
-end C460A01_1;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type (<>) is new F460A00.Tagged_Type with private;
- type Operand_Type is access Designated_Type;
-package C460A01_2 is
- procedure Proc (P : Operand_Type;
- Res : out F460A00.TC_Result_Kind);
-end C460A01_2;
-
-
- --==================================================================--
-
-with Report;
-package body C460A01_2 is
- procedure Proc (P : Operand_Type;
- Res : out F460A00.TC_Result_Kind) is
- Ptr : F460A00.AccTag_L0;
- begin
- Ptr := F460A00.AccTag_L0(P);
-
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A01_2 instance");
- end if;
-
- Res := F460A00.OK;
- exception
- when Program_Error => Res := F460A00.PE_Exception;
- when others => Res := F460A00.Others_Exception;
- end Proc;
-end C460A01_2;
-
-
- --==================================================================--
-
-
-with F460A00;
-with C460A01_0;
-with C460A01_1;
-with C460A01_2;
-
-with Report;
-procedure C460A01 is
-begin -- C460A01. -- [ Level = 1 ]
-
- Report.Test ("C460A01", "Run-time accessibility checks: instance " &
- "bodies. Operand type of access type conversion is " &
- "passed as actual to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Operand: AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A01_0 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2);
- Target : Pack_OK.Target_Type;
- begin
- -- The accessibility level of Pack_OK.Target_Type will always be at
- -- least as deep as the operand type passed as an actual. Thus,
- -- a call to Pack_OK.Convert does not propagate an exception:
-
- Target := Pack_OK.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #1");
- end if;
-
- Result := F460A00.OK; -- Expected result.
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #1: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception raised");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Operand : AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
-
- type AccTag_L3 is access all F460A00.Tagged_Type;
- Target : AccTag_L3;
-
- -- The instantiation of C460A01_1 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_1
- (Designated_Type => F460A00.Tagged_Type,
- Operand_Type => AccTag_L2,
- Target_Type => AccTag_L3);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_OK is 2. The accessibility level of the actual passed as
- -- the target type is 3. Therefore, the access type conversion in
- -- Pack_OK.Convert does not raise an exception when the subprogram is
- -- called. If an exception is (incorrectly) raised, it is propagated
- -- to the innermost enclosing master:
-
- Target := Pack_OK.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #2");
- end if;
-
- Result := F460A00.OK; -- Expected result.
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #2: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception raised");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Target : AccTag_L2;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
-
- type AccTag_L3 is access all F460A00.Tagged_Type;
- Operand : AccTag_L3 := new F460A00.Tagged_Type;
-
- -- The instantiation of C460A01_1 should NOT result in any
- -- exceptions.
-
- package Pack_PE is new C460A01_1
- (Designated_Type => F460A00.Tagged_Type,
- Operand_Type => AccTag_L3,
- Target_Type => AccTag_L2);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_PE is 3. The accessibility level of the actual passed as
- -- the target type is 2. Therefore, the access type conversion in
- -- Pack_PE.Convert raises Program_Error when the subprogram is
- -- called. The exception is propagated to the innermost enclosing
- -- master:
-
- Target := Pack_PE.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #3");
- end if;
-
- Result := F460A00.OK;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- -- Expected result.
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception raised");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
-
- TType : F460A00.Tagged_Type;
- Operand : F460A00.AccTagClass_L0
- := new F460A00.Tagged_Type'(TType);
-
- -- The instantiation of C460A01_2 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class,
- F460A00.AccTagClass_L0);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_OK is 0. The accessibility level of the target type
- -- (F460A00.AccTag_L0) is also 0. Therefore, the access type
- -- conversion in Pack_OK.Proc does not raise an exception when the
- -- subprogram is called. If an exception is (incorrectly) raised,
- -- it is handled within the subprogram:
-
- Pack_OK.Proc(Operand, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST5.
-
- declare -- [ Level = 3 ]
-
- type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type;
- Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type;
-
- -- The instantiation of C460A01_2 should NOT result in any
- -- exceptions.
-
- package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type,
- AccDerTag_L3);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_PE is 3. The accessibility level of the target type
- -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion
- -- in Pack_PE.Proc raises Program_Error when the subprogram is
- -- called. The exception is handled within the subprogram:
-
- Pack_PE.Proc(Operand, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #5: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception raised");
- end SUBTEST5;
-
- Report.Result;
-
-end C460A01;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a02.a b/gcc/testsuite/ada/acats/tests/c4/c460a02.a
deleted file mode 100644
index 1d79d3a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460a02.a
+++ /dev/null
@@ -1,413 +0,0 @@
--- C460A02.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 target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level of
--- the operand type is deeper than that of the target type. Check for
--- cases where the type conversion occurs in an instance body, and
--- the operand type is declared inside the instance or is the anonymous
--- access type of an access parameter or access discriminant.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type must
--- be at the same or a less deep nesting level than the target type -- the
--- operand type must "live" as long as the target type. Nesting levels
--- are the run-time nestings of masters: block statements; subprogram,
--- task, and entry bodies; and accept statements. Packages are invisible
--- to accessibility rules.
---
--- This test checks for cases where the operand is a component of a
--- generic formal object, a stand-alone object, and an access parameter.
---
--- The test declares three generic units, each containing an access
--- type conversion in which the target type is a formal type:
---
--- (1) A generic package in which the operand type is the anonymous
--- access type of an access discriminant, and the conversion
--- occurs within the declarative part of the body.
---
--- (2) A generic package in which the operand type is declared within
--- the specification, and the conversion occurs within the
--- sequence of statements of the body.
---
--- (3) A generic procedure in which the operand type is the anonymous
--- access type of an access parameter, and the conversion occurs
--- within the sequence of statements.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised when the package is instantiated
--- if the actual passed through the formal object has an accessibility
--- level deeper than that of the target type passed as an actual, and
--- that no exception is raised otherwise. The exception is propagated
--- to the innermost enclosing master.
---
--- For (2), Program_Error is raised when the package is instantiated
--- if the package is instantiated at a level deeper than that of the
--- target type passed as an actual, and that no exception is raised
--- otherwise. The exception is handled within the package body.
---
--- For (3), Program_Error is raised when the instance procedure is
--- called if the actual passed through the access parameter has an
--- accessibility level deeper than that of the target type passed as
--- an actual, and that no exception is raised otherwise. The exception
--- is handled within the instance procedure.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F460A00.A
--- => C460A02.A
---
---
--- CHANGE HISTORY:
--- 10 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Changed the target type formal to be
--- access-to-constant; Modified code to avoid dead
--- variable optimization.
---
---!
-
-with F460A00;
-generic
- type Target_Type is access all F460A00.Tagged_Type;
- FObj: in out F460A00.Composite_Type;
-package C460A02_0 is
- procedure Dummy; -- Needed to allow package body.
-end C460A02_0;
-
-
- --==================================================================--
-
-with Report;
-package body C460A02_0 is
- Ptr: Target_Type := Target_Type(FObj.D);
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-
-begin
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A02_0 instance");
- end if;
-
-end C460A02_0;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type is private;
- type Target_Type is access all Designated_Type;
- FObj : in out Target_Type;
- FRes : in out F460A00.TC_Result_Kind;
-package C460A02_1 is
- type Operand_Type is access Designated_Type;
- Ptr : Operand_Type := new Designated_Type;
-
- procedure Dummy; -- Needed to allow package body.
-end C460A02_1;
-
-
- --==================================================================--
-
-
-package body C460A02_1 is
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- FRes := F460A00.UN_Init;
- FObj := Target_Type(Ptr);
- FRes := F460A00.OK;
-exception
- when Program_Error => FRes := F460A00.PE_Exception;
- when others => FRes := F460A00.Others_Exception;
-end C460A02_1;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type is new F460A00.Tagged_Type with private;
- type Target_Type is access constant Designated_Type;
-procedure C460A02_2 (P : access Designated_Type'Class;
- Res : out F460A00.TC_Result_Kind);
-
-
- --==================================================================--
-
-
-with Report;
-procedure C460A02_2 (P : access Designated_Type'Class;
- Res : out F460A00.TC_Result_Kind) is
- Ptr : Target_Type;
-begin
- Res := F460A00.UN_Init;
- Ptr := Target_Type(P);
-
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A02_2 instance");
- end if;
- Res := F460A00.OK;
-exception
- when Program_Error => Res := F460A00.PE_Exception;
- when others => Res := F460A00.Others_Exception;
-end C460A02_2;
-
-
- --==================================================================--
-
-
-with F460A00;
-with C460A02_0;
-with C460A02_1;
-with C460A02_2;
-
-with Report;
-procedure C460A02 is
-begin -- C460A02. -- [ Level = 1 ]
-
- Report.Test ("C460A02", "Run-time accessibility checks: instance " &
- "bodies. Operand type of access type conversion is " &
- "declared inside instance or is anonymous");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type;
- Operand_L2 : F460A00.Composite_Type(PTag_L2);
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST1.
-
- begin -- [ Level = 3 ]
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual passed as the target type
- -- in Pack_OK is 2. The accessibility level of the composite actual
- -- (and thus, the level of the anonymous type of the access
- -- discriminant, which is the same as that of the containing
- -- object) is also 2. Therefore, the access type conversion in
- -- Pack_OK does not raise an exception upon instantiation:
-
- package Pack_OK is new C460A02_0
- (Target_Type => AccTag_L2, FObj => Operand_L2);
- begin
- Result := F460A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");
-
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- Operand_L3 : F460A00.Composite_Type(PTag_L2);
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual passed as the target type
- -- in Pack_PE is 2. The accessibility level of the composite actual
- -- (and thus, the level of the anonymous type of the access
- -- discriminant, which is the same as that of the containing
- -- object) is 3. Therefore, the access type conversion in Pack_PE
- -- propagates Program_Error upon instantiation:
-
- package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3);
- begin
- Result := F460A00.OK;
- end;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- -- Expected result.
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2");
-
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- type AccArr_L3 is access all F460A00.Array_Type;
- Target: AccArr_L3;
-
- -- The accessibility level of the actual passed as the target type
- -- in Pack_OK is 3. The accessibility level of the operand type is
- -- that of the instance, which is also 3. Therefore, the access type
- -- conversion in Pack_OK does not raise an exception upon
- -- instantiation. If an exception is (incorrectly) raised, it is
- -- handled within the instance:
-
- package Pack_OK is new C460A02_1
- (Designated_Type => F460A00.Array_Type,
- Target_Type => AccArr_L3,
- FObj => Target,
- FRes => Result);
- begin
- null;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception propagated");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
- Target: F460A00.AccArr_L0;
-
- -- The accessibility level of the actual passed as the target type
- -- in Pack_PE is 0. The accessibility level of the operand type is
- -- that of the instance, which is 3. Therefore, the access type
- -- conversion in Pack_PE raises Program_Error upon instantiation.
- -- The exception is handled within the instance:
-
- package Pack_PE is new C460A02_1
- (Designated_Type => F460A00.Array_Type,
- Target_Type => F460A00.AccArr_L0,
- FObj => Target,
- FRes => Result);
- begin
- null;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST5.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A02_2 should NOT result in any
- -- exceptions.
-
- procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
- F460A00.AccTag_L0);
- begin
- -- The accessibility level of the actual passed to Proc is 0. The
- -- accessibility level of the actual passed as the target type is
- -- also 0. Therefore, the access type conversion in Proc does not
- -- raise an exception when the subprogram is called. If an exception
- -- is (incorrectly) raised, it is handled within the subprogram:
-
- Proc (F460A00.PTagClass_L0, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #5: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception raised");
- end SUBTEST5;
-
-
-
- SUBTEST6:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST6.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A02_2 should NOT result in any
- -- exceptions.
-
- procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
- F460A00.AccTag_L0);
- begin
- -- In the call to (instantiated) procedure Proc, the first actual
- -- parameter is an allocator. Its accessibility level is that of
- -- the level of execution of Proc, which is 3. The accessibility
- -- level of the actual passed as the target type is 0. Therefore,
- -- the access type conversion in Proc raises Program_Error when the
- -- subprogram is called. The exception is handled within the
- -- subprogram:
-
- Proc (new F460A00.Tagged_Type, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #6: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #6: Unexpected exception raised");
- end SUBTEST6;
-
- Report.Result;
-
-end C460A02;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002a.ada b/gcc/testsuite/ada/acats/tests/c4/c47002a.ada
deleted file mode 100644
index e86498d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47002a.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C47002A.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 VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
--- THE OPERANDS OF QUALIFIED EXPRESSIONS.
--- THIS TEST IS FOR DISCRETE TYPES.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47002A IS
-
-BEGIN
-
- TEST( "C47002A", "CHECK THAT VALUES HAVING DISCRETE TYPES " &
- "CAN BE WRITTEN AS THE OPERANDS OF " &
- "QUALIFIED EXPRESSIONS" );
-
- DECLARE -- ENUMERATION TYPES.
-
- TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- TYPE WEEKEND IS (SAT, SUN);
-
- TYPE CHAR IS ('B', 'A');
-
- TYPE MYBOOL IS (TRUE, FALSE);
-
- TYPE NBOOL IS NEW BOOLEAN;
-
- BEGIN
- IF WEEKEND'(SAT) >= SUN THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE WEEKEND" );
- END IF;
-
- IF CHAR'('B') >= 'A' THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE CHAR" );
- END IF;
-
- IF MYBOOL'(TRUE) >= FALSE THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE MYBOOL" );
- END IF;
-
- IF NBOOL'(TRUE) <= FALSE THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE NBOOL" );
- END IF;
- END;
-
- DECLARE -- INTEGER TYPES.
-
- TYPE RESULTS IS (INT1, INT2, INT3);
-
- TYPE NEWINT IS NEW INTEGER;
-
- TYPE INT IS RANGE -10 .. 10;
-
- FUNCTION F (I : NEWINT) RETURN RESULTS IS
- BEGIN
- RETURN INT1;
- END F;
-
- FUNCTION F (I : INT) RETURN RESULTS IS
- BEGIN
- RETURN INT2;
- END F;
-
- FUNCTION F (I : INTEGER) RETURN RESULTS IS
- BEGIN
- RETURN INT3;
- END F;
-
- BEGIN
- IF F (NEWINT'(5)) /= INT1 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE NEWINT" );
- END IF;
-
- IF F (INT'(5)) /= INT2 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE INT" );
- END IF;
-
- IF F (INTEGER'(5)) /= INT3 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE INTEGER" );
- END IF;
- END;
-
- RESULT;
-END C47002A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002b.ada b/gcc/testsuite/ada/acats/tests/c4/c47002b.ada
deleted file mode 100644
index ffa7b96..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47002b.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- C47002B.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 VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
--- THE OPERANDS OF QUALIFIED EXPRESSIONS.
--- THIS TEST IS FOR REAL TYPES.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47002B IS
-
-BEGIN
-
- TEST( "C47002B", "CHECK THAT VALUES HAVING REAL TYPES " &
- "CAN BE WRITTEN AS THE OPERANDS OF " &
- "QUALIFIED EXPRESSIONS" );
-
- DECLARE -- FLOATING POINT TYPES.
-
- TYPE RESULTS IS (FL1, FL2, FL3);
-
- TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
-
- TYPE NFLT IS NEW FLOAT;
-
- FUNCTION F (FL : FLT) RETURN RESULTS IS
- BEGIN
- RETURN FL1;
- END F;
-
- FUNCTION F (FL : NFLT) RETURN RESULTS IS
- BEGIN
- RETURN FL2;
- END F;
-
- FUNCTION F (FL : FLOAT) RETURN RESULTS IS
- BEGIN
- RETURN FL3;
- END F;
-
- BEGIN
- IF F (FLT'(0.0)) /= FL1 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE FLT" );
- END IF;
-
- IF F (NFLT'(0.0)) /= FL2 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE NFLT" );
- END IF;
-
- IF F (FLOAT'(0.0)) /= FL3 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE FLOAT" );
- END IF;
- END;
-
- DECLARE -- FIXED POINT TYPES.
-
- TYPE RESULTS IS (FI1, FI2, FI3);
-
- TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0;
-
- TYPE NFIX IS NEW FIXED;
-
- FUNCTION F (FI : FIXED) RETURN RESULTS IS
- BEGIN
- RETURN FI1;
- END F;
-
- FUNCTION F (FI : NFIX) RETURN RESULTS IS
- BEGIN
- RETURN FI2;
- END F;
-
- FUNCTION F (FI : DURATION) RETURN RESULTS IS
- BEGIN
- RETURN FI3;
- END F;
-
- BEGIN
- IF F (FIXED'(0.0)) /= FI1 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE FIXED" );
- END IF;
-
- IF F (NFIX'(0.0)) /= FI2 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE NFIX" );
- END IF;
-
- IF F (DURATION'(0.0)) /= FI3 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE DURATION" );
- END IF;
- END;
-
- RESULT;
-END C47002B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002c.ada b/gcc/testsuite/ada/acats/tests/c4/c47002c.ada
deleted file mode 100644
index b9327e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47002c.ada
+++ /dev/null
@@ -1,212 +0,0 @@
--- C47002C.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 VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
--- THE OPERANDS OF QUALIFIED EXPRESSIONS.
--- THIS TEST IS FOR ARRAY, RECORD, AND ACCESS TYPES.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47002C IS
-
-BEGIN
-
- TEST( "C47002C", "CHECK THAT VALUES HAVING ARRAY, RECORD, AND " &
- "ACCESS TYPES CAN BE WRITTEN AS THE OPERANDS " &
- "OF QUALIFIED EXPRESSIONS" );
-
- DECLARE -- ARRAY TYPES.
-
- TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- SUBTYPE ARR1 IS ARR (1 .. 1);
- SUBTYPE ARR5 IS ARR (1 .. 5);
-
- TYPE NARR IS NEW ARR;
- SUBTYPE NARR2 IS NARR (2 .. 2);
-
- TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
- OF INTEGER;
- SUBTYPE TARR15 IS TARR (1 .. 1, 1 .. 5);
- SUBTYPE TARR51 IS TARR (1 .. 5, 1 .. 1);
-
- TYPE NTARR IS NEW TARR;
- SUBTYPE NTARR26 IS NTARR (2 .. 6, 2 .. 6);
-
- FUNCTION F (X : ARR) RETURN ARR IS
- BEGIN
- RETURN X;
- END;
-
- FUNCTION F (X : NARR) RETURN NARR IS
- BEGIN
- RETURN X;
- END;
-
- FUNCTION F (X : TARR) RETURN TARR IS
- BEGIN
- RETURN X;
- END;
-
- FUNCTION F (X : NTARR) RETURN NTARR IS
- BEGIN
- RETURN X;
- END;
-
- BEGIN
- IF F (ARR1'(OTHERS => 0))'LAST /= 1 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR1" );
- END IF;
-
- IF F (ARR5'(OTHERS => 0))'LAST /= 5 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR5" );
- END IF;
-
- IF F (NARR2'(OTHERS => 0))'FIRST /= 2 OR
- F (NARR2'(OTHERS => 0))'LAST /= 2 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE NARR2" );
- END IF;
-
- IF F (TARR15'(OTHERS => (OTHERS => 0)))'LAST /= 1 OR
- F (TARR15'(OTHERS => (OTHERS => 0)))'LAST (2) /= 5 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR15" );
- END IF;
-
- IF F (TARR51'(OTHERS => (OTHERS => 0)))'LAST /= 5 OR
- F (TARR51'(OTHERS => (OTHERS => 0)))'LAST (2) /= 1 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR51" );
- END IF;
-
- IF F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST /= 2 OR
- F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST /= 6 OR
- F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST (2) /= 2 OR
- F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST (2) /= 6 THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE NTARR26" );
- END IF;
-
- END;
-
- DECLARE -- RECORD TYPES.
-
- TYPE GENDER IS (MALE, FEMALE, NEUTER);
-
- TYPE MAN IS
- RECORD
- AGE : POSITIVE;
- END RECORD;
-
- TYPE WOMAN IS
- RECORD
- AGE : POSITIVE;
- END RECORD;
-
- TYPE ANDROID IS NEW MAN;
-
- FUNCTION F (X: WOMAN) RETURN GENDER IS
- BEGIN
- RETURN FEMALE;
- END F;
-
- FUNCTION F (X: MAN) RETURN GENDER IS
- BEGIN
- RETURN MALE;
- END F;
-
- FUNCTION F (X : ANDROID) RETURN GENDER IS
- BEGIN
- RETURN NEUTER;
- END F;
-
- BEGIN
- IF F (MAN'(AGE => 23)) /= MALE THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE MAN" );
- END IF;
-
- IF F (WOMAN'(AGE => 38)) /= FEMALE THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE WOMAN" );
- END IF;
-
- IF F (ANDROID'(AGE => 2001)) /= NEUTER THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE ANDRIOD" );
- END IF;
- END;
-
- DECLARE -- ACCESS TYPES.
-
- TYPE CODE IS (OLD, BRANDNEW, WRECK);
-
- TYPE CAR (D : CODE) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE KEY IS ACCESS CAR;
-
- TYPE KEY_OLD IS ACCESS CAR (OLD);
- KO : KEY_OLD := NEW CAR'(D => OLD);
-
- TYPE KEY_WRECK IS ACCESS CAR (WRECK);
-
- TYPE KEY_CARD IS NEW KEY;
- KC : KEY_CARD := NEW CAR'(D => BRANDNEW);
-
- FUNCTION F (X : KEY_OLD) RETURN CODE IS
- BEGIN
- RETURN OLD;
- END F;
-
- FUNCTION F (X : KEY_WRECK) RETURN CODE IS
- BEGIN
- RETURN WRECK;
- END F;
-
- FUNCTION F (X : KEY_CARD) RETURN CODE IS
- BEGIN
- RETURN BRANDNEW;
- END F;
- BEGIN
- IF KEY_OLD'(KO) /= KO THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE KEY_OLD - 1" );
- END IF;
-
- IF KEY_CARD'(KC) /= KC THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 1" );
- END IF;
-
-
- IF F (KEY_OLD'(NULL)) /= OLD THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_OLD - 2" );
- END IF;
-
- IF F (KEY_WRECK'(NULL)) /= WRECK THEN
- FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_WRECK" );
- END IF;
-
- IF F (KEY_CARD'(NULL)) /= BRANDNEW THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 2" );
- END IF;
- END;
-
- RESULT;
-END C47002C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002d.ada b/gcc/testsuite/ada/acats/tests/c4/c47002d.ada
deleted file mode 100644
index 472c200..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47002d.ada
+++ /dev/null
@@ -1,273 +0,0 @@
--- C47002D.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 VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS
--- THE OPERANDS OF QUALIFIED EXPRESSIONS.
--- THIS TEST IS FOR PRIVATE AND LIMITED PRIVATE TYPES.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47002D IS
-
-BEGIN
-
- TEST( "C47002D", "CHECK THAT VALUES HAVING PRIVATE AND LIMITED " &
- "PRIVATE TYPES CAN BE WRITTEN AS THE OPERANDS " &
- "OF QUALIFIED EXPRESSIONS" );
-
- DECLARE -- PRIVATE TYPES.
-
- TYPE RESULTS IS (P1, P2, P3, P4, P5);
-
- PACKAGE PKG1 IS
- TYPE PINT IS PRIVATE;
- TYPE PCHAR IS PRIVATE;
- TYPE PARR IS PRIVATE;
- TYPE PREC (D : INTEGER) IS PRIVATE;
- TYPE PACC IS PRIVATE;
-
- FUNCTION F RETURN PINT;
- FUNCTION F RETURN PCHAR;
- FUNCTION F RETURN PARR;
- FUNCTION F RETURN PREC;
- FUNCTION F RETURN PACC;
-
- PRIVATE
- TYPE PINT IS NEW INTEGER;
- TYPE PCHAR IS NEW CHARACTER;
- TYPE PARR IS ARRAY (1 .. 2) OF NATURAL;
-
- TYPE PREC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE PACC IS ACCESS PREC;
-
- END PKG1;
-
- PACKAGE BODY PKG1 IS
- FUNCTION F RETURN PINT IS
- BEGIN
- RETURN 1;
- END F;
-
- FUNCTION F RETURN PCHAR IS
- BEGIN
- RETURN 'B';
- END F;
-
- FUNCTION F RETURN PARR IS
- BEGIN
- RETURN PARR'(OTHERS => 3);
- END F;
-
- FUNCTION F RETURN PREC IS
- BEGIN
- RETURN PREC'(D => 4);
- END F;
-
- FUNCTION F RETURN PACC IS
- BEGIN
- RETURN NEW PREC'(F);
- END F;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- FUNCTION CHECK (P : PINT) RETURN RESULTS IS
- BEGIN
- RETURN P1;
- END CHECK;
-
- FUNCTION CHECK (P : PCHAR) RETURN RESULTS IS
- BEGIN
- RETURN P2;
- END CHECK;
-
- FUNCTION CHECK (P : PARR) RETURN RESULTS IS
- BEGIN
- RETURN P3;
- END CHECK;
-
- FUNCTION CHECK (P : PREC) RETURN RESULTS IS
- BEGIN
- RETURN P4;
- END CHECK;
-
- FUNCTION CHECK (P : PACC) RETURN RESULTS IS
- BEGIN
- RETURN P5;
- END CHECK;
-
- BEGIN
- IF CHECK (PINT'(F)) /= P1 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE PINT" );
- END IF;
-
- IF CHECK (PCHAR'(F)) /= P2 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE PCHAR" );
- END IF;
-
- IF CHECK (PARR'(F)) /= P3 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE PARR" );
- END IF;
-
- IF CHECK (PREC'(F)) /= P4 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE PREC" );
- END IF;
-
- IF CHECK (PACC'(F)) /= P5 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE PACC" );
- END IF;
-
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPES.
-
- TYPE RESULTS IS (LP1, LP2, LP3, LP4, LP5);
-
- PACKAGE PKG1 IS
- TYPE LPINT IS LIMITED PRIVATE;
- TYPE LPCHAR IS LIMITED PRIVATE;
- TYPE LPARR IS LIMITED PRIVATE;
- TYPE LPREC (D : INTEGER) IS LIMITED PRIVATE;
- TYPE LPACC IS LIMITED PRIVATE;
-
- FUNCTION F RETURN LPINT;
- FUNCTION F RETURN LPCHAR;
- FUNCTION F RETURN LPARR;
- FUNCTION F RETURN LPREC;
- FUNCTION F RETURN LPACC;
-
- PRIVATE
- TYPE LPINT IS NEW INTEGER;
- TYPE LPCHAR IS NEW CHARACTER;
- TYPE LPARR IS ARRAY (1 .. 2) OF NATURAL;
-
- TYPE LPREC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE LPACC IS ACCESS LPREC;
-
- END PKG1;
-
- PACKAGE BODY PKG1 IS
- FUNCTION F RETURN LPINT IS
- BEGIN
- RETURN 1;
- END F;
-
- FUNCTION F RETURN LPCHAR IS
- BEGIN
- RETURN 'B';
- END F;
-
- FUNCTION F RETURN LPARR IS
- BEGIN
- RETURN LPARR'(OTHERS => 3);
- END F;
-
- FUNCTION F RETURN LPREC IS
- BEGIN
- RETURN LPREC'(D => 4);
- END F;
-
- FUNCTION F RETURN LPACC IS
- BEGIN
- RETURN NEW LPREC'(F);
- END F;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- FUNCTION CHECK (LP : LPINT) RETURN RESULTS IS
- BEGIN
- RETURN LP1;
- END CHECK;
-
- FUNCTION CHECK (LP : LPCHAR) RETURN RESULTS IS
- BEGIN
- RETURN LP2;
- END CHECK;
-
- FUNCTION CHECK (LP : LPARR) RETURN RESULTS IS
- BEGIN
- RETURN LP3;
- END CHECK;
-
- FUNCTION CHECK (LP : LPREC) RETURN RESULTS IS
- BEGIN
- RETURN LP4;
- END CHECK;
-
- FUNCTION CHECK (LP : LPACC) RETURN RESULTS IS
- BEGIN
- RETURN LP5;
- END CHECK;
-
- BEGIN
- IF CHECK (LPINT'(F)) /= LP1 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE LPINT" );
- END IF;
-
- IF CHECK (LPCHAR'(F)) /= LP2 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE LPCHAR" );
- END IF;
-
- IF CHECK (LPARR'(F)) /= LP3 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE LPARR" );
- END IF;
-
- IF CHECK (LPREC'(F)) /= LP4 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE LPREC" );
- END IF;
-
- IF CHECK (LPACC'(F)) /= LP5 THEN
- FAILED ( "INCORRECT RESULTS FOR TYPE LPACC" );
- END IF;
-
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C47002D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47003a.ada b/gcc/testsuite/ada/acats/tests/c4/c47003a.ada
deleted file mode 100644
index a3bd47a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47003a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- C47003A.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.
---*
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN
--- ENUMERATION TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE
--- VALUE OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47003A IS
-
-BEGIN
-
- TEST( "C47003A", "WHEN THE TYPE MARK IN A QUALIFIED " &
- "EXPRESSION DENOTES AN ENUMERATION " &
- "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " &
- "WITHIN THE RANGE OF THE TYPE MARK" );
-
- DECLARE
-
- TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- SUBTYPE MIDWEEK IS WEEK RANGE TUE .. THU;
-
- FUNCTION IDENT (W : WEEK) RETURN WEEK IS
- BEGIN
- RETURN WEEK'VAL (IDENT_INT (WEEK'POS (W)));
- END IDENT;
-
- BEGIN
- IF MIDWEEK'(IDENT (SUN)) = TUE THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE MIDWEEK - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE MIDWEEK - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE MIDWEEK" );
- END;
-
- DECLARE
-
- SUBTYPE CHAR IS CHARACTER RANGE 'C' .. 'R';
-
- BEGIN
- IF CHAR'(IDENT_CHAR ('A')) = 'C' THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE CHAR - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE CHAR - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE CHAR" );
- END;
-
- DECLARE
-
- TYPE NBOOL IS NEW BOOLEAN;
- SUBTYPE NFALSE IS NBOOL RANGE FALSE .. FALSE;
-
- FUNCTION IDENT (B : NBOOL) RETURN NBOOL IS
- BEGIN
- RETURN NBOOL (IDENT_BOOL (BOOLEAN (B)));
- END IDENT;
-
- BEGIN
- IF NFALSE'(IDENT (TRUE)) = FALSE THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE NFALSE - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE NFALSE - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE NFALSE" );
- END;
-
- RESULT;
-END C47003A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47004a.ada b/gcc/testsuite/ada/acats/tests/c4/c47004a.ada
deleted file mode 100644
index 3965900..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47004a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- C47004A.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.
---*
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN INTEGER
--- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE
--- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47004A IS
-
-BEGIN
-
- TEST( "C47004A", "WHEN THE TYPE MARK IN A QUALIFIED " &
- "EXPRESSION DENOTES AN INTEGER " &
- "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " &
- "WITHIN THE RANGE OF THE TYPE MARK" );
-
- DECLARE
-
- TYPE INT IS RANGE -10 .. 10;
- SUBTYPE SINT IS INT RANGE -5 .. 5;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- RETURN INT (IDENT_INT (INTEGER (I)));
- END;
-
- BEGIN
- IF SINT'(IDENT (10)) = 5 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SINT - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SINT - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SINT" );
- END;
-
- DECLARE
-
- SUBTYPE SINTEGER IS INTEGER RANGE -10 .. 10;
-
- BEGIN
- IF SINTEGER'(IDENT_INT (20)) = 15 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SINTEGER - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SINTEGER - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SINTEGER" );
- END;
-
- DECLARE
-
- TYPE NINTEGER IS NEW INTEGER;
- SUBTYPE SNINT IS NINTEGER RANGE -10 .. 10;
-
- FUNCTION IDENT (I : NINTEGER) RETURN NINTEGER IS
- BEGIN
- RETURN NINTEGER (IDENT_INT (INTEGER (I)));
- END;
-
- BEGIN
- IF SNINT'(IDENT (-20)) = -10 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNINT - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNINT - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SNINT" );
- END;
-
- RESULT;
-END C47004A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47005a.ada b/gcc/testsuite/ada/acats/tests/c4/c47005a.ada
deleted file mode 100644
index f9ec930..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47005a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C47005A.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:
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FLOATING
--- POINT TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE
--- OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK.
-
--- HISTORY:
--- RJW 07/23/86 CREATED ORIGINAL TEST.
--- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. ADDED
--- TEST FOR UPPER SIDE OF RANGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47005A IS
-
-BEGIN
-
- TEST( "C47005A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
- "DENOTES A FLOATING POINT TYPE, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED WHEN THE VALUE " &
- "OF THE OPERAND DOES NOT LIE WITHIN THE " &
- "RANGE OF THE TYPE MARK" );
-
- DECLARE
-
- SUBTYPE SFLOAT IS FLOAT RANGE -1.0 .. 1.0;
-
- FUNCTION IDENT (F : FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN F;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- BEGIN
- IF SFLOAT'(IDENT (-2.0)) = -1.0 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFLOAT - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFLOAT - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SFLOAT" );
- END;
-
- DECLARE
-
- TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0;
- SUBTYPE SFLT IS FLT RANGE -1.0 .. 1.0;
-
- FUNCTION IDENT (F : FLT) RETURN FLT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN F;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- BEGIN
- IF SFLT'(IDENT (-2.0)) = -1.0 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFLT - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFLT - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SFLT" );
- END;
-
- DECLARE
-
- TYPE NFLT IS NEW FLOAT;
- SUBTYPE SNFLT IS NFLT RANGE -1.0 .. 1.0;
-
- FUNCTION IDENT (F : NFLT) RETURN NFLT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN F;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- BEGIN
- IF SNFLT'(IDENT (2.0)) = 1.0 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNFLT 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNFLT 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SNFLT" );
- END;
-
- RESULT;
-END C47005A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47006a.ada b/gcc/testsuite/ada/acats/tests/c4/c47006a.ada
deleted file mode 100644
index c958743..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47006a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C47006A.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.
---*
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FIXED POINT
--- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE
--- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47006A IS
-
- TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0;
-
-BEGIN
-
- TEST( "C47006A", "WHEN THE TYPE MARK IN A QUALIFIED " &
- "EXPRESSION DENOTES A FIXED POINT TYPE, " &
- "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " &
- "WITHIN THE RANGE OF THE TYPE MARK" );
-
- DECLARE
-
- SUBTYPE SFIXED IS FIXED RANGE -2.0 .. 2.0;
-
- FUNCTION IDENT (X : FIXED) RETURN FIXED IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- BEGIN
- IF SFIXED'(IDENT (-5.0)) = -2.0 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFIXED - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SFIXED - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SFIXED" );
- END;
-
- DECLARE
-
- TYPE NFIX IS NEW FIXED;
- SUBTYPE SNFIX IS NFIX RANGE -2.0 .. 2.0;
-
- FUNCTION IDENT (X : NFIX) RETURN NFIX IS
- BEGIN
- RETURN NFIX (IDENT_INT (INTEGER (X)));
- END IDENT;
-
- BEGIN
- IF SNFIX'(IDENT (-5.0)) = -2.0 THEN
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNFIX - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " &
- "SUBTYPE SNFIX - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " &
- "OF SUBTYPE SNFIX" );
- END;
-
- RESULT;
-END C47006A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47007a.ada b/gcc/testsuite/ada/acats/tests/c4/c47007a.ada
deleted file mode 100644
index bacc39f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47007a.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C47007A.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.
---*
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A CONSTRAINED
--- ARRAY TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS
--- OF THE OPERAND ARE NOT THE SAME AS THE BOUNDS OF THE TYPE MARK.
-
--- RJW 7/23/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47007A IS
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
-
- TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
- OF INTEGER;
-
- TYPE NARR IS NEW ARR;
-
- TYPE NTARR IS NEW TARR;
-
-BEGIN
-
- TEST( "C47007A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
- "DENOTES A CONSTRAINED ARRAY TYPE, CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS " &
- "OF THE OPERAND ARE NOT THE SAME AS THE " &
- "BOUNDS OF THE TYPE MARK" );
-
- DECLARE
-
- SUBTYPE SARR IS ARR (IDENT_INT (1) .. IDENT_INT (1));
- A : ARR (IDENT_INT (2) .. IDENT_INT (2));
- BEGIN
- A := SARR'(A'RANGE => 0);
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE SARR" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE SARR" );
- END;
-
- DECLARE
-
- SUBTYPE NULLA IS ARR (IDENT_INT (1) .. IDENT_INT (0));
- A : ARR (IDENT_INT (2) .. IDENT_INT (1));
-
- BEGIN
- A := NULLA'(A'FIRST .. A'LAST => 0);
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE NULLA" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE NULLA" );
- END;
-
- DECLARE
-
- SUBTYPE STARR IS TARR (IDENT_INT (1) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (5));
- A : TARR (IDENT_INT (2) .. IDENT_INT (6),
- IDENT_INT (1) .. IDENT_INT (1));
- BEGIN
- A := STARR'(A'RANGE => (A'RANGE (2) => 0));
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE STARR" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE STARR" );
- END;
-
- DECLARE
-
- SUBTYPE NULLT IS TARR (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (1) .. IDENT_INT (0));
-
- A : TARR (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (2) .. IDENT_INT (1));
- BEGIN
- A := NULLT'(A'FIRST .. A'LAST =>
- (A'FIRST (2) .. A'LAST (2) => 0));
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE NULLT" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE NULLT" );
- END;
-
- DECLARE
-
- SUBTYPE SNARR IS NARR (IDENT_INT (1) .. IDENT_INT (1));
- A : NARR (IDENT_INT (2) .. IDENT_INT (2));
-
- BEGIN
- A := SNARR'(A'RANGE => 0);
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE SNARR" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE SNARR" );
- END;
-
- DECLARE
-
- SUBTYPE NULLNA IS NARR (IDENT_INT (1) .. IDENT_INT (0));
- A : NARR (IDENT_INT (2) .. IDENT_INT (1));
-
- BEGIN
- A := NULLNA'(A'RANGE => 0);
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE NULLNA" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE NULLNA" );
- END;
-
- DECLARE
-
- SUBTYPE SNTARR IS NTARR (IDENT_INT (1) .. IDENT_INT (1),
- IDENT_INT (1) .. IDENT_INT (5));
-
- A : NTARR (IDENT_INT (2) .. IDENT_INT (2),
- IDENT_INT (1) .. IDENT_INT (5));
- BEGIN
- A := SNTARR'(A'RANGE => (A'RANGE (2) => 0));
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE SNTARR" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE SNTARR" );
- END;
-
- DECLARE
-
- SUBTYPE NULLNT IS NTARR (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (1) .. IDENT_INT (0));
-
- A : NTARR (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (1) .. IDENT_INT (1));
- BEGIN
- A := NULLNT'(A'RANGE => (A'RANGE (2) => 0));
- FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " &
- "THOSE OF SUBTYPE NULLNT" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " &
- "THE SAME AS THOSE OF SUBTYPE NULLNT" );
- END;
-
- RESULT;
-END C47007A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47008a.ada b/gcc/testsuite/ada/acats/tests/c4/c47008a.ada
deleted file mode 100644
index b221829..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47008a.ada
+++ /dev/null
@@ -1,299 +0,0 @@
--- C47008A.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:
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A
--- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE TYPE, CHECK THAT
--- CONSTRAINT_ERROR IS RAISED WHEN THE DISCRIMINANTS OF THE OPERAND
--- DO NOT EQUAL THOSE OF THE TYPE MARK.
-
--- HISTORY:
--- RJW 07/23/86
--- DWC 07/24/87 CHANGED CODE TO TEST FOR FIRST DISCRIMINANT
--- AND LAST DISCRIMINANT MISMATCH.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47008A IS
-
- TYPE GENDER IS (MALE, FEMALE, NEUTER);
-
- FUNCTION IDENT (G : GENDER) RETURN GENDER IS
- BEGIN
- RETURN GENDER'VAL (IDENT_INT (GENDER'POS (G)));
- END IDENT;
-
-BEGIN
-
- TEST( "C47008A", "WHEN THE TYPE MARK IN A QUALIFIED " &
- "EXPRESSION DENOTES A CONSTRAINED RECORD, " &
- "PRIVATE, OR LIMITED PRIVATE TYPE, CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " &
- "DISCRIMANTS OF THE OPERAND DO NOT EQUAL " &
- "THOSE OF THE TYPE MARK" );
-
- DECLARE
-
- TYPE PERSON (SEX : GENDER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE WOMAN IS PERSON (IDENT (FEMALE));
- TOM : PERSON (MALE) := (SEX => IDENT (MALE));
-
- BEGIN
- IF WOMAN'(TOM) = PERSON'(SEX => MALE) THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE WOMAN" );
- END;
-
- DECLARE
- TYPE PAIR (SEX1, SEX2 : GENDER) IS
- RECORD
- NULL;
- END RECORD;
-
- SUBTYPE COUPLE IS PAIR (IDENT (FEMALE), IDENT (MALE));
- JONESES : PAIR (IDENT (MALE), IDENT (FEMALE));
-
- BEGIN
- IF COUPLE'(JONESES) = PAIR'(SEX1 => MALE, SEX2 => FEMALE)
- THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE COUPLE" );
- END;
-
- DECLARE
-
- PACKAGE PKG IS
- TYPE PERSON (SEX : GENDER) IS PRIVATE;
- SUBTYPE MAN IS PERSON (IDENT (MALE));
-
- TESTWRITER : CONSTANT PERSON;
-
- PRIVATE
- TYPE PERSON (SEX : GENDER) IS
- RECORD
- NULL;
- END RECORD;
-
- TESTWRITER : CONSTANT PERSON := (SEX => FEMALE);
-
- END PKG;
-
- USE PKG;
-
- ROSA : PERSON (IDENT (FEMALE));
-
- BEGIN
- IF MAN'(ROSA) = TESTWRITER THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE MAN - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE MAN - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE MAN" );
- END;
-
- DECLARE
- PACKAGE PKG IS
- TYPE PAIR (SEX1, SEX2 : GENDER) IS PRIVATE;
- SUBTYPE FRIENDS IS PAIR (IDENT (FEMALE), IDENT (MALE));
-
- ALICE_AND_JERRY : CONSTANT FRIENDS;
-
- PRIVATE
- TYPE PAIR (SEX1, SEX2 : GENDER) IS
- RECORD
- NULL;
- END RECORD;
-
- ALICE_AND_JERRY : CONSTANT FRIENDS :=
- (IDENT (FEMALE), IDENT (MALE));
-
- END PKG;
-
- USE PKG;
-
- DICK_AND_JOE : PAIR (IDENT (MALE), IDENT (MALE));
-
- BEGIN
- IF FRIENDS'(DICK_AND_JOE) = ALICE_AND_JERRY THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " &
- "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE FRIENDS" );
- END;
-
- DECLARE
-
- PACKAGE PKG1 IS
- TYPE PERSON (SEX : GENDER) IS LIMITED PRIVATE;
- SUBTYPE ANDROID IS PERSON (IDENT (NEUTER));
-
- FUNCTION F RETURN PERSON;
- FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN;
- PRIVATE
- TYPE PERSON (SEX : GENDER) IS
- RECORD
- NULL;
- END RECORD;
-
- END PKG1;
-
- PACKAGE BODY PKG1 IS
-
- FUNCTION F RETURN PERSON IS
- BEGIN
- RETURN PERSON'(SEX => (IDENT (MALE)));
- END F;
-
- FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN IS
- BEGIN
- RETURN A.SEX = B.SEX;
- END;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- BEGIN
- IF ANDROID'(F) = F THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
- "ANDROID - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
- "ANDROID - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " &
- "WITH DISC NOT EQUAL TO THOSE OF " &
- "SUBTYPE ANDROID" );
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- DECLARE
- PACKAGE PKG1 IS
- TYPE PAIR (SEX1, SEX2 : GENDER) IS LIMITED PRIVATE;
- SUBTYPE LOVERS IS PAIR (IDENT (FEMALE), IDENT (MALE));
-
- FUNCTION F RETURN PAIR;
- FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN;
- PRIVATE
- TYPE PAIR (SEX1, SEX2 : GENDER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- PACKAGE BODY PKG1 IS
-
- FUNCTION F RETURN PAIR IS
- BEGIN
- RETURN PAIR'(SEX1 => (IDENT (FEMALE)),
- SEX2 => (IDENT (FEMALE)));
- END F;
-
- FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN IS
- BEGIN
- RETURN A.SEX1 = B.SEX2;
- END;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- BEGIN
- IF LOVERS'(F) = F THEN
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
- "LOVERS - 1");
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " &
- "DISC NOT EQUAL TO THOSE OF SUBTYPE " &
- "LOVERS - 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " &
- "WITH DISC NOT EQUAL TO THOSE OF " &
- "SUBTYPE LOVERS" );
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C47008A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47009a.ada b/gcc/testsuite/ada/acats/tests/c4/c47009a.ada
deleted file mode 100644
index 2fee519..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47009a.ada
+++ /dev/null
@@ -1,254 +0,0 @@
--- C47009A.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:
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A
--- CONSTRAINED ACCESS TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED
--- WHEN THE VALUE OF THE OPERAND IS NOT NULL AND THE DESIGNATED
--- OBJECT HAS INDEX BOUNDS OR DISCRIMINANT VALUES THAT DO NOT EQUAL
--- THOSE SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT.
-
--- HISTORY:
--- RJW 7/23/86
--- DWC 07/24/87 REVISED TO MAKE THE ACCESS TYPE UNCONSTRAINED
--- AND TO PREVENT DEAD VARIABLE OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47009A IS
-
-BEGIN
-
- TEST( "C47009A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " &
- "DENOTES A CONSTRAINED ACCESS TYPE, CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " &
- "VALUE OF THE OPERAND IS NOT NULL AND THE " &
- "DESIGNATED OBJECT HAS INDEX BOUNDS OR " &
- "DISCRIMINANT VALUES THAT DO NOT EQUAL THOSE " &
- "SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT" );
-
- DECLARE
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
- TYPE ACC1 IS ACCESS ARR;
- SUBTYPE ACC1S IS ACC1 (IDENT_INT (1) .. IDENT_INT (5));
- A : ACC1;
- B : ARR (IDENT_INT (2) .. IDENT_INT (6));
-
- BEGIN
- A := ACC1S'(NEW ARR'(B'FIRST .. B'LAST => 0));
- IF A'FIRST = 1 THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC1 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC1 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC1" );
- END;
-
- DECLARE
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
- OF INTEGER;
- TYPE ACC2 IS ACCESS ARR;
- SUBTYPE ACC2S IS ACC2 (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (1) .. IDENT_INT (1));
- A : ACC2;
- B : ARR (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (2) .. IDENT_INT (2));
-
- BEGIN
- A := ACC2S'(NEW ARR'(B'RANGE => (B'RANGE (2) => 0)));
- IF A'FIRST = 1 THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC2 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC2 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC2" );
- END;
-
- DECLARE
-
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC3 IS ACCESS REC;
- SUBTYPE ACC3S IS ACC3 (IDENT_INT (3));
- A : ACC3;
- B : REC (IDENT_INT (5)) := (D => (IDENT_INT (5)));
-
- BEGIN
- A := ACC3S'(NEW REC'(B));
- IF A = NULL THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC3 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC3 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC3" );
- END;
-
- DECLARE
-
- TYPE REC (D1,D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC4 IS ACCESS REC;
- SUBTYPE ACC4S IS ACC4 (IDENT_INT (4), IDENT_INT (5));
- A : ACC4;
- B : REC (IDENT_INT (5), IDENT_INT (4)) :=
- (D1 => (IDENT_INT (5)), D2 => (IDENT_INT (4)));
-
- BEGIN
- A := ACC4S'(NEW REC'(B));
- IF A = NULL THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC4 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC4 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " &
- "DIFFERENT FROM THOSE OF TYPE ACC4" );
- END;
-
- DECLARE
-
- PACKAGE PKG IS
- TYPE REC (D : INTEGER) IS PRIVATE;
-
- B : CONSTANT REC;
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- B : CONSTANT REC := (D => (IDENT_INT (4)));
- END PKG;
-
- USE PKG;
-
- TYPE ACC5 IS ACCESS REC;
- SUBTYPE ACC5S IS ACC5 (IDENT_INT (3));
- A : ACC5;
-
- BEGIN
- A := ACC5S'(NEW REC'(B));
- IF A = NULL THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC5 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC5 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " &
- "DIFFERENT FROM THOSE OF TYPE ACC5" );
- END;
-
- DECLARE
-
- PACKAGE PKG1 IS
- TYPE REC (D : INTEGER) IS LIMITED PRIVATE;
- TYPE ACC6 IS ACCESS REC;
- SUBTYPE ACC6S IS ACC6 (IDENT_INT (6));
-
- FUNCTION F RETURN ACC6;
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- PACKAGE BODY PKG1 IS
-
- FUNCTION F RETURN ACC6 IS
- BEGIN
- RETURN NEW REC'(D => IDENT_INT (5));
- END F;
-
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- A : ACC6;
-
- BEGIN
- A := ACC6S'(F);
- IF A = NULL THEN
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC6 - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " &
- "DIFFERENT FROM THOSE OF TYPE ACC6 - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR DISC " &
- "VALUES DIFFERENT FROM THOSE OF TYPE " &
- "ACC6" );
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C47009A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c47009b.ada b/gcc/testsuite/ada/acats/tests/c4/c47009b.ada
deleted file mode 100644
index accd787..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c47009b.ada
+++ /dev/null
@@ -1,282 +0,0 @@
--- C47009B.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:
--- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN ACCESS
--- TYPE, CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE VALUE
--- OF THE OPERAND IS NULL.
-
--- HISTORY:
--- RJW 07/23/86 CREATED ORIGINAL TEST.
--- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED
--- CONSTRAINTS OF B SUBTYPES TO VALUES WHICH ARE
--- CLOSER TO THE VALUES OF THE A SUBTYPES. INDENTED
--- THE EXCEPTION STATEMENTS IN SUBTEST 11.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C47009B IS
-
-BEGIN
-
- TEST( "C47009B", "WHEN THE TYPE MARK IN A QUALIFIED " &
- "EXPRESSION DENOTES AN ACCESS TYPE, " &
- "CHECK THAT CONSTRAINT_ERROR IS NOT " &
- "RAISED WHEN THE VALUE OF THE OPERAND IS NULL" );
-
- DECLARE
-
- TYPE ACC1 IS ACCESS BOOLEAN;
- A : ACC1;
-
- BEGIN
- A := ACC1'(NULL);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC1" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC1" );
- END;
-
- DECLARE
-
- TYPE ACC2 IS ACCESS INTEGER;
- A : ACC2;
-
- BEGIN
- A := ACC2'(NULL);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC2" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC2" );
- END;
-
- DECLARE
-
- TYPE CHAR IS ('A', 'B');
- TYPE ACC3 IS ACCESS CHAR;
- A : ACC3;
-
- BEGIN
- A := ACC3'(NULL);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC3" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC3" );
- END;
-
- DECLARE
-
- TYPE FLOAT1 IS DIGITS 5 RANGE -1.0 .. 1.0;
- TYPE ACC4 IS ACCESS FLOAT1;
- A : ACC4;
-
- BEGIN
- A := ACC4'(NULL);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC4" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC4" );
- END;
-
- DECLARE
-
- TYPE FIXED IS DELTA 0.5 RANGE -1.0 .. 1.0;
- TYPE ACC5 IS ACCESS FIXED;
- A : ACC5;
-
- BEGIN
- A := ACC5'(NULL);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC5" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC5" );
- END;
-
- DECLARE
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
- TYPE ACC6 IS ACCESS ARR;
- SUBTYPE ACC6A IS ACC6 (IDENT_INT (1) .. IDENT_INT (5));
- SUBTYPE ACC6B IS ACC6 (IDENT_INT (2) .. IDENT_INT (10));
- A : ACC6A;
- B : ACC6B;
-
- BEGIN
- A := ACC6A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
- "TYPE ACC6" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC6" );
- END;
-
- DECLARE
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>)
- OF INTEGER;
- TYPE ACC7 IS ACCESS ARR;
- SUBTYPE ACC7A IS ACC7 (IDENT_INT (1) .. IDENT_INT (5),
- IDENT_INT (1) .. IDENT_INT (1));
- SUBTYPE ACC7B IS ACC7 (IDENT_INT (1) .. IDENT_INT (15),
- IDENT_INT (1) .. IDENT_INT (10));
- A : ACC7A;
- B : ACC7B;
-
- BEGIN
- A := ACC7A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
- "TYPE ACC7" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC7" );
- END;
-
- DECLARE
-
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC8 IS ACCESS REC;
- SUBTYPE ACC8A IS ACC8 (IDENT_INT (5));
- SUBTYPE ACC8B IS ACC8 (IDENT_INT (6));
- A : ACC8A;
- B : ACC8B;
-
- BEGIN
- A := ACC8A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
- "TYPE ACC8" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC8" );
- END;
-
- DECLARE
-
- TYPE REC (D1,D2 : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC9 IS ACCESS REC;
- SUBTYPE ACC9A IS ACC9 (IDENT_INT (4), IDENT_INT (5));
- SUBTYPE ACC9B IS ACC9 (IDENT_INT (5), IDENT_INT (4));
- A : ACC9A;
- B : ACC9B;
-
- BEGIN
- A := ACC9A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
- "TYPE ACC9" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC9" );
- END;
-
- DECLARE
-
- PACKAGE PKG IS
- TYPE REC (D : INTEGER) IS PRIVATE;
-
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
-
- END PKG;
-
- USE PKG;
-
- TYPE ACC10 IS ACCESS REC;
- SUBTYPE ACC10A IS ACC10 (IDENT_INT (10));
- SUBTYPE ACC10B IS ACC10 (IDENT_INT (9));
- A : ACC10A;
- B : ACC10B;
-
- BEGIN
- A := ACC10A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " &
- "TYPE ACC10" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC10" );
- END;
-
- DECLARE
-
- PACKAGE PKG1 IS
- TYPE REC (D : INTEGER) IS LIMITED PRIVATE;
-
- PRIVATE
- TYPE REC (D : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END PKG1;
-
- PACKAGE PKG2 IS END PKG2;
-
- PACKAGE BODY PKG2 IS
- USE PKG1;
-
- TYPE ACC11 IS ACCESS REC;
- SUBTYPE ACC11A IS ACC11 (IDENT_INT (11));
- SUBTYPE ACC11B IS ACC11 (IDENT_INT (12));
- A : ACC11A;
- B : ACC11B;
-
- BEGIN
- A := ACC11A'(B);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF" &
- " TYPE ACC11" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " &
- "TYPE ACC11" );
- END PKG2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C47009B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004a.ada b/gcc/testsuite/ada/acats/tests/c4/c48004a.ada
deleted file mode 100644
index 5dd315a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004a.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C48004A.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 FORM "NEW T" IS PERMITTED IF T IS A SCALAR SUBTYPE.
-
--- RM 01/12/80
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48004A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004A","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " &
- "T IS A SCALAR SUBTYPE");
-
- DECLARE
-
- SUBTYPE TA IS INTEGER RANGE 1 .. 7;
- TYPE ATA IS ACCESS TA;
- VA : ATA;
-
- BEGIN
-
- VA := NEW TA;
- VA.ALL := IDENT_INT(6);
- IF VA.ALL /= 6 THEN
- FAILED ("INCORRECT VALUE");
- END IF;
-
- END;
-
- RESULT;
-
-END C48004A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004b.ada b/gcc/testsuite/ada/acats/tests/c4/c48004b.ada
deleted file mode 100644
index 0ba6c07..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004b.ada
+++ /dev/null
@@ -1,140 +0,0 @@
--- C48004B.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 FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED
--- RECORD, PRIVATE, OR LIMITED PRIVATE TYPE.
-
--- RM 01/12/80
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48004B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004B","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " &
- "T IS A CONSTRAINED RECORD, PRIVATE, OR " &
- "LIMITED PRIVATE TYPE");
-
- DECLARE
-
- TYPE TB0(A , B : INTEGER ) IS
- RECORD
- C : INTEGER := 7;
- END RECORD;
- SUBTYPE TB IS TB0( 2 , 3 );
- TYPE ATB IS ACCESS TB0;
- VB : ATB;
-
- TYPE TBB0( A , B : INTEGER := 5 ) IS
- RECORD
- C : INTEGER := 6;
- END RECORD;
- SUBTYPE TBB IS TBB0( 4 , 5 );
- TYPE ATBB IS ACCESS TBB0;
- VBB : ATBB;
-
- PACKAGE P IS
- TYPE PRIV0( A , B : INTEGER ) IS PRIVATE;
- TYPE LPRIV0( A , B : INTEGER := 1 ) IS LIMITED PRIVATE;
- FUNCTION FUN(LP : LPRIV0) RETURN INTEGER;
- PRIVATE
- TYPE PRIV0( A , B : INTEGER ) IS
- RECORD
- Q : INTEGER;
- END RECORD;
- TYPE LPRIV0( A , B : INTEGER := 1 ) IS
- RECORD
- Q : INTEGER := 7;
- END RECORD;
- END P;
-
- USE P;
-
- SUBTYPE PRIV IS P.PRIV0( 12 , 13 );
- TYPE A_PRIV IS ACCESS P.PRIV0;
- VP : A_PRIV;
-
- TYPE A_LPRIV IS ACCESS LPRIV0;
- VLP : A_LPRIV;
-
- TYPE LCR(A, B : INTEGER := 4) IS
- RECORD
- C : P.LPRIV0;
- END RECORD;
- SUBTYPE SLCR IS LCR(1, 2);
- TYPE A_SLCR IS ACCESS SLCR;
- VSLCR : A_SLCR;
-
- PACKAGE BODY P IS
- FUNCTION FUN(LP : LPRIV0) RETURN INTEGER IS
- BEGIN
- RETURN LP.Q;
- END FUN;
- END P;
-
- BEGIN
-
- VB := NEW TB;
- IF ( VB.A /= IDENT_INT(2) OR
- VB.B /= 3 OR
- VB.C /= 7 ) THEN FAILED( "WRONG VALUES - B1" );
- END IF;
-
- VBB := NEW TBB0;
- IF ( VBB.A /= IDENT_INT(5) OR
- VBB.B /= 5 OR
- VBB.C /= 6 ) THEN
- FAILED( "WRONG VALUES - B2" );
- END IF;
-
- VP := NEW PRIV;
- IF ( VP.A /= IDENT_INT(12) OR
- VP.B /= 13 ) THEN
- FAILED( "WRONG VALUES - B3" );
- END IF;
-
- VLP := NEW LPRIV0;
- IF ( VLP.A /= IDENT_INT(1) OR
- VLP.B /= 1 OR
- P.FUN(VLP.ALL) /= IDENT_INT(7) ) THEN
- FAILED( "WRONG VALUES - B4" );
- END IF;
-
- VSLCR := NEW SLCR;
- IF ( VSLCR.A /= IDENT_INT(1) OR
- VSLCR.B /= IDENT_INT(2) OR
- P.FUN(VSLCR.C) /= IDENT_INT(7) ) THEN
- FAILED ("WRONG VALUES - B5");
- END IF;
-
- END;
-
- RESULT;
-
-END C48004B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004c.ada b/gcc/testsuite/ada/acats/tests/c4/c48004c.ada
deleted file mode 100644
index 2b867a0..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004c.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C48004C.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 FORM "NEW T" IS PERMITTED IF T IS AN UNCONSTRAINED
--- RECORD, PRIVATE, OR LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT
--- VALUES.
-
--- EG 08/03/84
-
-WITH REPORT;
-
-PROCEDURE C48004C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004C","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " &
- "T IS AN UNCONSTRAINED RECORD, PRIVATE, OR " &
- "LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT " &
- "VALUES");
-
- DECLARE
-
- TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS
- RECORD
- C : INTEGER := 7;
- END RECORD;
-
- PACKAGE P IS
-
- TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS PRIVATE;
- TYPE UL(A, B : INTEGER := 1) IS LIMITED PRIVATE;
-
- PRIVATE
-
- TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS
- RECORD
- Q : INTEGER;
- END RECORD;
- TYPE UL(A, B : INTEGER := 1) IS
- RECORD
- Q : INTEGER;
- END RECORD;
-
- END P;
-
- USE P;
-
- TYPE A_UR IS ACCESS UR;
- TYPE A_UP IS ACCESS UP;
- TYPE A_UL IS ACCESS UL;
-
- V_UR : A_UR;
- V_UP : A_UP;
- V_UL : A_UL;
-
- BEGIN
-
- V_UR := NEW UR;
- IF ( V_UR.A /= IDENT_INT(1) OR V_UR.B /= 2 OR
- V_UR.C /= 7 ) THEN
- FAILED("WRONG VALUES - UR");
- END IF;
-
- V_UP := NEW UP;
- IF ( V_UP.A /= IDENT_INT(12) OR V_UP.B /= 13 ) THEN
- FAILED("WRONG VALUES - UP");
- END IF;
-
- V_UL := NEW UL;
- IF ( V_UL.A /= IDENT_INT(1) OR V_UL.B /= 1 ) THEN
- FAILED("WRONG VALUES - UL");
- END IF;
-
- END;
-
- RESULT;
-
-END C48004C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004d.ada b/gcc/testsuite/ada/acats/tests/c4/c48004d.ada
deleted file mode 100644
index 9454327..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004d.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C48004D.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 FORM "NEW T" IS PERMITTED IF T IS A RECORD, PRIVATE,
--- OR LIMITED TYPE WITHOUT DISCRIMINANTS.
-
--- RM 01/12/80
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48004D IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004D","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " &
- "IS A RECORD, PRIVATE, OR LIMITED TYPE WITHOUT " &
- "DISCRIMINANTS");
-
- DECLARE
-
- TYPE TC IS
- RECORD
- C : INTEGER := 18;
- END RECORD;
- TYPE ATC IS ACCESS TC;
- VC : ATC;
-
- PACKAGE P IS
- TYPE PRIV IS PRIVATE;
- TYPE LPRIV IS LIMITED PRIVATE;
- TYPE A_PRIV IS ACCESS PRIV;
- TYPE A_LPRIV IS ACCESS LPRIV;
- PROCEDURE CHECK( X: A_PRIV );
- PROCEDURE LCHECK( X: A_LPRIV );
- PROCEDURE LRCHECK( X: LPRIV );
- PRIVATE
- TYPE PRIV IS
- RECORD
- Q : INTEGER := 19;
- END RECORD;
- TYPE LPRIV IS
- RECORD
- Q : INTEGER := 20;
- END RECORD;
- END P;
-
-
- VP : P.A_PRIV;
- VLP : P.A_LPRIV;
-
- TYPE LCR IS
- RECORD
- C : P.LPRIV;
- END RECORD;
- TYPE A_LCR IS ACCESS LCR;
- VLCR : A_LCR;
-
- PACKAGE BODY P IS
-
- PROCEDURE CHECK( X: A_PRIV ) IS
- BEGIN
- IF X.Q /= 19 THEN FAILED( "WRONG VALUES - C2" );
- END IF;
- END CHECK;
-
- PROCEDURE LCHECK( X: A_LPRIV ) IS
- BEGIN
- IF X.Q /= 20 THEN FAILED( "WRONG VALUES - C3" );
- END IF;
- END LCHECK;
-
- PROCEDURE LRCHECK (X : LPRIV) IS
- BEGIN
- IF X.Q /= 20 THEN
- FAILED ("WRONG VALUES - C4");
- END IF;
- END LRCHECK;
-
- END P;
-
- BEGIN
-
- VC := NEW TC;
- IF VC.C /= 18 THEN FAILED( "WRONG VALUES - C1" );
- END IF;
-
- VP := NEW P.PRIV;
- P.CHECK( VP );
- VLP := NEW P.LPRIV;
- P.LCHECK( VLP );
-
- VLCR := NEW LCR;
- P.LRCHECK( VLCR.ALL.C );
-
- END;
-
- RESULT;
-
-END C48004D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004e.ada b/gcc/testsuite/ada/acats/tests/c4/c48004e.ada
deleted file mode 100644
index 22e62ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004e.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- C48004E.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 FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED ARRAY
--- TYPE.
-
--- RM 01/12/80
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48004E IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004E","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " &
- "IS A CONSTRAINED ARRAY TYPE");
-
- DECLARE
-
- TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN;
- SUBTYPE ARR IS ARR0(1 .. 10);
- TYPE A_ARR IS ACCESS ARR;
- VARR : A_ARR;
-
- PACKAGE P IS
- TYPE LPRIV IS LIMITED PRIVATE;
- FUNCTION CHECK (X : LPRIV) RETURN INTEGER;
- PRIVATE
- TYPE LPRIV IS
- RECORD
- Q : INTEGER := 20;
- END RECORD;
- END P;
-
- TYPE LPARR IS ARRAY(1 .. 2) OF P.LPRIV;
- TYPE A_LPARR IS ACCESS LPARR;
-
- V_A_LPARR : A_LPARR;
-
- PACKAGE BODY P IS
- FUNCTION CHECK (X : LPRIV) RETURN INTEGER IS
- BEGIN
- RETURN X.Q;
- END CHECK;
- END P;
-
- BEGIN
-
- VARR := NEW ARR;
- IF ( VARR'FIRST /= IDENT_INT(1) OR
- VARR'LAST /= 10 ) THEN FAILED("WRONG BOUNDS - CASE 1");
- END IF;
-
- V_A_LPARR := NEW LPARR;
- IF ( P.CHECK(V_A_LPARR.ALL(1)) /= IDENT_INT(20) OR
- P.CHECK(V_A_LPARR.ALL(2)) /= IDENT_INT(20) ) THEN
- FAILED ("WRONG VALUES - CASE 2");
- END IF;
-
- END;
-
- RESULT;
-
-END C48004E;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004f.ada b/gcc/testsuite/ada/acats/tests/c4/c48004f.ada
deleted file mode 100644
index 50ab9e7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48004f.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C48004F.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 FORM "NEW T" IS PERMITTED IF T IS AN ACCESS TYPE.
-
--- RM 01/12/80
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48004F IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48004F","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " &
- "IS AN ACCESS TYPE");
-
- DECLARE
-
- TYPE AINT IS ACCESS INTEGER;
- TYPE A_AINT IS ACCESS AINT;
- VA_AINT : A_AINT;
-
- TYPE AST IS ACCESS STRING;
- SUBTYPE CAST_4 IS AST(1 .. 4);
- TYPE A_AST IS ACCESS AST;
- TYPE ACAST_3 IS ACCESS AST(1 .. 3);
- V_AAST : A_AST;
- V_ACAST_3 : ACAST_3;
-
- TYPE UR(A, B : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
- SUBTYPE CR IS UR(1, 2);
- TYPE A_CR IS ACCESS CR;
- TYPE AA_CR IS ACCESS A_CR;
- V_AA_CR : AA_CR;
-
- BEGIN
-
- VA_AINT := NEW AINT;
- IF VA_AINT.ALL /= NULL THEN
- FAILED ("VARIABLE IS NOT NULL - CASE 1");
- END IF;
-
- BEGIN
-
- V_ACAST_3 := NEW CAST_4;
- IF V_ACAST_3.ALL /= NULL THEN
- FAILED ("VARIABLE IS NOT NULL - CASE 2");
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - CASE 2");
-
- END;
-
- V_AAST := NEW AST;
- IF V_AAST.ALL /= NULL THEN
- FAILED ("VARIABLE IS NOT NULL - CASE 3");
- END IF;
-
- V_AA_CR := NEW A_CR;
- IF V_AA_CR.ALL /= NULL THEN
- FAILED ("VARIABLE IS NOT NULL - CASE 4");
- END IF;
-
- END;
-
- RESULT;
-
-END C48004F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48005a.ada b/gcc/testsuite/ada/acats/tests/c4/c48005a.ada
deleted file mode 100644
index 13bea3a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48005a.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- C48005A.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 ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT
--- EACH TIME IT IS EXECUTED AND THAT IF T IS AN UNCONSTRAINED RECORD,
--- PRIVATE, OR LIMITED TYPE, THE ALLOCATED OBJECT HAS THE DISCRIMINANT
--- VALUES SPECIFIED BY X.
-
--- EG 08/08/84
-
-WITH REPORT;
-
-PROCEDURE C48005A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48005A","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " &
- "NEW OBJECT AND THAT IF T IS AN UNCONSTRAINED " &
- "RECORD, PRIVATE, OR LIMITED TYPE, THE " &
- "ALLOCATED OBJECT HAS THE DISCRIMINANT " &
- "VALUES SPECIFIED BY X");
-
- DECLARE
-
- TYPE UR1(A : INTEGER) IS
- RECORD
- B : INTEGER := 7;
- C : INTEGER := 4;
- END RECORD;
- TYPE UR2(A : INTEGER) IS
- RECORD
- CASE A IS
- WHEN 1 =>
- A1 : INTEGER := 4;
- WHEN 2 =>
- A2 : INTEGER := 5;
- WHEN OTHERS =>
- NULL;
- END CASE;
- END RECORD;
-
- TYPE A_UR1 IS ACCESS UR1;
- TYPE A_UR2 IS ACCESS UR2;
-
- V1AUR1 : A_UR1;
- V1AUR2, V2AUR2 : A_UR2;
-
- TYPE REC (A : INTEGER) IS
- RECORD
- B : INTEGER;
- END RECORD;
-
- TYPE A_REC IS ACCESS REC;
-
- V_A_REC : A_REC;
-
- TYPE ARR IS ARRAY(1 .. 1) OF INTEGER;
-
- TYPE RECVAL IS
- RECORD
- A : INTEGER;
- B : ARR;
- END RECORD;
-
- FUNCTION FUN (A : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(A);
- END FUN;
- FUNCTION FUN (A : INTEGER) RETURN RECVAL IS
- BEGIN
- FAILED ("WRONG OVERLOADED FUNCTION CALLED");
- RETURN (1, (1 => 2));
- END FUN;
-
- BEGIN
-
- V1AUR1 := NEW UR1(3);
- IF ( V1AUR1.A /= 3 OR V1AUR1.B /= 7 OR
- V1AUR1.C /= IDENT_INT(4) ) THEN
- FAILED("WRONG VALUES - V1UAR1");
- END IF;
-
- V1AUR2 := NEW UR2(IDENT_INT(2));
- IF ( V1AUR2.A /= 2 OR V1AUR2.A2 /= IDENT_INT(5) ) THEN
- FAILED("WRONG VALUES - V1AUR2");
- END IF;
-
- V2AUR2 := NEW UR2(IDENT_INT(3));
- IF ( V2AUR2.A /= IDENT_INT(3) ) THEN
- FAILED("WRONG VALUES - V2AUR2");
- END IF;
-
- V_A_REC := NEW REC(FUN(2));
- END;
-
- RESULT;
-
-END C48005A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48005b.ada b/gcc/testsuite/ada/acats/tests/c4/c48005b.ada
deleted file mode 100644
index c03bde6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48005b.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- C48005B.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 ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT
--- EACH TIME IT IS EXECUTED AND THAT IF X IS AN INDEX CONSTRAINT AND T
--- AN UNCONSTRAINED ARRAY TYPE, THE ALLOCATED OBJECT HAS THE INDEX
--- BOUNDS SPECIFIED BY X.
-
--- EG 08/10/84
-
-WITH REPORT;
-
-PROCEDURE C48005B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48005B","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " &
- "NEW OBJECT AND THAT IF X IS AN INDEX " &
- "CONSTRAINT AND T AN UNCONSTRAINED ARRAY " &
- "TYPE, THE ALLOCATED OBJECT HAS THE INDEX " &
- "BOUND SPECIFIED BY X");
-
- DECLARE
-
- TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>)
- OF INTEGER;
-
- TYPE A_UA1 IS ACCESS UA1;
- TYPE A_UA2 IS ACCESS UA2;
-
- V_A_UA1 : A_UA1;
- V_A_UA2 : A_UA2;
-
- BEGIN
-
- V_A_UA1 := NEW UA1(4 .. 7);
- IF ( V_A_UA1'FIRST /= IDENT_INT(4) OR
- V_A_UA1'LAST /= IDENT_INT(7) ) THEN
- FAILED("WRONG ARRAY BOUNDS - V_A_UA1");
- END IF;
-
- V_A_UA2 := NEW UA2(2 .. 3, 4 .. 6);
- IF ( V_A_UA2'FIRST(1) /= IDENT_INT(2) OR
- V_A_UA2'LAST(1) /= IDENT_INT(3) OR
- V_A_UA2'FIRST(2) /= IDENT_INT(4) OR
- V_A_UA2'LAST(2) /= IDENT_INT(6) ) THEN
- FAILED("WRONG ARRAY BOUNDS - V_A_UA2");
- END IF;
-
- END;
-
- RESULT;
-
-END C48005B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48006a.ada b/gcc/testsuite/ada/acats/tests/c4/c48006a.ada
deleted file mode 100644
index 22c0582..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48006a.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C48006A.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 ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW
--- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A SCALAR OR ACCESS
--- TYPE, THE ALLOCATED OBJECT HAS THE VALUE OF X.
-
--- RM 01/14/80
--- RM 01/O1/82
--- SPS 10/27/82
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48006A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48006A","CHECK THAT THE FORM 'NEW T'(X)' " &
- "ALLOCATES A NEW OBJECT " &
- "AND THAT IF T IS A SCALAR OR ACCESS TYPE, THE " &
- "ALLOCATED OBJECT HAS THE VALUE OF X");
-
- DECLARE
-
- TYPE ATA IS ACCESS INTEGER;
- TYPE AATA IS ACCESS ATA;
- VA1, VA2, VA3 : ATA;
- VAA1, VAA2, VAA3 : AATA;
-
- BEGIN
-
- VA1 := NEW INTEGER'(5 + 7);
- IF VA1.ALL /= IDENT_INT(12) THEN
- FAILED("WRONG VALUES - VA1");
- END IF;
-
- VA2 := NEW INTEGER'(1 + 2);
- IF (VA1.ALL /= IDENT_INT(12) OR
- VA2.ALL /= IDENT_INT( 3)) THEN
- FAILED("WRONG VALUES - VA2");
- END IF;
-
- VA3 := NEW INTEGER'(IDENT_INT(3) + IDENT_INT(4));
- IF (VA1.ALL /= IDENT_INT(12) OR
- VA2.ALL /= IDENT_INT( 3) OR
- VA3.ALL /= IDENT_INT( 7)) THEN
- FAILED("WRONG VALUES - VA3");
- END IF;
-
- VAA1 := NEW ATA'(NEW INTEGER'(3));
- IF VAA1.ALL.ALL /= IDENT_INT(3) THEN
- FAILED ("WRONG VALUES - VAA1");
- END IF;
-
- VAA2 := NEW ATA'(NEW INTEGER'(IDENT_INT(5)));
- IF (VAA1.ALL.ALL /= 3 OR
- VAA2.ALL.ALL /= 5 ) THEN
- FAILED ("WRONG VALUES - VAA2");
- END IF;
-
- VAA3 := NEW ATA'(NEW INTEGER'(IDENT_INT(6)));
- IF (VAA1.ALL.ALL /= 3 OR
- VAA2.ALL.ALL /= 5 OR
- VAA3.ALL.ALL /= 6 ) THEN
- FAILED ("WRONG VALUES - VAA3");
- END IF;
-
- END;
-
- RESULT;
-
-END C48006A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48006b.ada b/gcc/testsuite/ada/acats/tests/c4/c48006b.ada
deleted file mode 100644
index 001b889..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48006b.ada
+++ /dev/null
@@ -1,236 +0,0 @@
--- C48006B.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 ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW
--- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR
--- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS
--- THE VALUE OF (X).
-
--- RM 01/14/80
--- RM 01/O1/82
--- SPS 10/27/82
--- EG 07/05/84
--- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275
-
-WITH REPORT;
-
-PROCEDURE C48006B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " &
- "ALLOCATES A NEW OBJECT " &
- "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " &
- "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)");
-
- -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED)
-
- DECLARE
-
- TYPE TB0( A , B : INTEGER ) IS
- RECORD
- C : INTEGER := 7 ;
- END RECORD;
- SUBTYPE TB IS TB0( 2 , 3 );
- TYPE ATB IS ACCESS TB ;
- TYPE ATB0 IS ACCESS TB0 ;
- VB1 , VB2 : ATB ;
- VB01 , VB02 : ATB0 ;
-
- TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
- SUBTYPE ARR IS ARR0( 1..4 );
- TYPE A_ARR IS ACCESS ARR ;
- TYPE A_ARR0 IS ACCESS ARR0 ;
- VARR1 , VARR2 : A_ARR ;
- VARR01 , VARR02 : A_ARR0 ;
-
- BEGIN
-
- VB1 := NEW TB'( 2 , 3 , 5 );
- IF ( VB1.A /=IDENT_INT( 2) OR
- VB1.B /=IDENT_INT( 3) OR
- VB1.C /=IDENT_INT( 5) )
- THEN FAILED( "WRONG VALUES - B1 1" );
- END IF;
-
- VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6));
- IF ( VB2.A /= 2 OR
- VB2.B /= 3 OR
- VB2.C /= 6 OR
- VB1.A /= 2 OR
- VB1.B /= 3 OR
- VB1.C /= 5 )
- THEN FAILED( "WRONG VALUES - B1 2" );
- END IF;
-
- VB01 := NEW TB0'( 1 , 2 , 3 );
- IF ( VB01.A /=IDENT_INT( 1) OR
- VB01.B /=IDENT_INT( 2) OR
- VB01.C /=IDENT_INT( 3) )
- THEN FAILED( "WRONG VALUES - B2 1" );
- END IF;
-
- VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) ,
- IDENT_INT(6) );
- IF ( VB02.A /=IDENT_INT( 4) OR
- VB02.B /=IDENT_INT( 5) OR
- VB02.C /=IDENT_INT( 6) OR
- VB01.A /=IDENT_INT( 1) OR
- VB01.B /=IDENT_INT( 2) OR
- VB01.C /=IDENT_INT( 3) )
- THEN FAILED( "WRONG VALUES - B2 2" );
- END IF;
-
- VARR1 := NEW ARR'( 5 , 6 , 7 , 8 );
- IF ( VARR1(1) /=IDENT_INT( 5) OR
- VARR1(2) /=IDENT_INT( 6) OR
- VARR1(3) /=IDENT_INT( 7) OR
- VARR1(4) /=IDENT_INT( 8) )
- THEN FAILED( "WRONG VALUES - B3 1" );
- END IF ;
-
- VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3),
- IDENT_INT(4) );
- IF ( VARR2(1) /= 1 OR
- VARR2(2) /= 2 OR
- VARR2(3) /= 3 OR
- VARR2(4) /= 4 OR
- VARR1(1) /= 5 OR
- VARR1(2) /= 6 OR
- VARR1(3) /= 7 OR
- VARR1(4) /= 8 )
- THEN FAILED( "WRONG VALUES - B3 2" );
- END IF ;
-
- VARR01 := NEW ARR0'( 11 , 12 , 13 );
- IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR
- VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR
- VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) )
- THEN FAILED( "WRONG VALUES - B4 1" );
- END IF ;
- IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR
- VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) )
- THEN FAILED( "WRONG VALUES - B4 2" );
- END IF ;
-
- VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15));
- IF ( VARR02(1) /= 14 OR
- VARR02(2) /= 15 OR
- VARR01(INTEGER'FIRST) /= 11 OR
- VARR01(INTEGER'FIRST + 1) /= 12 OR
- VARR01(INTEGER'FIRST + 2) /= 13 )
- THEN FAILED( "WRONG VALUES - B4 3" );
- END IF ;
-
- END ;
-
- -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED)
-
- DECLARE
-
- PACKAGE P IS
- TYPE UP(A, B : INTEGER) IS PRIVATE;
--- SUBTYPE CP IS UP(1, 2);
--- TYPE A_CP IS ACCESS CP;
- TYPE A_UP IS ACCESS UP;
- CONS1_UP : CONSTANT UP;
- CONS2_UP : CONSTANT UP;
- CONS3_UP : CONSTANT UP;
- CONS4_UP : CONSTANT UP;
--- PROCEDURE CHECK1 (X : A_CP);
--- PROCEDURE CHECK2 (X, Y : A_CP);
- PROCEDURE CHECK3 (X : A_UP);
- PROCEDURE CHECK4 (X, Y : A_UP);
- PRIVATE
- TYPE UP(A, B : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
- CONS1_UP : CONSTANT UP := (1, 2, 3);
- CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2),
- IDENT_INT(4));
- CONS3_UP : CONSTANT UP := (7, 8, 9);
- CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11),
- IDENT_INT(12));
- END P;
-
- USE P;
-
--- V_A_CP1, V_A_CP2 : A_CP;
- V_A_UP1, V_A_UP2 : A_UP;
-
- PACKAGE BODY P IS
--- PROCEDURE CHECK1 (X : A_CP) IS
--- BEGIN
--- IF (X.A /= IDENT_INT(1) OR
--- X.B /= IDENT_INT(2) OR
--- X.C /= IDENT_INT(3)) THEN
--- FAILED ("WRONG VALUES - CP1");
--- END IF;
--- END CHECK1;
--- PROCEDURE CHECK2 (X, Y : A_CP) IS
--- BEGIN
--- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR
--- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN
--- FAILED ("WRONG VALUES - CP2");
--- END IF;
--- END CHECK2;
- PROCEDURE CHECK3 (X : A_UP) IS
- BEGIN
- IF (X.A /= IDENT_INT(7) OR
- X.B /= IDENT_INT(8) OR
- X.C /= IDENT_INT(9)) THEN
- FAILED ("WRONG VALUES - UP1");
- END IF;
- END CHECK3;
- PROCEDURE CHECK4 (X, Y : A_UP) IS
- BEGIN
- IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR
- Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN
- FAILED ("WRONG VALUES - UP2");
- END IF;
- END CHECK4;
- END P;
-
- BEGIN
-
--- V_A_CP1 := NEW CP'(CONS1_UP);
--- CHECK1(V_A_CP1);
-
--- V_A_CP2 := NEW CP'(CONS2_UP);
--- CHECK2(V_A_CP1, V_A_CP2);
-
- V_A_UP1 := NEW P.UP'(CONS3_UP);
- CHECK3(V_A_UP1);
-
- V_A_UP2 := NEW P.UP'(CONS4_UP);
- CHECK4(V_A_UP1, V_A_UP2);
-
- END;
-
- RESULT;
-
-END C48006B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007a.ada b/gcc/testsuite/ada/acats/tests/c4/c48007a.ada
deleted file mode 100644
index 7fe88b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48007a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- C48007A.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS
--- RAISED IF T IS AN UNCONSTRAINED TYPE WITH DEFAULT DISCRIMINANTS
--- (RECORD, PRIVATE OR LIMITED) AND ONE DEFAULT DISCRIMINANT VALUE DOES
--- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE
--- TYPE.
-
--- EG 08/10/84
-
-WITH REPORT;
-
-PROCEDURE C48007A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48007A","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED TYPE WITH " &
- "DEFAULT DISCRIMINANTS");
-
- DECLARE
-
- TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS
- RECORD
- C : INTEGER := 7;
- END RECORD;
-
- PACKAGE P IS
-
- TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS
- PRIVATE;
- TYPE UL(A, B : INTEGER := 4) IS LIMITED PRIVATE;
-
- PRIVATE
-
- TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS
- RECORD
- C : INTEGER := 8;
- END RECORD;
- TYPE UL(A, B : INTEGER := 4) IS
- RECORD
- C : INTEGER := 9;
- END RECORD;
-
- END P;
-
- USE P;
-
- TYPE A_UR IS ACCESS UR(1, 9);
- TYPE A_UP IS ACCESS UP(9, 13);
- TYPE A_UL IS ACCESS UL(4, 9);
-
- VUR : A_UR;
- VUP : A_UP;
- VUL : A_UL;
-
- BEGIN
-
- BEGIN -- UR
-
- VUR := NEW UR;
- FAILED("NO EXCEPTION RAISED - UR");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - UR");
-
- END;
-
- BEGIN -- UP
-
- VUP := NEW UP;
- FAILED("NO EXCEPTION RAISED - UP");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - UP");
-
- END;
-
- BEGIN -- UL
-
- VUL := NEW UL;
- FAILED("NO EXCEPTION RAISED - UL");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - UL");
-
- END;
-
- END;
-
- RESULT;
-
-END C48007A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007b.ada b/gcc/testsuite/ada/acats/tests/c4/c48007b.ada
deleted file mode 100644
index 117e167..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48007b.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- C48007B.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS
--- RAISED IF T IS A CONSTRAINED TYPE WITH DISCRIMINANTS (RECORD, PRIVATE
--- OR LIMITED) AND AT LEAST ONE DISCRIMINANT VALUE SPECIFIED FOR T DOES
--- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE
--- TYPE.
-
--- EG 08/10/84
-
-WITH REPORT;
-
-PROCEDURE C48007B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48007B","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - CONSTRAINED TYPE WITH " &
- "DISCRIMINANT");
-
- DECLARE
-
- TYPE UR(A, B : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- PACKAGE P IS
-
- TYPE UP(A, B : INTEGER) IS PRIVATE;
- TYPE UL(A, B : INTEGER) IS LIMITED PRIVATE;
-
- PRIVATE
-
- TYPE UP(A, B : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
- TYPE UL(A, B : INTEGER) IS
- RECORD
- C : INTEGER;
- END RECORD;
-
- END P;
-
- USE P;
-
- SUBTYPE CR IS UR(1, 2);
- SUBTYPE CP IS UP(12, 13);
- SUBTYPE CL IS UL(4, 4);
-
- TYPE A_UR IS ACCESS UR(1, 9);
- TYPE A_UP IS ACCESS UP(9, 13);
- TYPE A_UL IS ACCESS UL(4, 9);
-
- VUR : A_UR;
- VUP : A_UP;
- VUL : A_UL;
-
- BEGIN
-
- BEGIN -- CR
-
- VUR := NEW CR;
- FAILED("NO EXCEPTION RAISED - CR");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CR");
-
- END;
-
- BEGIN -- CP
-
- VUP := NEW CP;
- FAILED("NO EXCEPTION RAISED - CP");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CP");
-
- END;
-
- BEGIN -- CL
-
- VUL := NEW CL;
- FAILED("NO EXCEPTION RAISED - CL");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CL");
-
- END;
-
- END;
-
- RESULT;
-
-END C48007B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007c.ada b/gcc/testsuite/ada/acats/tests/c4/c48007c.ada
deleted file mode 100644
index fff3172..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48007c.ada
+++ /dev/null
@@ -1,162 +0,0 @@
--- C48007C.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS
--- RAISED IF T IS A CONSTRAINED ARRAY TYPE AND AT LEAST ONE INDEX BOUND
--- FOR T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE
--- ALLOCATOR'S BASE TYPE.
-
--- EG 08/10/84
-
-WITH REPORT;
-
-PROCEDURE C48007C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48007C","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - CONSTRAINED ARRAY TYPE");
-
- DECLARE
-
- TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) OF
- INTEGER;
- TYPE UA3 IS ARRAY(INTEGER RANGE <>) OF UA1(1 .. 2);
-
- SUBTYPE CA11 IS UA1(1 .. 3);
- SUBTYPE CA12 IS UA1(3 .. 2);
- SUBTYPE CA21 IS UA2(1 .. 2, 1 .. 2);
- SUBTYPE CA22 IS UA2(1 .. 2, 2 .. 0);
- SUBTYPE CA31 IS UA3(1 .. 2);
- SUBTYPE CA32 IS UA3(4 .. 1);
-
- TYPE A_UA11 IS ACCESS UA1(2 .. 4);
- TYPE A_UA12 IS ACCESS UA1(4 .. 3);
- TYPE A_UA21 IS ACCESS UA2(1 .. 3, 1 .. 2);
- TYPE A_UA22 IS ACCESS UA2(1 .. 2, 2 .. 1);
- TYPE A_UA31 IS ACCESS UA3(1 .. 3);
- TYPE A_UA32 IS ACCESS UA3(3 .. 1);
-
- V11 : A_UA11;
- V12 : A_UA12;
- V21 : A_UA21;
- V22 : A_UA22;
- V31 : A_UA31;
- V32 : A_UA32;
-
- BEGIN
-
- BEGIN -- V11
-
- V11 := NEW CA11;
- FAILED("NO EXCEPTION RAISED - V11");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V11");
-
- END;
-
- BEGIN -- V12
-
- V12 := NEW CA12;
- FAILED("NO EXCEPTION RAISED - V12");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V12");
-
- END;
-
- BEGIN -- V21
-
- V21 := NEW CA21;
- FAILED("NO EXCEPTION RAISED - V21");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V21");
-
- END;
-
- BEGIN -- V22
-
- V22 := NEW CA22;
- FAILED("NO EXCEPTION RAISED - V22");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V22");
-
- END;
-
- BEGIN -- V31
-
- V31 := NEW CA31;
- FAILED("NO EXCEPTION RAISED - V31");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V31");
-
- END;
-
- BEGIN -- V32
-
- V32 := NEW CA32;
- FAILED("NO EXCEPTION RAISED - V32");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - V32");
-
- END;
-
- END;
-
- RESULT;
-
-END C48007C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48008a.ada b/gcc/testsuite/ada/acats/tests/c4/c48008a.ada
deleted file mode 100644
index 19e87aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48008a.ada
+++ /dev/null
@@ -1,345 +0,0 @@
--- C48008A.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS
--- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X
--- IS A DISCRIMINANT CONSTRAINT, AND
--- 1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING
--- DISCRIMINANT;
--- 2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A
--- CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED;
--- 3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING
--- VALUE OF THE ALLOCATOR'S BASE TYPE;
--- 4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION.
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- JBG 03/02/83
--- EG 07/05/84
--- PWB 02/05/86 CORRECTED TEST ERROR:
--- CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK,
--- SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01)
--- ADDED COMMENTS FOR CASES.
-
-WITH REPORT;
-
-PROCEDURE C48008A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " &
- "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED RECORD AND " &
- "PRIVATE TYPES");
-
- DECLARE
-
- DISC_FLAG : BOOLEAN := FALSE;
- INCR_VAL : INTEGER;
- FUNCTION INCR(A : INTEGER) RETURN INTEGER;
-
- SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
- SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
- SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
-
- TYPE REC (A : I2_9) IS
- RECORD
- B : INTEGER := INCR(2);
- END RECORD;
-
- TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
-
- TYPE T_REC (C : I1_10) IS
- RECORD
- D : REC(C);
- END RECORD;
-
- TYPE T_ARR (C : I1_10) IS
- RECORD
- D : ARR(2..C);
- E : ARR(C..9);
- END RECORD;
-
- TYPE T_REC_REC (A : I1_10) IS
- RECORD
- B : T_REC(A);
- END RECORD;
-
- TYPE T_REC_ARR (A : I1_10) IS
- RECORD
- B : T_ARR(A);
- END RECORD;
-
- TYPE TB ( A : I1_7 ) IS
- RECORD
- R : INTEGER := INCR(1);
- END RECORD;
-
- TYPE UR (A : INTEGER) IS
- RECORD
- B : I2_9 := INCR(1);
- END RECORD;
-
- TYPE A_T_REC_REC IS ACCESS T_REC_REC;
- TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
- TYPE ATB IS ACCESS TB;
- TYPE ACTB IS ACCESS TB(3);
- TYPE A_UR IS ACCESS UR;
-
- VA_T_REC_REC : A_T_REC_REC;
- VA_T_REC_ARR : A_T_REC_ARR;
- VB : ATB;
- VCB : ACTB;
- V_A_UR : A_UR;
-
- BOOL : BOOLEAN;
-
- FUNCTION DISC (A : INTEGER) RETURN INTEGER;
-
-
- PACKAGE P IS
- TYPE PRIV( A : I1_10 := DISC(8) ) IS PRIVATE;
- CONS_PRIV : CONSTANT PRIV;
- PRIVATE
- TYPE PRIV( A : I1_10 := DISC(8) ) IS
- RECORD
- R : INTEGER := INCR(1);
- END RECORD;
- CONS_PRIV : CONSTANT PRIV := (2, 3);
- END P;
-
- TYPE A_PRIV IS ACCESS P.PRIV;
- TYPE A_CPRIV IS ACCESS P.PRIV (3);
-
- VP : A_PRIV;
- VCP : A_CPRIV;
-
- PROCEDURE PREC_REC (X : A_T_REC_REC) IS
- BEGIN
- NULL;
- END PREC_REC;
-
- PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS
- BEGIN
- NULL;
- END PREC_ARR;
-
- PROCEDURE PB (X : ATB) IS
- BEGIN
- NULL;
- END PB;
-
- PROCEDURE PCB (X : ACTB) IS
- BEGIN
- NULL;
- END PCB;
-
- PROCEDURE PPRIV (X : A_PRIV) IS
- BEGIN
- NULL;
- END PPRIV;
-
- PROCEDURE PCPRIV (X : A_CPRIV) IS
- BEGIN
- NULL;
- END PCPRIV;
-
- FUNCTION DISC (A : INTEGER) RETURN INTEGER IS
- BEGIN
- DISC_FLAG := TRUE;
- RETURN A;
- END DISC;
-
- FUNCTION INCR(A : INTEGER) RETURN INTEGER IS
- BEGIN
- INCR_VAL := IDENT_INT(INCR_VAL+1);
- RETURN A;
- END INCR;
-
- PROCEDURE INCR_CHECK(CASE_ID : STRING) IS
- BEGIN
- IF INCR_VAL /= IDENT_INT(0) THEN
- COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " &
- "CASE " & CASE_ID);
- END IF;
- END INCR_CHECK;
-
- BEGIN
-
- BEGIN -- A1A: 0 ILLEGAL FOR TB.A.
- INCR_VAL := 0;
- VB := NEW TB (A => 0);
- FAILED ("NO EXCEPTION RAISED - CASE A1A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A1A");
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE A1A" );
- END; -- A1A
-
- BEGIN -- A1B: 8 ILLEGAL IN I1_7.
- INCR_VAL := 0;
- VB := NEW TB (A => I1_7'(IDENT_INT(8)));
- FAILED ("NO EXCEPTION RAISED - CASE A1B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A1B");
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE A1B");
- END; -- A1B
-
- BEGIN -- A1C: 8 ILLEGAL FOR TB.A.
- INCR_VAL := 0;
- PB(NEW TB (A => 8));
- FAILED ("NO EXCEPTION RAISED - CASE A1C");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A1C");
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE A1C");
- END; --A1C
-
- BEGIN --A1D: 0 ILLEGAL FOR TB.A.
- INCR_VAL := 0;
- BOOL := ATB'(NEW TB(A => 0)) = NULL;
- FAILED ("NO EXCEPTION RAISED - CASE A1D");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A1D");
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE A1D");
- END; --A1D
-
- BEGIN --A1E: 11 ILLEGAL FOR PRIV.A.
- DISC_FLAG := FALSE;
- INCR_VAL := 0;
- VP := NEW P.PRIV(11);
- FAILED("NO EXCEPTION RAISED - CASE A1E");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF DISC_FLAG THEN
- FAILED ("DISCR DEFAULT EVALUATED WHEN " &
- "EXPLICIT VALUE WAS PROVIDED - A1E");
- END IF;
- INCR_CHECK("A1E");
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CASE A1E");
- END; -- A1E
-
- BEGIN -- A2A: 1 ILLEGAL FOR REC.A.
- INCR_VAL := 0;
- VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1)));
- FAILED ("NO EXCEPTION RAISED - CASE A2A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A2A");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A2A");
- END; -- A2A
-
- BEGIN --A2B: 10 ILLEGAL FOR REC.A.
- INCR_VAL := 0;
- VA_T_REC_REC := NEW T_REC_REC (10);
- FAILED ("NO EXCEPTION RAISED - CASE A2B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A2B");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A2B");
- END; -- A2B
-
- BEGIN -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST.
- INCR_VAL := 0;
- PREC_ARR (NEW T_REC_ARR (1));
- FAILED ("NO EXCEPTION RAISED - CASE A2C");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK ("A2C");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A2C");
- END; -- A2C
-
- BEGIN -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST.
- INCR_VAL := 0;
- BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL;
- FAILED ("NO EXCEPTION RAISED - CASE A2D");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK ("A2D");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A2D");
- END; -- A2D
-
- BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE.
- INCR_VAL := 0;
- VCB := NEW TB (4);
- FAILED ("NO EXCEPTION RAISED - CASE A3A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A3A");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A3A");
- END; -- A3A
-
- BEGIN -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE.
- INCR_VAL := 0;
- PCB (NEW TB (4));
- FAILED ("NO EXCEPTION RAISED - CASE A3B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A3B");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A3B");
- END; -- A3B
-
- BEGIN -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB.
- INCR_VAL := 0;
- BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL;
- FAILED ("NO EXCEPTION RAISED - CASE A3C");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- INCR_CHECK("A3C");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A3C");
- END; -- A3C
-
- BEGIN -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION.
- INCR_VAL := 0;
- V_A_UR := NEW UR(4);
- FAILED ("NO EXCEPTION RAISED - CASE A4A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE A4A");
- END; -- A4A
-
- END;
-
- RESULT;
-
-END C48008A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48008c.ada b/gcc/testsuite/ada/acats/tests/c4/c48008c.ada
deleted file mode 100644
index 39f564d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48008c.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C48008C.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS
--- RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) S, X
--- IS AN INDEX CONSTRAINT, AND THE BOUNDS OF X ARE NOT COMPATIBLE WITH
--- AN INDEX SUBTYPE OF T.
-
--- RM 01/08/80
--- NL 10/13/81
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48008C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48008C","FOR ALLOCATORS OF THE FORM 'NEW T X', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED ARRAY TYPE");
-
- DECLARE
-
- SUBTYPE TWO IS INTEGER RANGE 1..2;
- TYPE TF IS ARRAY( TWO RANGE <> , TWO RANGE <> ) OF INTEGER;
- TYPE ATF IS ACCESS TF;
- VF : ATF;
-
- BEGIN
-
- BEGIN
- VF := NEW TF ( 0..1 , 1..2 );
- FAILED ("NO EXCEPTION RAISED - CASE 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 1");
- END;
-
- BEGIN
- VF := NEW TF(1 .. 2, 2 .. IDENT_INT(3));
- FAILED ("NO EXCEPTION RAISED - CASE 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2");
- END;
-
- END;
-
- RESULT;
-
-END C48008C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009a.ada b/gcc/testsuite/ada/acats/tests/c4/c48009a.ada
deleted file mode 100644
index fa0d407..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C48009A.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS A SCALAR SUBTYPE AND X IS OUTSIDE THE RANGE OF T,
--- OR IS WITHIN T'S RANGE AND OUTSIDE OF THE RANGE OF VALUES PERMITTED
--- FOR OBJECTS DESIGNATED BY VALUES OF THE ALLOCATOR'S BASE TYPE.
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- JBG 03/02/83
--- EG 07/05/84
--- EDS 12/01/97 ADDED IDENT_INT TO MAKE EXPRESSION NON-STATIC.
-
-WITH REPORT;
-
-PROCEDURE C48009A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C48009A" , "FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK" &
- " THAT CONSTRAINT_ERROR IS RAISED WHEN" &
- " APPROPRIATE - SCALAR TYPES");
- DECLARE -- A1
-
- SUBTYPE TA IS INTEGER RANGE 1..7;
- TYPE ATA IS ACCESS TA;
- VA : ATA;
-
- BEGIN
-
- VA := NEW TA'( IDENT_INT(0) );
- FAILED ("NO EXCEPTION RAISED - 1");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ( "WRONG EXCEPTION RAISED - 1" );
-
- END; -- A1
-
- DECLARE -- A2
-
- SUBTYPE T1_7 IS INTEGER RANGE 1..7;
- TYPE AT2_6 IS ACCESS INTEGER RANGE 2..6;
- VAT2_6 : AT2_6;
-
- BEGIN
-
- BEGIN
-
- VAT2_6 := NEW T1_7'(1);
- FAILED ("NO EXCEPTION RAISED - 2");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
-
- END;
-
- BEGIN
-
- VAT2_6 := NEW T1_7'(7);
- FAILED ("NO EXCEPTION RAISED - 3");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
-
- END;
-
- END; -- A2
-
- RESULT;
-
-END C48009A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009b.ada b/gcc/testsuite/ada/acats/tests/c4/c48009b.ada
deleted file mode 100644
index d74d902..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009b.ada
+++ /dev/null
@@ -1,255 +0,0 @@
--- C48009B.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
--- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
--- X:
--- 1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING
--- DISCRIMINANT OF T.
--- 2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE
--- DECLARATION OF THE ALLOCATOR'S BASE TYPE.
--- 3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE
--- BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT
--- CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT.
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- JBG 03/02/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48009B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
- "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED RECORD AND " &
- "PRIVATE TYPES");
-
- DECLARE
-
- SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
- SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
- SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
-
- TYPE REC (A : I2_9) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
-
- TYPE T_REC (C : I1_10) IS
- RECORD
- D : REC(C);
- END RECORD;
-
- TYPE T_ARR (C : I1_10) IS
- RECORD
- D : ARR(2..C);
- E : ARR(C..9);
- END RECORD;
-
- TYPE T_REC_REC (A : I1_10) IS
- RECORD
- B : T_REC(A);
- END RECORD;
-
- TYPE T_REC_ARR (A : I1_10) IS
- RECORD
- B : T_ARR(A);
- END RECORD;
-
- TYPE TB ( A : I1_7 ) IS
- RECORD
- R : INTEGER;
- END RECORD;
-
- TYPE A_T_REC_REC IS ACCESS T_REC_REC;
- TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
- TYPE ATB IS ACCESS TB;
- TYPE ACTB IS ACCESS TB(3);
-
- VA_T_REC_REC : A_T_REC_REC;
- VA_T_REC_ARR : A_T_REC_ARR;
- VB : ATB;
- VCB : ACTB;
-
- PACKAGE P IS
- TYPE PRIV( A : I1_10 ) IS PRIVATE;
- CONS_PRIV : CONSTANT PRIV;
- PRIVATE
- TYPE PRIV( A : I1_10 ) IS
- RECORD
- R : INTEGER;
- END RECORD;
- CONS_PRIV : CONSTANT PRIV := (2, 3);
- END P;
-
- USE P;
-
- TYPE A_PRIV IS ACCESS P.PRIV;
- TYPE A_CPRIV IS ACCESS P.PRIV (3);
-
- VP : A_PRIV;
- VCP : A_CPRIV;
-
- FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
- BEGIN
- IF EQUAL(1, 1) THEN
- RETURN NEW P.PRIV'(X);
- ELSE
- RETURN NULL;
- END IF;
- END ALLOC1;
- FUNCTION ALLOC2(X : TB) RETURN ACTB IS
- BEGIN
- IF EQUAL(1, 1) THEN
- RETURN NEW TB'(X);
- ELSE
- RETURN NULL;
- END IF;
- END ALLOC2;
-
- BEGIN
-
- BEGIN -- B1
- VB := NEW TB'(A => IDENT_INT(0), R => 1);
- FAILED ("NO EXCEPTION RAISED - CASE 1A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
- END;
-
- BEGIN
- VB := NEW TB'(A => 8, R => 1);
- FAILED ("NO EXCEPTION RAISED - CASE 1B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
- END; -- B1
-
- BEGIN -- B2
- VCB := NEW TB'(2, 3);
- FAILED ("NO EXCEPTION RAISED - CASE 2A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
- END;
-
- BEGIN
- IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
- FAILED ("IMPOSSIBLE - CASE 2B");
- END IF;
- FAILED ("NO EXCEPTION RAISED - CASE 2B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
- END;
-
- BEGIN
-
- IF ALLOC1(CONS_PRIV) = NULL THEN
- FAILED ("IMPOSSIBLE - CASE 2C");
- END IF;
- FAILED ("NO EXCEPTION RAISED - CASE 2C");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
-
- END; -- B2
-
- BEGIN -- B3
-
- VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
- FAILED ("NO EXCEPTION RAISED - CASE 3A");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
-
- END;
-
- BEGIN
-
- VA_T_REC_REC := NEW T_REC_REC'(10,
- (10, (A => 10)));
- FAILED ("NO EXCEPTION RAISED - CASE 3B");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
-
- END;
-
- BEGIN
-
- VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
- (OTHERS => 2)));
- FAILED ("NO EXCEPTION RAISED - CASE 3C");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
-
- END;
-
- BEGIN
-
- VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
- (OTHERS => 2)));
- FAILED ("NO EXCEPTION RAISED - CASE 3D");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
-
- END;
-
- END;
-
- RESULT;
-
-END C48009B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009c.ada b/gcc/testsuite/ada/acats/tests/c4/c48009c.ada
deleted file mode 100644
index 80d18f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009c.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- C48009C.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS A CONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
--- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
--- X:
--- 1) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR T.
--- 2) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE SPECIFIED
--- IN THE DECLARATION OF THE ALLOCATOR'S BASE TYPE.
--- 3) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE IN THE
--- ACCESS TO ACCESS CASE.
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48009C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48009C","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - CONSTRAINED RECORD TYPES");
-
- DECLARE
-
- TYPE TC0(A, B : INTEGER) IS
- RECORD
- C : INTEGER RANGE 1 .. 7;
- END RECORD;
- SUBTYPE TC IS TC0(2, 3);
- TYPE ATC IS ACCESS TC0(2, 3);
- SUBTYPE TC4_5 IS TC0(IDENT_INT(4), IDENT_INT(5));
- VC : ATC;
-
- BEGIN
-
- BEGIN
- VC := NEW TC'(102, 3, 4);
- FAILED ("NO EXCEPTION RAISED - CASE 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CASE 1");
- END;
-
- BEGIN
- VC := NEW TC4_5'(IDENT_INT(4), IDENT_INT(5), 1);
- FAILED ("NO EXCEPTION RAISED - CASE 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED - CASE 2");
- END;
-
- END;
-
- DECLARE
-
- TYPE UR(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- TYPE A_UR IS ACCESS UR;
- SUBTYPE CA_UR IS A_UR(2);
- TYPE A_CA_UR IS ACCESS CA_UR;
-
- V : A_CA_UR;
-
- BEGIN
-
- V := NEW CA_UR'(NEW UR'(A => IDENT_INT(3)));
- FAILED ("NO EXCEPTION RAISED - CASE 3");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3");
-
- END;
-
- RESULT;
-
-END C48009C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009d.ada b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada
deleted file mode 100644
index 0c5d3d6..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009d.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C48009D.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S)
--- S,
--- 1) X HAS TOO MANY VALUES FOR S;
--- 2) A NAMED NON-NULL BOUND OF X LIES OUTSIDE S'S RANGE;
--- 3) THE BOUND'S OF X ARE NOT EQUAL TO BOUNDS SPECIFIED FOR THE
--- ALLOCATOR'S DESIGNATED BASE TYPE. (THEY ARE EQUAL TO THE BOUNDS
--- SPECIFIED FOR T).
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- JBG 03/03/83
--- EG 07/05/84
--- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
--- KAS 11/14/95 FOR SLIDING ASSIGNMENT, CHANGED FAIL TO COMMENT ON LANGUAGE
--- KAS 12/02/95 INCLUDED SECOND CASE
--- PWN 05/03/96 Enforced Ada 95 sliding rules
-
-WITH REPORT;
-
-PROCEDURE C48009D IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("C48009D","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED ARRAY TYPES");
- DECLARE
-
- SUBTYPE TWO IS INTEGER RANGE 1 .. 2;
- SUBTYPE TWON IS INTEGER RANGE IDENT_INT(1) .. IDENT_INT(2);
- TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE TD IS ARRAY(TWO RANGE <>) OF INTEGER RANGE 1 .. 7;
- TYPE TDN IS ARRAY(TWON RANGE <>) OF INTEGER RANGE 1 .. 7;
- TYPE ATD IS ACCESS TD;
- TYPE ATDN IS ACCESS TDN;
- TYPE A_UA IS ACCESS UA;
- TYPE A_CA IS ACCESS UA(3 .. 4);
- TYPE A_CAN IS ACCESS UA(4 .. 3);
- VD : ATD;
- VDN : ATDN;
- V_A_CA : A_CA;
- V_A_CAN : A_CAN;
-
- BEGIN
-
- BEGIN
- VD := NEW TD'(3, 4, 5);
- FAILED ("NO EXCEPTION RAISED - CASE 1A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
- END;
-
- BEGIN
- VDN := NEW TDN'(3, 4, 5);
- FAILED ("NO EXCEPTION RAISED - CASE 1B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
- END;
-
- BEGIN
- VD := NEW TD'(IDENT_INT(0) .. 2 => 6);
- FAILED ("NO EXCEPTION RAISED - CASE 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2");
- END;
-
- BEGIN
- V_A_CA := NEW UA'(2 .. 3 => 3);
- COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3A");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
- END;
-
- BEGIN
- V_A_CAN := NEW UA'(IDENT_INT(3) .. IDENT_INT(2) => 3);
- COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3B");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
- END;
-
- END;
-
- RESULT;
-
-END C48009D;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009e.ada b/gcc/testsuite/ada/acats/tests/c4/c48009e.ada
deleted file mode 100644
index e273192..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009e.ada
+++ /dev/null
@@ -1,224 +0,0 @@
--- C48009E.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND:
--- 1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE
--- CORRESPONDING BOUND FOR T;
--- 2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN
--- THE DECLARATION OF THE ALLOCATOR'S BASE TYPE;
--- 3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS
--- REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE.
-
- -- RM 01/08/80
- -- NL 10/13/81
- -- SPS 10/26/82
- -- JBG 03/03/83
- -- EG 07/05/84
- -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
- -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE
- -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS
- -- PWN 05/03/96 Enforced Ada 95 sliding rules
- -- PWN 10/24/96 Adjusted expected results for Ada 95.
- -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES
- -- MRM 12/16/96 Removed problem code from withdrawn version of test, and
- -- implemented a dereference-index check to ensure Ada95
- -- required behavior.
- -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does
- -- not occur
- WITH REPORT;
-
- PROCEDURE C48009E IS
-
- USE REPORT ;
-
- BEGIN
-
- TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - CONSTRAINED ARRAY TYPES");
- DECLARE
-
- TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER;
- TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER;
- TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER;
- SUBTYPE CA2_6 IS UA(2 .. 6);
- SUBTYPE CA1_4 IS UA(1 .. 4);
- SUBTYPE CA1_6 IS UA(1 .. 6);
- SUBTYPE CA4_1 IS UA(4 .. 1);
- SUBTYPE CA4_2 IS UA(4 .. 2);
-
- TYPE A_CA3_2 IS ACCESS CA3_2;
- TYPE A_SA1_3 IS ACCESS SA1_3;
- TYPE A_NA1_3 IS ACCESS NA1_3;
- TYPE A_CA1_5 IS ACCESS UA(1 .. 5);
- TYPE A_CA4_2 IS ACCESS CA4_2;
-
- V_A_CA3_2 : A_CA3_2;
- V_A_SA1_3 : A_SA1_3;
- V_A_NA1_3 : A_NA1_3;
- V_A_CA1_5 : A_CA1_5;
-
- FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS
- BEGIN
- IF EQUAL(1, 1) THEN
- RETURN NEW CA2_6'(X);
- ELSE
- RETURN NULL;
- END IF;
- END ALLOC1;
- FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS
- BEGIN
- IF EQUAL(1, 1) THEN
- RETURN NEW CA4_1'(X);
- ELSE
- RETURN NULL;
- END IF;
- END ALLOC2;
-
- BEGIN
-
- BEGIN
- V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2)
- => 5);
- FAILED ("NO EXCEPTION RAISED - CASE 1A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
- END;
-
- BEGIN
- V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4);
- FAILED ("NO EXCEPTION RAISED - CASE 1B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
- END;
-
- BEGIN
- -- note that ALLOC1 returns A_CA1_5, so both
- -- (1) and (5) are valid index references!
- IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN
- FAILED ("Wrong Value Returned - CASE 2A");
- ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN
- FAILED ("Unlikely Index Case - CASE 2A");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - CASE 2A");
- END;
-
- BEGIN
- IF ALLOC2((4 .. 1 => 3)) = NULL THEN
- FAILED ("IMPOSSIBLE - CASE 2B");
- END IF;
- COMMENT ("ADA 95 SLIDING ASSIGNMENT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("ADA 83 NON-SLIDING ASSIGNMENT");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
- END;
-
- BEGIN
- V_A_SA1_3 := NEW SA1_3'(1, 2);
- FAILED ("NO EXCEPTION RAISED - CASE 3A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
- END;
-
- BEGIN
- V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6);
- FAILED ("NO EXCEPTION RAISED - CASE 3B");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
- END;
-
- BEGIN
- V_A_NA1_3 := NEW NA1_3'(1, 2);
- FAILED ("NO EXCEPTION RAISED - CASE 3C");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
- END;
-
- BEGIN -- SATISFIES T BUT NOT BASE TYPE.
- V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4);
- FAILED ("NO EXCEPTION RAISED - CASE 3D");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
- END;
-
- BEGIN -- SATISFIES T BUT NOT BASE TYPE.
- V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6);
- FAILED ("NO EXCEPTION RAISED - CASE 3E");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3E");
- END;
-
- BEGIN -- SATISFIES BASE TYPE BUT NOT T.
- V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5);
- FAILED ("NO EXCEPTION RAISED - CASE 3F");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3F");
- END;
-
- BEGIN -- SATISFIES BASE TYPE BUT NOT T.
- V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5);
- FAILED ("NO EXCEPTION RAISED - CASE 3G");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CASE 3G");
- END;
-
- END ;
-
- RESULT ;
-
- END C48009E ;
-
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009f.ada b/gcc/testsuite/ada/acats/tests/c4/c48009f.ada
deleted file mode 100644
index d02e2c1..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009f.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C48009F.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS A CONSTRAINED OR UNCONSTRAINED MULTI-DIMENSIONAL
--- ARRAY TYPE AND ALL COMPONENTS OF X DO NOT HAVE THE SAME LENGTH OR
--- BOUNDS.
-
--- RM 01/08/80
--- NL 10/13/81
--- SPS 10/26/82
--- JBG 03/03/83
--- EG 07/05/84
-
-WITH REPORT;
-
-PROCEDURE C48009F IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48009F","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "X IS AN ILL-FORMED MULTIDIMENSIONAL AGGREGATE");
-
- DECLARE
-
- TYPE TG00 IS ARRAY( 4..2 ) OF INTEGER;
- TYPE TG10 IS ARRAY( 1..2 ) OF INTEGER;
- TYPE TG20 IS ARRAY( INTEGER RANGE <> ) OF INTEGER;
-
- TYPE TG0 IS ARRAY( 3..2 ) OF TG00;
- TYPE TG1 IS ARRAY( 1..2 ) OF TG10;
- TYPE TG2 IS ARRAY( INTEGER RANGE <> ) OF TG20(1..3);
-
- TYPE ATG0 IS ACCESS TG0;
- TYPE ATG1 IS ACCESS TG1;
- TYPE ATG2 IS ACCESS TG2;
-
- VG0 : ATG0;
- VG1 : ATG1;
- VG2 : ATG2;
-
- BEGIN
-
- BEGIN
- VG0 := NEW TG0 '( 5..4 => ( 3..1 => 2 ) );
- FAILED ("NO EXCEPTION RAISED - CASE 0");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE 0" );
- END;
-
- BEGIN
- VG1 := NEW TG1 '( ( 1 , 2 ) , ( 3 , 4 , 5 ) );
- FAILED ("NO EXCEPTION RAISED - CASE 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE 1" );
- END;
-
- BEGIN
- VG2 := NEW TG2'( 1 => ( 1..2 => 7) , 2 => ( 1..3 => 7));
- FAILED ("NO EXCEPTION RAISED - CASE 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - CASE 2" );
- END;
-
- END;
-
- RESULT;
-
-END C48009F;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009g.ada b/gcc/testsuite/ada/acats/tests/c4/c48009g.ada
deleted file mode 100644
index 13fec94..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009g.ada
+++ /dev/null
@@ -1,209 +0,0 @@
--- C48009G.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:
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT
--- CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS
--- TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS
--- OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T.
-
--- HISTORY:
--- EG 08/30/84 CREATED ORIGINAL TEST.
--- JET 01/05/87 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
--- OPTIMIZATION.
-
-WITH REPORT;
-
-PROCEDURE C48009G IS
-
- USE REPORT;
-
- GENERIC
- TYPE G_TYPE IS PRIVATE;
- FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN;
-
- FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF (IDENT_INT(3) = 3) AND (X = Y) THEN
- RETURN TRUE;
- ELSE
- RETURN FALSE;
- END IF;
- END EQUAL_G;
-
-BEGIN
-
- TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - CONSTRAINED ACCESS TYPE");
-
- DECLARE
-
- TYPE INT IS RANGE 1 .. 5;
-
- TYPE UR(A : INT) IS
- RECORD
- B : INTEGER;
- END RECORD;
- TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER;
-
- PACKAGE P IS
- TYPE UP(A, B : INT) IS PRIVATE;
- TYPE UL(A, B : INT) IS LIMITED PRIVATE;
- CONS_UP : CONSTANT UP;
- PRIVATE
- TYPE UP(A, B : INT) IS
- RECORD
- C : INTEGER;
- END RECORD;
- TYPE UL(A, B : INT) IS
- RECORD
- C : INTEGER;
- END RECORD;
- CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3)));
- END P;
-
- TYPE A_UR IS ACCESS UR;
- TYPE A_UA IS ACCESS UA;
- TYPE A_UP IS ACCESS P.UP;
- TYPE A_UL IS ACCESS P.UL;
-
- SUBTYPE CA_UR IS A_UR(2);
- SUBTYPE CA_UA IS A_UA(2 .. 3);
- SUBTYPE CA_UP IS A_UP(3, 2);
- SUBTYPE CA_UL IS A_UL(2, 4);
-
- TYPE A_CA_UR IS ACCESS CA_UR;
- TYPE A_CA_UA IS ACCESS CA_UA;
- TYPE A_CA_UP IS ACCESS CA_UP;
- TYPE A_CA_UL IS ACCESS CA_UL;
-
- V_A_CA_UR : A_CA_UR;
- V_A_CA_UA : A_CA_UA;
- V_A_CA_UP : A_CA_UP;
- V_A_CA_UL : A_CA_UL;
-
- FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR);
- FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA);
- FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP);
- FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL);
-
- BEGIN
-
- BEGIN
- V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2))));
-
- IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
- FAILED ("NO EXCEPTION RAISED - UR");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UR");
- END;
-
- BEGIN
- V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2,
- 2 => IDENT_INT(3)));
-
- IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
- FAILED ("NO EXCEPTION RAISED - UA");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UA");
- END;
-
- BEGIN
- V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP));
-
- IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
- FAILED ("NO EXCEPTION RAISED - UP");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UP");
- END;
-
- BEGIN
- V_A_CA_UR := NEW CA_UR'(NULL);
-
- IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
- COMMENT ("NO EXCEPTION RAISED - UR");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - UR");
- END;
-
- BEGIN
- V_A_CA_UA := NEW CA_UA'(NULL);
-
- IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
- COMMENT ("NO EXCEPTION RAISED - UA");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - UA");
- END;
-
- BEGIN
- V_A_CA_UP := NEW CA_UP'(NULL);
-
- IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
- COMMENT ("NO EXCEPTION RAISED - UP");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - UP");
- END;
-
- BEGIN
- V_A_CA_UL := NEW CA_UL'(NULL);
-
- IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN
- COMMENT ("NO EXCEPTION RAISED - UL");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - UL");
- END;
-
- END;
-
- RESULT;
-
-END C48009G;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009h.ada b/gcc/testsuite/ada/acats/tests/c4/c48009h.ada
deleted file mode 100644
index 661793b..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009h.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C48009H.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS AN (UNCONSTRAINED) ACCESS TYPE, THE DESIGNATED TYPE
--- FOR T'BASE IS CONSTRAINED, AND THE OBJECT DESIGNATED BY X DOES NOT
--- HAVE DISCRIMINANTS OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING
--- VALUES FOR T'S DESIGNATED TYPE.
-
--- EG 08/30/84
-
-WITH REPORT;
-
-PROCEDURE C48009H IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48009H","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - UNCONSTRAINED ACCESS TYPE OF A " &
- "CONSTRAINED TYPE");
-
- DECLARE
-
- TYPE UR(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
-
- PACKAGE P IS
- TYPE UP(A : INTEGER) IS PRIVATE;
- TYPE UL(A : INTEGER) IS LIMITED PRIVATE;
- PRIVATE
- TYPE UP(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UL(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END P;
-
- TYPE A_CR IS ACCESS UR(IDENT_INT(2));
- TYPE A_CA IS ACCESS UA(2 .. IDENT_INT(4));
- TYPE A_CP IS ACCESS P.UP(3);
- TYPE A_CL IS ACCESS P.UL(4);
-
- TYPE AA_CR IS ACCESS A_CR;
- TYPE AA_CA IS ACCESS A_CA;
- TYPE AA_CP IS ACCESS A_CP;
- TYPE AA_CL IS ACCESS A_CL;
-
- V_AA_CR : AA_CR;
- V_AA_CA : AA_CA;
- V_AA_CP : AA_CP;
- V_AA_CL : AA_CL;
-
- BEGIN
-
- BEGIN
- V_AA_CR := NEW A_CR'(NEW UR(3));
- FAILED ("NO EXCEPTION RAISED - CR");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CR");
- END;
-
- BEGIN
- V_AA_CA := NEW A_CA'(NEW UA(IDENT_INT(3) .. 5));
- FAILED ("NO EXCEPTION RAISED - CA");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CA");
- END;
-
- BEGIN
- V_AA_CP := NEW A_CP'(NEW P.UP(IDENT_INT(4)));
- FAILED ("NO EXCEPTION RAISED - CP");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CP");
- END;
-
- BEGIN
- V_AA_CL := NEW A_CL'(NEW P.UL(5));
- FAILED ("NO EXCEPTION RAISED - CL");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CL");
- END;
-
- END;
-
- RESULT;
-
-END C48009H;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009i.ada b/gcc/testsuite/ada/acats/tests/c4/c48009i.ada
deleted file mode 100644
index d59b4dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009i.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C48009I.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF THE DESIGNATED TYPE FOR "NEW T'(X)" IS A CONSTRAINED
--- ACCESS TYPE, CA, T IS CA'BASE, AND A DISCRIMINANT OR INDEX VALUE OF X
--- DOES NOT EQUAL A VALUE SPECIFIED FOR CA.
-
--- EG 08/30/84
-
-WITH REPORT;
-
-PROCEDURE C48009I IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48009I","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - ACCESS TYPE OF CONSTRAINED " &
- "ACCESS TYPE");
-
- DECLARE
-
- TYPE UR(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
-
- PACKAGE P IS
- TYPE UP(A : INTEGER) IS PRIVATE;
- TYPE UL(A : INTEGER) IS LIMITED PRIVATE;
- PRIVATE
- TYPE UP(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UL(A : INTEGER) IS
- RECORD
- NULL;
- END RECORD;
- END P;
-
- TYPE A_UR IS ACCESS UR;
- TYPE A_UA IS ACCESS UA;
- TYPE A_UP IS ACCESS P.UP;
- TYPE A_UL IS ACCESS P.UL;
-
- TYPE AC_A_UR IS ACCESS A_UR(2);
- TYPE AC_A_UA IS ACCESS A_UA(2 .. 4);
- TYPE AC_A_UP IS ACCESS A_UP(3);
- TYPE AC_A_UL IS ACCESS A_UL(4);
-
- V_AC_A_UR : AC_A_UR;
- V_AC_A_UA : AC_A_UA;
- V_AC_A_UP : AC_A_UP;
- V_AC_A_UL : AC_A_UL;
-
- BEGIN
-
- BEGIN
- V_AC_A_UR := NEW A_UR'(NEW UR(3));
- FAILED ("NO EXCEPTION RAISED - UR");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UR");
- END;
-
- BEGIN
- V_AC_A_UA := NEW A_UA'(NEW UA(3 .. 5));
- FAILED ("NO EXCEPTION RAISED - UA");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UA");
- END;
-
- BEGIN
- V_AC_A_UP := NEW A_UP'(NEW P.UP(IDENT_INT(4)));
- FAILED ("NO EXCEPTION RAISED - UP");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UP");
- END;
-
- BEGIN
- V_AC_A_UL := NEW A_UL'(NEW P.UL(IDENT_INT(5)));
- FAILED ("NO EXCEPTION RAISED - UL");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UL");
- END;
-
- END;
-
- RESULT;
-
-END C48009I;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009j.ada b/gcc/testsuite/ada/acats/tests/c4/c48009j.ada
deleted file mode 100644
index c384f38..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48009j.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- C48009J.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.
---*
--- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
--- IS RAISED IF T IS AN UNCONSTRAINED ACCESS TYPE, ITS DESIGNATED TYPE
--- IS ALSO UNCONSTRAINED, AND A DISCRIMINANT VALUE FOR X LIES OUTSIDE
--- THE RANGE OF THE CORRESPONDING DISCRIMINANT SPECIFICATION FOR THE
--- DESIGNATED TYPE, OR A NON-NULL INDEX BOUND LIES OUTSIDE THE RANGE OF
--- AN INDEX SUBTYPE OF THE DESIGNATED TYPE.
-
--- EG 08/30/84
-
-WITH REPORT;
-
-PROCEDURE C48009J IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48009J","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
- "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "APPROPRIATE - ACCESS TYPE OF UNCONSTRAINED " &
- "ACCESS TYPE");
-
- DECLARE
-
- TYPE INT IS RANGE 1 .. 5;
-
- TYPE UR(A : INT) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER;
-
- PACKAGE P IS
- TYPE UP(A : INT) IS PRIVATE;
- TYPE UL(A : INT) IS LIMITED PRIVATE;
- PRIVATE
- TYPE UP(A : INT) IS
- RECORD
- NULL;
- END RECORD;
- TYPE UL(A : INT) IS
- RECORD
- NULL;
- END RECORD;
- END P;
-
- TYPE A_UR IS ACCESS UR;
- TYPE A_UA IS ACCESS UA;
- TYPE A_UP IS ACCESS P.UP;
- TYPE A_UL IS ACCESS P.UL;
-
- TYPE AA_UR IS ACCESS A_UR;
- TYPE AA_UA IS ACCESS A_UA;
- TYPE AA_UP IS ACCESS A_UP;
- TYPE AA_UL IS ACCESS A_UL;
-
- V_AA_UR : AA_UR;
- V_AA_UA : AA_UA;
- V_AA_UP : AA_UP;
- V_AA_UL : AA_UL;
-
- BEGIN
-
- BEGIN
- V_AA_UR := NEW A_UR'(NEW UR(INT(IDENT_INT(6))));
- FAILED ("NO EXCEPTION RAISED - UR");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UR");
- END;
-
- BEGIN
- V_AA_UA := NEW A_UA'(NEW UA(4 .. 7));
- FAILED ("NO EXCEPTION RAISED - UA");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UA");
- END;
-
- BEGIN
- V_AA_UP := NEW A_UP'(NEW P.UP(0));
- FAILED ("NO EXCEPTION RAISED - UP");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UP");
- END;
-
- BEGIN
- V_AA_UL := NEW A_UL'(NEW P.UL(INT(IDENT_INT(0))));
- FAILED ("NO EXCEPTION RAISED - UL");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - UL");
- END;
-
- END;
-
- RESULT;
-
-END C48009J;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48010a.ada b/gcc/testsuite/ada/acats/tests/c4/c48010a.ada
deleted file mode 100644
index 15c7e21..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48010a.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C48010A.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 NULL ARRAYS AND NULL RECORDS CAN BE ALLOCATED.
-
--- EG 08/30/84
-
-WITH REPORT;
-
-PROCEDURE C48010A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48010A","CHECK THAT NULL ARRAYS AND NULL RECORDS CAN " &
- "BE ALLOCATED");
-
- DECLARE
-
- TYPE CA IS ARRAY(4 .. 3) OF INTEGER;
- TYPE CR IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE A_CA IS ACCESS CA;
- TYPE A_CR IS ACCESS CR;
-
- TYPE AA_CA IS ACCESS A_CA;
- TYPE AA_CR IS ACCESS A_CR;
-
- V_A_CA : A_CA;
- V_A_CR : A_CR;
- V_AA_CA : AA_CA;
- V_AA_CR : AA_CR;
-
- BEGIN
-
- V_A_CA := NEW CA;
- IF V_A_CA = NULL THEN
- FAILED ("NULL ARRAY WAS NOT ALLOCATED - CA");
- ELSIF V_A_CA.ALL'FIRST /= 4 AND V_A_CA.ALL'LAST /= 3 THEN
- FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - CA");
- END IF;
-
- V_A_CR := NEW CR;
- IF V_A_CR = NULL THEN
- FAILED ("NULL RECORD WAS NOT ALLOCATED - CR");
- END IF;
-
- V_AA_CA := NEW A_CA'(NEW CA);
- IF V_AA_CA.ALL = NULL THEN
- FAILED ("NULL ARRAY WAS NOT ALLOCATED - A_CA");
- ELSIF V_AA_CA.ALL.ALL'FIRST /= 4 AND
- V_AA_CA.ALL.ALL'LAST /= 3 THEN
- FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - A_CA");
- END IF;
-
- V_AA_CR := NEW A_CR'(NEW CR);
- IF (V_AA_CR = NULL OR V_AA_CR.ALL = NULL) THEN
- FAILED ("NULL RECORD WAS NOT ALLOCATED - A_CR");
- END IF;
-
- END;
-
- RESULT;
-
-END C48010A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48011a.ada b/gcc/testsuite/ada/acats/tests/c4/c48011a.ada
deleted file mode 100644
index 7281fce..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48011a.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C48011A.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 OVERLOADED ALLOCATORS ARE DETERMINED TO HAVE THE
--- APPROPRIATE TYPE.
-
--- HISTORY:
--- JET 08/17/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C48011A IS
-
- TYPE ACC1 IS ACCESS INTEGER;
- TYPE ACC2 IS ACCESS INTEGER;
-
- A1 : ACC1 := NULL;
- A2 : ACC2 := NULL;
-
- TYPE REC1 IS RECORD
- A : INTEGER;
- END RECORD;
-
- TYPE REC2 IS RECORD
- A : ACC2;
- END RECORD;
-
- TYPE AREC1 IS ACCESS REC1;
- TYPE AREC2 IS ACCESS REC2;
-
- PROCEDURE PROC(A : ACC1) IS
- BEGIN
- IF A.ALL /= 1 THEN
- FAILED("INCORRECT CALL OF FIRST PROC");
- END IF;
- END PROC;
-
- PROCEDURE PROC(A : INTEGER) IS
- BEGIN
- IF A /= 2 THEN
- FAILED("INCORRECT CALL OF SECOND PROC");
- END IF;
- END PROC;
-
- FUNCTION FUNC(I : INTEGER) RETURN AREC1 IS
- BEGIN
- IF I /= 1 THEN
- FAILED("INCORRECT CALL OF FIRST FUNC");
- END IF;
- RETURN NEW REC1'(A => 0);
- END FUNC;
-
- FUNCTION FUNC(I : INTEGER) RETURN AREC2 IS
- BEGIN
- IF I /= 2 THEN
- FAILED("INCORRECT CALL OF SECOND FUNC");
- END IF;
- RETURN NEW REC2'(A => NULL);
- END FUNC;
-
-BEGIN
- TEST ("C48011A", "CHECK THAT OVERLOADED ALLOCATORS ARE " &
- "DETERMINED TO HAVE THE APPROPRIATE TYPE");
-
- IF A1 = NEW INTEGER'(1) THEN
- FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 1");
- END IF;
-
- IF A2 = NEW INTEGER'(2) THEN
- FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 2");
- END IF;
-
- FUNC(1).A := INTEGER'(1);
- FUNC(IDENT_INT(2)).A := NEW INTEGER'(2);
-
- PROC(NEW INTEGER'(IDENT_INT(1)));
- PROC(IDENT_INT(2));
-
- RESULT;
-END C48011A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c48012a.ada b/gcc/testsuite/ada/acats/tests/c4/c48012a.ada
deleted file mode 100644
index f85ad78..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c48012a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C48012A.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 DISCRIMINANTS GOVERNING VARIANT PARTS NEED NOT BE
--- SPECIFIED WITH STATIC VALUES IN AN ALLOCATOR OF THE FORM
--- "NEW T X".
-
--- EG 08/30/84
-
-WITH REPORT;
-
-PROCEDURE C48012A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C48012A","CHECK THAT DISCRIMINANTS GOVERNING VARIANT " &
- "PARTS NEED NOT BE SPECIFIED WITH STATIC " &
- "VALUES IN AN ALLOCATOR OF THE FORM 'NEW T X'");
-
- DECLARE
-
- TYPE INT IS RANGE 1 .. 5;
- TYPE ARR IS ARRAY(INT RANGE <>) OF INTEGER;
-
- TYPE UR(A : INT) IS
- RECORD
- CASE A IS
- WHEN 1 =>
- NULL;
- WHEN OTHERS =>
- B : ARR(1 .. A);
- END CASE;
- END RECORD;
-
- TYPE A_UR IS ACCESS UR;
-
- V_A_UR : A_UR;
-
- BEGIN
-
- V_A_UR := NEW UR(A => INT(IDENT_INT(2)));
- IF V_A_UR.A /= 2 THEN
- FAILED ("WRONG DISCRIMINANT VALUE");
- ELSIF V_A_UR.B'FIRST /= 1 AND V_A_UR.B'LAST /= 2 THEN
- FAILED ("WRONG BOUNDS IN VARIANT PART");
- END IF;
-
- END;
-
- RESULT;
-
-END C48012A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490001.a b/gcc/testsuite/ada/acats/tests/c4/c490001.a
deleted file mode 100644
index 1915350..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490001.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- C490001.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, for a real static expression that is not part of a larger
--- static expression, and whose expected type T is a floating point type
--- that is not a descendant of a formal scalar type, the value is rounded
--- to the nearest machine number of T if T'Machine_Rounds is true, and is
--- truncated otherwise. Check that if rounding is performed, and the value
--- is exactly halfway between two machine numbers, one of the two machine
--- numbers is used.
---
--- TEST DESCRIPTION:
--- The test obtains a machine number M1 for a floating point subtype S by
--- passing a real literal to S'Machine. It then obtains an adjacent
--- machine number M2 by using S'Succ (or S'Pred). It then constructs
--- values which lie between these two machine numbers: one (A) which is
--- closer to M1, one (B) which is exactly halfway between M1 and M2, and
--- one (C) which is closer to M2. This is done for both positive and
--- negative machine numbers.
---
--- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
--- C must be rounded to M2, A must be rounded to M1, and B must be rounded
--- to either M1 or M2. If S'Machine_Rounds is false, all the values must
--- be truncated to M1.
---
--- A, B, and C are constructed using the following static expressions:
---
--- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5.
--- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5.
--- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5.
---
--- Since these are static expressions, they must be evaluated exactly,
--- and no rounding may occur until the final result is calculated.
---
--- The checks for equality between the members of (A, B, C) and (M1, M2)
--- are performed at run-time within the body of a subprogram.
---
--- The test performs additional checks that the rounding performed on
--- real literals is consistent for a floating point subtype. A literal is
--- assigned to a constant of a floating point subtype S. The same literal
--- is then passed to a subprogram, along with the constant, and an
--- equality check is performed within the body of the subprogram.
---
---
--- CHANGE HISTORY:
--- 25 Sep 95 SAIC Initial prerelease version.
--- 25 May 01 RLB Repaired to work with the repeal of the round away
--- rule by AI-268.
---
---!
-
-with System;
-package C490001_0 is
-
- type My_Flt is digits System.Max_Digits;
-
- procedure Float_Subtest (A, B: in My_Flt; Msg: in String);
-
- procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String);
-
-
---
--- Positive cases:
---
-
- -- |----|-------------|-----------------|-------------------|-----------|
- -- | | | | | |
- -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2
-
-
- Positive_Float : constant My_Flt := 12.440193950021943;
-
- -- The literal value 12.440193950021943 is rounded up or down to the
- -- nearest machine number of My_Flt when Positive_Float is initialized.
- -- The value of Positive_Float should therefore be a machine number, and
- -- the use of 'Machine in the initialization of P_M1 will be redundant for
- -- a correct implementation. It's done anyway to make certain that P_M1 is
- -- a machine number, independent of whether an implementation correctly
- -- performs rounding.
-
- P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float);
- P_M2 : constant My_Flt := My_Flt'Succ(P_M1);
-
- -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not
- -- certain whether 12.440193950021943 is a machine number, nor whether
- -- 'Machine rounds it up or down, 12.440193950021943 may not lie between
- -- P_M1 and P_M2. The test does not depend on this information, however;
- -- the literal is only used as a "seed" to obtain the machine numbers.
-
-
- -- The following entities are used to verify that rounding is performed
- -- according to the value of 'Machine_Rounds. If language rules are
- -- obeyed, the intermediate expressions in the following static
- -- initialization expressions will not be rounded; all calculations will
- -- be performed exactly. The final result, however, will be rounded to
- -- a machine number (either P_M1 or P_M2, depending on the value of
- -- My_Flt'Machine_Rounds). Thus, the value of each constant below will
- -- equal that of P_M1 or P_M2.
-
- Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0);
- Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0);
- More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0);
-
-
---
--- Negative cases:
---
-
- -- -|-------------|-----------------|-------------------|-----------|----|
- -- | | | | | |
- -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0
-
-
- -- The descriptions for the positive cases above apply to the negative
- -- cases below as well. Note that, for N_M2, 'Pred is used rather than
- -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
-
- Negative_Float : constant My_Flt := -0.692074550952117;
-
-
- N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float);
- N_M2 : constant My_Flt := My_Flt'Pred(N_M1);
-
- More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0);
- Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0);
- Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0);
-
-end C490001_0;
-
-
- --==================================================================--
-
-
-with TCTouch;
-package body C490001_0 is
-
- procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is
- begin
- TCTouch.Assert (A = B, Msg);
- end Float_Subtest;
-
- procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is
- begin
- TCTouch.Assert (A = B or A = C, Msg);
- end Float_Subtest;
-
-end C490001_0;
-
-
- --==================================================================--
-
-
-with C490001_0; -- Floating point support.
-use C490001_0;
-
-with Report;
-procedure C490001 is
-begin
- Report.Test ("C490001", "Rounding of real static expressions: " &
- "floating point subtypes");
-
-
- -- Check that rounding direction is consistent for literals:
-
- Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal");
- Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal");
-
-
- -- Now check that rounding is performed correctly for values between
- -- machine numbers, according to the value of 'Machine_Rounds:
-
- if My_Flt'Machine_Rounds then
- Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half");
- Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half");
- Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
-
- Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half");
- Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half");
- Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
- else
- Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half");
- Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half");
- Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
-
- Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half");
- Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half");
- Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
- end if;
-
-
- Report.Result;
-end C490001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490002.a b/gcc/testsuite/ada/acats/tests/c4/c490002.a
deleted file mode 100644
index 71169b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490002.a
+++ /dev/null
@@ -1,239 +0,0 @@
--- C490002.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, for a real static expression that is not part of a larger
--- static expression, and whose expected type T is an ordinary fixed
--- point type that is not a descendant of a formal scalar type, the value
--- is rounded to the nearest integral multiple of the small of T if
--- T'Machine_Rounds is true, and is truncated otherwise. Check that if
--- rounding is performed, and the value is exactly halfway between two
--- multiples of the small, one of the two multiples of small is used.
---
--- TEST DESCRIPTION:
--- The test obtains an integral multiple M1 of the small of an ordinary
--- fixed point subtype S by dividing a real literal by S'Small, and then
--- truncating the result using 'Truncation. It then obtains an adjacent
--- multiple M2 of the small by using S'Succ (or S'Pred). It then
--- constructs values which lie between these multiples: one (A) which is
--- closer to M1, one (B) which is exactly halfway between M1 and M2, and
--- one (C) which is closer to M2. This is done for both positive and
--- negative multiples of the small.
---
--- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
--- C must be rounded to M2, A must be rounded to M1, and B must be rounded
--- to either M1 or M2. If S'Machine_Rounds is false, all the values must
--- be truncated to M1.
---
--- A, B, and C are constructed using the following static expressions:
---
--- A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0.
--- B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0.
--- C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0.
---
--- Since these are static expressions, they must be evaluated exactly,
--- and no rounding may occur until the final result is calculated.
---
--- The checks for equality between the members of (A, B, C) and (M1, M2)
--- are performed at run-time within the body of a subprogram.
---
--- The test performs additional checks that the rounding performed on
--- real literals is consistent for ordinary fixed point subtypes. A
--- named number (initialized with a literal) is assigned to a constant of
--- a fixed point subtype S. The same literal is then passed to a
--- subprogram, along with the constant, and an equality check is
--- performed within the body of the subprogram.
---
---
--- CHANGE HISTORY:
--- 26 Sep 95 SAIC Initial prerelease version.
---
---!
-
-package C490002_0 is
-
- type My_Fix is delta 0.0625 range -1000.0 .. 1000.0;
-
- Small : constant := My_Fix'Small; -- Named number.
-
- procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String);
-
- procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String);
-
-
---
--- Positive cases:
---
-
- -- |----|-------------|-----------------|-------------------|-----------|
- -- | | | | | |
- -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2
-
-
- Positive_Real : constant := 0.11433; -- Named number.
- Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small);
-
- -- Pos_Multiplier is the number of integral multiples of small contained
- -- in Positive_Real. P_M1 is thus the largest integral multiple of
- -- small less than or equal to Positive_Real. Note that since Positive_Real
- -- is a named number and not a fixed point object, P_M1 is generated
- -- without assuming that rounding is performed correctly for fixed point
- -- subtypes.
-
- Positive_Fixed : constant My_Fix := Positive_Real;
-
- P_M1 : constant My_Fix := Pos_Multiplier * Small;
- P_M2 : constant My_Fix := My_Fix'Succ(P_M1);
-
- -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that
- -- 0.11433 either equals P_M1 (if it is an integral multiple of the small)
- -- or lies between P_M1 and P_M2 (since truncation was forced in
- -- generating Pos_Multiplier). It is not certain, however, exactly where
- -- it lies between them (halfway, less than halfway, more than halfway).
- -- This fact is irrelevant to the test.
-
-
- -- The following entities are used to verify that rounding is performed
- -- according to the value of 'Machine_Rounds. If language rules are
- -- obeyed, the intermediate expressions in the following static
- -- initialization expressions will not be rounded; all calculations will
- -- be performed exactly. The final result, however, will be rounded to
- -- an integral multiple of the small (either P_M1 or P_M2, depending on the
- -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below
- -- will equal that of P_M1 or P_M2.
-
- Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050);
- Pos_Exactly_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000);
- More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975);
-
-
---
--- Negative cases:
---
-
- -- -|-------------|-----------------|-------------------|-----------|----|
- -- | | | | | |
- -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0
-
-
- -- The descriptions for the positive cases above apply to the negative
- -- cases below as well. Note that, for N_M2, 'Pred is used rather than
- -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
-
- Negative_Real : constant := -467.13988; -- Named number.
- Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small);
-
- Negative_Fixed : constant My_Fix := Negative_Real;
-
- N_M1 : constant My_Fix := Neg_Multiplier * Small;
- N_M2 : constant My_Fix := My_Fix'Pred(N_M1);
-
- More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980);
- Neg_Exactly_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000);
- Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033);
-
-end C490002_0;
-
-
- --==================================================================--
-
-
-with TCTouch;
-package body C490002_0 is
-
- procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is
- begin
- TCTouch.Assert (A = B, Msg);
- end Fixed_Subtest;
-
- procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is
- begin
- TCTouch.Assert (A = B or A = C, Msg);
- end Fixed_Subtest;
-
-end C490002_0;
-
-
- --==================================================================--
-
-
-with C490002_0; -- Fixed point support.
-use C490002_0;
-
-with Report;
-procedure C490002 is
-begin
- Report.Test ("C490002", "Rounding of real static expressions: " &
- "ordinary fixed point subtypes");
-
-
- -- Literal cases: If the named numbers used to initialize Positive_Fixed
- -- and Negative_Fixed are rounded to an integral multiple of the small
- -- prior to assignment (as expected), then Positive_Fixed and
- -- Negative_Fixed are already integral multiples of the small, and
- -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check
- -- can determine in which direction rounding occurred. For example:
- --
- -- if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0.
- --
- -- Check here that the rounding direction is consistent for literals:
-
- if (Positive_Fixed = P_M1) then
- Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal");
- else
- Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal");
- end if;
-
- if (Negative_Fixed = N_M1) then
- Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal");
- else
- Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal");
- end if;
-
-
- -- Now check that rounding is performed correctly for values between
- -- multiples of the small, according to the value of 'Machine_Rounds:
-
- if My_Fix'Machine_Rounds then
- Fixed_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Fixed: = half");
- Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half");
- Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
-
- Fixed_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Fixed: = half");
- Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half");
- Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
- else
- Fixed_Subtest (Pos_Exactly_Half, P_M1, "Positive Fixed: = half");
- Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half");
- Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
-
- Fixed_Subtest (Neg_Exactly_Half, N_M1, "Negative Fixed: = half");
- Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half");
- Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
- end if;
-
-
- Report.Result;
-end C490002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490003.a b/gcc/testsuite/ada/acats/tests/c4/c490003.a
deleted file mode 100644
index a135b5a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490003.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- C490003.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 static expression is legal if its evaluation fails
--- no language-defined check other than Overflow_Check. Check that such
--- a static expression is legal if it is part of a larger static
--- expression, even if its value is outside the base range of the
--- expected type.
---
--- Check that if a static expression is part of the right operand of a
--- short circuit control form whose value is determined by its left
--- operand, it is not evaluated.
---
--- Check that a static expression in a non-static context is evaluated
--- exactly.
---
--- TEST DESCRIPTION:
--- The first part of the objective is tested by constructing static
--- expressions which involve predefined operations of integer, floating
--- point, and fixed point subtypes. Intermediate expressions within the
--- static expressions have values outside the base range of the expected
--- type. In one case, the extended-range intermediates are compared as
--- part of a boolean expression. In the remaining two cases, further
--- predefined operations on the intermediates bring the final result
--- within the base range. An implementation which compiles these static
--- expressions satisfies this portion of the objective. A check is
--- performed at run-time to ensure that the static expressions evaluate
--- to values within the base range of their respective expected types.
---
--- The second part of the objective is tested by constructing
--- short-circuit control forms whose left operands have the values
--- shown below:
---
--- (TRUE) or else (...)
--- (FALSE) and then (...)
---
--- In both cases the left operand determines the value of the condition.
--- In the test each right operand involves a division by zero, which will
--- raise Constraint_Error if evaluated. A check is made that no exception
--- is raised when each short-circuit control form is evaluated, and that
--- the value of the condition is that of the left operand.
---
--- The third part of the objective is tested by evaluating static
--- expressions involving many operations in contexts which do not
--- require a static expression, and verifying that the exact
--- mathematical results are calculated.
---
---
--- CHANGE HISTORY:
--- 15 Sep 95 SAIC Initial prerelease version for ACVC 2.1.
--- 20 Oct 96 SAIC Modified expressions in C490003_0 to avoid
--- the use of universal operands.
---
---!
-
-with System;
-package C490003_0 is
-
- type My_Flt is digits System.Max_Digits;
-
- Flt_Range_Diff : My_Flt := (My_Flt'Base'Last - My_Flt'Base'First) -
- (My_Flt'Last - My_Flt'First); -- OK.
-
-
- type My_Fix is delta 0.125 range -128.0 .. 128.0;
-
- Symmetric : Boolean := (My_Fix'Base'Last - My_Fix'Base'First) =
- (My_Fix'Base'Last + My_Fix'Base'Last); -- OK.
-
-
- Center : constant Integer := Integer'Base'Last -
- (Integer'Base'Last -
- Integer'Base'First) / 2; -- OK.
-
-end C490003_0;
-
-
- --==================================================================--
-
-
-with Ada.Numerics;
-package C490003_1 is
-
- Zero : constant := 0.0;
- Pi : constant := Ada.Numerics.Pi;
-
- Two_Pi : constant := 2.0 * Pi;
- Half_Pi : constant := Pi/2.0;
-
- Quarter : constant := 90.0;
- Half : constant := 180.0;
- Full : constant := 360.0;
-
- Deg_To_Rad : constant := Half_Pi/90;
- Rad_To_Deg : constant := 1.0/Deg_To_Rad;
-
-end C490003_1;
-
-
- --==================================================================--
-
-
-with C490003_0;
-with C490003_1;
-
-with Report;
-procedure C490003 is
-begin
- Report.Test ("C490003", "Check that static expressions failing " &
- "Overflow_Check are legal if part of a larger static " &
- "expression. Check that static expressions as right " &
- "operands of short-circuit control forms are not " &
- "evaluated if value of control form is determined by " &
- "left operand. Check that static expressions in non-static " &
- "contexts are evaluated exactly");
-
-
---
--- Static expressions within larger static expressions:
---
-
-
- if C490003_0.Flt_Range_Diff not in C490003_0.My_Flt'Base'Range then
- Report.Failed ("Error evaluating static expression: floating point");
- end if;
-
- if C490003_0.Symmetric not in Boolean'Range then
- Report.Failed ("Error evaluating static expression: fixed point");
- end if;
-
- if C490003_0.Center not in Integer'Base'Range then
- Report.Failed ("Error evaluating static expression: integer");
- end if;
-
-
---
--- Short-circuit control forms:
---
-
- declare
- N : constant := 0.0;
- begin
-
- begin
- if not ( (N = 0.0) or else (1.0/N > 0.5) ) then
- Report.Failed ("Error evaluating OR ELSE");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Right side of OR ELSE was evaluated");
- when others =>
- Report.Failed ("OR ELSE: unexpected exception raised");
- end;
-
- begin
- if (N /= 0.0) and then (1.0/N <= 0.5) then
- Report.Failed ("Error evaluating AND THEN");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Right side of AND THEN was evaluated");
- when others =>
- Report.Failed ("AND THEN: unexpected exception raised");
- end;
-
- end;
-
-
---
--- Exact evaluation of static expressions:
---
-
-
- declare
- use C490003_1;
-
- Left : constant := 6.0 + 0.3125*( (Full*0.375) + (Half/2.4) -
- ((Quarter + 36.0)/3.0) )/10.0; -- 11.25
- Right : constant := (Pi/3.0) * 1.2 * (15.0/96.0); -- Pi/16
- begin
- if Deg_To_Rad*Left /= Right then
- Report.Failed ("Static expressions not evaluated exactly: #1");
- end if;
-
- if ((Pi*Rad_To_Deg)*2.0 + 4.0*Quarter)/16.0 /= Rad_To_Deg*(Pi/4.0) then
- Report.Failed ("Static expressions not evaluated exactly: #2");
- end if;
- end;
-
-
- Report.Result;
-end C490003;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49020a.ada b/gcc/testsuite/ada/acats/tests/c4/c49020a.ada
deleted file mode 100644
index ebd2fde..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49020a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C49020A.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 ENUMERATION LITERALS (INCLUDING CHARACTER LITERALS) CAN BE
--- USED IN STATIC EXPRESSIONS TOGETHER WITH RELATIONAL AND EQUALITY
--- OPERATORS.
-
--- L.BROWN 09/30/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C49020A IS
-
- CAS_BOL : BOOLEAN := TRUE;
- OBJ1 : INTEGER := 4;
- TYPE ENUM IS (RED,GREEN,BLUE,OFF,ON,'A','B');
-
-BEGIN
- TEST("C49020A","ENUMERATION LITERALS (INCLUDING CHARACTER "&
- "LITERALS) TOGETHER WITH RELATIONAL OPERATORS "&
- "CAN BE USED IN STATIC EXPRESSION");
-
- CASE CAS_BOL IS
- WHEN (RED <= BLUE) =>
- OBJ1 := 5;
- WHEN (BLUE = GREEN) =>
- FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "&
- "EXPRESSION 1");
- END CASE;
-
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN (GREEN >= ON) =>
- FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "&
- "EXPRESSION 2");
- WHEN (ENUM'('A') < ENUM'('B')) =>
- OBJ1 := 6;
- END CASE;
-
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN (BLUE > 'B') =>
- FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "&
- "EXPRESSION 3");
- WHEN (OFF /= 'A') =>
- OBJ1 := 7;
- END CASE;
-
- RESULT;
-
-END C49020A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49021a.ada b/gcc/testsuite/ada/acats/tests/c4/c49021a.ada
deleted file mode 100644
index b58fcd4..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49021a.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C49021A.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 BOOLEAN LITERALS CAN BE USED IN STATIC EXPRESSIONS
--- TOGETHER WITH THE LOGICAL OPERATORS, THE NOT OPERATOR, AND THE
--- RELATIONAL AND EQUALITY OPERATORS.
-
--- L.BROWN 09/25/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C49021A IS
-
- CAS_BOL : BOOLEAN := TRUE;
- X1 : CONSTANT := BOOLEAN'POS((TRUE AND FALSE)OR(TRUE AND TRUE));
- X2 : CONSTANT := BOOLEAN'POS((TRUE <= FALSE)AND(FALSE >= FALSE));
-
-BEGIN
- TEST("C49021A","BOOLEAN LITERALS TOGETHER WITH CERTAIN OPERATORS,"&
- "CAN BE USED IN STATIC EXPRESSIONS.");
- IF X1 /= 1 THEN
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 1");
- END IF;
-
- IF X2 /= 0 THEN
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 2");
- END IF;
-
- CASE CAS_BOL IS
- WHEN ((TRUE AND FALSE) XOR (TRUE XOR TRUE)) =>
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " &
- "EXPRESSION 2");
- WHEN OTHERS =>
- CAS_BOL := TRUE;
- END CASE;
-
- CASE CAS_BOL IS
- WHEN ((TRUE > FALSE) OR (FALSE <= TRUE)) =>
- CAS_BOL := TRUE;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " &
- "EXPRESSION 3");
- END CASE;
-
- CASE CAS_BOL IS
- WHEN NOT((TRUE OR FALSE) = (FALSE AND TRUE)) =>
- CAS_BOL := TRUE;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " &
- "EXPRESSION 4");
- END CASE;
-
- CASE CAS_BOL IS
- WHEN (((TRUE = FALSE) OR (FALSE AND TRUE)) /= (TRUE < TRUE))=>
- FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " &
- "EXPRESSION 5");
- WHEN OTHERS =>
- CAS_BOL := TRUE;
- END CASE;
-
- RESULT;
-
-END C49021A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022a.ada b/gcc/testsuite/ada/acats/tests/c4/c49022a.ada
deleted file mode 100644
index d0cfa9d..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49022a.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C49022A.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 NAMED NUMBER DECLARATIONS (INTEGER) MAY USE EXPRESSIONS
--- WITH INTEGERS.
-
--- BAW 29 SEPT 80
--- TBN 10/28/85 RENAMED FROM C4A001A.ADA. ADDED RELATIONAL
--- OPERATORS AND USE OF NAMED NUMBERS.
-
-WITH REPORT;
-PROCEDURE C49022A IS
-
- USE REPORT;
-
- ADD1 : CONSTANT := 1 + 1;
- ADD2 : CONSTANT := 1 + (-1);
- ADD3 : CONSTANT := (-1) + 1;
- ADD4 : CONSTANT := (-1) + (-1);
- SUB1 : CONSTANT := 1 - 1;
- SUB2 : CONSTANT := 1 - (-1);
- SUB3 : CONSTANT := (-1) - 1;
- SUB4 : CONSTANT := (-1) - (-1);
- MUL1 : CONSTANT := 1 * 1;
- MUL2 : CONSTANT := 1 * (-1);
- MUL3 : CONSTANT := (-1) * 1;
- MUL4 : CONSTANT := (-1) * (-1);
- DIV1 : CONSTANT := 1 / 1;
- DIV2 : CONSTANT := 1 / (-1);
- DIV3 : CONSTANT := (-1) / 1;
- DIV4 : CONSTANT := (-1) / (-1);
- REM1 : CONSTANT := 14 REM 5;
- REM2 : CONSTANT := 14 REM(-5);
- REM3 : CONSTANT :=(-14) REM 5;
- REM4 : CONSTANT :=(-14) REM(-5);
- MOD1 : CONSTANT := 4 MOD 3;
- MOD2 : CONSTANT := 4 MOD (-3);
- MOD3 : CONSTANT := (-4) MOD 3;
- MOD4 : CONSTANT := (-4) MOD (-3);
- EXP1 : CONSTANT := 1 ** 1;
- EXP2 : CONSTANT := (-1) ** 1;
- ABS1 : CONSTANT := ABS( - 10 );
- ABS2 : CONSTANT := ABS( + 10 );
- TOT1 : CONSTANT := ADD1 + SUB1 - MUL1 + DIV1 - REM3 + MOD2 - EXP1;
- LES1 : CONSTANT := BOOLEAN'POS (1 < 2);
- LES2 : CONSTANT := BOOLEAN'POS (1 < (-2));
- LES3 : CONSTANT := BOOLEAN'POS ((-1) < (-2));
- LES4 : CONSTANT := BOOLEAN'POS (ADD1 < SUB1);
- GRE1 : CONSTANT := BOOLEAN'POS (2 > 1);
- GRE2 : CONSTANT := BOOLEAN'POS ((-1) > 2);
- GRE3 : CONSTANT := BOOLEAN'POS ((-1) > (-2));
- GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1);
- LEQ1 : CONSTANT := BOOLEAN'POS (1 <= 1);
- LEQ2 : CONSTANT := BOOLEAN'POS ((-1) <= 1);
- LEQ3 : CONSTANT := BOOLEAN'POS ((-1) <= (-2));
- LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB3);
- GEQ1 : CONSTANT := BOOLEAN'POS (2 >= 1);
- GEQ2 : CONSTANT := BOOLEAN'POS ((-2) >= 1);
- GEQ3 : CONSTANT := BOOLEAN'POS ((-2) >= (-1));
- GEQ4 : CONSTANT := BOOLEAN'POS (ADD2 >= SUB3);
- EQU1 : CONSTANT := BOOLEAN'POS (2 = 2);
- EQU2 : CONSTANT := BOOLEAN'POS ((-2) = 2);
- EQU3 : CONSTANT := BOOLEAN'POS ((-2) = (-2));
- EQU4 : CONSTANT := BOOLEAN'POS (ADD2 = SUB3);
- NEQ1 : CONSTANT := BOOLEAN'POS (2 /= 2);
- NEQ2 : CONSTANT := BOOLEAN'POS ((-2) /= 1);
- NEQ3 : CONSTANT := BOOLEAN'POS ((-2) /= (-2));
- NEQ4 : CONSTANT := BOOLEAN'POS (ADD2 /= SUB3);
-
-
-BEGIN
- TEST("C49022A","CHECK THAT NAMED NUMBER DECLARATIONS (INTEGER) " &
- "MAY USE EXPRESSIONS WITH INTEGERS");
-
- IF ADD1 /= 2 OR ADD2 /= 0 OR ADD3 /= 0 OR ADD4 /= -2 THEN
- FAILED("ERROR IN THE ADDING OPERATOR +");
- END IF;
-
- IF SUB1 /= 0 OR SUB2 /= 2 OR SUB3 /= -2 OR SUB4 /= 0 THEN
- FAILED("ERROR IN THE ADDING OPERATOR -");
- END IF;
-
- IF MUL1 /= 1 OR MUL2 /= -1 OR MUL3 /= -1 OR MUL4 /= 1 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR *");
- END IF;
-
- IF DIV1 /= 1 OR DIV2 /= -1 OR DIV3 /= -1 OR DIV4 /= 1 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR /");
- END IF;
-
- IF REM1 /= 4 OR REM2 /= 4 OR REM3 /= -4 OR REM4 /= -4 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR REM");
- END IF;
-
- IF MOD1 /= 1 OR MOD2 /= -2 OR MOD3 /= 2 OR MOD4 /= -1 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR MOD");
- END IF;
-
- IF EXP1 /= 1 OR EXP2 /= -1 THEN
- FAILED("ERROR IN THE EXPONENTIATING OPERATOR");
- END IF;
-
- IF ABS1 /= 10 OR ABS2 /= 10 THEN
- FAILED("ERROR IN THE ABS OPERATOR");
- END IF;
-
- IF TOT1 /= 3 THEN
- FAILED("ERROR IN USING NAMED NUMBERS WITH OPERATORS");
- END IF;
-
- IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN
- FAILED("ERROR IN THE LESS THAN OPERATOR");
- END IF;
-
- IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 1 OR GRE4 /= 1 THEN
- FAILED("ERROR IN THE GREATER THAN OPERATOR");
- END IF;
-
- IF LEQ1 /= 1 OR LEQ2 /= 1 OR LEQ3 /= 0 OR LEQ4 /= 0 THEN
- FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR");
- END IF;
-
- IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN
- FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR");
- END IF;
-
- IF EQU1 /= 1 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 0 THEN
- FAILED("ERROR IN THE EQUAL OPERATOR");
- END IF;
-
- IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 0 OR NEQ4 /= 1 THEN
- FAILED("ERROR IN THE NOT EQUAL OPERATOR");
- END IF;
-
- RESULT;
-
-END C49022A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022b.ada b/gcc/testsuite/ada/acats/tests/c4/c49022b.ada
deleted file mode 100644
index a7fe57e..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49022b.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C49022B.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 NUMBER DECLARATIONS, IDENTIFIERS CORRECTLY REPRESENT
--- VALUES OF OTHER LITERALS.
-
--- BAW 29 SEPT 80
--- TBN 10/22/85 RENAMED FROM C4A003A.ADA AND ADDED RELATIONAL
--- OPERATORS USING NAMED NUMBERS.
-
-
-WITH REPORT;
-PROCEDURE C49022B IS
-
- USE REPORT;
-
- A : CONSTANT := 10; -- A = 10
- B : CONSTANT := 25 - (2 * A); -- B = 5
- C : CONSTANT := A / B; -- C = 2
- D : CONSTANT := (C * A) - (B - C); -- D = 17
- E : CONSTANT := D ** C; -- E = 289
- F : CONSTANT := (E MOD A) + 1; -- F = 10
- G : CONSTANT := A REM B + C + D + E + ABS(-F); -- G = 318
- H : CONSTANT := BOOLEAN'POS (A > B); -- H = 1
- I : CONSTANT := BOOLEAN'POS (A < B); -- I = 0
- J : CONSTANT := BOOLEAN'POS (C >= A); -- J = 0
- K : CONSTANT := BOOLEAN'POS (B <= B); -- K = 1
- L : CONSTANT := BOOLEAN'POS (D = A); -- L = 0
- M : CONSTANT := BOOLEAN'POS (A /= F); -- M = 0
-
-BEGIN
- TEST("C49022B","CHECK THAT IN NUMBER DECLARATIONS, IDENTIFIERS " &
- "CORRECTLY REPRESENT VALUES OF OTHER LITERALS");
-
- IF G /= 318 THEN
- FAILED("USE OF OTHER NUMBER DECLARATIONS GIVES " &
- "WRONG RESULTS");
- END IF;
-
- IF H /= 1 OR I /= 0 OR J /= 0 OR K /= 1 THEN
- FAILED("USE OF NAMED NUMBERS AND RELATIONAL OPERATORS " &
- "GIVES WRONG RESULTS");
- END IF;
-
- IF L /= 0 OR M /= 0 THEN
- FAILED("USE OF NAMED NUMBERS AND EQUALITY OPERATORS " &
- "GIVES WRONG RESULTS");
- END IF;
-
- RESULT;
-
-END C49022B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022c.ada b/gcc/testsuite/ada/acats/tests/c4/c49022c.ada
deleted file mode 100644
index 69822c8..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49022c.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C49022C.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 NAMED NUMBER DECLARATIONS (REAL) MAY USE EXPRESSIONS
--- WITH REALS.
-
--- BAW 29 SEPT 80
--- TBN 10/24/85 RENAMED FROM C4A011A.ADA. ADDED RELATIONAL
--- OPERATORS AND NAMED NUMBERS.
-
-WITH REPORT;
-PROCEDURE C49022C IS
-
- USE REPORT;
-
- ADD1 : CONSTANT := 2.5 + 1.5;
- ADD2 : CONSTANT := 2.5 + (-1.5);
- ADD3 : CONSTANT := (-2.5) + 1.5;
- ADD4 : CONSTANT := (-2.5) + (-1.5);
- SUB1 : CONSTANT := 2.5 - 1.5;
- SUB2 : CONSTANT := 2.5 - (-1.5);
- SUB3 : CONSTANT := (-2.5) - 1.5;
- SUB4 : CONSTANT := (-2.5) - (-1.5);
- MUL1 : CONSTANT := 2.5 * 1.5;
- MUL2 : CONSTANT := 2.5 * (-1.5);
- MUL3 : CONSTANT := (-2.5) * 1.5;
- MUL4 : CONSTANT := (-2.5) * (-1.5);
- MLR1 : CONSTANT := 2 * 1.5;
- MLR2 : CONSTANT := (-2) * 1.5;
- MLR3 : CONSTANT := 2 * (-1.5);
- MLR4 : CONSTANT := (-2) * (-1.5);
- MLL1 : CONSTANT := 1.5 * 2 ;
- MLL2 : CONSTANT := 1.5 * (-2);
- MLL3 : CONSTANT :=(-1.5) * 2 ;
- MLL4 : CONSTANT :=(-1.5) * (-2);
- DIV1 : CONSTANT := 3.75 / 2.5;
- DIV2 : CONSTANT := 3.75 / (-2.5);
- DIV3 : CONSTANT := (-3.75) / 2.5;
- DIV4 : CONSTANT := (-3.75) / (-2.5);
- DVI1 : CONSTANT := 3.0 / 2;
- DVI2 : CONSTANT := (-3.0) / 2;
- DVI3 : CONSTANT := 3.0 / (-2);
- DVI4 : CONSTANT := (-3.0) / (-2);
- EXP1 : CONSTANT := 2.0 ** 1;
- EXP2 : CONSTANT := 2.0 ** (-1);
- EXP3 : CONSTANT := (-2.0) ** 1;
- EXP4 : CONSTANT := (-2.0) ** (-1);
- ABS1 : CONSTANT := ABS( - 3.75 );
- ABS2 : CONSTANT := ABS( + 3.75 );
- TOT1 : CONSTANT := ADD1 + SUB4 - MUL1 + DIV1 - EXP2 + ABS1;
- LES1 : CONSTANT := BOOLEAN'POS (1.5 < 2.0);
- LES2 : CONSTANT := BOOLEAN'POS (1.5 < (-2.0));
- LES3 : CONSTANT := BOOLEAN'POS ((-1.5) < (-2.0));
- LES4 : CONSTANT := BOOLEAN'POS (ADD2 < SUB1);
- GRE1 : CONSTANT := BOOLEAN'POS (2.0 > 1.5);
- GRE2 : CONSTANT := BOOLEAN'POS ((-2.0) > 1.5);
- GRE3 : CONSTANT := BOOLEAN'POS ((-2.0) > (-1.5));
- GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1);
- LEQ1 : CONSTANT := BOOLEAN'POS (1.5 <= 2.0);
- LEQ2 : CONSTANT := BOOLEAN'POS (1.5 <= (-2.0));
- LEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) <= (-2.0));
- LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB1);
- GEQ1 : CONSTANT := BOOLEAN'POS (2.0 >= 1.5);
- GEQ2 : CONSTANT := BOOLEAN'POS ((-2.0) >= 1.5);
- GEQ3 : CONSTANT := BOOLEAN'POS ((-2.0) >= (-1.5));
- GEQ4 : CONSTANT := BOOLEAN'POS (ADD1 >= SUB2);
- EQU1 : CONSTANT := BOOLEAN'POS (1.5 = 2.0);
- EQU2 : CONSTANT := BOOLEAN'POS ((-1.5) = 2.0);
- EQU3 : CONSTANT := BOOLEAN'POS ((-1.5) = (-1.5));
- EQU4 : CONSTANT := BOOLEAN'POS (ADD1 = SUB2);
- NEQ1 : CONSTANT := BOOLEAN'POS (1.5 /= 1.5);
- NEQ2 : CONSTANT := BOOLEAN'POS ((-1.5) /= 1.5);
- NEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) /= (-2.0));
- NEQ4 : CONSTANT := BOOLEAN'POS (ADD1 /= SUB2);
-
-
-BEGIN
- TEST("C49022C","CHECK THAT NAMED NUMBER DECLARATIONS (REAL) " &
- "MAY USE EXPRESSIONS WITH REALS.");
-
- IF ADD1 /= 4.0 OR ADD2 /= 1.0 OR ADD3 /= -1.0 OR ADD4 /= -4.0 THEN
- FAILED("ERROR IN THE ADDING OPERATOR +");
- END IF;
-
- IF SUB1 /= 1.0 OR SUB2 /= 4.0 OR SUB3 /= -4.0 OR SUB4 /= -1.0 THEN
- FAILED("ERROR IN THE ADDING OPERATOR -");
- END IF;
-
- IF MUL1 /= 3.75 OR MUL2 /= -3.75 OR
- MUL3 /= -3.75 OR MUL4 /= 3.75 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR *");
- END IF;
-
- IF MLR1 /= 3.0 OR MLR2 /= -3.0 OR
- MLR3 /= -3.0 OR MLR4 /= 3.0 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR *");
- END IF;
-
- IF MLL1 /= 3.0 OR MLL2 /= -3.0 OR MLL3 /= -3.0 OR MLL4 /= 3.0 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR *");
- END IF;
-
- IF DIV1 /= 1.5 OR DIV2 /= -1.5 OR DIV3 /= -1.5 OR DIV4 /= 1.5 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR /");
- END IF;
-
- IF DVI1 /= 1.5 OR DVI2 /= -1.5 OR DVI3 /= -1.5 OR DVI4 /= 1.5 THEN
- FAILED("ERROR IN THE MULTIPLYING OPERATOR /");
- END IF;
-
- IF EXP1 /= 2.0 OR EXP2 /= 0.5 OR EXP3 /= -2.0 OR EXP4 /= -0.5 THEN
- FAILED("ERROR IN THE EXPONENTIATING OPERATOR");
- END IF;
-
- IF ABS1 /= 3.75 OR ABS2 /= 3.75 THEN
- FAILED("ERROR IN THE ABS OPERATOR");
- END IF;
-
- IF TOT1 /= 4.00 THEN
- FAILED("ERROR IN USE OF NAMED NUMBERS WITH OPERATORS");
- END IF;
-
- IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN
- FAILED("ERROR IN THE LESS THAN OPERATOR");
- END IF;
-
- IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 0 OR GRE4 /= 1 THEN
- FAILED("ERROR IN THE GREATER THAN OPERATOR");
- END IF;
-
- IF LEQ1 /= 1 OR LEQ2 /= 0 OR LEQ3 /= 0 OR LEQ4 /= 1 THEN
- FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR");
- END IF;
-
- IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN
- FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR");
- END IF;
-
- IF EQU1 /= 0 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 1 THEN
- FAILED("ERROR IN THE EQUAL OPERATOR");
- END IF;
-
- IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 1 OR NEQ4 /= 0 THEN
- FAILED("ERROR IN THE NOT EQUAL OPERATOR");
- END IF;
-
- RESULT;
-
-END C49022C;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49023a.ada b/gcc/testsuite/ada/acats/tests/c4/c49023a.ada
deleted file mode 100644
index 0520342..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49023a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C49023A.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 CONSTANT DECLARED BY AN OBJECT DECLARATION CAN BE USED
--- IN A STATIC EXPRESSION IF THE CONSTANT WAS DECLARED WITH A STATIC
--- SUBTYPE AND INITIALIZED WITH A STATIC EXPRESSION.
-
--- L.BROWN 10/01/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C49023A IS
-
-BEGIN
- TEST("C49023A","A CONSTANT DECLARED BY AN OBJECT DECLARATION "&
- "UNDER CERTAIN CONDITIONS CAN BE USED IN A "&
- "STATIC EXPRESSION");
- DECLARE
- TYPE ENUM IS (RED,GREEN,BLUE,YELLOW);
- SUBTYPE SENUM IS ENUM RANGE RED .. BLUE;
- CONEN : CONSTANT SENUM := GREEN;
- TYPE INT IS RANGE 1 .. 10;
- SUBTYPE SINT IS INT RANGE 1 .. 5;
- CONIN : CONSTANT SINT := 3;
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0;
- SUBTYPE SFLT IS FLT RANGE 10.0 .. 20.0;
- CONFL : CONSTANT SFLT := 11.0;
- TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 25.0;
- SUBTYPE SFIX IS FIX RANGE 0.0 .. 12.0;
- CONFI : CONSTANT SFIX := 0.25;
- CAS_EN : ENUM := CONEN;
- TYPE ITEG IS RANGE 1 .. CONIN;
- TYPE FLTY IS DIGITS CONIN;
- TYPE FIXY IS DELTA CONFI RANGE 0.0 .. 10.0;
- TYPE REAL IS DELTA 0.25 RANGE 0.0 .. 11.0;
- TYPE FIXTY IS DELTA 0.25 RANGE 0.0 .. CONFL;
-
- FUNCTION IDENT_REAL (X : REAL) RETURN REAL;
-
- PACKAGE P IS
- TYPE T IS PRIVATE;
- CON1 : CONSTANT T;
- PRIVATE
- TYPE T IS NEW INTEGER;
- CON1 : CONSTANT T := 10;
- TYPE NINT IS RANGE 1 .. CON1;
- END P;
- PACKAGE BODY P IS
- TYPE CON2 IS RANGE CON1 .. 50;
- BEGIN
- IF NINT'LAST /= NINT(IDENT_INT(10)) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 1");
- END IF;
- IF CON2'FIRST /= CON2(IDENT_INT(10)) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 2");
- END IF;
- END P;
-
- FUNCTION IDENT_REAL (X : REAL) RETURN REAL IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_REAL;
-
- BEGIN
-
- IF ITEG'LAST /= ITEG(IDENT_INT(3)) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 3");
- END IF;
-
- IF FLTY'DIGITS /= IDENT_INT(3) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 4");
- END IF;
-
- IF FIXY'DELTA /= IDENT_REAL(0.25) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 5");
- END IF;
-
- IF FIXTY'LAST /= FIXTY(IDENT_REAL(11.0)) THEN
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 6");
- END IF;
-
- CASE CAS_EN IS
- WHEN CONEN =>
- CAS_EN := RED;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 7");
- END CASE;
-
- END;
-
- RESULT;
-
-END C49023A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49024a.ada b/gcc/testsuite/ada/acats/tests/c4/c49024a.ada
deleted file mode 100644
index df81579..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49024a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- C49024A.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 FUNCTION CALL CAN APPEAR IN A STATIC EXPRESSION IF THE
--- FUNCTION NAME DENOTES A PREDEFINED OPERATOR AND HAS THE FORM OF AN
--- OPERATOR SYMBOL OR AN EXPANDED NAME WHOSE SELECTOR IS AN OPERATOR
--- SYMBOL.
-
--- L.BROWN 10/02/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C49024A IS
-
- PACKAGE P IS
- TYPE TY IS NEW INTEGER;
- END P;
-
- CON1 : CONSTANT P.TY := 3;
- CON2 : CONSTANT P.TY := 4;
- TYPE INT1 IS RANGE 1 .. P."+"(CON1,CON2);
- CON3 : CONSTANT := 5;
- CON4 : CONSTANT := 7;
- TYPE FLT IS DIGITS "-"(CON4,CON3);
- TYPE FIX1 IS DELTA 1.0 RANGE 0.0 .. 25.0;
- CON5 : CONSTANT := 3.0;
- CON6 : CONSTANT := 6.0;
- TYPE FIX2 IS DELTA 1.0 RANGE 0.0 .. "/"(CON6,CON5);
- TYPE ENUM IS (RED,BLUE,GREEN,BLACK);
- CON7 : CONSTANT BOOLEAN := TRUE;
- CON8 : CONSTANT ENUM := BLUE;
- CAS_INT1 : CONSTANT := 10;
- CAS_INT2 : CONSTANT := 2;
- OBJ1 : INTEGER := 10;
- CAS_BOL : BOOLEAN := TRUE;
- CON9 : CONSTANT ENUM := BLACK;
- CON10 : CONSTANT FIX1 := 2.0;
- CON11 : CONSTANT FIX1 := 10.0;
- TYPE FIX3 IS DELTA "+"(CON10) RANGE 0.0 .. 20.0;
- TYPE INT2 IS RANGE 0 .. "ABS"("-"(CON4));
- CON12 : CONSTANT CHARACTER := 'D';
- CON13 : CONSTANT CHARACTER := 'B';
- CON14 : CONSTANT BOOLEAN := FALSE;
- CON15 : CONSTANT := 10;
-
-BEGIN
-
- TEST("C49024A","A FUNCTION CALL CAN BE IN A STATIC EXPRESSION "&
- "IF THE FUNCTION NAME DENOTES A PREDEFINED "&
- "OPERATOR AND HAS THE FORM OF AN OPERATOR SYMBOL");
-
- CASE CAS_BOL IS
- WHEN ("NOT"(CON7)) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 1");
- WHEN ("/="(CON8,CON9)) =>
- OBJ1 := 2;
- END CASE;
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN ("*"(CON3,CON4) = CAS_INT1) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 2");
- WHEN ("ABS"(CON15) = CAS_INT1) =>
- OBJ1 := 3;
- END CASE;
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN ("<"(CON11,CON10)) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 3");
- WHEN ("<="(CON13,CON12)) =>
- OBJ1 := 4;
- END CASE;
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN ("REM"(CON4,CON3) = CAS_INT2) =>
- OBJ1 := 5;
- WHEN ("**"(CON3,CON4) = CAS_INT2) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 4");
- END CASE;
-
- CASE CAS_BOL IS
- WHEN (P.">"(CON1,CON2)) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 5");
- WHEN ("OR"(CON7,CON14)) =>
- OBJ1 := 6;
- END CASE;
- CAS_BOL := TRUE;
-
- CASE CAS_BOL IS
- WHEN ("MOD"(CON4,CON3) = CAS_INT2) =>
- OBJ1 := 7;
- WHEN ("ABS"(CON4) = CAS_INT2) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 6");
- END CASE;
-
- CASE CAS_BOL IS
- WHEN ("AND"(CON7,CON14)) =>
- FAILED("INCORRECT VALUE RETURNED FOR STATIC "&
- "OPERATORS 7");
- WHEN (">="(CON12,CON13)) =>
- OBJ1 := 9;
- END CASE;
-
- RESULT;
-
-END C49024A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49025a.ada b/gcc/testsuite/ada/acats/tests/c4/c49025a.ada
deleted file mode 100644
index be15cbd..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49025a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C49025A.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 CERTAIN ATTRIBUTES CAN BE USED IN STATIC EXPRESSIONS
--- SUCH AS: 'SUCC, 'PRED, 'POS, 'VAL, 'AFT, 'DELTA, 'DIGITS, 'FIRST,
---'FORE, 'LAST, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_MANTISSA,
---'MACHINE_OVERFLOWS, 'MACHINE_RADIX, 'MACHINE_ROUNDS, 'SIZE, 'SMALL, 'WIDTH.
-
--- L.BROWN 10/07/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C49025A IS
-
- TYPE ENUM IS (RED,BLUE,GREEN,BLACK);
- TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 20.0;
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0;
- TYPE INT IS RANGE 1 .. 100;
- TYPE TINT1 IS RANGE 1 .. ENUM'POS(BLUE);
- TYPE TFLT IS DIGITS FIX'AFT RANGE 0.0 .. 10.0;
- TYPE TFIX2 IS DELTA FIX'DELTA RANGE 0.0 .. 5.0;
- TYPE TFLT1 IS DIGITS FLT'DIGITS;
- TYPE ITN IS RANGE 0 .. INT'FIRST;
- TYPE TINT2 IS RANGE 1 .. FIX'FORE;
- TYPE TFLT3 IS DIGITS 3 RANGE 5.0 .. FLT'LAST;
- CON3 : CONSTANT := FLT'MACHINE_EMAX;
- TYPE TINT3 IS RANGE FLT'MACHINE_EMIN .. 1;
- CON4 : CONSTANT := FLT'MACHINE_MANTISSA;
- TYPE TINT4 IS RANGE 1 .. FLT'MACHINE_RADIX;
- CON6 : CONSTANT := INT'SIZE;
- TYPE TFIX5 IS DELTA 0.125 RANGE 0.0 .. FIX'SMALL;
- TYPE TINT6 IS RANGE 1 .. ENUM'WIDTH;
- OBJ1 : INTEGER := 1;
- CAS_OBJ : BOOLEAN := TRUE;
-
-BEGIN
-
- TEST("C49025A","CHECK THAT CERTAIN ATTRIBUTES CAN "&
- "BE USED IN STATIC EXPRESSIONS.");
-
- CASE CAS_OBJ IS
- WHEN (ENUM'PRED(BLUE) = ENUM'(RED)) =>
- OBJ1 := 2;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 1");
- END CASE;
- CAS_OBJ := TRUE;
-
- CASE CAS_OBJ IS
- WHEN (ENUM'SUCC(RED) = ENUM'(BLUE)) =>
- OBJ1 := 3;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 2");
- END CASE;
- CAS_OBJ := TRUE;
-
- CASE CAS_OBJ IS
- WHEN (ENUM'VAL(3) = ENUM'(BLACK)) =>
- OBJ1 := 4;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 3");
- END CASE;
- CAS_OBJ := TRUE;
-
- CASE CAS_OBJ IS
- WHEN (TRUE OR FLT'MACHINE_OVERFLOWS) =>
- OBJ1 := 5;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 4");
- END CASE;
- CAS_OBJ := FALSE;
-
- CASE CAS_OBJ IS
- WHEN (FALSE AND FIX'MACHINE_ROUNDS) =>
- OBJ1 := 6;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 5");
- END CASE;
-
- RESULT;
-
-END C49025A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c49026a.ada b/gcc/testsuite/ada/acats/tests/c4/c49026a.ada
deleted file mode 100644
index c4cffa7..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c49026a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C49026A.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 QUALIFIED EXPRESSION CAN APPEAR IN A STATIC EXPRESSION.
-
--- L.BROWN 10/07/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C49026A IS
-
- TYPE ENUM IS (RED,GREEN,BLUE,YELLOW);
- TYPE INT1 IS RANGE 1 .. 50;
- TYPE FLT1 IS DIGITS 3 RANGE 1.0 .. 5.0;
- TYPE FIX1 IS DELTA 0.125 RANGE 0.0 .. 10.0;
- TYPE INT2 IS RANGE 1 .. INT1'(25);
- TYPE FLT2 IS DIGITS 3 RANGE 1.0 .. FLT1'(2.0);
- TYPE FIX2 IS DELTA 0.125 RANGE 0.0 .. FIX1'(5.0);
- TYPE FLT3 IS DIGITS INT1'(3);
- TYPE FIX3 IS DELTA FIX1'(0.125) RANGE 0.0 .. 5.0;
- OBJ1 : INTEGER := 2;
- CAS_OBJ : ENUM := GREEN;
-
-BEGIN
-
- TEST("C49026A","QUALIFIED EXPRESSIONS CAN APPEAR IN STATIC "&
- "EXPRESSIONS");
-
- CASE CAS_OBJ IS
- WHEN ENUM'(GREEN) =>
- OBJ1 := 3;
- WHEN OTHERS =>
- FAILED("INCORRECT VALUE FOR QUALIFIED EXPRESSION 1");
- END CASE;
-
- RESULT;
-
-END C49026A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada
deleted file mode 100644
index 371077f..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C4A005B.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 NONSTATIC UNIVERSAL INTEGER EXPRESSION RAISES
--- CONSTRAINT_ERROR IF DIVISION BY ZERO IS ATTEMPTED
--- OR IF THE SECOND OPERAND OF REM OR MOD IS ZERO.
-
--- *** 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
-
--- JBG 5/2/85
--- EG 10/24/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387; PREVENT DEAD VARIABLE OPTIMIZATION
--- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C4A005B IS
-BEGIN
- TEST("C4A005B", "CHECK CONSTRAINT_ERROR FOR " &
- "NONSTATIC UNIVERSAL " &
- "INTEGER EXPRESSIONS - DIVISION BY ZERO");
- BEGIN
- DECLARE
- X : BOOLEAN := 1 = 1/INTEGER'POS(IDENT_INT(0));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - DIV");
- IF X /= IDENT_BOOL(X) THEN
- FAILED ("WRONG RESULT - DIV");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION IN WRONG PLACE - DIV");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR / BY 0");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - DIV");
- END;
-
- BEGIN
- DECLARE
- X : BOOLEAN := 1 = 1 REM INTEGER'POS(IDENT_INT(0));
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - REM");
- IF X /= IDENT_BOOL(X) THEN
- FAILED ("WRONG RESULT - REM");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION IN WRONG PLACE - REM");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR REM BY 0");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - REM");
- END;
-
- BEGIN
- DECLARE
- X : BOOLEAN := 1 = INTEGER'POS(IDENT_INT(1)) MOD 0;
- BEGIN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - MOD");
- IF X /= IDENT_BOOL(X) THEN
- FAILED ("WRONG RESULT - MOD");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION IN WRONG PLACE - MOD");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR MOD BY 0");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - MOD");
- END;
-
- RESULT;
-
-END C4A005B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada
deleted file mode 100644
index 5ba984a..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- C4A006A.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 A UNIVERSAL_INTEGER
--- EXPRESSION CONTAINING AN EXPONENTIATION OPERATOR IF THE EXPONENT
--- HAS A NEGATIVE VALUE.
-
--- BAW 9/29/80
--- SPS 4/7/82
--- TBN 10/23/85 RENAMED FROM B4A006A-B.ADA. REVISED TO CHECK FOR
--- CONSTRAINT_ERROR WHEN EXPONENT IS NEGATIVE IN
--- A NONSTATIC CONTEXT.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C4A006A IS
-
-BEGIN
- TEST ("C4A006A", "CHECK THAT A NEGATIVE EXPONENT IN " &
- "UNIVERSAL_INTEGER EXPONENTIATION RAISES " &
- "CONSTRAINT_ERROR");
-
- DECLARE
- B : BOOLEAN;
- BEGIN
-
- B := (1 ** IDENT_INT(-1)) = 1;
- FAILED ("EXCEPTION NOT RAISED");
- IF NOT B THEN
- FAILED ("(1 ** (-1)) /= 1");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- RESULT;
-END C4A006A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst b/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst
deleted file mode 100644
index 56850ca..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst
+++ /dev/null
@@ -1,47 +0,0 @@
--- C4A007A.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.
---*
--- USE OF MAX_INT IN NUMBER DECLARATION
-
--- BAW 29 SEPT 80
-
-WITH REPORT;
-PROCEDURE C4A007A IS
-
- USE REPORT;
-
- X : CONSTANT := $MAX_INT - ($MAX_INT MOD 2);
- Y : CONSTANT := ($MAX_INT / 2) * 2;
-
-BEGIN TEST("C4A007A","USING THE INTEGER VALUE MAX_INT IN NUMBER " &
- " DECLARATIONS ");
-
- IF X /= Y
- THEN FAILED("USING THE INTEGER VALUE MAX_INT GIVES " &
- " GIVES WRONG RESULTS ");
- END IF;
-
- RESULT;
-
-END C4A007A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada
deleted file mode 100644
index e6dfe7e..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C4A010A.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 STATIC UNIVERSAL_REAL EXPRESSIONS ARE EVALUATED EXACTLY.
-
--- SMALL RATIONAL NUMBERS ARE USED IN THIS TEST.
-
--- JBG 5/3/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C4A010A IS
-
- C13 : CONSTANT := 1.0/3.0;
- C47 : CONSTANT := 4.0/7.0;
- C112: CONSTANT := 13.0/12.0;
- HALF: CONSTANT := 3.5/7.0;
-
-BEGIN
-
- TEST ("C4A010A", "CHECK STATIC UNIVERSAL_REAL ACCURACY FOR " &
- "SMALL RATIONAL NUMBERS");
-
- IF C13 - C47 /= -5.0/21.0 THEN
- FAILED ("REAL SUBTRACTION RESULT INCORRECT");
- END IF;
-
- IF C47 + C112 = 1.0 + 55.0/84.0 THEN
- NULL;
- ELSE
- FAILED ("REAL ADDITION RESULT INCORRECT");
- END IF;
-
- IF C112 - C13 /= 6.0/8.0 THEN
- FAILED ("LCD NOT FOUND");
- END IF;
-
- IF 0.1 * 0.1 /= 0.01 THEN
- FAILED ("REAL MULTIPLICATION RESULT INCORRECT");
- END IF;
-
- IF C112/C13 /= 13.0/4 THEN
- FAILED ("REAL QUOTIENT RESULT INCORRECT");
- END IF;
-
- IF 0.1 ** 4 /= 0.0001 THEN
- FAILED ("POSITIVE EXPONENTIATION RESULT INCORRECT");
- END IF;
-
- IF C13 ** (-3) /= 27.0 * 0.5 * 2 THEN
- FAILED ("NEGATIVE EXPONENTIATION RESULT INCORRECT");
- END IF;
-
- IF HALF /= 0.1/0.2 THEN
- FAILED ("FRACTIONAL NUMERATOR AND DENOMINATOR");
- END IF;
-
- RESULT;
-
-END C4A010A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada
deleted file mode 100644
index 31cf3d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C4A010B.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 STATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED
--- EXACTLY. IN PARTICULAR, CHECK THAT THE CASCADING USE OF FRACTIONAL
--- VALUES DOES NOT RESULT IN THE LOSS OF PRECISION.
-
--- RJW 7/31/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE C4A010B IS
-
-
-BEGIN
-
- TEST( "C4A010B", "CHECK THAT STATIC UNIVERSAL REAL EXPRESSIONS " &
- "ARE EVALUATED EXACTLY. IN PARTICULAR, CHECK " &
- "THAT THE CASCADING USE OF FRACTIONAL VALUES " &
- "DOES NOT RESULT IN THE LOSS OF PRECISION" );
-
- DECLARE
- B : CONSTANT := 2.0/3.0;
-
- X0 : CONSTANT := 1.0;
- X1 : CONSTANT := X0 + B;
- X2 : CONSTANT := X1 + B ** 2;
- X3 : CONSTANT := X2 + B ** 3;
- X4 : CONSTANT := X3 + B ** 4;
- X5 : CONSTANT := X4 + B ** 5;
- X6 : CONSTANT := X5 + B ** 6;
- X7 : CONSTANT := X6 + B ** 7;
- X8 : CONSTANT := X7 + B ** 8;
- X9 : CONSTANT := X8 + B ** 9;
-
- Y1 : CONSTANT := B ** 10;
- Y2 : CONSTANT := 1.0;
- Y3 : CONSTANT := Y1 - Y2;
- Y4 : CONSTANT := B;
- Y5 : CONSTANT := Y4 - Y2;
- Y6 : CONSTANT := Y3 / Y5;
-
- BEGIN
- IF X9 /= 58025.0/19683.0 THEN
- FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " &
- "NUMBERS - 1" );
- END IF;
-
- IF Y6 /= 58025.0/19683.0 THEN
- FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " &
- "NUMBERS - 2" );
- END IF;
-
- IF X9 /= Y6 THEN
- FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " &
- "NUMBERS - 3" );
- END IF;
-
- END;
-
- RESULT;
-END C4A010B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada
deleted file mode 100644
index 374827c..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada
+++ /dev/null
@@ -1,334 +0,0 @@
--- C4A011A.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 NONSTATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED WITH
--- THE ACCURACY OF THE MOST PRECISE PREDEFINED FLOATING POINT TYPE
--- (I. E., THE TYPE FOR WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS).
-
--- RJW 8/4/86
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE C4A011A IS
-
- TYPE MAX_FLOAT IS DIGITS MAX_DIGITS;
-
- C5L : CONSTANT := 16#0.AAAA8#;
- C5U : CONSTANT := 16#0.AAAAC#;
-
- C6L : CONSTANT := 16#0.AAAAA8#;
- C6U : CONSTANT := 16#0.AAAAB0#;
-
- C7L : CONSTANT := 16#0.AAAAAA8#;
- C7U : CONSTANT := 16#0.AAAAAB0#;
-
- C8L : CONSTANT := 16#0.AAAAAAA#;
- C8U : CONSTANT := 16#0.AAAAAAB#;
-
- C9L : CONSTANT := 16#0.AAAAAAAA#;
- C9U : CONSTANT := 16#0.AAAAAAAC#;
-
- C10L : CONSTANT := 16#0.AAAAAAAAA#;
- C10U : CONSTANT := 16#0.AAAAAAAAC#;
-
- C11L : CONSTANT := 16#0.AAAAAAAAA8#;
- C11U : CONSTANT := 16#0.AAAAAAAAAC#;
-
- C12L : CONSTANT := 16#0.AAAAAAAAAA8#;
- C12U : CONSTANT := 16#0.AAAAAAAAAB0#;
-
- C13L : CONSTANT := 16#0.AAAAAAAAAAA8#;
- C13U : CONSTANT := 16#0.AAAAAAAAAAB0#;
-
- C14L : CONSTANT := 16#0.AAAAAAAAAAAA#;
- C14U : CONSTANT := 16#0.AAAAAAAAAAAB#;
-
- C15L : CONSTANT := 16#0.AAAAAAAAAAAAA#;
- C15U : CONSTANT := 16#0.AAAAAAAAAAAAC#;
-
- C16L : CONSTANT := 16#0.AAAAAAAAAAAAAA#;
- C16U : CONSTANT := 16#0.AAAAAAAAAAAAAC#;
-
- C17L : CONSTANT := 16#0.AAAAAAAAAAAAAA8#;
- C17U : CONSTANT := 16#0.AAAAAAAAAAAAAAC#;
-
- C18L : CONSTANT := 16#0.AAAAAAAAAAAAAAA8#;
- C18U : CONSTANT := 16#0.AAAAAAAAAAAAAAB0#;
-
- C19L : CONSTANT := 16#0.AAAAAAAAAAAAAAAA8#;
- C19U : CONSTANT := 16#0.AAAAAAAAAAAAAAAB0#;
-
- C20L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAA#;
- C20U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAB#;
-
- C21L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAA#;
- C21U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAC#;
-
- C22L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA#;
- C22U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAC#;
-
- C23L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA8#;
- C23U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAC#;
-
- C24L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAA8#;
- C24U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAB0#;
-
- C25L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAA8#;
- C25U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAB0#;
-
- C26L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAA#;
- C26U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAB#;
-
- C27L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAA#;
- C27U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAC#;
-
- C28L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA#;
- C28U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAC#;
-
- C29L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA8#;
- C29U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAC#;
-
- C30L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAA8#;
- C30U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAB0#;
-
- C31L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAA#;
- C31U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAB#;
-
- C32L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAA#;
- C32U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAB#;
-
- C33L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA#;
- C33U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAC#;
-
- C34L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA8#;
- C34U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAC#;
-
- C35L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAA8#;
- C35U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAAC#;
-
-BEGIN
-
- TEST ( "C4A011A", "CHECK THAT NONSTATIC UNIVERSAL REAL " &
- "EXPRESSIONS ARE EVALUATED WITH THE " &
- "ACCURACY OF THE MOST PRECISE PREDEFINED " &
- "FLOATING POINT TYPE (I. E., THE TYPE FOR " &
- "WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS" );
-
- CASE MAX_DIGITS IS
- WHEN 5 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C5L .. C5U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 5" );
- END IF;
- WHEN 6 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C6L .. C6U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 6" );
- END IF;
- WHEN 7 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C7L .. C7U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 7" );
- END IF;
- WHEN 8 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C8L .. C8U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 8" );
- END IF;
- WHEN 9 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C9L .. C9U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 9" );
- END IF;
- WHEN 10 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C10L .. C10U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 10" );
- END IF;
- WHEN 11 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C11L .. C11U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 11" );
- END IF;
- WHEN 12 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C12L .. C12U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 12" );
- END IF;
- WHEN 13 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C13L .. C13U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 13" );
- END IF;
- WHEN 14 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C14L .. C14U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 14" );
- END IF;
- WHEN 15 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C15L .. C15U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 15" );
- END IF;
- WHEN 16 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C16L .. C16U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 16" );
- END IF;
- WHEN 17 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C17L .. C17U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 17" );
- END IF;
- WHEN 18 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C18L .. C18U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 18" );
- END IF;
- WHEN 19 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C19L .. C19U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 19" );
- END IF;
- WHEN 20 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C20L .. C20U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 20" );
- END IF;
- WHEN 21 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C21L .. C21U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 21" );
- END IF;
- WHEN 22 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C22L .. C22U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 22" );
- END IF;
- WHEN 23 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C23L .. C23U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 23" );
- END IF;
- WHEN 24 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C24L .. C24U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 24" );
- END IF;
- WHEN 25 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C25L .. C25U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 25" );
- END IF;
- WHEN 26 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C26L .. C26U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 26" );
- END IF;
- WHEN 27 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C27L .. C27U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 27" );
- END IF;
- WHEN 28 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C28L .. C28U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 28" );
- END IF;
- WHEN 29 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C29L .. C29U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 29" );
- END IF;
- WHEN 30 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C30L .. C30U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 30" );
- END IF;
- WHEN 31 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C31L .. C31U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 31" );
- END IF;
- WHEN 32 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C32L .. C32U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 32" );
- END IF;
- WHEN 33 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C33L .. C33U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 33" );
- END IF;
- WHEN 34 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C34L .. C34U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 34" );
- END IF;
- WHEN 35 =>
- IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN
- C35L .. C35U THEN
- FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " &
- "VALUE OF 35" );
- END IF;
- WHEN OTHERS =>
- NOT_APPLICABLE ( "MAX_DIGITS OUT OF RANGE OF TEST. " &
- "MAX_DIGITS = " &
- INTEGER'IMAGE (MAX_DIGITS));
- END CASE;
-
- RESULT;
-
-END C4A011A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada
deleted file mode 100644
index 70c23ad..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- C4A012B.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 CONSTRAINT_ERROR IS RAISED FOR
--- A UNIVERSAL_REAL EXPRESSION IF DIVISION BY ZERO IS ATTEMPTED.
-
--- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR
--- 0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT VALUE).
-
--- HISTORY:
--- RJW 09/04/86 CREATED ORIGINAL TEST.
--- CJJ 09/04/87 ADDED PASS MESSAGE FOR RAISING NUMERIC_ERROR;
--- MODIFIED CODE TO PREVENT COMPILER OPTIMIZING
--- OUT THE TEST.
--- JET 12/31/87 ADDED MORE CODE TO PREVENT OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
--- JRL 02/29/96 Added code to check for value of Machine_Overflows; if
--- False, test is inapplicable.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C4A012B IS
-
- F : FLOAT;
-
- I3 : INTEGER := -3;
-
- SUBTYPE SINT IS INTEGER RANGE -10 .. 10;
- SI5 : CONSTANT SINT := -5;
-
- FUNCTION IDENT (X:FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN X;
- ELSE
- RETURN 1.0;
- END IF;
- END IDENT;
-
-BEGIN
-
- TEST ( "C4A012B", "CHECK THAT CONSTRAINT_ERROR " &
- "IS RAISED FOR " &
- "0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT " &
- "VALUE)" );
-
- IF FLOAT'MACHINE_OVERFLOWS = FALSE THEN
- REPORT.NOT_APPLICABLE ("Float'Machine_Overflows = False");
- ELSE
-
- BEGIN
- F := IDENT (0.0) ** (-1);
- FAILED ( "THE EXPRESSION '0.0 ** (-1)' DID NOT RAISE " &
- "AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 1");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** (-1)' RAISED THE " &
- "WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := 0.0 ** (IDENT_INT (-1));
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' DID " &
- "NOT RAISE AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 2");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' " &
- "RAISED THE WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := 0.0 ** (INTEGER'POS (IDENT_INT (-1)));
- FAILED ( "THE EXPRESSION '0.0 ** " &
- "(INTEGER'POS (IDENT_INT (-1)))' DID " &
- "NOT RAISE AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 3");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** " &
- "(INTEGER'POS (IDENT_INT (-1)))' RAISED " &
- "THE WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := IDENT(0.0) ** I3;
- FAILED ( "THE EXPRESSION '0.0 ** I3' DID NOT RAISE " &
- "AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 4");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** I3' RAISED THE " &
- "WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := 0.0 ** (IDENT_INT (I3));
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' DID " &
- "NOT RAISE AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 5");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' " &
- "RAISED THE WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := IDENT (0.0) ** SI5;
- FAILED ( "THE EXPRESSION '0.0 ** SI5' DID NOT RAISE " &
- "AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 6");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** SI5' RAISED THE " &
- "WRONG EXCEPTION" );
- END;
-
- BEGIN
- F := 0.0 ** (IDENT_INT (SI5));
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' DID " &
- "NOT RAISE AN EXCEPTION" );
- IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN
- COMMENT ("SHOULDN'T BE HERE!");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - 7");
- WHEN OTHERS =>
- FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' " &
- "RAISED THE WRONG EXCEPTION" );
- END;
-
- END IF;
-
- RESULT;
-
-END C4A012B;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada
deleted file mode 100644
index 1f385b5..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C4A013A.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 A NONSTATIC
--- UNIVERSAL_REAL EXPRESSION IF THE VALUE WOULD LIE OUTSIDE THE RANGE OF
--- THE BASE TYPE OF THE MOST ACCURATE PREDEFINED FLOATING POINT TYPE AND
--- MACHINE_OVERFLOWS IS TRUE FOR THAT TYPE.
-
--- *** 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
-
--- BAW 29 SEPT 80
--- TBN 10/30/85 RENAMED FROM C4A013A.ADA.
--- JRK 1/13/86 COMPLETELY REVISED TO CHECK NONSTATIC UNIVERSAL_REAL
--- EXPRESSIONS WHOSE RESULTS OVERFLOW. REVISED
--- NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH SYSTEM, REPORT;
-USE SYSTEM, REPORT;
-
-PROCEDURE C4A013A IS
-
- TYPE F IS DIGITS MAX_DIGITS;
-
- B : BOOLEAN;
-
-BEGIN
- TEST ("C4A013A", "CHECK NONSTATIC UNIVERSAL_REAL EXPRESSIONS " &
- "WHOSE RESULTS OVERFLOW");
-
- BEGIN
- B := 1.0 < 1.0 / (1.0 * INTEGER'POS (IDENT_INT (0)));
-
- IF F'MACHINE_OVERFLOWS THEN
- FAILED ("MACHINE_OVERFLOWS IS TRUE, BUT NO EXCEPTION " &
- "WAS RAISED");
- ELSE COMMENT ("MACHINE_OVERFLOWS IS FALSE AND NO EXCEPTION " &
- "WAS RAISED");
- END IF;
-
- IF NOT B THEN -- USE B TO PREVENT DEAD VARIABLE OPTIMIZATION.
- COMMENT ("1.0 < 1.0 / 0.0 YIELDS FALSE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- RESULT;
-END C4A013A;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada
deleted file mode 100644
index 84aa878..0000000
--- a/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C4A014A.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 ROUNDING IS DONE CORRECTLY FOR STATIC UNIVERSAL REAL
--- EXPRESSIONS.
-
--- JBG 5/3/85
--- JBG 11/3/85 DECLARE INTEGER CONSTANTS INSTEAD OF UNIVERSAL INTEGER
--- DTN 11/27/91 DELETED SUBPART (B).
-
-WITH REPORT; USE REPORT;
-PROCEDURE C4A014A IS
-
- C15 : CONSTANT := 1.5;
- C25 : CONSTANT := 2.5;
- CN15 : CONSTANT := -1.5;
- CN25 : CONSTANT := -2.5;
-
- C15R : CONSTANT INTEGER := INTEGER(C15);
- C25R : CONSTANT INTEGER := INTEGER(C25);
- CN15R : CONSTANT INTEGER := INTEGER(CN15);
- CN25R : CONSTANT INTEGER := INTEGER(CN25);
-
- C15_1 : BOOLEAN := 1 = C15R;
- C15_2 : BOOLEAN := 2 = C15R;
- C25_2 : BOOLEAN := 2 = C25R;
- C25_3 : BOOLEAN := 3 = C25R;
-
- CN15_N1 : BOOLEAN := -1 = CN15R;
- CN15_N2 : BOOLEAN := -2 = CN15R;
- CN25_N2 : BOOLEAN := -2 = CN25R;
- CN25_N3 : BOOLEAN := -3 = CN25R;
-
-BEGIN
-
- TEST ("C4A014A", "CHECK ROUNDING TO INTEGER FOR UNIVERSAL REAL " &
- "EXPRESSIONS");
-
- IF 1 /= INTEGER(1.4) THEN
- FAILED ("INTEGER(1.4) DOES NOT EQUAL 1");
- END IF;
-
- IF 2 /= INTEGER(1.6) THEN
- FAILED ("INTEGER(1.6) DOES NOT EQUAL 2");
- END IF;
-
- IF -1 /= INTEGER(-1.4) THEN
- FAILED ("INTEGER(-1.4) DOES NOT EQUAL -1");
- END IF;
-
- IF -2 /= INTEGER(-1.6) THEN
- FAILED ("INTEGER(-1.6) DOES NOT EQUAL -2");
- END IF;
-
- IF NOT (C15_1 OR C15_2) OR (NOT (C25_2 OR C25_3)) THEN
- FAILED ("ROUNDING OF POSITIVE VALUES NOT CORRECT");
- END IF;
-
- IF NOT (CN15_N1 OR CN15_N2) OR (NOT (CN25_N2 OR CN25_N3)) THEN
- FAILED ("ROUNDING OF NEGATIVE VALUES NOT CORRECT");
- END IF;
-
- RESULT;
-
-END C4A014A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c51004a.ada b/gcc/testsuite/ada/acats/tests/c5/c51004a.ada
deleted file mode 100644
index 75fa271..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c51004a.ada
+++ /dev/null
@@ -1,261 +0,0 @@
--- C51004A.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 LABELS, LOOP IDENTIFIERS, AND BLOCK IDENTIFIERS ARE
--- IMPLICITLY DECLARED AT THE END OF THE DECLARATIVE PART. PRIOR TO
--- THE END OF THE DECLARATIVE PART, THEY MAY BE USED TO REFERENCE
--- ENTITIES IN AN ENCLOSING SCOPE. SUBTESTS ARE:
--- (A) BLOCK.
--- (B) PROCEDURE BODY.
--- (C) PACKAGE BODY.
--- (D) GENERIC FUNCTION BODY.
--- (E) GENERIC PACKAGE BODY.
--- (F) TASK BODY.
-
--- CPP 6/1/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C51004A IS
-
-BEGIN
- TEST("C51004A", "CHECK THAT LABELS, LOOP IDENTIFIERS, AND BLOCK " &
- "IDENTIFIERS MAY BE USED PRIOR TO THEIR IMPLICIT " &
- "DECLARATION");
-
-OUTER: DECLARE
-
- TYPE IDN1 IS NEW INTEGER;
- IDN2 : CONSTANT INTEGER := 2;
- TYPE IDN3 IS ACCESS INTEGER;
-
- BEGIN -- OUTER
-
- -----------------------------------------------
-
- A : DECLARE
-
- A1 : IDN1;
- A2 : CONSTANT INTEGER := IDN2;
- A3 : IDN3;
-
- TEMP : INTEGER;
-
- BEGIN -- A
-
- <<IDN1>> TEMP := 0;
-
- IDN2 : FOR I IN 1..1 LOOP
- TEMP := A2;
- END LOOP IDN2;
-
- IDN3 : BEGIN
- NULL;
- END IDN3;
-
- END A;
-
- -----------------------------------------------
-
- B : DECLARE
-
- PROCEDURE P (TEMP : OUT INTEGER) IS
-
- B1 : IDN1;
- B2 : CONSTANT INTEGER := IDN2 + 2;
- B3 : IDN3;
-
- BEGIN -- P
-
- <<L>> <<IDN1>> TEMP := 0;
-
- IDN2 : WHILE B2 < 0 LOOP
- TEMP := 0;
- END LOOP IDN2;
-
- IDN3 : DECLARE
- BEGIN
- NULL;
- END IDN3;
-
- END P;
-
- BEGIN -- B
- NULL;
- END B;
-
- -----------------------------------------------
-
- C : DECLARE
-
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
-
- C1 : IDN1;
- C2 : CONSTANT INTEGER := 2 * IDN2;
- C3 : IDN3;
-
- TEMP : INTEGER;
-
- BEGIN
-
- <<IDN1>> TEMP := 0;
-
- IDN2 : LOOP
- TEMP := 0;
- EXIT;
- END LOOP IDN2;
-
- IDN3 : BEGIN
- NULL;
- END IDN3;
-
- END PKG;
-
- BEGIN -- C
- NULL;
- END C;
-
- ---------------------------------------------------
-
- D : DECLARE
-
- GENERIC
- TYPE Q IS (<>);
- FUNCTION FN RETURN INTEGER;
-
- FUNCTION FN RETURN INTEGER IS
-
- D1 : IDN1;
- D2 : CONSTANT INTEGER := IDN2;
- D3 : IDN3;
-
- TEMP : INTEGER;
-
- BEGIN
-
- <<IDN1>> TEMP := 0;
-
- IDN2 : FOR I IN 1..5 LOOP
- TEMP := 0;
- END LOOP IDN2;
-
- IDN3 : BEGIN
- NULL;
- END IDN3;
-
- RETURN TEMP;
-
- END FN;
-
- BEGIN
- NULL;
- END D;
-
- -----------------------------------------------
-
- E : DECLARE
-
- GENERIC
-
- TYPE ELEMENT IS (<>);
- ITEM : ELEMENT;
-
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
-
- E1 : IDN1 RANGE 1..5;
- E2 : CONSTANT INTEGER := IDN2;
- E3 : IDN3;
-
- TEMP : ELEMENT;
-
- BEGIN
-
- <<IDN1>> <<L>> TEMP := ITEM;
-
- IDN2 : WHILE TEMP /= ITEM LOOP
- TEMP := ITEM;
- END LOOP IDN2;
-
- IDN3 : DECLARE
- BEGIN
- NULL;
- END IDN3;
-
- END PKG;
-
- BEGIN -- E
-
- DECLARE
- PACKAGE P1 IS NEW PKG (INTEGER, 0);
- BEGIN
- NULL;
- END;
-
- END E;
-
- -----------------------------------------------
-
- F : DECLARE
-
- TASK T;
-
- TASK BODY T IS
-
- F1 : IDN1 RANGE -4..2;
- F2 : CONSTANT INTEGER := IDN2;
- F3 : IDN3;
-
- TEMP : INTEGER;
-
- BEGIN
-
- <<IDN1>> TEMP := 1;
-
- IDN2 : LOOP
- TEMP := TEMP + 1;
- EXIT;
- END LOOP IDN2;
-
- IDN3 : DECLARE
- BEGIN
- TEMP := TEMP + 1;
- END IDN3;
-
- END T;
-
- BEGIN -- F
- NULL;
- END F;
-
- -----------------------------------------------
-
- END OUTER;
-
- RESULT;
-END C51004A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005a.ada b/gcc/testsuite/ada/acats/tests/c5/c52005a.ada
deleted file mode 100644
index 2c70049..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005a.ada
+++ /dev/null
@@ -1,177 +0,0 @@
--- C52005A.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 CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A STATIC
--- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN,
--- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES.
-
--- DCB 2/5/80
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005A", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED "
- & "ON STATIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " &
- "AND ENUMERATION ASSIGNMENTS");
-
--------------------------
-
- DECLARE
- I1 : INTEGER RANGE 0..10 := 5;
-
- BEGIN
- I1 := 11;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I1 /= 5 THEN
- FAILED ("VALUE ALTERED BEFORE INT RANGE" &
- "EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- I2 : INTEGER RANGE 0..10 := 5;
-
- BEGIN
- I2 := 10;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT");
- END;
-
--------------------------
-
- DECLARE
- B1 : BOOLEAN RANGE TRUE..TRUE := TRUE;
-
- BEGIN
- B1 := FALSE;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF B1 /= TRUE THEN
- FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION");
- END IF;
- END;
-
--------------------------
-
- DECLARE
- B2 : BOOLEAN := TRUE;
-
- BEGIN
- B2 := FALSE;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT");
-
- END;
-
--------------------------
-
- DECLARE
- C1 : CHARACTER RANGE 'B'..'Z' := 'M';
-
- BEGIN
- C1 := 'A';
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF C1 /= 'M' THEN
- FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " &
- "EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- C2 : CHARACTER RANGE 'B'..'Z' := 'M';
-
- BEGIN
- C2 := 'B';
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT");
-
- END;
-
--------------------------
-
- DECLARE
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- WORKDAY : DAY RANGE MON..FRI := TUE;
-
- BEGIN
- WORKDAY := SUN;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF WORKDAY /= TUE THEN
- FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- WORKDAY : DAY RANGE MON..FRI := TUE;
-
- BEGIN
- WORKDAY := FRI;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT");
-
- END;
-
--------------------------
-
- RESULT;
-END C52005A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005b.ada b/gcc/testsuite/ada/acats/tests/c5/c52005b.ada
deleted file mode 100644
index 94b55be..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005b.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- C52005B.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 CONSTRAINT_ERROR EXCEPTION IS RAISED
--- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE
--- OF FLOATING POINT ASSIGNMENTS.
-
--- DCB 2/6/80
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005B IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005B", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED"
- & " ON STATIC OUT OF RANGE FLOATING POINT ASSIGNMENTS");
-
--------------------------
-
- DECLARE
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2;
- FL1 : FLT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- FL1 := 101.0;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FL1 /= 50.0 THEN
- FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2;
- FL2 : FLT RANGE 0.0 .. 100.0 := 50.0;
-
-
- BEGIN
- FL2 := 100.0;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT" &
- "ASSIGNMENT");
-
- END;
-
--------------------------
-
- DECLARE
- FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- FL1 := -0.001;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FL1 /= 50.0 THEN
- FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- FL2 := 0.0;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT");
-
- END;
-
-----------------------
-
- RESULT;
-END C52005B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005c.ada b/gcc/testsuite/ada/acats/tests/c5/c52005c.ada
deleted file mode 100644
index e064e5c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005c.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C52005C.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 CONSTRAINT_ERROR EXCEPTION IS RAISED
--- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE
--- OF FIXED POINT ASSIGNMENTS.
-
--- DCB 2/6/80
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005C IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005C", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED"
- & " ON STATIC OUT OF RANGE FIXED POINT ASSIGNMENTS");
-
------------------------
-
- DECLARE
- TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99;
- FX1 : REAL RANGE 0.00 .. 7.00 := 4.50;
-
- BEGIN
- FX1 := 7.01;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FX1 /= 4.50 THEN
- FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99;
- FX2 : REAL RANGE 0.00 .. 7.00 := 4.50;
-
- BEGIN
- FX2 := 7.00;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT");
-
- END;
-
--------------------------
-
- RESULT;
-END C52005C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005d.ada b/gcc/testsuite/ada/acats/tests/c5/c52005d.ada
deleted file mode 100644
index 055482b..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005d.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- C52005D.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 CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A DYNAMIC
--- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN,
--- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES.
-
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005D IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005D", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED "
- & "ON DYNAMIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " &
- "AND ENUMERATION ASSIGNMENTS");
-
--------------------------
-
- DECLARE
- I1 : INTEGER RANGE 0..10 := 5;
-
- BEGIN
- I1 := IDENT_INT(11);
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I1 /= 5 THEN
- FAILED ("VALUE ALTERED BEFORE INT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- I2 : INTEGER RANGE 0..10 := 5;
-
- BEGIN
- I2 := IDENT_INT(10);
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT");
- END;
-
--------------------------
-
- DECLARE
- B1 : BOOLEAN RANGE TRUE..TRUE := TRUE;
-
- BEGIN
- B1 := IDENT_BOOL(FALSE);
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF B1 /= TRUE THEN
- FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION");
- END IF;
- END;
-
--------------------------
-
- DECLARE
- B2 : BOOLEAN := TRUE;
-
- BEGIN
- B2 := IDENT_BOOL(FALSE);
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT");
-
- END;
-
--------------------------
-
- DECLARE
- C1 : CHARACTER RANGE 'B'..'Z' := 'M';
-
- BEGIN
- C1 := IDENT_CHAR('A');
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF C1 /= 'M' THEN
- FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " &
- "EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- C2 : CHARACTER RANGE 'B'..'Z' := 'M';
-
- BEGIN
- C2 := IDENT_CHAR('B');
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT");
-
- END;
-
--------------------------
-
- DECLARE
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- ALLDAYS : DAY := TUE;
- WORKDAY : DAY RANGE MON..FRI := TUE;
-
- BEGIN
- IF EQUAL(3,3) THEN
- ALLDAYS := SUN;
- END IF;
- WORKDAY := ALLDAYS;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF WORKDAY /= TUE THEN
- FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT);
- ALLDAYS : DAY := TUE;
- WORKDAY : DAY RANGE MON..FRI := TUE;
-
- BEGIN
- IF EQUAL(3,3) THEN
- ALLDAYS := FRI;
- END IF;
- WORKDAY := ALLDAYS;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT");
-
- END;
-
--------------------------
-
- RESULT;
-END C52005D;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005e.ada b/gcc/testsuite/ada/acats/tests/c5/c52005e.ada
deleted file mode 100644
index c474e21..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005e.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C52005E.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 CONSTRAINT_ERROR EXCEPTION IS RAISED
--- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE
--- OF FLOATING POINT ASSIGNMENTS.
-
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005E IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005E", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED"
- & " ON DYNAMIC OUT OF RANGE FLOATING POINT ASSIGNMENTS");
-
--------------------------
-
- DECLARE
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2;
- FL : FLT := 50.0;
- FL1 : FLT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- IF EQUAL(3,3) THEN
- FL := 101.0;
- END IF;
- FL1 := FL;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FL1 /= 50.0 THEN
- FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2;
- FL : FLT := 50.0;
- FL2 : FLT RANGE 0.0 .. 100.0 := 50.0;
-
-
- BEGIN
- IF EQUAL(3,3) THEN
- FL := 100.0;
- END IF;
- FL2 := FL;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT ASSNMT");
-
- END;
-
--------------------------
-
- DECLARE
- FL : FLOAT := 50.0;
- FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- IF EQUAL(3,3) THEN
- FL := -0.001;
- END IF;
- FL1 := FL;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " &
- "ASSIGNMENT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FL1 /= 50.0 THEN
- FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- FL : FLOAT := 50.0;
- FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0;
-
- BEGIN
- IF EQUAL(3,3) THEN
- FL := 0.0;
- END IF;
- FL2 := FL;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT");
-
- END;
-
-----------------------
-
- RESULT;
-END C52005E;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52005f.ada b/gcc/testsuite/ada/acats/tests/c5/c52005f.ada
deleted file mode 100644
index 19d58d0..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52005f.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C52005F.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 CONSTRAINT_ERROR EXCEPTION IS RAISED
--- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE
--- OF FIXED POINT ASSIGNMENTS.
-
--- JRK 7/21/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52005F IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C52005F", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED"
- & " ON DYNAMIC OUT OF RANGE FIXED POINT ASSIGNMENTS");
-
------------------------
-
- DECLARE
- TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99;
- FX : REAL := 4.50;
- FX1 : REAL RANGE 0.00 .. 7.00 := 4.50;
-
- BEGIN
- IF EQUAL(3,3) THEN
- FX := 7.01;
- END IF;
- FX1 := FX;
-
- FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF FX1 /= 4.50 THEN
- FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION");
- END IF;
-
- END;
-
--------------------------
-
- DECLARE
- TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99;
- FX : REAL := 4.50;
- FX2 : REAL RANGE 0.00 .. 7.00 := 4.50;
-
- BEGIN
- IF EQUAL(3,3) THEN
- FX := 7.00;
- END IF;
- FX2 := FX;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT");
-
- END;
-
--------------------------
-
- RESULT;
-END C52005F;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52008a.ada b/gcc/testsuite/ada/acats/tests/c5/c52008a.ada
deleted file mode 100644
index ac0e8b0..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52008a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C52008A.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 RECORD VARIABLE CONSTRAINED BY A SPECIFIED DISCRIMINANT
--- VALUE CANNOT HAVE ITS DISCRIMINANT VALUE ALTERED BY ASSIGNMENT.
--- ASSIGNING AN ENTIRE RECORD VALUE WITH A DIFFERENT DISCRIMINANT VALUE
--- SHOULD RAISE CONSTRAINT_ERROR AND LEAVE THE TARGET VARIABLE
--- UNALTERED. THIS TEST USES STATIC DISCRIMINANT VALUES.
-
--- ASL 6/25/81
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52008A IS
-
- USE REPORT;
-
- TYPE REC(DISC : INTEGER) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- R : REC(5) := (5,0);
-
-BEGIN
-
- TEST ("C52008A", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " &
- "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " &
- "STATIC DISCRIMINANT VALUE");
-
- BEGIN
- R := (DISC => 5, COMP => 3);
- IF R /= (5,3) THEN
- FAILED ("LEGAL ASSIGNMENT FAILED");
- END IF;
- R := (DISC => 4, COMP => 2);
- FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " &
- "VALUE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF R /= (5,3) THEN
- FAILED ("TARGET RECORD VALUE ALTERED BY " &
- "ASSIGNMENT TO VALUE WITH DIFFERENT " &
- "DISCRIMINANT VALUE EVEN AFTER " &
- "CONSTRAINT_ERROR RAISED");
- END IF;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION");
- END;
-
- RESULT;
-
-END C52008A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52008b.ada b/gcc/testsuite/ada/acats/tests/c5/c52008b.ada
deleted file mode 100644
index 3d0fa8d..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52008b.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C52008B.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 RECORD VARIABLE DECLARED WITH A SPECIFIED
--- DISCRIMINANT CONSTRAINT CANNOT HAVE A DISCRIMINANT VALUE ALTERED
--- BY ASSIGNMENT. ASSIGNING AN ENTIRE RECORD VALUE WITH A
--- DIFFERENT DISCRIMINANT VALUE SHOULD RAISE CONSTRAINT_ERROR AND
--- LEAVE THE TARGET VARIABLE UNALTERED. THIS TEST USES NON-STATIC
--- DISCRIMINANT VALUES.
-
--- HISTORY:
--- ASL 6/25/81 CREATED ORIGINAL TEST
--- JRK 11/18/82
--- RJW 8/17/89 ADDED SUBTYPE 'SUBINT'.
-
-WITH REPORT;
-PROCEDURE C52008B IS
-
- USE REPORT;
-
- TYPE REC1(D1,D2 : INTEGER) IS
- RECORD
- COMP1 : STRING(D1..D2);
- END RECORD;
-
- TYPE AR_REC1 IS ARRAY (NATURAL RANGE <>) OF REC1(IDENT_INT(3),
- IDENT_INT(5));
-
- SUBTYPE SUBINT IS INTEGER RANGE -128 .. 127;
-
- TYPE REC2(D1,D2,D3,D4 : SUBINT := 0) IS
- RECORD
- COMP1 : STRING(1..D1);
- COMP2 : STRING(D2..D3);
- COMP5 : AR_REC1(1..D4);
- COMP6 : REC1(D3,D4);
- END RECORD;
-
- STR : STRING(IDENT_INT(3)..IDENT_INT(5)) := "ZZZ";
-
- R1A : REC1(IDENT_INT(3),IDENT_INT(5)) := (3,5,STR);
- R1C : REC1(5,6) := (5,6,COMP1 => (5..6 => 'K'));
-
- Q,R : REC2(IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6));
- TEMP : REC2(2,3,5,6);
-
- W : REC2(1,4,6,8);
- OK : BOOLEAN := FALSE;
-
-
-BEGIN
-
- TEST ("C52008B", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " &
- "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " &
- "(DYNAMIC) DISCRIMINANT VALUE");
-
- BEGIN
- R1A := (IDENT_INT(3),5,"XYZ");
-
- R := (IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6),
- "AB",
- STR,
- (1..6 => R1A),
- R1C);
-
- TEMP := R;
- Q := TEMP;
- R.COMP1 := "YY";
- OK := TRUE;
- W := R;
- FAILED ("ASSIGNMENT MADE USING INCORRECT DISCRIMINANT " &
- "VALUES");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT OK
- OR Q /= TEMP
- OR R = TEMP
- OR R = Q
- OR W.D4 /= 8 THEN
- FAILED ("LEGITIMATE ASSIGNMENT FAILED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION");
- END;
-
- RESULT;
-
-END C52008B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52009a.ada b/gcc/testsuite/ada/acats/tests/c5/c52009a.ada
deleted file mode 100644
index 8a46f98..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52009a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C52009A.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 RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT
--- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD
--- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT
--- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO
--- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES
--- THE TARGET RECORD UNALTERED. THIS TEST USES STATIC DISCRIMINANT
--- VALUES.
-
--- ASL 6/25/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C52009A IS
-
- USE REPORT;
-
- TYPE REC (DISC : INTEGER) IS
- RECORD
- COMP : INTEGER;
- END RECORD;
-
- TYPE REC_NAME IS ACCESS REC;
-
- HR : REC_NAME := NEW REC'(5,0);
-
-BEGIN
-
- TEST ("C52009A", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " &
- "(STATIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " &
- "BY AN ACCESS VALUE");
-
- BEGIN
- HR.ALL := (DISC => 5, COMP => 3);
- IF HR.ALL /= (5,3) THEN
- FAILED ("LEGAL ASSIGNMENT FAILED");
- END IF;
- HR.ALL := (DISC => 4, COMP => 2);
- FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " &
- "VALUE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF HR.ALL /= (5,3) THEN
- FAILED ("TARGET RECORD VALUE ALTERED BY " &
- "ASSIGNMENT WITH A DIFFERENT " &
- "DISCRIMINANT VALUE EVEN AFTER " &
- "CONSTRAINT_ERROR RAISED");
- END IF;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION");
- END;
-
- RESULT;
-
-END C52009A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52009b.ada b/gcc/testsuite/ada/acats/tests/c5/c52009b.ada
deleted file mode 100644
index 98577fd..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52009b.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C52009B.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 RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT
--- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD
--- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT
--- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO
--- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES
--- THE TARGET RECORD UNALTERED. THIS TEST USES NON-STATIC DISCRIMINANT
--- VALUES AND A TYPE WITH DEFAULT DISCRIMINANTS.
-
--- ASL 7/6/81
--- SPS 10/26/82
--- JBG 1/10/84
-
-WITH REPORT;
-PROCEDURE C52009B IS
-
- USE REPORT;
-
- TYPE REC(DISC : INTEGER := 5) IS
- RECORD
- COMP : INTEGER := 0;
- END RECORD;
-
- TYPE REC_NAME IS ACCESS REC;
-
- HR : REC_NAME := NEW REC;
-
-BEGIN
-
- TEST ("C52009B", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " &
- "(DYNAMIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " &
- "BY AN ACCESS VALUE");
-
- BEGIN
- HR.ALL := (DISC => IDENT_INT(5), COMP => 3);
- IF HR.ALL /= (IDENT_INT(5),3) THEN
- FAILED ("LEGAL ASSIGNMENT FAILED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED WHEN DISCRIMINANT " &
- "VALUE NOT CHANGED");
- END;
-
- BEGIN
- HR.ALL := (DISC => IDENT_INT(4), COMP => 2);
- FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " &
- "VALUE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("DETECTED ATTEMPT TO CHANGE DISCRIMINANT " &
- "VALUE");
- WHEN OTHERS => FAILED ("WRONG EXCEPTION");
- END;
-
- RESULT;
-
-END C52009B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52010a.ada b/gcc/testsuite/ada/acats/tests/c5/c52010a.ada
deleted file mode 100644
index ddb58f7..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52010a.ada
+++ /dev/null
@@ -1,186 +0,0 @@
--- C52010A.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 RECORD ASSIGNMENTS USE "COPY" SEMANTICS. (PART I).
-
-
--- FACTORS AFFECTING THE SITUATION TO BE TESTED:
---
--- COMPONENT TYPE * INTEGER
--- * BOOLEAN (OMITTED)
--- * CHARACTER (OMITTED)
--- * USER-DEFINED ENUMERATION
---
--- DERIVED VS. NON-DERIVED
---
--- TYPE VS. SUBTYPE
---
--- ORDER OF COMPONENT ASSIGNMENTS * LEFT-TO-RIGHT
--- * RIGHT-TO-LEFT
--- * INSIDE-OUT
--- * OUTSIDE IN
-
-
--- RM 02/23/80
--- SPS 3/21/83
-
-WITH REPORT;
-PROCEDURE C52010A IS
-
- USE REPORT;
-
- TYPE ENUM IS ( AA , BB , CC , DD , EE , FF , GG , HH ,
- II , JJ , KK , LL , MM , NN , PP , QQ ,
- TT , UU , VV , WW , XX , YY );
-
-BEGIN
-
- TEST ( "C52010A" , "CHECK THAT RECORD ASSIGNMENTS USE ""COPY""" &
- " SEMANTICS" );
-
-
- DECLARE
- TYPE REC IS
- RECORD
- X , Y : INTEGER ;
- END RECORD;
- R : REC ;
- BEGIN
-
- R := ( 5 , 8 ) ;
- R := ( X => 1 , Y => R.X ) ;
- IF R /= ( 1 , 5 ) THEN
- FAILED ( "WRONG VALUE (1)" );
- END IF;
-
- R := ( 5 , 8 ) ;
- R := ( Y => 1 , X => R.Y ) ;
- IF R /= ( 8 , 1 ) THEN
- FAILED ( "WRONG VALUE (2)" );
- END IF;
-
- R := ( 5 , 8 ) ;
- R := ( R.Y+1 , R.X+1 ) ;
- IF R /= ( 9 , 6 ) THEN
- FAILED ( "WRONG VALUE (3)" );
- END IF;
-
- END;
-
- DECLARE
- TYPE REC3 IS
- RECORD
- DEEP0 : INTEGER ;
- DEEP : INTEGER ;
- END RECORD;
- TYPE REC2 IS
- RECORD
- YX : REC3 ;
- MODERATE : INTEGER ;
- END RECORD;
- TYPE REC IS
- RECORD
- SHALLOW : INTEGER ;
- YZ : REC2 ;
- END RECORD;
- R : REC ;
- BEGIN
- R := ( 0 , ((5, 1 ), 2 ));
- R := ( R.YZ.MODERATE+8, ((7, R.SHALLOW+1),R.YZ.YX.DEEP+99));
- IF R/= ( 10, ((7, 1), 100))
- THEN
- FAILED ( "WRONG VALUE (4)" );
- END IF;
- END;
-
-
- DECLARE
- TYPE SUB_ENUM IS NEW ENUM RANGE AA..DD ;
- TYPE REC IS
- RECORD
- X , Y : SUB_ENUM ;
- END RECORD;
- R : REC ;
- BEGIN
- R := ( AA , CC ) ;
- R := ( X => BB , Y => R.X ) ;
- IF R /= ( BB , AA ) THEN
- FAILED ( "WRONG VALUE (5)" );
- END IF;
-
- R := ( AA , CC ) ;
- R := ( Y => BB , X => R.Y ) ;
- IF R /= ( CC , BB ) THEN
- FAILED ( "WRONG VALUE (6)" );
- END IF;
-
- R := ( AA , CC ) ;
- R := ( SUB_ENUM'SUCC( R.Y ) , SUB_ENUM'SUCC( R.X ) ) ;
- IF R /= ( DD , BB ) THEN
- FAILED ( "WRONG VALUE (7)" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE REC3 IS
- RECORD
- DEEP0 : ENUM ;
- DEEP : ENUM ;
- END RECORD;
- TYPE REC2 IS
- RECORD
- YX : REC3 ;
- MODERATE : ENUM ;
- END RECORD;
- TYPE REC IS
- RECORD
- SHALLOW : ENUM ;
- YZ : REC2 ;
- END RECORD;
- R : REC ;
- BEGIN
-
- R := ( TT ,
- (( YY , II ) ,
- AA ) ) ;
-
- R := ( ENUM'SUCC(ENUM'SUCC( R.YZ.MODERATE )) ,
- (( AA , ENUM'SUCC( R.SHALLOW ) ) ,
- ( ENUM'SUCC(ENUM'SUCC(ENUM'SUCC(ENUM'SUCC(
- R.YZ.YX.DEEP )))) ) ) ) ;
-
- IF R/= ( CC ,
- (( AA , UU ) ,
- MM ) )
- THEN
- FAILED ( "WRONG VALUE (8)" );
- END IF;
-
- END;
-
- RESULT ;
-
-END C52010A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52011a.ada b/gcc/testsuite/ada/acats/tests/c5/c52011a.ada
deleted file mode 100644
index 1f46c4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52011a.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C52011A.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 INDEX CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES.
--- SPECIFICALLY, CHECK THAT:
-
--- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT
--- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED
--- IS NULL.
-
--- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED
--- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE.
-
--- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS
--- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES.
-
--- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT
--- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS
--- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER
--- FROM THOSE ON THE SUBTYPE.
-
--- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED
--- SUBTYPES OF THIS TYPE.
-
--- ASL 6/29/81
--- RM 6/17/82
--- SPS 10/26/82
--- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION.
-
-WITH REPORT;
-PROCEDURE C52011A IS
-
- USE REPORT;
-
- TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
- TYPE ARR_NAME IS ACCESS ARR;
- SUBTYPE S1 IS ARR_NAME(IDENT_INT(1)..IDENT_INT(10));
- SUBTYPE S2 IS ARR_NAME(IDENT_INT(3)..IDENT_INT(6));
-
- W : ARR_NAME := NULL; -- E.
- X1,X2 : S1 := NULL; -- E.
- Y1,Y2 : S2 := NULL; -- E.
-
- W_NONNULL : ARR_NAME := NEW ARR'(3..5=>7) ;
- X1_NONNULL : S1 := NEW ARR'(IDENT_INT(1)..IDENT_INT(10)=>7);
- Y1_NONNULL : S2 := NEW ARR'(IDENT_INT(3)..IDENT_INT( 6)=>7);
-
- TOO_EARLY : BOOLEAN := TRUE;
-
-BEGIN
-
- TEST ("C52011A", "INDEX CONSTRAINTS ON ACCESS SUBTYPE OBJECTS " &
- "MUST BE SATISFIED FOR ASSIGNMENT");
-
- BEGIN
-
- IF EQUAL(3,3) THEN
- W_NONNULL := X1; -- A.
- END IF;
- IF W_NONNULL /= X1 THEN
- FAILED ("ASSIGNMENT FAILED - 1");
- END IF;
-
- IF EQUAL(3,3) THEN
- X1_NONNULL := X2; -- A.
- END IF;
- IF X1_NONNULL /= X2 THEN
- FAILED ("ASSIGNMENT FAILED - 2");
- END IF;
-
- IF EQUAL(3,3) THEN
- X1_NONNULL := Y1; -- A.
- END IF;
- IF X1 /= Y1 THEN
- FAILED ("ASSIGNMENT FAILED - 3");
- END IF;
-
- X1 := NEW ARR'(1..IDENT_INT(10) => 5);
- IF EQUAL(3,3) THEN
- X2 := X1; -- B.
- END IF;
- IF X2 /= X1 THEN
- FAILED ("ASSIGNMENT FAILED - 4");
- END IF;
-
- IF EQUAL(3,3) THEN
- W := X1; -- B.
- END IF;
- IF W /= X1 THEN
- FAILED ("ASSIGNMENT FAILED - 5");
- END IF;
-
- BEGIN
- Y1 := X1; -- C.
- IF Y1'FIRST /= REPORT.IDENT_INT(3) THEN
- FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
- "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
- "AND CONSTRAINT IS CHANGED");
- ELSE
- FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
- "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
- "AND CONSTRAINT IS NOT CHANGED");
- END IF;
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
-
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 1");
-
- END;
-
- W := NEW ARR'(IDENT_INT(3)..IDENT_INT(6) => 3);
-
- BEGIN
- X1 := W; -- D.
- IF X1'FIRST /= REPORT.IDENT_INT(1) THEN
- FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
- "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
- "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
- "AND CONSTRAINT IS CHANGED");
- ELSE
- FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
- "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
- "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
- "AND CONSTRAINT IS NOT CHANGED");
- END IF;
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL ;
-
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 2");
-
- END;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
-
- END;
-
-
- RESULT;
-
-
-END C52011A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52011b.ada b/gcc/testsuite/ada/acats/tests/c5/c52011b.ada
deleted file mode 100644
index 460f518..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52011b.ada
+++ /dev/null
@@ -1,180 +0,0 @@
--- C52011B.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 DISCRIMINANT CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES.
--- SPECIFICALLY, CHECK THAT:
-
--- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT
--- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED
--- IS NULL.
-
--- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED
--- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE.
-
--- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS
--- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES.
-
--- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT
--- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS
--- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER
--- FROM THOSE ON THE SUBTYPE.
-
--- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED
--- SUBTYPES OF THIS TYPE.
-
--- ASL 7/06/81
--- RM 6/17/82
--- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION.
-
-WITH REPORT;
-PROCEDURE C52011B IS
-
- USE REPORT;
-
- TYPE REC(DISC : INTEGER := -1 ) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE REC_NAME IS ACCESS REC;
- SUBTYPE S1 IS REC_NAME(IDENT_INT(5));
- SUBTYPE S2 IS REC_NAME(IDENT_INT(3));
-
- W : REC_NAME := NULL; -- E.
- X1,X2 : S1 := NULL; -- E.
- Y1,Y2 : S2 := NULL; -- E.
-
- W_NONNULL : REC_NAME := NEW REC(7) ;
- X1_NONNULL : S1 := NEW REC(IDENT_INT(5));
- Y1_NONNULL : S2 := NEW REC(IDENT_INT(3));
-
- TOO_EARLY : BOOLEAN := TRUE;
-
-BEGIN
-
- TEST ("C52011B", "DISCRIMINANT CONSTRAINTS ON ACCESS SUBTYPE " &
- "OBJECTS MUST BE SATISFIED FOR ASSIGNMENT");
-
- BEGIN
-
- IF EQUAL(3,3) THEN
- W_NONNULL := X1; -- A.
- END IF;
- IF W_NONNULL /= X1 THEN
- FAILED ("ASSIGNMENT FAILED - 1");
- END IF;
-
- IF EQUAL(3,3) THEN
- W := Y1; -- A.
- END IF;
- IF W /= Y1 THEN
- FAILED ("ASSIGNMENT FAILED - 2");
- END IF;
-
- IF EQUAL(3,3) THEN
- X1_NONNULL := Y1; -- A.
- END IF;
- IF X1_NONNULL /= Y1 THEN
- FAILED ("ASSIGNMENT FAILED - 3");
- END IF;
-
- IF EQUAL(3,3) THEN
- Y1_NONNULL := Y2; -- A.
- END IF;
- IF Y1_NONNULL /= Y2 THEN
- FAILED ("ASSIGNMENT FAILED - 4");
- END IF;
-
- X1 := NEW REC(IDENT_INT(5));
- IF EQUAL(3,3) THEN
- X2 := X1; -- B.
- END IF;
- IF X1 /= X2 THEN
- FAILED ("ASSIGNMENT FAILED - 5");
- END IF;
-
- IF EQUAL(3,3) THEN
- W := X1; -- B.
- END IF;
- IF W /= X1 THEN
- FAILED ("ASSIGNMENT FAILED - 6");
- END IF;
-
- BEGIN
- Y1 := X1; -- C.
- IF Y1.DISC /= REPORT.IDENT_INT(3) THEN
- FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
- "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
- "AND CONSTRAINT IS CHANGED");
- ELSE
- FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " &
- "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " &
- "AND CONSTRAINT IS NOT CHANGED");
- END IF;
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL;
-
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 1");
-
- END;
-
- W := NEW REC(IDENT_INT(3));
-
- BEGIN
- X1 := W; -- D.
- IF X1.DISC /= REPORT.IDENT_INT(5) THEN
- FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
- "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
- "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
- "AND CONSTRAINT IS CHANGED");
- ELSE
- FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " &
- "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "&
- "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " &
- "AND CONSTRAINT IS NOT CHANGED");
- END IF;
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- NULL ;
-
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - 2");
-
- END;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED");
-
- END;
-
-
- RESULT;
-
-
-END C52011B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52101a.ada b/gcc/testsuite/ada/acats/tests/c5/c52101a.ada
deleted file mode 100644
index 87a4500..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52101a.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C52101A.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 ARRAY SUBTYPE CONVERSION IS APPLIED AFTER AN ARRAY VALUE
--- IS DETERMINED.
-
--- BHS 6/22/84
-
-WITH REPORT;
-PROCEDURE C52101A IS
-
- USE REPORT;
-
- TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN);
- SUBTYPE WEEKDAY IS DAY RANGE MON..FRI;
-
- TYPE ARR IS ARRAY (WEEKDAY RANGE <>) OF INTEGER;
- TYPE ARR_DAY IS ARRAY (DAY RANGE <>) OF INTEGER;
-
- NORM : ARR (MON..FRI); -- INDEX SUBTYPE WEEKDAY
- NORM_DAY : ARR_DAY (MON..FRI); -- INDEX SUBTYPE DAY
-
-BEGIN
- TEST ("C52101A", "CHECK THAT ARRAY SUBTYPE CONVERSION " &
- "APPLIED AFTER ARRAY VAL. DETERMINED");
-
- BEGIN -- ILLEGAL CASE
- NORM := (WED..SUN => 0); -- ERROR: INDEX SUBTYPE
-
- FAILED ("EXCEPTION NOT RAISED FOR INDEX SUBTYPE ERROR");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("IMPROPER AGGREGATE BOUNDS DETECTED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED");
-
- END;
-
-
- BEGIN -- LEGAL CASE
- NORM_DAY := (WED..FRI => 0, SAT..SUN => 1);
- IF NORM_DAY /= ( 0, 0, IDENT_INT(0), IDENT_INT(1),
- IDENT_INT(1)) THEN
- FAILED ("INCORRECT ASSIGNMENT IN LEGAL CASE");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED ON LEGAL INDEX " &
- "SUBTYPE CONVERSION");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED IN LEGAL CASE");
-
- END;
-
-
- RESULT;
-
-END C52101A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102a.ada b/gcc/testsuite/ada/acats/tests/c5/c52102a.ada
deleted file mode 100644
index 0d686ed..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52102a.ada
+++ /dev/null
@@ -1,251 +0,0 @@
--- C52102A.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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES
--- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES
--- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS,
--- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.)
-
--- PART 1: STATIC BOUNDS
-
-
--- RM 02/25/80
--- SPS 2/18/83
--- JBG 8/21/83
--- JBG 5/8/84
--- JBG 6/09/84
-
-WITH REPORT;
-PROCEDURE C52102A IS
-
- USE REPORT;
-
-
-BEGIN
-
-
- TEST( "C52102A" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " &
- "SOURCE AND TARGET VARIABLES (INCLUDING " &
- "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " &
- "SATISFIES THE SEMANTICS OF ""COPY"" " &
- "ASSIGNMENT (PART 1: STATIC BOUNDS)" );
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF INTEGERS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF INTEGER;
-
- BEGIN
- A := ( 11 , 12 , 13 , 14 );
- A := ( 1 , A(1) , A(2) , A(1) );
- IF A /= ( 1 , 11 , 12 , 11 ) THEN
- FAILED( "WRONG VALUES - I1" );
- END IF;
-
- A := ( 11 , 12 , 13 , 14 );
- A := ( A(4) , A(3) , A(4) , 1 );
- IF A /= ( 14 , 13 , 14 , 1 ) THEN
- FAILED( "WRONG VALUES - I2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER;
-
- BEGIN
- A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 );
- A(-4..0) := A(0..4);
- IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 )
- THEN
- FAILED( "WRONG VALUES - I3" );
- END IF;
-
- A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 );
- A(0..4) := A(-4..0);
- IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 )
- THEN
- FAILED( "WRONG VALUES - I4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- A : INT_ARR (1..10);
-
- BEGIN
- A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 );
- A := 0 & A(1..2) & A(1..2) & A(1..5);
- IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 )
- THEN
- FAILED( "WRONG VALUES - I5" );
- END IF;
-
- A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 );
- A := A(6..9) & A(8..9) & A(8..9) & 0 & 0;
- IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 )
- THEN
- FAILED( "WRONG VALUES - I6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF BOOLEANS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF BOOLEAN;
-
- BEGIN
- A := ( FALSE , TRUE , TRUE , FALSE );
- A := ( TRUE , A(1) , A(2) , A(1) );
- IF A /= ( TRUE , FALSE , TRUE , FALSE )
- THEN
- FAILED( "WRONG VALUES - B1" );
- END IF;
-
- A := ( FALSE , TRUE , TRUE , FALSE );
- A := ( A(4) , A(3) , A(4) , TRUE );
- IF A /= ( FALSE , TRUE , FALSE, TRUE )
- THEN
- FAILED( "WRONG VALUES - B2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN;
-
- BEGIN
- A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE);
- A(-4..0) := A(0..4);
- IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B3" );
- END IF;
-
- A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE);
- A(0..4) := A(-4..0);
- IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A : B_ARR (1..10);
-
- BEGIN
- A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE);
- A := FALSE & A(1..2) & A(1..2) & A(1..5);
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B5" );
- END IF;
-
- A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE);
- A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE;
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- CHARACTER STRINGS --------------------------
-
- DECLARE
- A : STRING( 1..4 );
-
- BEGIN
- A := "ARGH";
- A := ( 'Q' , A(1) , A(2) , A(1) );
- IF A /= "QARA" THEN
- FAILED( "WRONG VALUES - C1" );
- END IF;
-
- A := "ARGH";
- A := ( A(4) , A(3) , A(4) , 'X' );
- IF A /= "HGHX" THEN
- FAILED( "WRONG VALUES - C2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : STRING( 96..104 );
-
- BEGIN
- A := "APHRODITE";
- A(96..100) := A(100..104);
- IF A /= "ODITEDITE" THEN
- FAILED( "WRONG VALUES - C3" );
- END IF;
-
- A := "APHRODITE";
- A(100..104) := A(96..100) ;
- IF A /= "APHRAPHRO" THEN
- FAILED( "WRONG VALUES - C4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER;
- A : CH_ARR (1..9);
-
- BEGIN
- A := "CAMBRIDGE";
- A := 'S' & A(1..2) & A(1..2) & A(1..4);
- IF A /= "SCACACAMB" THEN
- FAILED( "WRONG VALUES - C5" );
- END IF;
-
- A := "CAMBRIDGE";
- A := A(8..8) & A(6..8) & A(6..8) & "EA";
- IF A /= "GIDGIDGEA" THEN
- FAILED( "WRONG VALUES - C6" );
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C52102A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102b.ada b/gcc/testsuite/ada/acats/tests/c5/c52102b.ada
deleted file mode 100644
index 79b3049..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52102b.ada
+++ /dev/null
@@ -1,278 +0,0 @@
--- C52102B.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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES
--- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES
--- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS,
--- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.)
-
--- PART 2: DYNAMIC BOUNDS
-
-
--- RM 02/27/80
--- SPS 2/18/83
--- JBG 3/15/84
--- JBG 6/9/84
-
-WITH REPORT;
-PROCEDURE C52102B IS
-
- USE REPORT;
- IDENT_INT_0 : INTEGER := IDENT_INT(0);
- IDENT_INT_1 : INTEGER := IDENT_INT (1);
- IDENT_INT_2 : INTEGER := IDENT_INT (2);
- IDENT_INT_3 : INTEGER := IDENT_INT (3);
- IDENT_INT_4 : INTEGER := IDENT_INT (4);
- IDENT_INT_5 : INTEGER := IDENT_INT (5);
- IDENT_INT_6 : INTEGER := IDENT_INT (6);
- IDENT_INT_8 : INTEGER := IDENT_INT (8);
- IDENT_INT_9 : INTEGER := IDENT_INT (9);
-
-BEGIN
-
-
- TEST( "C52102B" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " &
- "SOURCE AND TARGET VARIABLES (INCLUDING " &
- "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " &
- "SATISFIES THE SEMANTICS OF ""COPY"" " &
- "ASSIGNMENT (PART 2: DYNAMIC BOUNDS)" );
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF INTEGERS -------------------------
-
- DECLARE
- A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER;
-
- BEGIN
- A := ( 11 , 12 , 13 , 14 );
- A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= ( 1 , 11 , 12 , 11 ) THEN
- FAILED( "WRONG VALUES - I1" );
- END IF;
-
- A := ( 11 , 12 , 13 , 14 );
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , 1 );
- IF A /= ( 14 , 13 , 14 , 1 ) THEN
- FAILED( "WRONG VALUES - I2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER;
-
- BEGIN
- A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 );
- A(-4..IDENT_INT_0) := A(IDENT_INT_0..4);
- IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 )
- THEN
- FAILED( "WRONG VALUES - I3" );
- END IF;
-
- A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 );
- A(IDENT_INT_0..4) := A(-4..IDENT_INT_0);
- IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 )
- THEN
- FAILED( "WRONG VALUES - I4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- A : ARR (1..10);
-
- BEGIN
- A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 );
- A := 0 & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_5);
- IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 )
- THEN
- FAILED( "WRONG VALUES - I5" );
- END IF;
-
- A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 );
- A := A(IDENT_INT_6..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) & 0 & 0;
- IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 )
- THEN
- FAILED( "WRONG VALUES - I6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF BOOLEANS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF BOOLEAN;
-
- BEGIN
- A := ( FALSE , TRUE , TRUE , FALSE );
- A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= ( TRUE , FALSE , TRUE , FALSE )
- THEN
- FAILED( "WRONG VALUES - B1" );
- END IF;
-
- A := ( FALSE , TRUE , TRUE , FALSE );
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , TRUE );
- IF A /= ( FALSE , TRUE , FALSE, TRUE )
- THEN
- FAILED( "WRONG VALUES - B2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN;
-
- BEGIN
- A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE);
- A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4);
- IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B3" );
- END IF;
-
- A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE);
- A(IDENT_INT_0..4) := A(-4..IDENT_INT_0);
- IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A : B_ARR (1..10);
-
- BEGIN
- A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE);
- A := FALSE & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_5);
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B5" );
- END IF;
-
- A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE);
- A := A(IDENT_INT_6..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE;
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- CHARACTER STRINGS --------------------------
-
- DECLARE
- A : STRING( 1..4 );
-
- BEGIN
- A := "ARGH";
- A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= "QARA" THEN
- FAILED( "WRONG VALUES - C1" );
- END IF;
-
- A := "ARGH";
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , 'X' );
- IF A /= "HGHX" THEN
- FAILED( "WRONG VALUES - C2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : STRING( IDENT_INT(96)..104 );
-
- BEGIN
- A := "APHRODITE";
- A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100)..
- IDENT_INT(104));
- IF A /= "ODITEDITE" THEN
- FAILED( "WRONG VALUES - C3" );
- END IF;
-
- A := "APHRODITE";
- A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96)..
- IDENT_INT(100)) ;
- IF A /= "APHRAPHRO" THEN
- FAILED( "WRONG VALUES - C4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER;
- A : CH_ARR (IDENT_INT_1..9);
-
- BEGIN
- A := "CAMBRIDGE";
- A := 'S' & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_4);
- IF A /= "SCACACAMB" THEN
- FAILED( "WRONG VALUES - C5" );
- END IF;
-
- A := "CAMBRIDGE";
- A := A(IDENT_INT_8..IDENT_INT_8) &
- A(IDENT_INT_6..IDENT_INT_8) &
- A(IDENT_INT_6..IDENT_INT_8) & "EA";
- IF A /= "GIDGIDGEA" THEN
- FAILED( "WRONG VALUES - C6" );
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C52102B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102c.ada b/gcc/testsuite/ada/acats/tests/c5/c52102c.ada
deleted file mode 100644
index 17fdf43..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52102c.ada
+++ /dev/null
@@ -1,280 +0,0 @@
--- C52102C.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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES
--- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES
--- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES
--- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS,
--- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.)
-
--- PART 1: STATIC BOUNDS
-
-
--- RM 02/25/80
--- SPS 2/18/83
--- JBG 8/21/83
--- JBG 5/8/84
--- JBG 6/09/84
--- BHS 6/26/84
-
-WITH REPORT;
-PROCEDURE C52102C IS
-
- USE REPORT;
-
- FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT;
- FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL;
-
-BEGIN
-
-
- TEST( "C52102C" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " &
- "SOURCE AND TARGET VARIABLES (INCLUDING " &
- "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " &
- "SATISFIES THE SEMANTICS OF ""COPY"" " &
- "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " &
- "ARE DYNAMIC (PART 1: STATIC BOUNDS)" );
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF INTEGERS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF INTEGER;
-
- BEGIN
- A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14));
- A := ( 1 , A(1) , A(2) , A(1) );
- IF A /= ( 1 , 11 , 12 , 11 ) THEN
- FAILED( "WRONG VALUES - I1" );
- END IF;
-
- A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14));
- A := ( A(4) , A(3) , A(4) , 1 );
- IF A /= ( 14 , 13 , 14 , 1 ) THEN
- FAILED( "WRONG VALUES - I2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER;
-
- BEGIN
- A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1),
- ID_I(100), ID_I(1),ID_I(2), ID_I(3), ID_I(4) );
- A(-4..0) := A(0..4);
- IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 )
- THEN
- FAILED( "WRONG VALUES - I3" );
- END IF;
-
- A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1),
- ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4) );
- A(0..4) := A(-4..0);
- IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 )
- THEN
- FAILED( "WRONG VALUES - I4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- A : INT_ARR (1..10);
-
- BEGIN
- A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5),
- ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) );
- A := 0 & A(1..2) & A(1..2) & A(1..5);
- IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 )
- THEN
- FAILED( "WRONG VALUES - I5" );
- END IF;
-
- A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5),
- ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) );
- A := A(6..9) & A(8..9) & A(8..9) & 0 & 0;
- IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 )
- THEN
- FAILED( "WRONG VALUES - I6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF BOOLEANS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF BOOLEAN;
-
- BEGIN
- A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE));
- A := ( TRUE , A(1) , A(2) , A(1) );
- IF A /= ( TRUE ,FALSE , TRUE , FALSE )
- THEN
- FAILED( "WRONG VALUES - B1" );
- END IF;
-
- A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE));
- A := ( A(4) , A(3) , A(4) , TRUE );
- IF A /= ( FALSE , TRUE , FALSE, TRUE )
- THEN
- FAILED( "WRONG VALUES - B2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN;
-
- BEGIN
- A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE),
- ID_B(FALSE), ID_B(TRUE), ID_B(TRUE),
- ID_B(TRUE), ID_B(TRUE));
- A(-4..0) := A(0..4);
- IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B3" );
- END IF;
-
- A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE),
- ID_B(TRUE), ID_B(TRUE), ID_B(TRUE),
- ID_B(TRUE), ID_B(TRUE));
- A(0..4) := A(-4..0);
- IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A : B_ARR (1..10);
-
- BEGIN
- A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE),
- ID_B(TRUE), ID_B(FALSE), ID_B(TRUE),
- ID_B(FALSE), ID_B(TRUE), ID_B(FALSE));
- A := FALSE & A(1..2) & A(1..2) & A(1..5);
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B5" );
- END IF;
-
- A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE),
- ID_B(TRUE), ID_B(FALSE), ID_B(TRUE),
- ID_B(FALSE), ID_B(TRUE), ID_B(FALSE));
- A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE;
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- CHARACTER STRINGS --------------------------
-
- DECLARE
- A : STRING( 1..4 );
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "ARGH";
- END IF;
- A := ( 'Q' , A(1) , A(2) , A(1) );
- IF A /= "QARA" THEN
- FAILED( "WRONG VALUES - C1" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "ARGH";
- END IF;
- A := ( A(4) , A(3) , A(4) , 'X' );
- IF A /= "HGHX" THEN
- FAILED( "WRONG VALUES - C2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : STRING( 96..104 );
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "APHRODITE";
- END IF;
- A(96..100) := A(100..104);
- IF A /= "ODITEDITE" THEN
- FAILED( "WRONG VALUES - C3" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "APHRODITE";
- END IF;
- A(100..104) := A(96..100) ;
- IF A /= "APHRAPHRO" THEN
- FAILED( "WRONG VALUES - C4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER;
- A : CH_ARR (1..9);
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "CAMBRIDGE";
- END IF;
- A := 'S' & A(1..2) & A(1..2) & A(1..4);
- IF A /= "SCACACAMB" THEN
- FAILED( "WRONG VALUES - C5" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "CAMBRIDGE";
- END IF;
- A := A(8..8) & A(6..8) & A(6..8) & "EA";
- IF A /= "GIDGIDGEA" THEN
- FAILED( "WRONG VALUES - C6" );
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C52102C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52102d.ada b/gcc/testsuite/ada/acats/tests/c5/c52102d.ada
deleted file mode 100644
index fd4e413..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52102d.ada
+++ /dev/null
@@ -1,307 +0,0 @@
--- C52102D.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 ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES
--- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES
--- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES
--- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS,
--- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.)
-
--- PART 2: DYNAMIC BOUNDS
-
-
--- RM 02/27/80
--- SPS 2/18/83
--- JBG 3/15/84
--- JBG 6/9/84
--- BHS 6/26/84
-
-WITH REPORT;
-PROCEDURE C52102D IS
-
- USE REPORT;
- IDENT_INT_0 : INTEGER := IDENT_INT(0);
- IDENT_INT_1 : INTEGER := IDENT_INT (1);
- IDENT_INT_2 : INTEGER := IDENT_INT (2);
- IDENT_INT_3 : INTEGER := IDENT_INT (3);
- IDENT_INT_4 : INTEGER := IDENT_INT (4);
- IDENT_INT_5 : INTEGER := IDENT_INT (5);
- IDENT_INT_6 : INTEGER := IDENT_INT (6);
- IDENT_INT_8 : INTEGER := IDENT_INT (8);
- IDENT_INT_9 : INTEGER := IDENT_INT (9);
-
- FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT;
- FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL;
-
-BEGIN
-
-
- TEST( "C52102D" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " &
- "SOURCE AND TARGET VARIABLES (INCLUDING " &
- "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " &
- "SATISFIES THE SEMANTICS OF ""COPY"" " &
- "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " &
- "ARE DYNAMIC (PART 2: DYNAMIC BOUNDS)" );
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF INTEGERS -------------------------
-
- DECLARE
- A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER;
-
- BEGIN
- A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) );
- A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= ( 1 , 11 , 12 , 11 ) THEN
- FAILED( "WRONG VALUES - I1" );
- END IF;
-
- A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) );
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , 1 );
- IF A /= ( 14 , 13 , 14 , 1 ) THEN
- FAILED( "WRONG VALUES - I2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER;
-
- BEGIN
- A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1),
- ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4));
- A(-4..IDENT_INT_0) := A(IDENT_INT_0..4);
- IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 )
- THEN
- FAILED( "WRONG VALUES - I3" );
- END IF;
-
- A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1),
- ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4));
- A(IDENT_INT_0..4) := A(-4..IDENT_INT_0);
- IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 )
- THEN
- FAILED( "WRONG VALUES - I4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- A : INT_ARR (1..10);
-
- BEGIN
- A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5),
- ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10));
- A := 0 & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_5);
- IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 )
- THEN
- FAILED( "WRONG VALUES - I5" );
- END IF;
-
- A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5),
- ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10));
- A := A(IDENT_INT_6..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) & 0 & 0;
- IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 )
- THEN
- FAILED( "WRONG VALUES - I6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- ARRAYS OF BOOLEANS -------------------------
-
- DECLARE
- A : ARRAY( 1..4 ) OF BOOLEAN;
-
- BEGIN
- A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE));
- A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= ( TRUE ,FALSE , TRUE , FALSE )
- THEN
- FAILED( "WRONG VALUES - B1" );
- END IF;
-
- A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE));
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , TRUE );
- IF A /= ( FALSE , TRUE , FALSE, TRUE )
- THEN
- FAILED( "WRONG VALUES - B2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN;
-
- BEGIN
- A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE),
- ID_B(FALSE), ID_B(TRUE), ID_B(TRUE),
- ID_B(TRUE), ID_B(TRUE));
- A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4);
- IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B3" );
- END IF;
-
- A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE),
- ID_B(TRUE), ID_B(TRUE), ID_B(TRUE),
- ID_B(TRUE), ID_B(TRUE));
- A(IDENT_INT_0..4) := A(-4..IDENT_INT_0);
- IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A : B_ARR (1..10);
-
- BEGIN
- A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE),
- ID_B(TRUE), ID_B(FALSE), ID_B(TRUE),
- ID_B(FALSE), ID_B(TRUE), ID_B(FALSE));
- A := FALSE & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_5);
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B5" );
- END IF;
-
- A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE),
- ID_B(TRUE), ID_B(FALSE), ID_B(TRUE),
- ID_B(FALSE), ID_B(TRUE), ID_B(FALSE));
- A := A(IDENT_INT_6..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) &
- A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE;
- IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE)
- THEN
- FAILED( "WRONG VALUES - B6" );
- END IF;
-
- END;
-
-
- -------------------------------------------------------------------
- -------------------- CHARACTER STRINGS --------------------------
-
- DECLARE
- A : STRING( 1..4 );
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "ARGH";
- END IF;
- A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) ,
- A(IDENT_INT_1) );
- IF A /= "QARA" THEN
- FAILED( "WRONG VALUES - C1" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "ARGH";
- END IF;
- A := ( A(IDENT_INT_4) , A(IDENT_INT_3) ,
- A(IDENT_INT_4) , 'X' );
- IF A /= "HGHX" THEN
- FAILED( "WRONG VALUES - C2" );
- END IF;
-
- END;
-
-
- DECLARE
- A : STRING( IDENT_INT(96)..104 );
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "APHRODITE";
- END IF;
- A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100)..
- IDENT_INT(104));
- IF A /= "ODITEDITE" THEN
- FAILED( "WRONG VALUES - C3" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "APHRODITE";
- END IF;
- A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96)..
- IDENT_INT(100)) ;
- IF A /= "APHRAPHRO" THEN
- FAILED( "WRONG VALUES - C4" );
- END IF;
-
- END;
-
-
- DECLARE
- TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER;
- A : CH_ARR (IDENT_INT_1..9);
-
- BEGIN
- IF EQUAL (3,3) THEN
- A := "CAMBRIDGE";
- END IF;
- A := 'S' & A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_2) &
- A(IDENT_INT_1..IDENT_INT_4);
- IF A /= "SCACACAMB" THEN
- FAILED( "WRONG VALUES - C5" );
- END IF;
-
- IF EQUAL (3,3) THEN
- A := "CAMBRIDGE";
- END IF;
- A := A(IDENT_INT_8..IDENT_INT_8) &
- A(IDENT_INT_6..IDENT_INT_8) &
- A(IDENT_INT_6..IDENT_INT_8) & "EA";
- IF A /= "GIDGIDGEA" THEN
- FAILED( "WRONG VALUES - C6" );
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C52102D;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103a.ada b/gcc/testsuite/ada/acats/tests/c5/c52103a.ada
deleted file mode 100644
index f8fca51..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103a.ada
+++ /dev/null
@@ -1,385 +0,0 @@
--- C52103A.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 2/18/83
-
-WITH REPORT;
-PROCEDURE C52103A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE SELECTIONS ARE 7 , 8 , 9 ,
- -- AND PRECISELY 5 CASES FROM THE
- -- TWO 5-CASE SERIES 2-3-4-5-6 AND
- -- 10-11-12-13-14)
- --
- -- ( IN THE CURRENT DIVISION, THE 5
- -- FLOATING SELECTIONS ARE 2-11-4-
- -- -13-6 ; THUS THE 8 SELECTIONS ARE
- -- 2-11-4-13-6-7-8-9 (IN THIS ORDER)
- -- .)
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION.
- -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.)
- --
- -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED
- -- IN THE SAME DECLARATION.)
- --
- --
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER
- -- USING AGGREGATES
- -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS;
- -- SEE (5) )
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS
- -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY
- -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR
- -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) --
- -- TO THE TYPEMARK OF ARR ),
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (SINCE WE ARE NOT USING AGGREGATES
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS,
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (THE ASSIGNMENT MAY REQUIRE SLIDING.)
- --
- -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL
- -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT
- -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK
- -- ALSO WHEN NO SLIDING IS INVOLVED.)
- --
- --
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B.
- -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TA21 IS ARRAY( INTEGER RANGE 1..5 , INTEGER RANGE 0..7
- ) OF INTEGER ;
-
- SUBTYPE TA22 IS TA21 ;
-
- ARR21 : TA21 ;
- ARR22 : TA22 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
-
- FOR J IN 0..7 LOOP
- ARR21( I , J ) := I * I * J ;
- END LOOP;
-
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARR22 := ARR21 ;
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN 1..5 LOOP
-
- FOR J IN 0..7 LOOP
-
- IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 )
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT" );
- END IF;
-
- END LOOP;
-
- END LOOP;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 2" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( 1..5 ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( 5..9 );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
- ARRX11( I ) := I * I ;
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN 5..9 LOOP
-
- IF ARRX12( I ) /= ( I-4 ) * ( I-4 )
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" );
- END IF;
-
- END LOOP;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TA42 IS ARRAY( INTEGER RANGE 1..5 ) OF BOOLEAN ;
-
- SUBTYPE TA41 IS TA42 ;
-
- ARR41 : TA41 ;
- ARR42 : TA42 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
- ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARR41(2) := TRUE ;
-
- ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR42( 1 ) := TRUE ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARR42(2..5) := ARR41(1..4) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- FOR I IN 2..5 LOOP
-
- IF ARR42( I ) /= FALSE AND I /= 3
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- ELSIF ARR42( I ) /= TRUE AND I = 3
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- END IF;
-
- END LOOP;
-
- IF ARR42( 1 ) /= TRUE
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 4" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103b.ada b/gcc/testsuite/ada/acats/tests/c5/c52103b.ada
deleted file mode 100644
index 678ef5d..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103b.ada
+++ /dev/null
@@ -1,139 +0,0 @@
--- C52103B.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 2/18/83
-
-WITH REPORT;
-PROCEDURE C52103B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( 11..15 );
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15
-
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX31 /= "QUINC" OR
- ARRX31( 11..15 ) /= "QUINC"
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
-
- DECLARE
-
- TYPE TA61 IS ARRAY( INTEGER RANGE 11..15 ) OF CHARACTER ;
-
- ARR61 : TA61 ;
-
- BEGIN
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR61( 11..11 ) := "Q" ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARR61( 12..15 ) := "UINC" ; -- "UINC"(1..4) SLIDES TO 12..15
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR61 /= "QUINC" OR
- ARR61( 11..15 ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 6" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103c.ada b/gcc/testsuite/ada/acats/tests/c5/c52103c.ada
deleted file mode 100644
index fb122a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103c.ada
+++ /dev/null
@@ -1,178 +0,0 @@
--- C52103C.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-
-
-PROCEDURE C52103C IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( 1..5 ) := "ABCDE" ;
- ARR72 : STRING( 5..9 ) := "FGHIJ" ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
-
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= "ABCDE"
- THEN
- FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( 5..9 ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR82( 5..5 ) := "Q" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( 5..9 )( 6..9 ) := "BCDE" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QBCDE" OR
- ARR82( 5..9 ) /= "QBCDE"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( 5..9 ) ;
-
- ARR91 : STRING( 1..5 ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR92( 5..5 ) := "Q" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( 5..9 )( 6..9 ) := ARR91( 1..5 )(2..5 )( 2..5 ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QBCDE" OR
- ARR92( 5..9 ) /= "QBCDE"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103f.ada b/gcc/testsuite/ada/acats/tests/c5/c52103f.ada
deleted file mode 100644
index fad0616..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103f.ada
+++ /dev/null
@@ -1,338 +0,0 @@
--- C52103F.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103F IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE SELECTIONS ARE 7 , 8 , 9 ,
- -- AND PRECISELY 5 CASES FROM THE
- -- TWO 5-CASE SERIES 2-3-4-5-6 AND
- -- 10-11-12-13-14)
- --
- -- ( IN THE CURRENT DIVISION, THE 5
- -- FLOATING SELECTIONS ARE 10-3-12-
- -- -5-14 ; THUS THE 8 SELECTIONS ARE
- -- 10-3-12-5-14-7-8-9 (IN THIS ORDER
- -- ).)
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION.
- -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.)
- --
- -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED
- -- IN THE SAME DECLARATION.)
- --
- --
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER
- -- USING AGGREGATES
- -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS;
- -- SEE (5) )
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS
- -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY
- -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR
- -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) --
- -- TO THE TYPEMARK OF ARR ),
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (SINCE WE ARE NOT USING AGGREGATES
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS,
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- -- (THE ASSIGNMENT MAY REQUIRE SLIDING.)
- --
- -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL
- -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT
- -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK
- -- ALSO WHEN NO SLIDING IS INVOLVED.)
- --
- --
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( 1..0 , 0..7 );
- SUBTYPE TABOX02 IS TABOX0 ;
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02( 7..6 , 20..27 );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TA3 IS ARRAY( INTEGER RANGE 100..99 ) OF INTEGER ;
-
- SUBTYPE TA31 IS TA3 ;
- SUBTYPE TA32 IS TA3 ;
-
- ARR31 : TA31 ;
- ARR32 : TA32 ;
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARR32 := ARR31 ;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 3" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( 1..5 );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( 5..9 );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
- ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARRX51(2) := TRUE ;
-
- ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN 5..9 LOOP
- ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F
- END LOOP;
-
- ARRX52(6) := FALSE ;
-
- ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX52(6..5) := ARRX51(4..3) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX52( 5 ) /= TRUE OR
- ARRX52( 6 ) /= FALSE OR
- ARRX52( 7 ) /= TRUE OR
- ARRX52( 8 ) /= TRUE OR
- ARRX52( 9 ) /= FALSE
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103F;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103g.ada b/gcc/testsuite/ada/acats/tests/c5/c52103g.ada
deleted file mode 100644
index 0a3a8f1..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103g.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C52103G.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103G IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
-
- DECLARE
-
- TYPE TA51 IS ARRAY( INTEGER RANGE 11..10 ) OF CHARACTER ;
-
- ARR51 : TA51 ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARR51 := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARR51 /= ""
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" );
- END IF;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 5" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( 11..15 );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX42( 13..12 ) := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( 11..15 ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103G;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103h.ada b/gcc/testsuite/ada/acats/tests/c5/c52103h.ada
deleted file mode 100644
index 6915cb4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103h.ada
+++ /dev/null
@@ -1,175 +0,0 @@
--- C52103H.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103H IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( 1..0 ) := "" ;
- ARR72 : STRING( 5..4 ) ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
-
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= ""
- THEN
- FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( 5..9 ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR82( 5..9 ) := "QUINC" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( 5..9 )( 6..9 )( 6..5 ) := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QUINC" OR
- ARR82( 5..9 ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( 5..9 ) ;
-
- ARR91 : STRING( 1..5 ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( 5..9 ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..4 ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( 5..9 ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103H;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103k.ada b/gcc/testsuite/ada/acats/tests/c5/c52103k.ada
deleted file mode 100644
index f0d593b..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103k.ada
+++ /dev/null
@@ -1,393 +0,0 @@
--- C52103K.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103K IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE SELECTIONS ARE 7 , 8 , 9 ,
- -- AND PRECISELY 5 CASES FROM THE
- -- TWO 5-CASE SERIES 2-3-4-5-6 AND
- -- 10-11-12-13-14)
- --
- -- ( IN THE CURRENT DIVISION, THE 5
- -- FLOATING SELECTIONS ARE 2-11-4-
- -- -13-6 ; THUS THE 8 SELECTIONS ARE
- -- 2-11-4-13-6-7-8-9 (IN THIS ORDER)
- -- .)
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION.
- -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.)
- --
- -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED
- -- IN THE SAME DECLARATION.)
- --
- --
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER
- -- USING AGGREGATES
- -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS;
- -- SEE (5) )
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS
- -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY
- -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR
- -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) --
- -- TO THE TYPEMARK OF ARR ),
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (SINCE WE ARE NOT USING AGGREGATES
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS,
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (THE ASSIGNMENT MAY REQUIRE SLIDING.)
- --
- -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL
- -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT
- -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK
- -- ALSO WHEN NO SLIDING IS INVOLVED.)
- --
- --
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B.
- -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TA21 IS ARRAY(
- INTEGER RANGE IDENT_INT(1)..IDENT_INT(5) ,
- INTEGER RANGE IDENT_INT(0)..IDENT_INT(7)
- ) OF INTEGER ;
-
- SUBTYPE TA22 IS TA21 ;
-
- ARR21 : TA21 ;
- ARR22 : TA22 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
-
- FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP
- ARR21( I , J ) := I * I * J ;
- END LOOP;
-
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARR22 := ARR21 ;
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
-
- FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP
-
- IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 )
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT" );
- END IF;
-
- END LOOP;
-
- END LOOP;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 2" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(9) );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- ARRX11( I ) := I * I ;
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP
-
- IF ARRX12( I ) /= ( I-4 ) * ( I-4 )
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" );
- END IF;
-
- END LOOP;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TA42 IS ARRAY(
- INTEGER RANGE IDENT_INT(1)..IDENT_INT(5)
- ) OF BOOLEAN ;
-
- SUBTYPE TA41 IS TA42 ;
-
- ARR41 : TA41 ;
- ARR42 : TA42 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARR41(2) := TRUE ;
-
- ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR42( 1 ) := TRUE ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARR42( IDENT_INT(2)..IDENT_INT(5) ) :=
- ARR41(
- IDENT_INT(1)..IDENT_INT(4) ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- FOR I IN IDENT_INT(2)..IDENT_INT(5) LOOP
-
- IF ARR42( I ) /= FALSE AND I /= 3
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- ELSIF ARR42( I ) /= TRUE AND I = 3
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- END IF;
-
- END LOOP;
-
- IF ARR42( 1 ) /= TRUE
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 4" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103K;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103l.ada b/gcc/testsuite/ada/acats/tests/c5/c52103l.ada
deleted file mode 100644
index 528745c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103l.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C52103L.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY.
-
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103L IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(15) );
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15
-
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX31 /= "QUINC" OR
- ARRX31( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC"
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
-
- DECLARE
-
- TYPE TA61 IS ARRAY(
- INTEGER RANGE IDENT_INT(11)..IDENT_INT(15)
- ) OF CHARACTER ;
-
- ARR61 : TA61 ;
-
- BEGIN
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR61( IDENT_INT(11)..IDENT_INT(11) ) := "Q" ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARR61( IDENT_INT(12)..IDENT_INT(15) ) := "UINC" ;
- -- "UINC"(1..4) SLIDES TO 12..15
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR61 /= "QUINC" OR
- ARR61( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 6" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103L ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103m.ada b/gcc/testsuite/ada/acats/tests/c5/c52103m.ada
deleted file mode 100644
index 2377248..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103m.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- C52103M.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103M IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ;
- ARR72 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "FGHIJ" ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
-
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= "ABCDE"
- THEN
- FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR82( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) ) := "BCDE" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QBCDE" OR
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR92( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) ) :=
- ARR91
- ( IDENT_INT(1)..IDENT_INT(5) )
- ( IDENT_INT(2)..IDENT_INT(5) )
- ( IDENT_INT(2)..IDENT_INT(5) ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QBCDE" OR
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103M ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103p.ada b/gcc/testsuite/ada/acats/tests/c5/c52103p.ada
deleted file mode 100644
index 7cbd7a5..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103p.ada
+++ /dev/null
@@ -1,344 +0,0 @@
--- C52103P.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-
-WITH REPORT;
-PROCEDURE C52103P IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE SELECTIONS ARE 7 , 8 , 9 ,
- -- AND PRECISELY 5 CASES FROM THE
- -- TWO 5-CASE SERIES 2-3-4-5-6 AND
- -- 10-11-12-13-14)
- --
- -- ( IN THE CURRENT DIVISION, THE 5
- -- FLOATING SELECTIONS ARE 10-3-12-
- -- -5-14 ; THUS THE 8 SELECTIONS ARE
- -- 10-3-12-5-14-7-8-9 (IN THIS ORDER
- -- ).)
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION.
- -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.)
- --
- -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED
- -- IN THE SAME DECLARATION.)
- --
- --
- -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER
- -- USING AGGREGATES
- -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS;
- -- SEE (5) )
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS
- -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY
- -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR
- -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) --
- -- TO THE TYPEMARK OF ARR ),
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- -- (SINCE WE ARE NOT USING AGGREGATES
- -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS,
- -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING,
- -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.)
- --
- --
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- -- (THE ASSIGNMENT MAY REQUIRE SLIDING.)
- --
- -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL
- -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT
- -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK
- -- ALSO WHEN NO SLIDING IS INVOLVED.)
- --
- --
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(0) ,
- IDENT_INT(0)..IDENT_INT(7) );
- SUBTYPE TABOX02 IS TABOX0 ;
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02( IDENT_INT(7)..IDENT_INT(6) ,
- IDENT_INT(20)..IDENT_INT(27) );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TA3 IS ARRAY(
- INTEGER RANGE IDENT_INT(100)..IDENT_INT(99)
- ) OF INTEGER ;
-
- SUBTYPE TA31 IS TA3 ;
- SUBTYPE TA32 IS TA3 ;
-
- ARR31 : TA31 ;
- ARR32 : TA32 ;
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARR32 := ARR31 ;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 3" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARRX51(2) := TRUE ;
-
- ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP
- ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F
- END LOOP;
-
- ARRX52(6) := FALSE ;
-
- ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX52( IDENT_INT(6)..IDENT_INT(5) ) :=
- ARRX51(
- IDENT_INT(4)..IDENT_INT(3) ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX52( 5 ) /= TRUE OR
- ARRX52( 6 ) /= FALSE OR
- ARRX52( 7 ) /= TRUE OR
- ARRX52( 8 ) /= TRUE OR
- ARRX52( 9 ) /= FALSE
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103P;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103q.ada b/gcc/testsuite/ada/acats/tests/c5/c52103q.ada
deleted file mode 100644
index 919d037..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103q.ada
+++ /dev/null
@@ -1,143 +0,0 @@
--- C52103Q.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSWEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 2/18/83
-
-WITH REPORT;
-PROCEDURE C52103Q IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
-
- DECLARE
-
- TYPE TA51 IS ARRAY(
- INTEGER RANGE IDENT_INT(11)..IDENT_INT(10)
- ) OF CHARACTER ;
-
- ARR51 : TA51 ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARR51 := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARR51 /= ""
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" );
- END IF;
-
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 5" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103Q;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103r.ada b/gcc/testsuite/ada/acats/tests/c5/c52103r.ada
deleted file mode 100644
index 1daa118..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103r.ada
+++ /dev/null
@@ -1,181 +0,0 @@
--- C52103R.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSWEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 2/18/83
-
-WITH REPORT;
-PROCEDURE C52103R IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( IDENT_INT(1)..IDENT_INT(0) ) := "" ;
- ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
-
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= ""
- THEN
- FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(5) ) := "" ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QUINC" OR
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) )
- ( IDENT_INT(8)..IDENT_INT(7) ) :=
- ARR91
- ( IDENT_INT(1)..IDENT_INT(5) )
- ( IDENT_INT(5)..IDENT_INT(4) ) ;
-
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52103R;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52103x.ada b/gcc/testsuite/ada/acats/tests/c5/c52103x.ada
deleted file mode 100644
index f0fa56a..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52103x.ada
+++ /dev/null
@@ -1,241 +0,0 @@
--- C52103X.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS A SPECIAL CASE IN
-
--- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY
-
--- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST .
--- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH
--- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE
--- CONSTRAINT_ERROR TO BE RAISED.
-
--- *** 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
-
--- RM 07/31/81
--- SPS 10/26/82
--- JBG 06/15/83
--- EG 11/02/84
--- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE C52103X IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52103X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " &
- "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " &
- "CHECK WHETHER CONSTRAINT_ERROR " &
- "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS" );
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -------------------------------------------------------------------
-
- -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
-CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR
- -- FOR THE TYPE DECLARATION.
- BEGIN
-
-DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY TYPE
-
- TYPE TA42 IS ARRAY(
- INTEGER RANGE IDENT_INT(-2)..IDENT_INT(INTEGER'LAST)
- ) OF BOOLEAN ;
- -- CONSTRAINT_ERROR MAY BE RAISED BY THE
- -- ARRAY TYPE DECLARATION.
- PRAGMA PACK (TA42);
-
- SUBTYPE TA41 IS TA42 ;
-
- BEGIN
-
- COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " &
- "WITH 'LENGTH = INTEGER'LAST + 3");
-
-OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT
- -- HAVE INTEGER'LAST + 3 COMPONENTS;
- -- STORAGE_ERROR MAY BE RAISED.
- ARR41 : TA41 ;
- ARR42 : TA42 ;
-
- BEGIN
-
- COMMENT ("NO STORAGE_ERROR OR CONSTRAINT_ERROR RAISED " &
- "WHEN ALLOCATING TWO BIG BOOLEAN ARRAYS");
- -- INITIALIZATION OF RHS ARRAY:
-
- -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED,
- -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG
- -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH
- -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED.
-
-NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR HERE.
- FOR I IN IDENT_INT(-2)..IDENT_INT(2) LOOP
- ARR41(I) := FALSE ; -- VALUES ARE:: FTFFT
- END LOOP;
-
- ARR41(-1) := TRUE ;
-
- ARR41( 2) := TRUE ; -- RHS IS: F T F F T
-
-
- -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY:
-
- ARR42( -2 ) := TRUE ;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED WHEN " &
- "ASSIGNING TO ARRAY COMPONENTS");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
-
- END NO_EXCP;
-
-DO_SLICE: BEGIN
- -- SLICE ASSIGNMENT:
-
- ARR42( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) :=
- ARR41(
- IDENT_INT(-2)..IDENT_INT(INTEGER'LAST-1)) ;
-
- COMMENT ("NO EXCEPTION RAISED DURING SLICE " &
- "ASSIGNMENT");
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- CHK_SLICE: BEGIN
- FOR I IN IDENT_INT(-1)..IDENT_INT(2) LOOP
-
- IF ARR42( I ) /= FALSE AND I /= 0
- THEN
- FAILED( "SLICE ASSIGNMENT NOT " &
- "CORRECT (VALUES)" );
- ELSIF ARR42( I ) /= TRUE AND I = 0
- THEN
- FAILED( "SLICE ASSIGNMENT NOT " &
- "CORRECT (VALUES)" );
- END IF;
-
- END LOOP;
-
- IF ARR42( -2 ) /= TRUE
- THEN
- FAILED( "SLICE ASSIGNMENT NOT CORRECT " &
- "(SLIDING)" );
- END IF;
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 2");
-
- END CHK_SLICE;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED DURING " &
- "SLICE ASSIGNMENT");
- WHEN STORAGE_ERROR =>
- COMMENT ("STORAGE_ERROR RAISED DURING SLICE " &
- "ASSIGNMENT");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION DURING SLICE " &
- "ASSIGNMENT");
- END DO_SLICE;
-
- END OBJ_DCL;
-
- EXCEPTION
-
- WHEN STORAGE_ERROR =>
- COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " &
- "TWO PACKED BOOLEAN ARRAYS WITH " &
- "INTEGER'LAST + 3 COMPONENTS");
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " &
- "TWO PACKED BOOLEAN ARRAYS WITH " &
- "INTEGER'LAST + 3 COMPONENTS");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3");
-
- END DCL_ARR;
-
- EXCEPTION
-
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " &
- "ARRAY TYPE WITH INTEGER'LAST + 3 COMPONENTS");
-
- WHEN STORAGE_ERROR =>
- FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION");
-
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 4");
-
- END CONSTR_ERR;
-
-
- RESULT ;
-
-
-END C52103X;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104a.ada b/gcc/testsuite/ada/acats/tests/c5/c52104a.ada
deleted file mode 100644
index c71408c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104a.ada
+++ /dev/null
@@ -1,343 +0,0 @@
--- C52104A.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE 8 SELECTIONS ARE THE 5-CASE
- -- SERIES 10-11-12-13-14 FOLLOWED
- -- BY 7 , 8 , 9 (IN THIS ORDER). )
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT
- -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.)
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B.
- -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (1..6: NOT APPLICABLE)
- --
- --
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( 1..5 , 0..7 );
- SUBTYPE TABOX02 IS TABOX0( 0..5 , 2..9 );
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
-
- FOR J IN 0..7 LOOP
- ARRX01( I , J ) := I * I * J ;
- END LOOP;
-
- END LOOP;
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN 0..5 LOOP
-
- FOR J IN 2..9 LOOP
- ARRX02( I , J ) := I * I * J * 3 ;
- END LOOP;
-
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN 0..5 LOOP
-
- FOR J IN 2..9 LOOP
-
- IF ARRX02( I , J ) /= I * I * J * 3
- THEN
- FAILED( "ORIG. VALUE ALTERED (10)" );
- END IF;
-
- END LOOP;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( 1..5 ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( 6..9 );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
-
- ARRX11( I ) := I * I ;
-
- END LOOP;
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN 6..9 LOOP
- ARRX12( I ) := I * I * 3 ;
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN 6..9 LOOP
-
- IF ARRX12( I ) /= I * I * 3
- THEN
- FAILED( "ORIG. VALUE ALTERED (11)" );
- END IF;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( 1..5 );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( 5..9 );
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN 5..9 LOOP
- ARRX52( I ) := FALSE ;
- END LOOP;
-
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
- ARRX51( I ) := TRUE ;
- END LOOP;
-
-
- -- SLICE ASSIGNMENT:
-
- ARRX52(6..9) := ARRX51(3..3) ;
- FAILED( "EXCEPTION NOT RAISED (12)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- FOR I IN 5..9 LOOP
-
- IF ARRX52( I ) /= FALSE
- THEN
- FAILED( "LHS ARRAY ALTERED ( 12 ) " );
- END IF;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104b.ada b/gcc/testsuite/ada/acats/tests/c5/c52104b.ada
deleted file mode 100644
index d2f4261..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104b.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- C52104B.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( 2..6 ) := "QUINC" ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "ABCD" ;
- FAILED( "NO EXCEPTION RAISED (13)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX31 /= "QUINC" OR
- ARRX31( 2..6 ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (13)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( 5..9 );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARRX42( 6..9 ) := "ABCDEFGH" ;
- FAILED( "NO EXCEPTION RAISED (14)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( 5..9 ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (14)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104c.ada b/gcc/testsuite/ada/acats/tests/c5/c52104c.ada
deleted file mode 100644
index 34cb2aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104c.ada
+++ /dev/null
@@ -1,178 +0,0 @@
--- C52104C.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104C IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( 1..5 ) := "ABCDE" ;
- ARR72 : STRING( 5..8 ) := "FGHI" ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= "FGHI"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (7)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( 5..9 ) := "QBCDE" ;
-
- BEGIN
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( 5..9 )( 6..9 ) := "EIN" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QBCDE" OR
- ARR82( 5..9 ) /= "QBCDE"
- THEN
- FAILED( "LHS ARRAY ALTERED (8)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( 5..9 ) ;
-
- ARR91 : STRING( 1..7 ) := "ABCDEFG" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( 5..9 ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( 5..9 )( 6..9 ) := ARR91( 1..7 )( 1..6 )( 1..6 ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( 5..9 ) /= "QUINC"
- THEN
- FAILED( "LHS VALUE ALTERED (9)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104f.ada b/gcc/testsuite/ada/acats/tests/c5/c52104f.ada
deleted file mode 100644
index a6e8a39..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104f.ada
+++ /dev/null
@@ -1,292 +0,0 @@
--- C52104F.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSWEWHERE.)
-
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 10/27/82
-
-WITH REPORT;
-PROCEDURE C52104F IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE 8 SELECTIONS ARE THE 5-CASE
- -- SERIES 10-11-12-13-14 FOLLOWED
- -- BY 7 , 8 , 9 (IN THIS ORDER). )
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT
- -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.)
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (1 .. 6: NOT APPLICABLE)
- --
- --
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( 1..1 , 0..7 );
- SUBTYPE TABOX02 IS TABOX0 ;
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02( 1..0 , 0..7 );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- NULL ;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( 4..5 ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( 5..4 );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- NULL ;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( 1..5 );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( 5..9 );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN 1..5 LOOP
- ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARRX51(2) := TRUE ;
-
- ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN 5..9 LOOP
- ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F
- END LOOP;
-
- ARRX52(6) := FALSE ;
-
- ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX52( 6..5 ) := ARRX51( 4..4 ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
- IF ARRX52( 5 ) /= TRUE OR
- ARRX52( 6 ) /= FALSE OR
- ARRX52( 7 ) /= TRUE OR
- ARRX52( 8 ) /= TRUE OR
- ARRX52( 9 ) /= FALSE
- THEN
- FAILED( "LHS ARRAY ALTERED (12)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104F;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104g.ada b/gcc/testsuite/ada/acats/tests/c5/c52104g.ada
deleted file mode 100644
index 40f5daa..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104g.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C52104G.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
--- JBG 4/24/84
-
-WITH REPORT;
-PROCEDURE C52104G IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( 11..10 ) := "" ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "AZ" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX31 /= ""
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( 11..15 );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX42( 13..12 ) := "ABCD" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( 11..15 ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (14)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104G;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104h.ada b/gcc/testsuite/ada/acats/tests/c5/c52104h.ada
deleted file mode 100644
index 8846bba..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104h.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- C52104H.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104H IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( 1..1 ) := "A" ;
- ARR72 : STRING( 5..4 ) := "" ;
-
- BEGIN
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= ""
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (7)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( 5..9 ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR82( 5..9 ) := "QUINC" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( 5..9 )( 6..9 )( 6..5 ) := "ABC" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR82 /= "QUINC" OR
- ARR82( 5..9 ) /= "QUINC"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (8)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( 5..9 ) ;
-
- ARR91 : STRING( 1..5 ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( 5..9 ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..7 ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( 5..9 ) /= "QUINC"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (9)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104H;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104k.ada b/gcc/testsuite/ada/acats/tests/c5/c52104k.ada
deleted file mode 100644
index f7abc73..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104k.ada
+++ /dev/null
@@ -1,347 +0,0 @@
--- C52104K.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104K IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE 8 SELECTIONS ARE THE 5-CASE
- -- SERIES 10-11-12-13-14 FOLLOWED
- -- BY 7 , 8 , 9 (IN THIS ORDER). )
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT
- -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.)
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B.
- -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
- -- (-) THE STATIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI-
- -- VISIONS A (FOR NON-NULL ARRAYS) AND B (FOR NULL ARRAYS).
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (1..6: NOT APPLICABLE)
- --
- --
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(5) ,
- IDENT_INT(0)..IDENT_INT(7) );
- SUBTYPE TABOX02 IS TABOX0( IDENT_INT(0)..IDENT_INT(5) ,
- IDENT_INT(2)..IDENT_INT(9) );
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02 ;
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
-
- FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP
- ARRX01( I , J ) := I * I * J ;
- END LOOP;
-
- END LOOP;
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP
-
- FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP
- ARRX02( I , J ) := I * I * J * 3 ;
- END LOOP;
-
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP
-
- FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP
-
- IF ARRX02( I , J ) /= I * I * J * 3
- THEN
- FAILED( "ORIG. VALUE ALTERED (10)" );
- END IF;
-
- END LOOP;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( IDENT_INT(6)..IDENT_INT(9) );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
-
- ARRX11( I ) := I * I ;
-
- END LOOP;
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP
- ARRX12( I ) := I * I * 3 ;
- END LOOP;
-
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT:
-
- FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP
-
- IF ARRX12( I ) /= I * I * 3
- THEN
- FAILED( "ORIG. VALUE ALTERED (11)" );
- END IF;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) );
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP
- ARRX52( I ) := FALSE ;
- END LOOP;
-
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- ARRX51( I ) := TRUE ;
- END LOOP;
-
-
- -- SLICE ASSIGNMENT:
-
- ARRX52( IDENT_INT(6)..IDENT_INT(9) ) :=
- ARRX51(
- IDENT_INT(3)..IDENT_INT(3) ) ;
- FAILED( "EXCEPTION NOT RAISED (12)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP
-
- IF ARRX52( I ) /= FALSE
- THEN
- FAILED( "LHS ARRAY ALTERED ( 12 ) " );
- END IF;
-
- END LOOP;
-
- WHEN OTHERS =>
- FAILED( "EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104K;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104l.ada b/gcc/testsuite/ada/acats/tests/c5/c52104l.ada
deleted file mode 100644
index ca7ae32..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104l.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C52104L.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
--- HISTORY:
--- RM 07/20/81 CREATED ORIGINAL TEST.
--- SPS 03/22/83
--- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT;
-PROCEDURE C52104L IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( IDENT_INT(2)..IDENT_INT(6) ) := "QUINC" ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "ABCD" ;
- FAILED( "NO EXCEPTION RAISED (13)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX31 /= "QUINC" OR
- ARRX31( IDENT_INT(2)..IDENT_INT(6) ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (13)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( IDENT_INT(5)..IDENT_INT(9) );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- SLICE ASSIGNMENT:
-
- ARRX42( IDENT_INT(6)..IDENT_INT(9) ) := "ABCDEFGH" ;
- FAILED( "NO EXCEPTION RAISED (14)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (14)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104L;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104m.ada b/gcc/testsuite/ada/acats/tests/c5/c52104m.ada
deleted file mode 100644
index 3227d59..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104m.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- C52104M.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104M IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ;
- ARR72 : STRING( IDENT_INT(5)..IDENT_INT(8) ) := "FGHI" ;
-
- BEGIN
-
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= "FGHI"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (7)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "QBCDE" ;
-
- BEGIN
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) ) := "EIN" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR82 /= "QBCDE" OR
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE"
- THEN
- FAILED( "LHS ARRAY ALTERED (8)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- ARR91 : STRING( IDENT_INT(1)..IDENT_INT(7) ) := "ABCDEFG" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) ) :=
- ARR91
- ( IDENT_INT(1)..IDENT_INT(7) )
- ( IDENT_INT(1)..IDENT_INT(6) )
- ( IDENT_INT(1)..IDENT_INT(6) ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "LHS VALUE ALTERED (9)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104M;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104p.ada b/gcc/testsuite/ada/acats/tests/c5/c52104p.ada
deleted file mode 100644
index f455519..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104p.ada
+++ /dev/null
@@ -1,292 +0,0 @@
--- C52104P.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
-
-
-WITH REPORT;
-PROCEDURE C52104P IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED)
- --
- -- ( THE 8 SELECTIONS ARE THE 5-CASE
- -- SERIES 10-11-12-13-14 FOLLOWED
- -- BY 7 , 8 , 9 (IN THIS ORDER). )
- --
- --
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
- --
- --
- -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT
- -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.)
- --
- --
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
- --
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
- --
- -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6
- -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 .
- --
- --
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
- --
- --
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
- --
- --
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
- --
- --
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING
- -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED
- -- BY THE TYPEMARK WILL NOT BE 1 .)
- --
- --
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
- --
- --
- --
- -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC
- -- ARRAYS ONLY,
- -- DIVISIONS C AND D .)
- --
- --
-
-
- -------------------------------------------------------------------
-
- -- (1 .. 6: NOT APPLICABLE)
- --
- --
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <>
- ) OF INTEGER ;
-
- SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(1) ,
- IDENT_INT(0)..IDENT_INT(7) );
- SUBTYPE TABOX02 IS TABOX0 ;
-
- ARRX01 : TABOX01 ;
- ARRX02 : TABOX02( IDENT_INT(1)..IDENT_INT(0) ,
- IDENT_INT(0)..IDENT_INT(7) );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX02 := ARRX01 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- NULL ;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.)
-
- DECLARE
-
- TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ;
-
- SUBTYPE TABOX11 IS TABOX1( IDENT_INT(4)..IDENT_INT(5) ) ;
-
- ARRX11 : TABOX11 ;
- ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(4) );
-
- BEGIN
-
- -- ARRAY ASSIGNMENT:
-
- ARRX12 := ARRX11 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- NULL ;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
- DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
-
- SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) );
-
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) );
-
- BEGIN
-
- -- INITIALIZATION OF RHS ARRAY:
-
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T
- END LOOP;
-
- ARRX51(2) := TRUE ;
-
- ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP
- ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F
- END LOOP;
-
- ARRX52(6) := FALSE ;
-
- ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX52( IDENT_INT(6)..IDENT_INT(5) ) :=
- ARRX51
- ( IDENT_INT(4)..IDENT_INT(4) ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
- IF ARRX52( 5 ) /= TRUE OR
- ARRX52( 6 ) /= FALSE OR
- ARRX52( 7 ) /= TRUE OR
- ARRX52( 8 ) /= TRUE OR
- ARRX52( 9 ) /= FALSE
- THEN
- FAILED( "LHS ARRAY ALTERED (12)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104P;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104q.ada b/gcc/testsuite/ada/acats/tests/c5/c52104q.ada
deleted file mode 100644
index dc01ca8..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104q.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C52104Q.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE SECOND FILE IN
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
--- JBG 4/24/84
-
-WITH REPORT;
-PROCEDURE C52104Q IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ;
-
- ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(10) ) := "" ;
-
- BEGIN
-
-
- -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE):
-
- ARRX31 := "AZ" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX31 /= ""
- THEN
- FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' .
-
- DECLARE
-
- TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ;
-
- SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) );
-
- ARRX42 : TABOX42 ;
-
- BEGIN
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARRX42 := "QUINC" ;
-
-
- -- NULL SLICE ASSIGNMENT:
-
- ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "ABCD" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT:
-
- IF ARRX42 /= "QUINC" OR
- ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC"
- THEN
- FAILED( "LHS ARRAY ALTERED (14)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104Q;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104r.ada b/gcc/testsuite/ada/acats/tests/c5/c52104r.ada
deleted file mode 100644
index 8b9e3d4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104r.ada
+++ /dev/null
@@ -1,190 +0,0 @@
--- C52104R.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS THE THIRD FILE IN
--- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY.
-
-
--- RM 07/20/81
--- SPS 3/22/83
-
-WITH REPORT;
-PROCEDURE C52104R IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS THE LENGTHS MUST MATCH" );
-
-
- -- ( EACH DIVISION COMPRISES 3 FILES,
- -- COVERING RESPECTIVELY THE FIRST
- -- 3 , NEXT 2 , AND LAST 3 OF THE 8
- -- SELECTIONS FOR THE DIVISION.)
-
-
- -------------------------------------------------------------------
-
- -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
-
- DECLARE
-
- ARR71 : STRING( IDENT_INT(1)..IDENT_INT(1) ) := "A" ;
- ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) := "" ;
-
- BEGIN
-
- -- STRING ASSIGNMENT:
-
- ARR72 := ARR71 ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR72 /= ""
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (7)" );
- END IF;
-
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH
- -- STRING LITERALS.
- --
-
- DECLARE
-
- ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ;
-
-
- -- STRING LITERAL ASSIGNMENT:
-
- ARR82( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(5) ) := "ABC" ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR82 /= "QUINC" OR
- ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (8)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
- -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY
- -- THEMSELVES).
- --
-
- DECLARE
-
- SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ;
-
- ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ;
- ARR92 : TA92 ;
-
- BEGIN
-
-
- -- INITIALIZATION OF LHS ARRAY:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ;
-
-
- -- STRING SLICE ASSIGNMENT:
-
- ARR92( IDENT_INT(5)..IDENT_INT(9) )
- ( IDENT_INT(6)..IDENT_INT(9) )
- ( IDENT_INT(8)..IDENT_INT(7) ) :=
- ARR91
- ( IDENT_INT(1)..IDENT_INT(5) )
- ( IDENT_INT(5)..IDENT_INT(7) ) ;
- FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT:
-
- IF ARR92 /= "QUINC" OR
- ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC"
- THEN
- FAILED( "ORIGINAL VALUE ALTERED (9)" );
- END IF;
-
- WHEN OTHERS =>
-
- FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" );
-
- END ;
-
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END C52104R;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104x.ada b/gcc/testsuite/ada/acats/tests/c5/c52104x.ada
deleted file mode 100644
index 3db74d7..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104x.ada
+++ /dev/null
@@ -1,222 +0,0 @@
--- C52104X.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS A SPECIAL CASE IN
-
--- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY
-
--- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST .
--- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH
--- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE
--- CONSTRAINT_ERROR TO BE RAISED.
-
--- *** 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
-
--- RM 07/31/81
--- SPS 02/07/83
--- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X INCOMPATIBILITY
-
-WITH REPORT;
-PROCEDURE C52104X IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " &
- "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " &
- "CHECK WHETHER CONSTRAINT_ERROR " &
- "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS");
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -------------------------------------------------------------------
-
- -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS
- -- WERE DEFINED USING THE "BOX" SYMBOL
- -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' .
- -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.)
-
-CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR
- -- FOR THE SUBTYPE DECLARATION.
- BEGIN
-
-DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY SUBTYPE.
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ;
- PRAGMA PACK (TABOX5);
-
- SUBTYPE TABOX51 IS TABOX5
- (IDENT_INT(-6)..IDENT_INT(INTEGER'LAST-4));
- -- CONSTRAINT_ERROR MAY BE RAISED BY THIS
- -- SUBTYPE DECLARATION.
-
- BEGIN
-
- COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " &
- "WITH 'LENGTH = INTEGER'LAST + 3");
-
-OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT
- -- HAVE INTEGER'LAST + 3 COMPONENTS;
- -- STORAGE_ERROR MAY BE RAISED.
- ARRX51 : TABOX51 ;
- ARRX52 : TABOX5
- (IDENT_INT(-2)..IDENT_INT( INTEGER'LAST));
-
- BEGIN
-
- COMMENT ("NO STORAGE_ERROR OR " &
- "CONSTRAINT_ERROR RAISED WHEN ALLOCATING TWO " &
- "BIG BOOLEAN ARRAYS");
-
- -- INITIALIZATION OF LHS ARRAY:
-
-NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR IN THIS BLOCK
- FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP
- ARRX52( I ) := FALSE ;
- END LOOP;
-
-
- -- INITIALIZATION OF RHS ARRAY:
-
- -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED,
- -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG
- -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH
- -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED.
-
- FOR I IN IDENT_INT(-6)..IDENT_INT(5) LOOP
- ARRX51( I ) := TRUE ;
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED WHEN " &
- "ASSIGNING TO ARRAY COMPONENTS");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
-
- END NO_EXCP;
-
-DO_SLICE: BEGIN
- -- SLICE ASSIGNMENT:
-
- ARRX52( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) :=
- ARRX51(
- IDENT_INT(-4)..IDENT_INT(INTEGER'LAST-4) ) ;
- FAILED( "EXCEPTION NOT RAISED (12)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
-
- COMMENT ("CONSTRAINT_ERROR RAISED DURING " &
- "CHECK FOR SLICE ASSIGNMENT");
-
- -- CHECKING THE VALUES AFTER THE SLICE
- -- ASSIGNMENT:
-
- FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP
-
- IF ARRX52( I ) /= FALSE
- THEN
- FAILED( "LHS ARRAY ALTERED (12A)");
- END IF;
-
- END LOOP;
-
-
- WHEN STORAGE_ERROR =>
- COMMENT ("STORAGE_ERROR RAISED DURING CHECK " &
- "FOR SLICE ASSIGNMENT");
-
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED DURING SLICE");
-
- END DO_SLICE;
-
- END OBJ_DCL;
-
- EXCEPTION
-
- WHEN STORAGE_ERROR =>
- COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " &
- "TWO PACKED BOOLEAN ARRAYS WITH " &
- "INTEGER'LAST + 3 COMPONENTS");
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " &
- "TWO PACKED BOOLEAN ARRAYS WITH " &
- "INTEGER'LAST + 3 COMPONENTS");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3");
-
- END DCL_ARR;
-
- EXCEPTION
-
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " &
- "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " &
- "COMPONENTS");
-
- WHEN STORAGE_ERROR =>
- FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION");
-
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 4");
-
- END CONSTR_ERR;
-
- RESULT ;
-
-END C52104X;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c52104y.ada b/gcc/testsuite/ada/acats/tests/c5/c52104y.ada
deleted file mode 100644
index 220a4a1..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c52104y.ada
+++ /dev/null
@@ -1,174 +0,0 @@
--- C52104Y.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 LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN
--- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY
--- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
--- THIS IS A SPECIAL CASE IN
-
--- DIVISION D : NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY
-
--- WHICH (THE SPECIAL CASE) TREATS TWO-DIMENSIONAL ARRAYS WHOSE LENGTH
--- ALONG ONE DIMENSION IS GREATER THAN INTEGER'LAST AND WHOSE
--- LENGTH ALONG THE OTHER DIMENSION IS 0 .
--- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH
--- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE CONSTRAINT_ERROR
--- TO BE RAISED.
-
--- *** 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
-
--- RM 07/31/81
--- SPS 03/22/83
--- JBG 06/16/83
--- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE C52104Y IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C52104Y" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" &
- " ASSIGNMENTS, THE LENGTHS MUST MATCH" );
-
- -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN
- -- THE AGGREGATES ARE STRING LITERALS); THEREFORE:
- --
- -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS;
- -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS.
-
-
- -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION
- -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL
- -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS
- -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON
- -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT
- -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED:
- -- INTEGER , CHARACTER , BOOLEAN .)
-
-
- -------------------------------------------------------------------
-
- -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE
- -- DEFINED USING THE "BOX" COMPOUND SYMBOL.
- -- (TWO-DIMENSIONAL ARRAYS OF BOOLEANS.)
-
-CONSTR_ERR:
- BEGIN -- THIS BLOCK CATCHES CONSTRAINT_ERROR IF IT IS
- -- RAISED BY THE SUBTYPE DECLARATION.
-
-DCL_ARR: DECLARE
-
- TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ,
- INTEGER RANGE <> ) OF BOOLEAN ;
- PRAGMA PACK (TABOX5);
-
- SUBTYPE TABOX52 IS TABOX5(
- IDENT_INT(13)..IDENT_INT( 13 ) ,
- IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) );
-
- BEGIN
-
- COMMENT ("NO CONSTRAINT_ERROR FOR NON-NULL ARRAY SUBTYPE " &
- "WHEN ONE DIMENSION HAS INTEGER'LAST + 3 " &
- "COMPONENTS");
-
-OBJ_DCL: DECLARE -- THIS BLOCK DECLARES ONE NULL ARRAY AND ONE
- -- PACKED BOOLEAN ARRAY WITH INTEGER'LAST + 3
- -- COMPONENTS; STORAGE ERROR MAY BE RAISED.
-
- ARRX51 : TABOX5(
- IDENT_INT(13)..IDENT_INT( 12 ) ,
- IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) );
- ARRX52 : TABOX52 ; -- BIG ARRAY HERE.
-
- BEGIN
-
- COMMENT ("NO CONSTRAINT OR STORAGE ERROR WHEN ARRAY "&
- "WITH INTEGER'LAST+3 COMPONENTS ALLOCATED");
-
- -- NULL ARRAY ASSIGNMENT:
-
- ARRX52 := ARRX51 ;
- FAILED( "EXCEPTION NOT RAISED (10)" );
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN " &
- "CHECKING LENGTHS FOR ARRAY HAVING " &
- "> INTEGER'LAST COMPONENTS ON ONE " &
- "DIMENSION");
-
-
- WHEN OTHERS =>
- FAILED( "OTHER EXCEPTION RAISED - SUBTEST 10");
-
- END OBJ_DCL;
-
- EXCEPTION
-
- WHEN STORAGE_ERROR =>
- COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING ONE "&
- "PACKED BOOLEAN ARRAY WITH INTEGER'LAST "&
- "+ 3 COMPONENTS");
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING "&
- "ONE PACKED BOOLEAN ARRAY WITH "&
- "INTEGER'LAST + 3 COMPONENTS");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3");
-
- END DCL_ARR;
-
- EXCEPTION
-
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " &
- "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " &
- "COMPONENTS");
-
- WHEN STORAGE_ERROR =>
- FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION");
-
- WHEN OTHERS =>
- FAILED( "OTHER EXCEPTION RAISED - 4");
-
- END CONSTR_ERR;
-
- RESULT ;
-
-END C52104Y;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c53007a.ada b/gcc/testsuite/ada/acats/tests/c5/c53007a.ada
deleted file mode 100644
index bda27b9..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c53007a.ada
+++ /dev/null
@@ -1,139 +0,0 @@
--- C53007A.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 CONTROL FLOWS CORRECTLY IN SIMPLE NESTED IF_STATEMENTS.
-
--- JRK 7/23/80
--- SPS 3/4/83
-
-WITH REPORT;
-PROCEDURE C53007A IS
-
- USE REPORT;
-
- CI1 : CONSTANT INTEGER := 1;
- CI9 : CONSTANT INTEGER := 9;
- CBT : CONSTANT BOOLEAN := TRUE;
- CBF : CONSTANT BOOLEAN := FALSE;
-
- VI1 : INTEGER := IDENT_INT(1);
- VI9 : INTEGER := IDENT_INT(9);
- VBT : BOOLEAN := IDENT_BOOL(TRUE);
- VBF : BOOLEAN := IDENT_BOOL(FALSE);
-
- FLOW_COUNT : INTEGER := 0;
-
-BEGIN
- TEST ("C53007A", "CHECK THAT CONTROL FLOWS CORRECTLY IN SIMPLE " &
- "NESTED IF_STATEMENTS");
-
- IF VBF THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 1");
- ELSIF CI9 < 20 THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- IF VI1 /= 0 AND TRUE THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- ELSE FAILED ("INCORRECT CONTROL FLOW 2");
- END IF;
- ELSE FAILED ("INCORRECT CONTROL FLOW 3");
- END IF;
-
- IF CBF OR ELSE VI9 = 9 THEN -- (TRUE)
- IF VI1 + CI9 > 0 OR (CBF AND VBT) THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- END IF;
- ELSIF VBF OR VI1 > 10 THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 4");
- END IF;
-
- IF NOT CBT AND THEN NOT VBT AND THEN CI9 < 0 THEN -- (FALSE)
- IF FALSE OR NOT TRUE THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 5");
- ELSIF VI1 >= 0 THEN -- (TRUE)
- NULL;
- ELSE FAILED ("INCORRECT CONTROL FLOW 6");
- END IF;
- FAILED ("INCORRECT CONTROL FLOW 7");
- ELSIF (VI1 * CI9 + 3 < 0) OR (VBT AND NOT (CI1 < 0)) THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- IF NOT CBT OR ELSE CI9 + 1 = 0 THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 8");
- ELSE FLOW_COUNT := FLOW_COUNT + 1;
- IF VI1 * 2 > 0 THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- ELSIF TRUE THEN -- (TRUE)
- FAILED ("INCORRECT CONTROL FLOW 9");
- ELSE NULL;
- END IF;
- END IF;
- ELSIF FALSE AND CBF THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 10");
- ELSE IF VBT THEN -- (TRUE)
- FAILED ("INCORRECT CONTROL FLOW 11");
- ELSIF VI1 = 0 THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 12");
- ELSE FAILED ("INCORRECT CONTROL FLOW 13");
- END IF;
- END IF;
-
- IF 3 = 5 OR NOT VBT THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 14");
- IF TRUE AND CBT THEN -- (TRUE)
- FAILED ("INCORRECT CONTROL FLOW 15");
- ELSE FAILED ("INCORRECT CONTROL FLOW 16");
- END IF;
- ELSIF CBF THEN -- (FALSE)
- IF VI9 >= 0 OR FALSE THEN -- (TRUE)
- IF VBT THEN -- (TRUE)
- FAILED ("INCORRECT CONTROL FLOW 17");
- END IF;
- FAILED ("INCORRECT CONTROL FLOW 18");
- ELSIF VI1 + CI9 /= 0 THEN -- (TRUE)
- FAILED ("INCORRECT CONTROL FLOW 19");
- END IF;
- FAILED ("INCORRECT CONTROL FLOW 20");
- ELSE IF VBT AND CI9 - 9 = 0 THEN -- (TRUE)
- IF FALSE THEN -- (FALSE)
- FAILED ("INCORRECT CONTROL FLOW 21");
- ELSIF NOT VBF AND THEN CI1 > 0 THEN -- (TRUE)
- FLOW_COUNT := FLOW_COUNT + 1;
- ELSE FAILED ("INCORRECT CONTROL FLOW 22");
- END IF;
- FLOW_COUNT := FLOW_COUNT + 1;
- ELSIF NOT CBF OR VI1 /= 0 THEN -- (TRUE)
- IF VBT THEN -- (TRUE)
- NULL;
- END IF;
- FAILED ("INCORRECT CONTROL FLOW 23");
- ELSE FAILED ("INCORRECT CONTROL FLOW 24");
- END IF;
- FLOW_COUNT := FLOW_COUNT + 1;
- END IF;
-
- IF FLOW_COUNT /= 9 THEN
- FAILED ("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END C53007A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c540001.a b/gcc/testsuite/ada/acats/tests/c5/c540001.a
deleted file mode 100644
index b7dbdd6..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c540001.a
+++ /dev/null
@@ -1,410 +0,0 @@
--- C540001.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 expression in a case statement may be of a generic formal
--- type. Check that a function call may be used as a case statement
--- expression. Check that a call to a generic formal function may be
--- used as a case statement expression. Check that a call to an inherited
--- function may be used as a case statement expression even if its result
--- type does not correspond to any nameable subtype.
---
--- TEST DESCRIPTION:
--- This transition test creates examples where expressions in a case
--- statement can be a generic formal object and a call to a generic formal
--- function. This test also creates examples when either a function call,
--- a renaming of a function, or a call to an inherited function is used
--- in the case expressions, the choices of the case statement only need
--- to cover the values in the result of the function.
---
--- Inspired by B54A08A.ADA.
---
---
--- CHANGE HISTORY:
--- 12 Feb 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package C540001_0 is
- type Int is range 1 .. 2;
-
-end C540001_0;
-
- --==================================================================--
-
-with C540001_0;
-package C540001_1 is
- type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.
- type Mixed is ('A','B', 'C', None);
- subtype Small_Num is Natural range 0 .. 10;
- type Small_Int is range 1 .. 2;
- function Get_Small_Int (P : Boolean) return Small_Int;
- procedure Assign_Mixed (P1 : in Boolean;
- P2 : out Mixed);
-
- type Tagged_Type is tagged
- record
- C1 : Enum_Type;
- end record;
- function Get_Tagged (P : Tagged_Type) return C540001_0.Int;
-
-end C540001_1;
-
- --==================================================================--
-
-package body C540001_1 is
- function Get_Small_Int (P : Boolean) return Small_Int is
- begin
- if P then
- return Small_Int'First;
- else
- return Small_Int'Last;
- end if;
- end Get_Small_Int;
-
- ---------------------------------------------------------------------
- procedure Assign_Mixed (P1 : in Boolean;
- P2 : out Mixed) is
- begin
- case Get_Small_Int (P1) is -- Function call as expression
- when 1 => P2 := None; -- in case statement.
- when 2 => P2 := 'A';
- -- No others needed.
- end case;
-
- end Assign_Mixed;
-
- ---------------------------------------------------------------------
- function Get_Tagged (P : Tagged_Type) return C540001_0.Int is
- begin
- return C540001_0.Int'Last;
- end Get_Tagged;
-
-end C540001_1;
-
- --==================================================================--
-
-generic
-
- type Formal_Scalar is range <>;
-
- FSO : Formal_Scalar;
-
-package C540001_2 is
-
- type Enum is (Alpha, Beta, Theta);
-
- procedure Assign_Enum (ET : out Enum);
-
-end C540001_2;
-
- --==================================================================--
-
-package body C540001_2 is
-
- procedure Assign_Enum (ET : out Enum) is
- begin
- case FSO is -- Type of expression in case
- when 1 => ET := Alpha; -- statement is generic formal type.
- when 2 => ET := Beta;
- when others => ET := Theta;
- end case;
-
- end Assign_Enum;
-
-end C540001_2;
-
- --==================================================================--
-
-with C540001_1;
-generic
-
- type Formal_Enum_Type is new C540001_1.Enum_Type;
-
- with function Formal_Func (P : C540001_1.Small_Num)
- return Formal_Enum_Type is <>;
-
-function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;
-
- --==================================================================--
-
-function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is
-
-begin
- return Formal_Func (P);
-end C540001_3;
-
- --==================================================================--
-
-with C540001_1;
-generic
-
- type Formal_Int_Type is new C540001_1.Small_Int;
-
- with function Formal_Func return Formal_Int_Type;
-
-package C540001_4 is
-
- procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);
-
-end C540001_4;
-
- --==================================================================--
-
-package body C540001_4 is
-
- procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is
- begin
- case Formal_Func is -- Case expression is
- when 1 => P := C540001_1.'A'; -- generic function.
- when others => P := C540001_1.'B';
- end case;
-
- end Gen_Assign_Mixed;
-
-end C540001_4;
-
- --==================================================================--
-
-with C540001_1;
-package C540001_5 is
- type New_Tagged is new C540001_1.Tagged_Type with
- record
- C2 : C540001_1.Mixed;
- end record;
-
- -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;
- -- Note that the return type of the inherited function is not
- -- nameable here.
-
- procedure Assign_Tagged (P1 : in New_Tagged;
- P2 : out New_Tagged);
-
-end C540001_5;
-
- --==================================================================--
-
-package body C540001_5 is
-
- procedure Assign_Tagged (P1 : in New_Tagged;
- P2 : out New_Tagged) is
- begin
- case Get_Tagged (P1) is -- Case expression is
- -- inherited function.
- when 2 => P2 := (C540001_1.Bee, 'B');
- when others => P2 := (C540001_1.Sea, C540001_1.None);
- end case;
-
- end Assign_Tagged;
-
-end C540001_5;
-
- --==================================================================--
-
-with Report;
-with C540001_1;
-with C540001_2;
-with C540001_3;
-with C540001_4;
-with C540001_5;
-
-procedure C540001 is
- type Value is range 1 .. 5;
-
-begin
- Report.Test ("C540001", "Check that an expression in a case statement " &
- "may be of a generic formal type. Check that a function " &
- "call may be used as a case statement expression. Check " &
- "that a call to a generic formal function may be used as " &
- "a case statement expression. Check that a call to an " &
- "inherited function may be used as a case statement " &
- "expression");
-
- Generic_Formal_Object_Subtest:
- begin
- declare
- One : Value := 1;
- package One_Pck is new C540001_2 (Value, One);
- use One_Pck;
- EObj : Enum;
- begin
- Assign_Enum (EObj);
- if EObj /= Alpha then
- Report.Failed ("Incorrect result for value of one in generic" &
- "formal object subtest");
- end if;
- end;
-
- declare
- Five : Value := 5;
- package Five_Pck is new C540001_2 (Value, Five);
- use Five_Pck;
- EObj : Enum;
- begin
- Assign_Enum (EObj);
- if EObj /= Theta then
- Report.Failed ("Incorrect result for value of five in generic" &
- "formal object subtest");
- end if;
- end;
-
- end Generic_Formal_Object_Subtest;
-
- Instantiated_Generic_Function_Subtest:
- declare
- type New_Enum_Type is new C540001_1.Enum_Type;
-
- function Get_Enum_Value (P : C540001_1.Small_Num)
- return New_Enum_Type is
- begin
- return New_Enum_Type'Val (P);
- end Get_Enum_Value;
-
- function Val_Func is new C540001_3
- (Formal_Enum_Type => New_Enum_Type,
- Formal_Func => Get_Enum_Value);
-
- procedure Assign_Num (P : in out C540001_1.Small_Num) is
- begin
- case Val_Func (P) is -- Case expression is
- -- instantiated generic
- when New_Enum_Type (C540001_1.Eh) | -- function.
- New_Enum_Type (C540001_1.Sea) => P := 4;
- when New_Enum_Type (C540001_1.Bee) => P := 7;
- when others => P := 9;
- end case;
-
- end Assign_Num;
-
- SNObj : C540001_1.Small_Num;
-
- begin
- SNObj := 0;
- Assign_Num (SNObj);
- if SNObj /= 4 then
- Report.Failed ("Incorrect result for value of zero in call to " &
- "generic function subtest");
- end if;
-
- SNObj := 3;
- Assign_Num (SNObj);
- if SNObj /= 9 then
- Report.Failed ("Incorrect result for value of three in call to " &
- "generic function subtest");
- end if;
-
- end Instantiated_Generic_Function_Subtest;
-
- -- When a function call, a renaming of a function, or a call to an
- -- inherited function is used in the case expressions, the choices
- -- of the case statement only need to cover the values in the result
- -- of the function.
-
- Function_Call_Subtest:
- declare
- MObj : C540001_1.Mixed := 'B';
- BObj : Boolean := True;
- use type C540001_1.Mixed;
- begin
- C540001_1.Assign_Mixed (BObj, MObj);
- if MObj /= C540001_1.None then
- Report.Failed ("Incorrect result for value of true in function" &
- "call subtest");
- end if;
-
- BObj := False;
- C540001_1.Assign_Mixed (BObj, MObj);
- if MObj /= C540001_1.'A' then
- Report.Failed ("Incorrect result for value of false in function" &
- "call subtest");
- end if;
-
- end Function_Call_Subtest;
-
- Function_Renaming_Subtest:
- declare
- use C540001_1;
- function Rename_Get_Small_Int (P : Boolean)
- return Small_Int renames Get_Small_Int;
- MObj : Mixed := None;
- BObj : Boolean := False;
- begin
- case Rename_Get_Small_Int (BObj) is
- when 1 => MObj := 'A';
- when 2 => MObj := 'B';
- -- No others needed.
- end case;
-
- if MObj /= 'B' then
- Report.Failed ("Incorrect result for value of false in function" &
- "renaming subtest");
- end if;
-
- end Function_Renaming_Subtest;
-
- Call_To_Generic_Formal_Function_Subtest:
- declare
- type New_Small_Int is new C540001_1.Small_Int;
-
- function Get_Int_Value return New_Small_Int is
- begin
- return New_Small_Int'First;
- end Get_Int_Value;
-
- package Int_Pck is new C540001_4
- (Formal_Int_Type => New_Small_Int,
- Formal_Func => Get_Int_Value);
-
- use type C540001_1.Mixed;
- MObj : C540001_1.Mixed := C540001_1.None;
-
- begin
- Int_Pck.Gen_Assign_Mixed (MObj);
- if MObj /= C540001_1.'A' then
- Report.Failed ("Incorrect result in call to generic formal " &
- "function subtest");
- end if;
-
- end Call_To_Generic_Formal_Function_Subtest;
-
- Call_To_Inherited_Function_Subtest:
- declare
- NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,
- C2 => C540001_1.'A');
- NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');
- use type C540001_1.Mixed;
- use type C540001_1.Enum_Type;
- begin
- C540001_5.Assign_Tagged (NTObj1, NTObj2);
- if NTObj2.C1 /= C540001_1.Bee or
- NTObj2.C2 /= C540001_1.'B' then
- Report.Failed ("Incorrect result in inherited function subtest");
- end if;
-
- end Call_To_Inherited_Function_Subtest;
-
- Report.Result;
-
-end C540001;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada
deleted file mode 100644
index cc46df8c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C54A03A.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 BOOLEAN, CHARACTER, USER-DEFINED ENUMERATED, INTEGER,
--- AND DERIVED TYPES MAY BE USED IN A CASE EXPRESSION.
-
--- DAT 1/22/81
--- PWB 4/22/86 RENAME TO -AB;
--- REMOVE EXTRANEOUS <CR> FROM BEGINNING OF LINE 45.
-
-WITH REPORT;
-PROCEDURE C54A03A IS
-
- USE REPORT;
-
- TYPE D_INT IS NEW INTEGER RANGE 1 .. 2;
- TYPE D_BOOL IS NEW BOOLEAN;
- TYPE D_BOOL_2 IS NEW D_BOOL;
- TYPE M_ENUM IS (FIRST, SECOND, THIRD);
- TYPE M_CHAR IS NEW CHARACTER RANGE ASCII.NUL .. 'Z';
- TYPE M_ENUM_2 IS NEW M_ENUM;
-
- I : INTEGER := 1;
- D_I : D_INT := 1;
- B : BOOLEAN := TRUE;
- D_B : D_BOOL := TRUE;
- D_B_2 : D_BOOL_2 := FALSE;
- E : M_ENUM := THIRD;
- C : CHARACTER := 'A';
- M_C : M_CHAR := 'Z';
- D_E : M_ENUM_2 := SECOND;
-
-BEGIN
- TEST ("C54A03A", "CHECK VARIOUS DISCRETE TYPES " &
- "IN CASE EXPRESSIONS");
-
- CASE I IS
- WHEN 2 | 3 => FAILED ("WRONG CASE 1");
- WHEN 1 => NULL;
- WHEN OTHERS => FAILED ("WRONG CASE 2");
- END CASE;
-
- CASE D_I IS
- WHEN 1 => NULL;
- WHEN 2 => FAILED ("WRONG CASE 2A");
- END CASE;
-
- CASE B IS
- WHEN TRUE => NULL;
- WHEN FALSE => FAILED ("WRONG CASE 3");
- END CASE;
-
- CASE D_B IS
- WHEN TRUE => NULL;
- WHEN FALSE => FAILED ("WRONG CASE 4");
- END CASE;
-
- CASE D_B_2 IS
- WHEN FALSE => NULL;
- WHEN TRUE => FAILED ("WRONG CASE 5");
- END CASE;
-
- CASE E IS
- WHEN SECOND | FIRST => FAILED ("WRONG CASE 6");
- WHEN THIRD => NULL;
- END CASE;
-
- CASE C IS
- WHEN 'A' .. 'Z' => NULL;
- WHEN OTHERS => FAILED ("WRONG CASE 7");
- END CASE;
-
- CASE M_C IS
- WHEN 'Z' => NULL;
- WHEN OTHERS => FAILED ("WRONG CASE 8");
- END CASE;
-
- CASE D_E IS
- WHEN FIRST => FAILED ("WRONG CASE 9");
- WHEN SECOND | THIRD => NULL;
- END CASE;
-
- RESULT;
-END C54A03A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada
deleted file mode 100644
index c52de50..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C54A04A.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 (DISCRETE) TYPES MAY BE USED IN CASE EXPRESSIONS
--- WITHIN THE DEFINING PACKAGE.
-
--- DAT 1/29/81
-
-WITH REPORT;
-PROCEDURE C54A04A IS
-
- USE REPORT;
-
- PACKAGE P IS
-
- TYPE T IS PRIVATE;
- TYPE LT IS LIMITED PRIVATE;
-
- PRIVATE
-
- TYPE T IS ('Z', X);
- TYPE LT IS NEW INTEGER RANGE 0 .. 1;
-
- END P;
-
- VT : P.T;
- VLT : P.LT;
-
- PACKAGE BODY P IS
-
- BEGIN
- TEST ("C54A04A", "PRIVATE DISCRETE TYPES MAY APPEAR IN " &
- "CASE EXPRESSIONS IN PACKAGE BODY");
-
- VT := 'Z';
- VLT := LT (IDENT_INT (1));
-
- CASE VT IS
- WHEN X => FAILED ("WRONG CASE 1");
- WHEN 'Z' => NULL; -- OK
- END CASE;
-
- CASE VLT IS
- WHEN 1 => NULL; -- OK
- WHEN 0 => FAILED ("WRONG CASE 2");
- END CASE;
- END P;
-
-BEGIN
-
- -- TEST CALLED FROM PACKAGE BODY, ALREADY ELABORATED.
-
- RESULT;
-END C54A04A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada
deleted file mode 100644
index 0729b80..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C54A07A.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 VARIABLE USED AS A CASE EXPRESSION IS NOT CONSIDERED
--- LOCAL TO THE CASE STATEMENT. IN PARTICULAR, CHECK THAT THE
--- VARIABLE CAN BE ASSIGNED A NEW VALUE, AND THE ASSIGNMENT TAKES
--- EFFECT IMMEDIATELY (I.E. THE CASE STATEMENT DOES NOT USE A
--- COPY OF THE CASE EXPRESSION).
-
-
--- RM 01/21/80
-
-
-WITH REPORT ;
-PROCEDURE C54A07A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("C54A07A" , "CHECK THAT A VARIABLE USED AS A CASE" &
- " EXPRESSION IS NOT CONSIDERED LOCAL TO" &
- " THE CASE STATEMENT" );
-
- DECLARE -- A
- BEGIN
-
-B1 : DECLARE
-
- TYPE VARIANT_REC( DISCR : BOOLEAN := TRUE ) IS
- RECORD
- A , B : INTEGER ;
- CASE DISCR IS
- WHEN TRUE => P , Q : CHARACTER ;
- WHEN FALSE => X , Y : INTEGER ;
- END CASE;
- END RECORD ;
-
- V : VARIANT_REC := ( TRUE , 1 , 2 ,
- IDENT_CHAR( 'P' ) ,
- IDENT_CHAR( 'Q' ) );
-
- BEGIN
-
- IF EQUAL( 3 , 7 ) THEN V := ( FALSE , 3 , 4 , 7 , 8 );
- END IF;
-
- CASE V.DISCR IS
-
- WHEN TRUE =>
-
- IF ( V.P /= 'P' OR
- V.Q /= 'Q' )
- THEN FAILED( "WRONG VALUES - 1" );
- END IF;
-
- B1.V := ( FALSE , 3 , 4 ,
- IDENT_INT( 5 ) ,
- IDENT_INT( 6 ) );
-
- IF V.DISCR THEN FAILED( "WRONG DISCR." );
- END IF;
-
- IF ( V.X /= 5 OR
- V.Y /= 6 )
- THEN FAILED( "WRONG VALUES - 2" );
- END IF;
-
- WHEN FALSE =>
- FAILED( "WRONG BRANCH IN CASE STMT." );
-
- END CASE;
-
- EXCEPTION
-
- WHEN OTHERS => FAILED("EXCEPTION RAISED");
-
- END B1 ;
-
- EXCEPTION
-
- WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECLARATIONS");
-
- END ; -- A
-
-
- RESULT ;
-
-
-END C54A07A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada
deleted file mode 100644
index 949de81..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C54A13A.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 CASE EXPRESSION IS A DECLARED VARIABLE OR
--- CONSTANT, OR ONE OF THESE IN PARENTHESES, AND ITS SUBTYPE IS
--- NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY
--- APPEAR AS A CHOICE.
-
--- HISTORY:
--- BCB 02/29/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C54A13A IS
-
- SUBTYPE INT IS INTEGER RANGE IDENT_INT(5) .. IDENT_INT(10);
-
- A : INT := 8;
- B : CONSTANT INT := 7;
- C, D : INTEGER;
-
- FUNCTION IDENT(X : INT) RETURN INT IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
-BEGIN
- TEST ("C54A13A", "CHECK THAT IF A CASE EXPRESSION IS A DECLARED " &
- "VARIABLE OR CONSTANT, OR ONE OF THESE IN " &
- "PARENTHESES, AND ITS SUBTYPE IS NONSTATIC, " &
- "THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE " &
- "MAY APPEAR AS A CHOICE");
-
- CASE A IS
- WHEN 0 => C := IDENT_INT(5);
- WHEN 8 => C := IDENT_INT(10);
- WHEN 30000 => C := IDENT_INT(15);
- WHEN -30000 => C := IDENT_INT(20);
- WHEN OTHERS => C := IDENT_INT(25);
- END CASE;
-
- IF C /= IDENT_INT(10) THEN
- FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 1");
- END IF;
-
- CASE B IS
- WHEN 0 => D := IDENT_INT(5);
- WHEN 100 => D := IDENT_INT(10);
- WHEN 30000 => D := IDENT_INT(15);
- WHEN -30000 => D := IDENT_INT(20);
- WHEN OTHERS => D := IDENT_INT(25);
- END CASE;
-
- IF D /= IDENT_INT(25) THEN
- FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 2");
- END IF;
-
- CASE (A) IS
- WHEN 0 => C := IDENT_INT(5);
- WHEN 8 => C := IDENT_INT(10);
- WHEN 30000 => C := IDENT_INT(15);
- WHEN -30000 => C := IDENT_INT(20);
- WHEN OTHERS => C := IDENT_INT(25);
- END CASE;
-
- IF C /= IDENT_INT(10) THEN
- FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 3");
- END IF;
-
- CASE (B) IS
- WHEN 0 => D := IDENT_INT(5);
- WHEN 110 => D := IDENT_INT(10);
- WHEN 30000 => D := IDENT_INT(15);
- WHEN -30000 => D := IDENT_INT(20);
- WHEN OTHERS => D := IDENT_INT(25);
- END CASE;
-
- IF D /= IDENT_INT(25) THEN
- FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 4");
- END IF;
-
- RESULT;
-END C54A13A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada
deleted file mode 100644
index b0f3d1a..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- C54A13B.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 CASE EXPRESSION IS A GENERIC "IN" OR "IN OUT"
--- PARAMETER WITH A NON-STATIC SUBTYPE OR ONE OF THESE IN
--- PARENTHESES, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY
--- APPEAR AS A CHOICE.
-
--- HISTORY:
--- BCB 07/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C54A13B IS
-
- L : INTEGER := IDENT_INT(1);
- R : INTEGER := IDENT_INT(100);
-
- SUBTYPE INT IS INTEGER RANGE L .. R;
-
- GENERIC
- IN_PAR : IN INT;
- IN_OUT_PAR : IN OUT INT;
- PROCEDURE GEN_PROC (I : IN OUT INTEGER);
-
- IN_VAR : INT := IDENT_INT (10);
- IN_OUT_VAR : INT := IDENT_INT (100);
- CHECK_VAR : INT := IDENT_INT (1);
-
- PROCEDURE GEN_PROC (I : IN OUT INTEGER) IS
- BEGIN
- CASE IN_PAR IS
- WHEN 0 => I := I + IDENT_INT (2);
- WHEN 10 => I := I + IDENT_INT (1);
- WHEN -3000 => I := I + IDENT_INT (3);
- WHEN OTHERS => I := I + IDENT_INT (4);
- END CASE;
-
- CASE IN_OUT_PAR IS
- WHEN 0 => IN_OUT_PAR := IDENT_INT (0);
- WHEN 100 => IN_OUT_PAR := IDENT_INT (50);
- WHEN -3000 => IN_OUT_PAR := IDENT_INT (-3000);
- WHEN OTHERS => IN_OUT_PAR := IDENT_INT (5);
- END CASE;
-
- CASE (IN_PAR) IS
- WHEN 0 => I := I + IDENT_INT (2);
- WHEN 10 => I := I + IDENT_INT (1);
- WHEN -3000 => I := I + IDENT_INT (3);
- WHEN OTHERS => I := I + IDENT_INT (4);
- END CASE;
-
- CASE (IN_OUT_PAR) IS
- WHEN 0 => IN_OUT_PAR := IDENT_INT (200);
- WHEN 50 => IN_OUT_PAR := IDENT_INT (25);
- WHEN -3000 => IN_OUT_PAR := IDENT_INT (300);
- WHEN OTHERS => IN_OUT_PAR := IDENT_INT (400);
- END CASE;
-
- END GEN_PROC;
-
- PROCEDURE P IS NEW GEN_PROC (IN_VAR, IN_OUT_VAR);
-
-BEGIN
- TEST ("C54A13B", "CHECK THAT IF A CASE EXPRESSION IS A " &
- "GENERIC 'IN' OR 'IN OUT' PARAMETER WITH A " &
- "NON-STATIC SUBTYPE OR ONE OF " &
- "THESE IN PARENTHESES, THEN ANY VALUE OF " &
- "THE EXPRESSION'S BASE TYPE MAY APPEAR AS " &
- "A CHOICE");
-
- P (CHECK_VAR);
-
- IF NOT EQUAL (CHECK_VAR, IDENT_INT(3)) THEN
- FAILED ("INCORRECT CHOICES MADE FOR IN PARAMETER IN CASE");
- END IF;
-
- IF NOT EQUAL (IN_OUT_VAR, IDENT_INT(25)) THEN
- FAILED ("INCORRECT CHOICESMADE FOR IN OUT PARAMETER IN CASE");
- END IF;
-
- RESULT;
-END C54A13B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada
deleted file mode 100644
index f093a44..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C54A13C.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 CASE EXPRESSION IS A QUALIFIED EXPRESSION, A
--- TYPE CONVERSION, OR ONE OF THESE IN PARENTHESES, AND ITS
--- SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S
--- BASE TYPE MAY APPEAR AS A CHOICE.
-
--- HISTORY:
--- BCB 07/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C54A13C IS
-
- L : INTEGER := 1;
- R : INTEGER := 100;
-
- SUBTYPE INT IS INTEGER RANGE L .. R;
-
- A : INT := 50;
-
- B : INTEGER := 50;
-
- C : INTEGER;
-
-BEGIN
- TEST ("C54A13C", "CHECK THAT IF A CASE EXPRESSION IS A " &
- "QUALIFIED EXPRESSION, A TYPE CONVERSION, " &
- "OR ONE OF THESE IN PARENTHESES, AND ITS " &
- "SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE " &
- "EXPRESSION'S BASE TYPE MAY APPEAR AS A CHOICE");
-
- CASE INT'(A) IS
- WHEN 0 => C := IDENT_INT (5);
- WHEN 50 => C := IDENT_INT (10);
- WHEN -3000 => C := IDENT_INT (15);
- WHEN OTHERS => C := IDENT_INT (20);
- END CASE;
-
- IF C /= IDENT_INT (10) THEN
- FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " &
- "CASE");
- END IF;
-
- CASE INT(B) IS
- WHEN 0 => C := IDENT_INT (5);
- WHEN 50 => C := IDENT_INT (10);
- WHEN -3000 => C := IDENT_INT (15);
- WHEN OTHERS => C := IDENT_INT (20);
- END CASE;
-
- IF C /= IDENT_INT (10) THEN
- FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN CASE");
- END IF;
-
- CASE (INT'(A)) IS
- WHEN 0 => C := IDENT_INT (5);
- WHEN 50 => C := IDENT_INT (10);
- WHEN -3000 => C := IDENT_INT (15);
- WHEN OTHERS => C := IDENT_INT (20);
- END CASE;
-
- IF C /= IDENT_INT (10) THEN
- FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " &
- "PARENTHESES IN CASE");
- END IF;
-
- CASE (INT(B)) IS
- WHEN 0 => C := IDENT_INT (5);
- WHEN 50 => C := IDENT_INT (10);
- WHEN -3000 => C := IDENT_INT (15);
- WHEN OTHERS => C := IDENT_INT (20);
- END CASE;
-
- IF C /= IDENT_INT (10) THEN
- FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN " &
- "PARENTHESES IN CASE");
- END IF;
-
- RESULT;
-END C54A13C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada b/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada
deleted file mode 100644
index 9c71bd1..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- C54A13D.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 CASE EXPRESSION IS A FUNCTION INVOCATION,
--- ATTRIBUTE, STATIC EXPRESSION, OR ONE OF THESE IN PARENTHESES,
--- THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS A
--- CHOICE.
-
--- HISTORY:
--- BCB 07/19/88 CREATED ORIGINAL TEST.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBLE ALTERNATIVE IN FIRST CASE.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C54A13D IS
-
- SUBTYPE INT IS INTEGER RANGE -100 .. 100;
-
- CONS : CONSTANT INT := 0;
-
- C : INT;
-
- TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
-
- SUBTYPE SUBENUM IS ENUM RANGE THREE .. FOUR;
-
- FUNCTION FUNC RETURN INT IS
- BEGIN
- RETURN 0;
- END FUNC;
-
-BEGIN
- TEST ("C54A13D", "CHECK THAT IF A CASE EXPRESSION IS A FUNCTION " &
- "INVOCATION, ATTRIBUTE, STATIC EXPRESSION, OR " &
- "ONE OF THESE IN PARENTHESES, THEN ANY VALUE " &
- "OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS " &
- "A CHOICE");
-
- CASE FUNC IS
- WHEN 0 => C := IDENT_INT (5);
- WHEN 100 => C := IDENT_INT (10);
- WHEN OTHERS => C := IDENT_INT (20);
- END CASE;
-
- IF NOT EQUAL (C,5) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " &
- "FUNCTION INVOCATION - 1");
- END IF;
-
- CASE (FUNC) IS
- WHEN 0 => C := IDENT_INT (25);
- WHEN 100 => C := IDENT_INT (50);
- WHEN -3000 => C := IDENT_INT (75);
- WHEN OTHERS => C := IDENT_INT (90);
- END CASE;
-
- IF NOT EQUAL (C,25) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " &
- "FUNCTION INVOCATION - 2");
- END IF;
-
- CASE SUBENUM'FIRST IS
- WHEN ONE => C := IDENT_INT (100);
- WHEN TWO => C := IDENT_INT (99);
- WHEN THREE => C := IDENT_INT (98);
- WHEN FOUR => C := IDENT_INT (97);
- WHEN FIVE => C := IDENT_INT (96);
- WHEN SIX => C := IDENT_INT (95);
- END CASE;
-
- IF NOT EQUAL (C,98) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " &
- "ATTRIBUTE - 1");
- END IF;
-
- CASE (SUBENUM'FIRST) IS
- WHEN ONE => C := IDENT_INT (90);
- WHEN TWO => C := IDENT_INT (89);
- WHEN THREE => C := IDENT_INT (88);
- WHEN FOUR => C := IDENT_INT (87);
- WHEN FIVE => C := IDENT_INT (86);
- WHEN SIX => C := IDENT_INT (85);
- END CASE;
-
- IF NOT EQUAL (C,88) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " &
- "ATTRIBUTE - 2");
- END IF;
-
- CASE CONS * 1 IS
- WHEN 0 => C := IDENT_INT (1);
- WHEN 100 => C := IDENT_INT (2);
- WHEN -3000 => C := IDENT_INT (3);
- WHEN OTHERS => C := IDENT_INT (4);
- END CASE;
-
- IF NOT EQUAL (C,1) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " &
- "STATIC EXPRESSION - 1");
- END IF;
-
- CASE (CONS * 1) IS
- WHEN 0 => C := IDENT_INT (10);
- WHEN 100 => C := IDENT_INT (20);
- WHEN -3000 => C := IDENT_INT (30);
- WHEN OTHERS => C := IDENT_INT (40);
- END CASE;
-
- IF NOT EQUAL (C,10) THEN
- FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " &
- "STATIC EXPRESSION - 2");
- END IF;
-
- RESULT;
-END C54A13D;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada
deleted file mode 100644
index 4f6ab69..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada
+++ /dev/null
@@ -1,68 +0,0 @@
--- C54A22A.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 ALL FORMS OF CHOICE IN CASE CHOICES.
-
--- DAT 1/29/81
--- SPS 1/21/83
-
-WITH REPORT;
-PROCEDURE C54A22A IS
-
- USE REPORT;
-
- TYPE T IS RANGE 1 .. 10;
- C5 : CONSTANT T := 5;
- SUBTYPE S1 IS T RANGE 1 .. 5;
- SUBTYPE S2 IS T RANGE C5 + 1 .. 7;
- SUBTYPE SN IS T RANGE C5 + 4 .. C5 - 4 + 7; -- NULL RANGE.
- SUBTYPE S10 IS T RANGE C5 + 5 .. T'LAST;
-
-BEGIN
- TEST ("C54A22A", "CHECK ALL FORMS OF CASE CHOICES");
-
- CASE T'(C5 + 3) IS
- WHEN SN -- 9..8
- | S1 RANGE 1 .. 0 -- 1..0
- | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6
- | 3 .. 2 -- 3..2
- => FAILED ("WRONG CASE 1");
-
- WHEN S1 RANGE 4 .. C5 -- 4..5
- | S1 RANGE C5 - 4 .. C5 / 2 -- 1..2
- | 3 .. 1 + C5 MOD 3 -- 3..3
- | SN -- 9..8
- | S1 RANGE 5 .. C5 - 1 -- 5..4
- | 6 .. 7 -- 6..7
- | S10 -- 10..10
- | 9 -- 9
- | S10 RANGE 10 .. 9 => -- 10..9
- FAILED ("WRONG CASE 2");
-
- WHEN C5 + C5 - 2 .. 8 -- 8
- => NULL;
- END CASE;
-
- RESULT;
-END C54A22A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada
deleted file mode 100644
index 7acaa5e..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada
+++ /dev/null
@@ -1,49 +0,0 @@
--- C54A23A.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 CASE CHOICES MAY BE CONSTANT NAMES
-
--- DAT 3/18/81
--- SPS 4/7/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C54A23A IS
-
- C1 : CONSTANT INTEGER := 1;
- C2 : CONSTANT INTEGER := 2;
- C3 : CONSTANT INTEGER := 3;
-
-BEGIN
- TEST ("C54A23A", "CASE CHOICES MAY BE CONSTANTS");
-
- CASE IDENT_INT (C3) IS
- WHEN C1 | C2
- => FAILED ("WRONG CASE CHOICE 1");
- WHEN 3 => NULL;
- WHEN OTHERS => FAILED ("WRONG CASE CHOICE 2");
- END CASE;
-
- RESULT;
-END C54A23A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada
deleted file mode 100644
index edac9de..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C54A24A.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 NULL SUBRANGE CHOICES MAY OCCUR IN CASE STATEMENT, WITH
--- OUT-OF-BOUNDS RANGE BOUNDS, AND WHERE VACUOUS CHOICES ARE NULL.
--- CHECK THAT AN UNNEEDED OTHERS CHOICE IS PERMITTED.
-
--- DAT 1/29/81
--- JBG 8/21/83
-
-WITH REPORT;
-PROCEDURE C54A24A IS
-
- USE REPORT;
-
- TYPE T IS RANGE 1 .. 1010;
- SUBTYPE ST IS T RANGE 5 .. 7;
-
- V : ST := 6;
-
-BEGIN
- TEST ("C54A24A", "CHECK NULL CASE SUBRANGE CHOICES, WITH " &
- "OUTRAGEOUS BOUNDS");
-
- CASE V IS
- WHEN -1000 .. -1010 => NULL;
- WHEN T RANGE -5 .. -6 => NULL;
- WHEN 12 .. 11 | ST RANGE 1000 .. 99 => NULL;
- WHEN ST RANGE -99 .. -999 => NULL;
- WHEN ST RANGE 6 .. 6 => V := V - 1;
- WHEN T RANGE ST'BASE'LAST .. ST'BASE'FIRST => NULL;
- WHEN 5 | 7 => NULL;
- WHEN ST RANGE T'BASE'LAST .. T'BASE'FIRST => NULL;
- WHEN T'BASE'LAST .. T'BASE'FIRST => NULL;
- WHEN OTHERS => V := V + 1;
- END CASE;
- IF V /= 5 THEN
- FAILED ("IMPROPER CASE EXECUTION");
- END IF;
-
- RESULT;
-END C54A24A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada
deleted file mode 100644
index 4515e93..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada
+++ /dev/null
@@ -1,58 +0,0 @@
--- C54A24B.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 NULL SUBTYPE RANGES ARE ACCEPTABLE CASE CHOICES,
--- WHERE THE BOUNDS ARE BOTH OUT OF THE SUBRANGE'S RANGE, AND
--- WHERE VACUOUS CHOICES HAVE NON-NULL STATEMENT SEQUENCES.
--- CHECK THAT AN UNNEEDED OTHERS CLAUSE IS PERMITTED.
-
--- HISTORY:
--- DAT 01/29/81 CREATED ORIGINAL TEST.
--- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT;
-PROCEDURE C54A24B IS
-
- USE REPORT;
-
- TYPE C IS NEW CHARACTER RANGE 'A' .. 'D';
- X : C := 'B';
-
-BEGIN
- TEST ("C54A24B", "NULL CASE CHOICE SUBRANGES WITH VALUES " &
- "OUTSIDE SUBRANGE");
-
- CASE X IS
- WHEN C RANGE C'BASE'LAST .. C'BASE'FIRST
- | C RANGE 'Z' .. ' ' => X := 'A';
- WHEN C => NULL;
- WHEN OTHERS => X := 'C';
- END CASE;
- IF X /= 'B' THEN
- FAILED ("WRONG CASE EXECUTION");
- END IF;
-
- RESULT;
-END C54A24B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada
deleted file mode 100644
index b6babb0..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- C54A42A.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 CASE_STATEMENT MAY HANDLE A LARGE NUMBER OF
--- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES
--- AND THAT EACH TIME THE APPROPRIATE ALTERNATIVE IS EXECUTED.
-
--- (OPTIMIZATION TEST.)
-
-
--- RM 03/24/81
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-
-WITH REPORT;
-PROCEDURE C54A42A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42A" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" &
- " A LARGE NUMBER OF POTENTIAL VALUES GROUPED" &
- " INTO A SMALL NUMBER OF ALTERNATIVES" );
-
- DECLARE
-
- STATCON : CONSTANT CHARACTER := 'B' ;
- STATVAR : CHARACTER := 'Q' ;
- DYNCON : CONSTANT CHARACTER := IDENT_CHAR( 'Y' );
- DYNVAR : CHARACTER := IDENT_CHAR( 'Z' );
-
- BEGIN
-
- CASE CHARACTER'('A') IS
- WHEN ASCII.NUL .. 'A' => NULL ;
- WHEN 'B' => FAILED( "WRONG ALTERN. A2" );
- WHEN 'P' => FAILED( "WRONG ALTERN. A3" );
- WHEN 'Y' => FAILED( "WRONG ALTERN. A4" );
- WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. A5" );
- WHEN OTHERS => FAILED( "WRONG ALTERN. A6" );
- END CASE;
-
- CASE STATCON IS
- WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. B1" );
- WHEN 'B' => NULL ;
- WHEN 'P' => FAILED( "WRONG ALTERN. B3" );
- WHEN 'Y' => FAILED( "WRONG ALTERN. B4" );
- WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. B5" );
- WHEN OTHERS => FAILED( "WRONG ALTERN. B6" );
- END CASE;
-
- CASE STATVAR IS
- WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. C1" );
- WHEN 'B' => FAILED( "WRONG ALTERN. C2" );
- WHEN 'P' => FAILED( "WRONG ALTERN. C3" );
- WHEN 'Y' => FAILED( "WRONG ALTERN. C4" );
- WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. C5" );
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE DYNCON IS
- WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. D1" );
- WHEN 'B' => FAILED( "WRONG ALTERN. D2" );
- WHEN 'P' => FAILED( "WRONG ALTERN. D3" );
- WHEN 'Y' => NULL ;
- WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. D5" );
- WHEN OTHERS => FAILED( "WRONG ALTERN. D6" );
- END CASE;
-
- CASE DYNVAR IS
- WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. E1" );
- WHEN 'B' => FAILED( "WRONG ALTERN. E2" );
- WHEN 'P' => FAILED( "WRONG ALTERN. E3" );
- WHEN 'Y' => FAILED( "WRONG ALTERN. E4" );
- WHEN 'Z' .. ASCII.DEL => NULL ;
- WHEN OTHERS => FAILED( "WRONG ALTERN. E6" );
- END CASE;
-
- END ;
-
-
- DECLARE
-
- NUMBER : CONSTANT := -100 ;
- LITEXPR : CONSTANT := 0 * NUMBER + 16 ;
- STATCON : CONSTANT INTEGER := +100 ;
- DYNVAR : INTEGER := IDENT_INT( 102 ) ;
- DYNCON : CONSTANT INTEGER := IDENT_INT( 17 ) ;
-
- BEGIN
-
- CASE INTEGER'(-102) IS
- WHEN INTEGER'FIRST..-101 => NULL ;
- WHEN -100 => FAILED("WRONG ALTERN. F2");
- WHEN 17 => FAILED("WRONG ALTERN. F2");
- WHEN 100 => FAILED("WRONG ALTERN. F4");
- WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. F5");
- WHEN OTHERS => FAILED("WRONG ALTERN. F6");
- END CASE;
-
- CASE IDENT_INT(NUMBER) IS
- WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. G1");
- WHEN -100 => NULL ;
- WHEN 17 => FAILED("WRONG ALTERN. G3");
- WHEN 100 => FAILED("WRONG ALTERN. G4");
- WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. G5");
- WHEN OTHERS => FAILED("WRONG ALTERN. G6");
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. H1");
- WHEN -100 => FAILED("WRONG ALTERN. H2");
- WHEN 17 => FAILED("WRONG ALTERN. H3");
- WHEN 100 => FAILED("WRONG ALTERN. H4");
- WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. H5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE STATCON IS
- WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. I1");
- WHEN -100 => FAILED("WRONG ALTERN. I2");
- WHEN 17 => FAILED("WRONG ALTERN. I3");
- WHEN 100 => NULL ;
- WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. I5");
- WHEN OTHERS => FAILED("WRONG ALTERN. I6");
- END CASE;
-
- CASE DYNVAR IS
- WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. J1");
- WHEN -100 => FAILED("WRONG ALTERN. J2");
- WHEN 17 => FAILED("WRONG ALTERN. J3");
- WHEN 100 => FAILED("WRONG ALTERN. J4");
- WHEN 101..INTEGER'LAST => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERN. J6");
- END CASE;
-
- CASE DYNCON IS
- WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. K1");
- WHEN -100 => FAILED("WRONG ALTERN. K2");
- WHEN 17 => NULL ;
- WHEN 100 => FAILED("WRONG ALTERN. K4");
- WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. K5");
- WHEN OTHERS => FAILED("WRONG ALTERN. K6");
- END CASE;
- END ;
-
-
- RESULT ;
-
-
-END C54A42A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada
deleted file mode 100644
index bcf1dcc..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- C54A42B.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 CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF
--- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES.
-
--- (OPTIMIZATION TEST -- JUMP TABLE.)
-
-
--- RM 03/26/81
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-
-WITH REPORT;
-PROCEDURE C54A42B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42B" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" &
- " A SMALL NUMBER OF POTENTIAL VALUES GROUPED" &
- " INTO A SMALL NUMBER OF ALTERNATIVES" );
-
- DECLARE
-
- STATCON : CONSTANT CHARACTER RANGE 'A'..'K' := 'J' ;
- STATVAR : CHARACTER RANGE 'A'..'K' := 'A' ;
- DYNCON : CONSTANT CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('K');
- DYNVAR : CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('G');
-
- BEGIN
-
- CASE STATVAR IS
- WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE A1" );
- WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE A2" );
- WHEN 'F' => FAILED( "WRONG ALTERNATIVE A3" );
- WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE A4" );
- WHEN 'G' => FAILED( "WRONG ALTERNATIVE A5" );
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE CHARACTER'('B') IS
- WHEN 'B' | 'E' => NULL ;
- WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE B2" );
- WHEN 'F' => FAILED( "WRONG ALTERNATIVE B3" );
- WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE B4" );
- WHEN 'G' => FAILED( "WRONG ALTERNATIVE B5" );
- WHEN OTHERS => FAILED( "WRONG ALTERNATIVE B6" );
- END CASE;
-
- CASE DYNVAR IS
- WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE C1" );
- WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE C2" );
- WHEN 'F' => FAILED( "WRONG ALTERNATIVE C3" );
- WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE C4" );
- WHEN 'G' => NULL ;
- WHEN OTHERS => FAILED( "WRONG ALTERNATIVE C6" );
- END CASE;
-
- CASE IDENT_CHAR(STATCON) IS
- WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE D1" );
- WHEN 'J' | 'C' => NULL ;
- WHEN 'F' => FAILED( "WRONG ALTERNATIVE D3" );
- WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE D4" );
- WHEN 'G' => FAILED( "WRONG ALTERNATIVE D5" );
- WHEN OTHERS => FAILED( "WRONG ALTERNATIVE D6" );
- END CASE;
-
- CASE DYNCON IS
- WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE E1" );
- WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE E2" );
- WHEN 'F' => FAILED( "WRONG ALTERNATIVE E3" );
- WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE E4" );
- WHEN 'G' => FAILED( "WRONG ALTERNATIVE E5" );
- WHEN OTHERS => NULL ;
- END CASE;
-
- END ;
-
-
- DECLARE
-
- NUMBER : CONSTANT := 1 ;
- LITEXPR : CONSTANT := NUMBER + 5 ;
- STATCON : CONSTANT INTEGER RANGE 0..10 := 9 ;
- DYNVAR : INTEGER RANGE 0..10 := IDENT_INT( 10 );
- DYNCON : CONSTANT INTEGER RANGE 0..10 := IDENT_INT( 2 );
-
- BEGIN
-
- CASE INTEGER'(0) IS
- WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE F1");
- WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE F2");
- WHEN 5 => FAILED("WRONG ALTERNATIVE F3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE F4");
- WHEN 6 => FAILED("WRONG ALTERNATIVE F5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE INTEGER'(NUMBER) IS
- WHEN 1 | 4 => NULL ;
- WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE G2");
- WHEN 5 => FAILED("WRONG ALTERNATIVE G3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE G4");
- WHEN 6 => FAILED("WRONG ALTERNATIVE G5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6");
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE H1");
- WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE H2");
- WHEN 5 => FAILED("WRONG ALTERNATIVE H3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE H4");
- WHEN 6 => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6");
- END CASE;
-
- CASE STATCON IS
- WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE I1");
- WHEN 9 | 2 => NULL ;
- WHEN 5 => FAILED("WRONG ALTERNATIVE I3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE I4");
- WHEN 6 => FAILED("WRONG ALTERNATIVE I5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6");
- END CASE;
-
- CASE DYNVAR IS
- WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE J1");
- WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE J2");
- WHEN 5 => FAILED("WRONG ALTERNATIVE J3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE J4");
- WHEN 6 => FAILED("WRONG ALTERNATIVE J5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE DYNCON IS
- WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE K1");
- WHEN 9 | 2 => NULL ;
- WHEN 5 => FAILED("WRONG ALTERNATIVE K3");
- WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE K4");
- WHEN 6 => FAILED("WRONG ALTERNATIVE K5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6");
- END CASE;
-
- END ;
-
-
- RESULT ;
-
-
-END C54A42B ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada
deleted file mode 100644
index 79a3979..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- C54A42C.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 CASE_STATEMENT CORRECTLY HANDLES A SPARSE SET OF
--- POTENTIAL VALUES (OF TYPE INTEGER) IN A LARGE RANGE.
-
--- (OPTIMIZATION TEST)
-
-
--- RM 03/26/81
-
-
-WITH REPORT;
-PROCEDURE C54A42C IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42C" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" &
- " A SPARSE SET OF POTENTIAL VALUES IN A LARGE" &
- " RANGE" );
-
- DECLARE
-
- NUMBER : CONSTANT := 1001 ;
- LITEXPR : CONSTANT := NUMBER + 998 ;
- STATCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST := 1000 ;
- DYNVAR : INTEGER RANGE 1..INTEGER'LAST :=
- IDENT_INT( INTEGER'LAST-50 );
- DYNCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST :=
- IDENT_INT( 1000 );
-
- BEGIN
-
- CASE INTEGER'( NUMBER ) IS
- WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE F1");
- WHEN 1000 => FAILED("WRONG ALTERNATIVE F2");
- WHEN 2000 => FAILED("WRONG ALTERNATIVE F3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE F4");
- WHEN INTEGER'LAST-100 ..
- INTEGER'LAST => FAILED("WRONG ALTERNATIVE F5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE IDENT_INT( 10 ) IS
- WHEN 1 .. 10 => NULL ;
- WHEN 1000 => FAILED("WRONG ALTERNATIVE G2");
- WHEN 2000 => FAILED("WRONG ALTERNATIVE G3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE G4");
- WHEN INTEGER'LAST -100 ..
- INTEGER'LAST => FAILED("WRONG ALTERNATIVE G5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6");
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE H1");
- WHEN 1000 => FAILED("WRONG ALTERNATIVE H2");
- WHEN 2000 => FAILED("WRONG ALTERNATIVE H3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE H4");
- WHEN INTEGER'LAST -100 ..
- INTEGER'LAST => FAILED("WRONG ALTERNATIVE H5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE STATCON IS
- WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE I1");
- WHEN 1000 => NULL ;
- WHEN 2000 => FAILED("WRONG ALTERNATIVE I3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE I4");
- WHEN INTEGER'LAST -100 ..
- INTEGER'LAST => FAILED("WRONG ALTERNATIVE I5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6");
- END CASE;
-
- CASE DYNVAR IS
- WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE J1");
- WHEN 1000 => FAILED("WRONG ALTERNATIVE J2");
- WHEN 2000 => FAILED("WRONG ALTERNATIVE J3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE J4");
- WHEN INTEGER'LAST -100 ..
- INTEGER'LAST => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE J6");
- END CASE;
-
- CASE DYNCON IS
- WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE K1");
- WHEN 1000 => NULL ;
- WHEN 2000 => FAILED("WRONG ALTERNATIVE K3");
- WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE K4");
- WHEN INTEGER'LAST -100 ..
- INTEGER'LAST => FAILED("WRONG ALTERNATIVE K5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6");
- END CASE;
-
- END ;
-
-
- RESULT ;
-
-
-END C54A42C ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada
deleted file mode 100644
index 9394f5c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C54A42D.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 CASE_STATEMENT CORRECTLY HANDLES A FEW ALTERNATIVES
--- COVERING A LARGE RANGE OF INTEGERS.
-
-
--- (OPTIMIZATION TEST.)
-
-
--- RM 03/30/81
-
-
-WITH REPORT;
-PROCEDURE C54A42D IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42D" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" &
- " A FEW ALTERNATIVES COVERING A LARGE RANGE" &
- " OF INTEGERS" );
-
- DECLARE
-
- NUMBER : CONSTANT := 2000 ;
- LITEXPR : CONSTANT := NUMBER + 2000 ;
- STATCON : CONSTANT INTEGER := 2001 ;
- DYNVAR : INTEGER := IDENT_INT( 0 );
- DYNCON : CONSTANT INTEGER := IDENT_INT( 1 );
-
- BEGIN
-
- CASE INTEGER'(-4000) IS
- WHEN 1..2000 => FAILED("WRONG ALTERNATIVE F1");
- WHEN INTEGER'FIRST..0=> NULL ;
- WHEN 2001 => FAILED("WRONG ALTERNATIVE F3");
- WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4");
- END CASE;
-
- CASE INTEGER'(NUMBER) IS
- WHEN 1..2000 => NULL ;
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE G3");
- WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4");
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN 1..2000 => FAILED("WRONG ALTERNATIVE H1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE H3");
- WHEN 2002..INTEGER'LAST=>NULL ;
- END CASE;
-
- CASE STATCON IS
- WHEN 1..2000 => FAILED("WRONG ALTERNATIVE I1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2");
- WHEN 2001 => NULL ;
- WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4");
- END CASE;
-
- CASE DYNVAR IS
- WHEN 1..2000 => FAILED("WRONG ALTERNATIVE J1");
- WHEN INTEGER'FIRST..0=> NULL ;
- WHEN 2001 => FAILED("WRONG ALTERNATIVE J3");
- WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4");
- END CASE;
-
- CASE DYNCON IS
- WHEN 1..2000 => NULL ;
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE K3");
- WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4");
- END CASE;
-
- END ;
-
-
- RESULT ;
-
-
-END C54A42D ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada
deleted file mode 100644
index fb22164..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C54A42E.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 CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF
--- POTENTIAL VALUES OF TYPE INTEGER, SITUATED FAR FROM 0 AND
--- GROUPED INTO A SMALL NUMBER OF ALTERNATIVES.
-
--- (OPTIMIZATION TEST -- BIASED JUMP TABLE.)
-
-
--- RM 03/26/81
-
-
-WITH REPORT;
-PROCEDURE C54A42E IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42E" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" &
- " A SMALL, FAR RANGE OF POTENTIAL VALUES OF" &
- " TYPE INTEGER" );
-
- DECLARE
-
- NUMBER : CONSTANT := 4001 ;
- LITEXPR : CONSTANT := NUMBER + 5 ;
- STATCON : CONSTANT INTEGER RANGE 4000..4010 := 4009 ;
- DYNVAR : INTEGER RANGE 4000..4010 :=
- IDENT_INT( 4010 );
- DYNCON : CONSTANT INTEGER RANGE 4000..4010 :=
- IDENT_INT( 4002 );
-
- BEGIN
-
- CASE INTEGER'(4000) IS
- WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE F1");
- WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE F2");
- WHEN 4005 => FAILED("WRONG ALTERNATIVE F3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE F4");
- WHEN 4006 => FAILED("WRONG ALTERNATIVE F5");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE IDENT_INT(NUMBER) IS
- WHEN 4001 | 4004 => NULL ;
- WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE G2");
- WHEN 4005 => FAILED("WRONG ALTERNATIVE G3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE G4");
- WHEN 4006 => FAILED("WRONG ALTERNATIVE G5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6");
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE H1");
- WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE H2");
- WHEN 4005 => FAILED("WRONG ALTERNATIVE H3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE H4");
- WHEN 4006 => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6");
- END CASE;
-
- CASE STATCON IS
- WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE I1");
- WHEN 4009 | 4002 => NULL ;
- WHEN 4005 => FAILED("WRONG ALTERNATIVE I3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE I4");
- WHEN 4006 => FAILED("WRONG ALTERNATIVE I5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6");
- END CASE;
-
- CASE DYNVAR IS
- WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE J1");
- WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE J2");
- WHEN 4005 => FAILED("WRONG ALTERNATIVE J3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE J4");
- WHEN 4006 => FAILED("WRONG ALTERNATIVE J5");
- WHEN OTHERS => NULL ;
-
- END CASE;
-
- CASE DYNCON IS
- WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE K1");
- WHEN 4009 | 4002 => NULL ;
- WHEN 4005 => FAILED("WRONG ALTERNATIVE K3");
- WHEN 4003 |
- 4007..4008 => FAILED("WRONG ALTERNATIVE K4");
- WHEN 4006 => FAILED("WRONG ALTERNATIVE K5");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6");
- END CASE;
-
- END ;
-
-
- RESULT ;
-
-
-END C54A42E ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada
deleted file mode 100644
index c321ce8..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- C54A42F.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 CASE_STATEMENT CORRECTLY HANDLES SEVERAL SMALL,
--- NON-CONTIGUOUS RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS'
--- ALTERNATIVE.
-
-
--- (OPTIMIZATION TEST.)
-
-
--- RM 03/31/81
-
-
-WITH REPORT;
-PROCEDURE C54A42F IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42F" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" &
- " SEVERAL SMALL, NON-CONTIGUOUS ENUMERATION" &
- " RANGES COVERED BY A SINGLE 'OTHERS' " &
- " ALTERNATIVE" );
-
- DECLARE
-
- TYPE DAY IS (SUN , MON , TUE , WED , THU , FRI , SAT );
-
- DYNVAR2 : DAY := MON ;
- STATVAR : DAY := TUE ;
- STATCON : CONSTANT DAY := WED ;
- DYNVAR : DAY := THU ;
- DYNCON : CONSTANT DAY := DAY'VAL( IDENT_INT(5) ); -- FRI
-
- BEGIN
-
- IF EQUAL(1,289) THEN
- DYNVAR := SUN ;
- DYNVAR2 := SUN ;
- END IF;
-
- CASE SUN IS -- SUN
- WHEN THU => FAILED("WRONG ALTERNATIVE F1");
- WHEN SUN => NULL ;
- WHEN SAT => FAILED("WRONG ALTERNATIVE F3");
- WHEN TUE..WED => FAILED("WRONG ALTERNATIVE F4");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5");
- END CASE;
-
- CASE DYNVAR2 IS -- MON
- WHEN THU => FAILED("WRONG ALTERNATIVE G1");
- WHEN SUN => FAILED("WRONG ALTERNATIVE G2");
- WHEN SAT => FAILED("WRONG ALTERNATIVE G3");
- WHEN TUE..WED => FAILED("WRONG ALTERNATIVE G4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE STATVAR IS -- TUE
- WHEN THU => FAILED("WRONG ALTERNATIVE H1");
- WHEN SUN => FAILED("WRONG ALTERNATIVE H2");
- WHEN SAT => FAILED("WRONG ALTERNATIVE H3");
- WHEN TUE..WED => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5");
- END CASE;
-
- CASE STATCON IS -- WED
- WHEN THU => FAILED("WRONG ALTERNATIVE I1");
- WHEN SUN => FAILED("WRONG ALTERNATIVE I2");
- WHEN SAT => FAILED("WRONG ALTERNATIVE I3");
- WHEN TUE..WED => NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE I5");
- END CASE;
-
- CASE DYNVAR IS -- THU
- WHEN THU => NULL ;
- WHEN SUN => FAILED("WRONG ALTERNATIVE J2");
- WHEN SAT => FAILED("WRONG ALTERNATIVE J3");
- WHEN TUE..WED => FAILED("WRONG ALTERNATIVE J4");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5");
- END CASE;
-
- CASE DYNCON IS -- FRI
- WHEN THU => FAILED("WRONG ALTERNATIVE K1");
- WHEN SUN => FAILED("WRONG ALTERNATIVE K2");
- WHEN SAT => FAILED("WRONG ALTERNATIVE K3");
- WHEN TUE..WED => FAILED("WRONG ALTERNATIVE K4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE DAY'SUCC( DYNCON ) IS -- SAT
- WHEN THU => FAILED("WRONG ALTERNATIVE L1");
- WHEN SUN => FAILED("WRONG ALTERNATIVE L2");
- WHEN SAT => NULL ;
- WHEN TUE..WED => FAILED("WRONG ALTERNATIVE L4");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE L5");
- END CASE;
- END ;
-
-
- RESULT ;
-
-
-END C54A42F ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada b/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada
deleted file mode 100644
index ebe44f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- C54A42G.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 CASE_STATEMENT CORRECTLY HANDLES SEVERAL NON-CONTIGUOUS
--- RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS' ALTERNATIVE.
-
-
--- (OPTIMIZATION TEST.)
-
-
--- RM 03/30/81
-
-
-WITH REPORT;
-PROCEDURE C54A42G IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C54A42G" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" &
- " SEVERAL NON-CONTIGUOUS RANGES OF INTEGERS" &
- " COVERED BY A SINGLE 'OTHERS' ALTERNATIVE" );
-
- DECLARE
-
- NUMBER : CONSTANT := 2000 ;
- LITEXPR : CONSTANT := NUMBER + 2000 ;
- STATCON : CONSTANT INTEGER := 2002 ;
- DYNVAR : INTEGER := IDENT_INT( 0 );
- DYNCON : CONSTANT INTEGER := IDENT_INT( 1 );
-
- BEGIN
-
- CASE INTEGER'(-4000) IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE F1");
- WHEN INTEGER'FIRST..0=> NULL ;
- WHEN 2001 => FAILED("WRONG ALTERNATIVE F3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5");
- END CASE;
-
- CASE IDENT_INT(NUMBER) IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE G1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE G3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE IDENT_INT(LITEXPR) IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE H1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE H3");
- WHEN 2100..INTEGER'LAST=>NULL ;
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5");
- END CASE;
-
- CASE IDENT_INT(STATCON) IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE I1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE I3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE DYNVAR IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE J1");
- WHEN INTEGER'FIRST..0=> NULL ;
- WHEN 2001 => FAILED("WRONG ALTERNATIVE J3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4");
- WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5");
- END CASE;
-
- CASE DYNCON IS
- WHEN 100..1999 => FAILED("WRONG ALTERNATIVE K1");
- WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE K3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- CASE IDENT_INT( -3900 ) IS
- WHEN -3000..1999 => FAILED("WRONG ALTERNATIVE X1");
- WHEN INTEGER'FIRST..
- -4000 => FAILED("WRONG ALTERNATIVE X2");
- WHEN 2001 => FAILED("WRONG ALTERNATIVE X3");
- WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE X4");
- WHEN OTHERS => NULL ;
- END CASE;
-
- END ;
-
-
- RESULT ;
-
-
-END C54A42G ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada
deleted file mode 100644
index ddcadce..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C55B03A.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 LOOP_PARAMETER IS ASSIGNED VALUES IN ASCENDING ORDER
--- IF REVERSE IS ABSENT, AND DESCENDING ORDER IF REVERSE IS PRESENT.
-
--- DAS 1/12/81
--- SPS 3/2/83
-
-WITH REPORT;
-PROCEDURE C55B03A IS
-
- USE REPORT;
- I1 : INTEGER;
-
-BEGIN
- TEST( "C55B03A" , "CHECK CORRECT ORDER OF VALUE SEQUENCING" &
- " FOR A LOOP_PARAMETER" );
-
- I1 := 0;
- FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP
- I1 := I1 + 1;
- IF ( I /= I1 ) THEN
- FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY" );
- END IF;
- END LOOP;
-
- I1 := 6;
- FOR I IN REVERSE IDENT_INT(1)..IDENT_INT(5) LOOP
- I1 := I1 - 1;
- IF ( I /= I1 ) THEN
- FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY" );
- END IF;
- END LOOP;
-
- RESULT;
-
-END C55B03A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada
deleted file mode 100644
index 748f192..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C55B04A.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 LOOP IS NOT ENTERED IF THE LOWER BOUND OF THE DISCRETE
--- RANGE IS GREATER THAN THE UPPER BOUND, WHETHER REVERSE IS PRESENT
--- OR NOT.
-
--- CHECK THAT LOOP BOUNDS ARE EVALUATED ONLY ONCE, UPON ENTRY TO
--- THE LOOP.
-
--- DAS 01/12/81
--- SPS 3/2/83
--- JBG 8/21/83
-
-WITH REPORT;
-PROCEDURE C55B04A IS
-
- USE REPORT;
-
- C10 : CONSTANT INTEGER := 10;
- I10 : INTEGER;
-
-BEGIN
- TEST ( "C55B04A", "CHECK OPERATION OF A FOR LOOP OVER A NULL " &
- "DISCRETE RANGE" );
-
- -- NOTE: EXIT STATEMENTS ARE INCLUDED TO AID IN RECOVERY FROM
- -- TEST FAILURE.
-
- -- SUBTESTS INVOLVING STATIC BOUNDS:
-
- FOR I IN 10..1 LOOP
- FAILED ( "LOOPING OVER NULL RANGE 10..1" );
- EXIT;
- END LOOP;
-
- FOR I IN REVERSE INTEGER RANGE -1..-10 LOOP
- FAILED ( "LOOPING OVER NULL RANGE -1..-10" );
- EXIT;
- END LOOP;
-
- FOR I IN (C10 + 3)..(-3 * C10 + 27) LOOP -- 13..-3
- FAILED ("LOOPING OVER NULL RANGE (C10 + 3)..(-3 * C10 + 27)");
- EXIT;
- END LOOP;
-
-
- -- SUBTESTS INVOLVING DYNAMIC BOUNDS:
-
- I10 := IDENT_INT(10);
-
- FOR I IN REVERSE I10..(I10-1) LOOP -- 10..9
- FAILED ( "LOOPING OVER NULL RANGE I10..(I10-1)");
- EXIT;
- END LOOP;
-
-
- FOR I IN (C10 - I10)..(I10 - 11) LOOP -- 0..-1
- FAILED ( "LOOPING OVER NULL RANGE (C10 - I10)..(I10 - 11)" );
- EXIT;
- END LOOP;
-
-
- -- SUBTEST OF BOUNDS EVALUTION ONLY AT ENTRY:
-
- FOR I IN 1..I10 LOOP
- I10 := I10 - 1;
- END LOOP;
- IF (I10 /= 0) THEN
- FAILED ( "LOOP BOUNDS NOT FIXED AT LOOP ENTRY" );
- END IF;
-
- RESULT;
-
-END C55B04A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada
deleted file mode 100644
index 20e8ff4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- C55B05A.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 LOOPS WITH BOUNDS INTEGER'LAST OR
--- INTEGER'FIRST DO NOT RAISE INVALID EXCEPTIONS.
-
--- *** 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
-
--- DAT 3/26/81
--- SPS 3/2/83
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C55B05A IS
-BEGIN
- TEST ("C55B05A", "LOOPS WITH INTEGER'FIRST AND 'LAST AS BOUNDS");
-
- DECLARE
-
- COUNT : INTEGER := 0;
-
- PROCEDURE C IS
- BEGIN
- COUNT := COUNT + 1;
- END C;
-
- BEGIN
- FOR I IN INTEGER'LAST .. INTEGER'FIRST LOOP
- FAILED ("WRONG NULL RANGE LOOP EXECUTION");
- EXIT;
- END LOOP;
- FOR I IN INTEGER'FIRST .. INTEGER'FIRST LOOP
- C;
- END LOOP;
- FOR I IN INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP
- C; C;
- END LOOP;
- FOR I IN INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP
- FAILED ("NULL RANGE ERROR 2");
- EXIT;
- END LOOP;
- FOR I IN INTEGER'FIRST .. INTEGER'LAST LOOP
- C;
- EXIT;
- END LOOP;
- FOR I IN INTEGER LOOP
- C;
- EXIT;
- END LOOP;
- FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST LOOP
- C; C; C;
- END LOOP;
- FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP
- C;
- END LOOP;
- FOR I IN 0 .. INTEGER'FIRST LOOP
- FAILED ("NULL LOOP ERROR 3");
- EXIT;
- END LOOP;
- FOR I IN -1 .. INTEGER'FIRST LOOP
- FAILED ("NULL LOOP ERROR 4");
- EXIT;
- END LOOP;
- FOR I IN -3 .. IDENT_INT(0) LOOP
- FOR J IN INTEGER'FIRST .. INTEGER'FIRST - I LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN INTEGER'FIRST - I .. INTEGER'FIRST + 3 - I LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN INTEGER'LAST - 3 .. INTEGER'LAST + I LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN INTEGER'LAST + I .. INTEGER'LAST LOOP
- C; C; C; C;
- END LOOP;
- END LOOP;
-
- FOR I IN REVERSE INTEGER'LAST .. INTEGER'FIRST LOOP
- FAILED ("REVERSE WRONG NULL RANGE LOOP EXECUTION");
- EXIT;
- END LOOP;
- FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST LOOP
- C;
- END LOOP;
- FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP
- C; C;
- END LOOP;
- FOR I IN REVERSE INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP
- FAILED ("NULL RANGE ERROR 8");
- EXIT;
- END LOOP;
- FOR I IN REVERSE INTEGER'FIRST .. INTEGER'LAST LOOP
- C;
- EXIT;
- END LOOP;
- FOR I IN REVERSE INTEGER LOOP
- C;
- EXIT;
- END LOOP;
- FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST LOOP
- C; C; C;
- END LOOP;
- FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP
- C;
- END LOOP;
- FOR I IN REVERSE 0 .. INTEGER'FIRST LOOP
- FAILED ("NULL LOOP ERROR 9");
- EXIT;
- END LOOP;
- FOR I IN REVERSE -1 .. INTEGER'FIRST LOOP
- FAILED ("NULL LOOP ERROR 7");
- EXIT;
- END LOOP;
- FOR I IN REVERSE -3 .. IDENT_INT(0) LOOP
- FOR J IN REVERSE INTEGER'FIRST .. INTEGER'FIRST - I LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN REVERSE INTEGER'FIRST - I
- .. INTEGER'FIRST + 3 - I
- LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN REVERSE INTEGER'LAST - 3 .. INTEGER'LAST + I
- LOOP
- C; C; C; C;
- END LOOP;
- FOR J IN REVERSE INTEGER'LAST + I .. INTEGER'LAST LOOP
- C; C; C; C;
- END LOOP;
- END LOOP;
-
- IF COUNT /= 408 THEN
- FAILED ("WRONG LOOP EXECUTION COUNT");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED INCORRECTLY");
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED INCORRECTLY");
- END;
-
- RESULT;
-END C55B05A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada
deleted file mode 100644
index 524de24..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada
+++ /dev/null
@@ -1,313 +0,0 @@
--- C55B06A.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 LOOPS MAY BE SPECIFIED FOR BOOLEAN, INTEGER,
--- CHARACTER, ENUMERATION, AND DERIVED TYPES, INCLUDING
--- TYPES DERIVED FROM DERIVED TYPES. DERIVED BOOLEAN IS NOT
--- TESTED IN THIS TEST.
-
--- DAT 3/26/81
--- JBG 9/29/82
--- SPS 3/11/83
--- JBG 10/5/83
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C55B06A IS
-
- TYPE ENUM IS ('A', 'B', 'D', 'C', Z, X, D, A, C);
-
- TYPE D1 IS NEW CHARACTER RANGE 'A' .. 'Z';
- TYPE D2 IS NEW INTEGER;
- TYPE D3 IS NEW ENUM;
- TYPE D4 IS NEW D1;
- TYPE D5 IS NEW D2;
- TYPE D6 IS NEW D3;
-
- ONE : INTEGER := IDENT_INT(1);
- COUNT : INTEGER := 0;
- OLDCOUNT : INTEGER := 0;
-
- PROCEDURE Q IS
- BEGIN
- COUNT := COUNT + ONE;
- END Q;
-
-BEGIN
- TEST ("C55B06A", "TEST LOOPS FOR ALL DISCRETE TYPES");
-
- FOR I IN BOOLEAN LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 1");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 2");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 3");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN INTEGER LOOP
- Q;
- EXIT WHEN I = INTEGER'FIRST + 2;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN
- FAILED ("LOOP 4");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN 3 .. IDENT_INT (5) LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN
- FAILED ("LOOP 5");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN INTEGER RANGE -2 .. -1 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 6");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN INTEGER RANGE INTEGER'FIRST .. INTEGER'FIRST + 1 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 7");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN 'A' .. CHARACTER'('Z') LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN
- FAILED ("LOOP 9");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN CHARACTER RANGE 'A' .. 'D' LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN
- FAILED ("LOOP 10");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN ENUM LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN
- FAILED ("LOOP 11");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN ENUM RANGE D .. C LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN
- FAILED ("LOOP 12");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN 'A' .. ENUM'(Z) LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 13");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D1 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN
- FAILED ("LOOP 14");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D1 RANGE 'A' .. 'Z' LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN
- FAILED ("LOOP 15");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D1'('A') .. 'D' LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN
- FAILED ("LOOP 16");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D2 LOOP
- Q;
- IF I > D2'FIRST + 3 THEN
- EXIT;
- END IF;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 17");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D2 RANGE -100 .. -99 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 18");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D2'(1) .. 2 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 19");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D3 LOOP
- IF I IN 'A' .. 'C' THEN
- Q; -- 4
- ELSE
- Q; Q; -- 10
- END IF;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(14) /= COUNT THEN
- FAILED ("LOOP 20");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D3 RANGE 'A' .. Z LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 21");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN 'A' .. D3'(Z) LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 22");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D4 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN
- FAILED ("LOOP 23");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D4'('A') .. 'Z' LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN
- FAILED ("LOOP 24");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR I IN D4 RANGE 'B' .. 'D' LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN
- FAILED ("LOOP 25");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D5 LOOP
- Q; -- 4
- EXIT WHEN J = D5(INTEGER'FIRST) + 3;
- Q; -- 3
- END LOOP;
- IF OLDCOUNT + IDENT_INT(7) /= COUNT THEN
- FAILED ("LOOP 26");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D5 RANGE -2 .. -1 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN
- FAILED ("LOOP 27");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D5'(-10) .. D5'(-6) LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 28");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D6 LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN
- FAILED ("LOOP 29");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D6 RANGE Z .. A LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN
- FAILED ("LOOP 30");
- END IF;
- OLDCOUNT := COUNT;
-
- FOR J IN D6'('D') .. D LOOP
- Q;
- END LOOP;
- IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN
- FAILED ("LOOP 31");
- END IF;
- OLDCOUNT := COUNT;
-
-
- RESULT;
-END C55B06A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada b/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada
deleted file mode 100644
index 4bff008..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada
+++ /dev/null
@@ -1,188 +0,0 @@
--- C55B06B.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 LOOPS MAY BE SPECIFIED FOR DERIVED BOOLEAN AND
--- DERIVED DERIVED BOOLEAN.
-
--- DAT 3/26/81
--- SPS 3/2/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C55B06B IS
-
- TYPE E IS (FALSE, TRUE);
- TYPE B1 IS NEW BOOLEAN;
- TYPE B2 IS NEW B1;
- TYPE B3 IS NEW E;
-
- ONE : INTEGER := IDENT_INT (1);
- COUNT : INTEGER := 0;
- OLD_COUNT : INTEGER := 0;
-
- PROCEDURE Q IS
- BEGIN
- COUNT := COUNT + 1;
- END Q;
-
-BEGIN
- TEST ("C55B06B", "LOOPS OVER DERIVED BOOLEAN");
-
- FOR I IN BOOLEAN LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 1");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 2");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN BOOLEAN'(FALSE) .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 3");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN E LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 4");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN E RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 5");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN FALSE .. E'(TRUE) LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 6");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B1 LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 7");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B1 RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 8");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN FALSE .. B1'(TRUE) LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 9");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B2 LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 10");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B2 RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 11");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B2'(FALSE) .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 12");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B3 LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 13");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN B3 RANGE FALSE .. TRUE LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 14");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- FOR I IN FALSE .. B3'(TRUE) LOOP
- Q;
- END LOOP;
- IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN
- FAILED ("LOOP 15");
- ELSE
- OLD_COUNT := COUNT;
- END IF;
-
- RESULT;
- END C55B06B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep b/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep
deleted file mode 100644
index 22c2ce4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep
+++ /dev/null
@@ -1,126 +0,0 @@
--- C55B07A.DEP
-
--- 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 LOOPS OVER RANGES OF TYPE LONG_INTEGER
--- CAN BE WRITTEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- THE TYPE LONG_INTEGER.
---
--- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE
--- DECLARATION OF CHECK MUST BE REJECTED.
-
--- HISTORY:
--- RM 07/06/82 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C55B07A IS
-
- CHECK : LONG_INTEGER; -- N/A => ERROR.
-
- TYPE NEW_LONG_INTEGER IS NEW LONG_INTEGER ;
-
- THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY...
-
- LI_VAR : LONG_INTEGER := 1 ;
- LI_CON : CONSTANT LONG_INTEGER := 1 ;
-
- NLI_VAR : NEW_LONG_INTEGER := 1 ;
- NLI_CON : CONSTANT NEW_LONG_INTEGER := 1 ;
-
- SUBTYPE LI_SEGMENT IS LONG_INTEGER RANGE
- LONG_INTEGER'LAST..LONG_INTEGER'LAST ;
-
- SUBTYPE NLI_SEGMENT IS NEW_LONG_INTEGER RANGE
- NEW_LONG_INTEGER'FIRST..
- NEW_LONG_INTEGER'FIRST ;
-
- COUNT : INTEGER := 0;
-
- PROCEDURE BUMP ( DUMMY : INTEGER ) IS
- BEGIN
- COUNT := COUNT + 1;
- END BUMP;
-
-BEGIN
-
- TEST ( "C55B07A" , "LOOPS OVER RANGES OF TYPE LONG_INTEGER " );
-
- FOR I IN 1..LI_CON LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN NLI_VAR..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN 1..LONG_INTEGER(1) LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN 1..NEW_LONG_INTEGER(1) LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN LI_SEGMENT LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN REVERSE NLI_SEGMENT LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN LONG_INTEGER RANGE 1..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN NEW_LONG_INTEGER RANGE 1..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN LONG_INTEGER LOOP
- BUMP(THE_COUNT) ;
- EXIT WHEN I = LONG_INTEGER'FIRST + 1;
- END LOOP;
-
- FOR I IN NEW_LONG_INTEGER LOOP
- BUMP(THE_COUNT) ;
- EXIT WHEN I = NEW_LONG_INTEGER'FIRST + 1;
- END LOOP;
-
-
- IF COUNT /= 12 THEN
- FAILED ("WRONG LOOP COUNT");
- END IF;
-
-
- RESULT;
-
-
-END C55B07A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep b/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep
deleted file mode 100644
index 17c0c6b..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep
+++ /dev/null
@@ -1,126 +0,0 @@
--- C55B07B.DEP
-
--- 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 LOOPS OVER RANGES OF TYPE SHORT_INTEGER
--- CAN BE WRITTEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- THE TYPE SHORT_INTEGER.
---
--- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE
--- DECLARATION OF CHECK MUST BE REJECTED.
-
--- HISTORY:
--- RM 07/08/82 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C55B07B IS
-
- CHECK : SHORT_INTEGER; -- N/A => ERROR.
-
- TYPE NEW_SHORT_INTEGER IS NEW SHORT_INTEGER ;
-
- THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY...
-
- SI_VAR : SHORT_INTEGER := 1 ;
- SI_CON : CONSTANT SHORT_INTEGER := 1 ;
-
- NSI_VAR : NEW_SHORT_INTEGER := 1 ;
- NSI_CON : CONSTANT NEW_SHORT_INTEGER := 1 ;
-
- SUBTYPE SI_SEGMENT IS SHORT_INTEGER RANGE
- SHORT_INTEGER'LAST..SHORT_INTEGER'LAST ;
-
- SUBTYPE NSI_SEGMENT IS NEW_SHORT_INTEGER RANGE
- NEW_SHORT_INTEGER'FIRST..
- NEW_SHORT_INTEGER'FIRST ;
-
- COUNT : INTEGER := 0;
-
- PROCEDURE BUMP ( DUMMY : INTEGER ) IS
- BEGIN
- COUNT := COUNT + 1;
- END BUMP;
-
-BEGIN
-
- TEST ( "C55B07B" , "LOOPS OVER RANGES OF TYPE SHORT_INTEGER " );
-
- FOR I IN 1..SI_CON LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN NSI_VAR..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN 1..SHORT_INTEGER(1) LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN 1..NEW_SHORT_INTEGER(1) LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN SI_SEGMENT LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN REVERSE NSI_SEGMENT LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN SHORT_INTEGER RANGE 1..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN NEW_SHORT_INTEGER RANGE 1..1 LOOP
- BUMP(THE_COUNT) ;
- END LOOP;
-
- FOR I IN SHORT_INTEGER LOOP
- BUMP(THE_COUNT) ;
- EXIT WHEN I = SHORT_INTEGER'FIRST + 1;
- END LOOP;
-
- FOR I IN NEW_SHORT_INTEGER LOOP
- BUMP(THE_COUNT) ;
- EXIT WHEN I = NEW_SHORT_INTEGER'FIRST + 1;
- END LOOP;
-
-
- IF COUNT /= 12 THEN
- FAILED ("WRONG LOOP COUNT");
- END IF;
-
-
- RESULT;
-
-
-END C55B07B ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada
deleted file mode 100644
index 46773d4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C55B10A.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, IN 'FOR I IN L .. R LOOP', IF EITHER L OR R IS AN
--- OVERLOADED ENUMERATION LITERAL, THE OVERLOADING IS CORRECTLY
--- RESOLVED AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C55B10A IS
-
- TYPE ENUM IS (ALPH, BET, NEITHER);
-
- GLOBAL : ENUM := NEITHER;
-
- TYPE ALPHA IS (A, B, C, D, E);
- TYPE BETA IS (G, F, E, D, C);
-
- PROCEDURE VAR(DEC : ALPHA) IS
- BEGIN
- IF EQUAL(3, 3) THEN
- GLOBAL := ALPH;
- END IF;
- END;
-
- PROCEDURE VAR(DEC : BETA) IS
- BEGIN
- IF EQUAL(3, 3) THEN
- GLOBAL := BET;
- END IF;
- END;
-
-BEGIN
- TEST("C55B10A", "CHECK THAT, IN 'FOR I IN L .. R LOOP', IF " &
- "EITHER L OR R IS AN OVERLOADED ENUMERATION " &
- "LITERAL, THE OVERLOADING IS CORRECTLY RESOLVED " &
- "AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE");
-
- FOR I IN A .. E LOOP
- VAR(I);
-
- IF GLOBAL /= ALPH THEN
- FAILED("WRONG TYPE FOR ALPHA");
- END IF;
- END LOOP;
-
- FOR I IN G .. E LOOP
- VAR(I);
-
- IF GLOBAL /= BET THEN
- FAILED("WRONG TYPE FOR BETA");
- END IF;
- END LOOP;
-
- RESULT;
-END C55B10A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada
deleted file mode 100644
index 4dae097..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C55B11A.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, IN 'FOR IN ST RANGE L .. R LOOP', THE PARAMETER IS OF
--- THE TYPE ST'BASE; THAT IS THAT IT CAN BE ASSIGNED TO OTHER
--- VARIABLES DECLARED WITH SOME OTHER SUBTYPES OF ST.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C55B11A IS
-
- TYPE ENUM IS (A, B, C, D, E, F, G, H);
-
- SUBTYPE ONE IS ENUM RANGE A .. H;
- SUBTYPE TWO IS ENUM RANGE B .. H;
- SUBTYPE THREE IS ENUM RANGE C .. H;
- SUBTYPE FOUR IS ENUM RANGE D .. H;
-
- GLOBAL : INTEGER := 0;
-
- VAR_1 : ONE;
- VAR_2 : TWO;
- VAR_3 : THREE;
- VAR_4 : FOUR;
-
- PROCEDURE CHECK_VAR(T : ENUM) IS
- BEGIN
- GLOBAL := GLOBAL + 1;
- CASE T IS
- WHEN D =>
- IF GLOBAL /= IDENT_INT(1) THEN
- FAILED("VAR_1 WRONG VALUE");
- END IF;
-
- WHEN E =>
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED("VAR_2 WRONG VALUE");
- END IF;
-
- WHEN F =>
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED("VAR_3 WRONG VALUE");
- END IF;
-
- WHEN G =>
- IF GLOBAL /= IDENT_INT(4) THEN
- FAILED("VAR_4 WRONG VALUE");
- END IF;
-
- WHEN OTHERS =>
-
- FAILED("WRONG VALUE TO PROCEDURE");
- END CASE;
- END CHECK_VAR;
-
-BEGIN
- TEST("C55B11A", "CHECK THAT, IN 'FOR IN ST RANGE L .. R LOOP', " &
- "THE PARAMETER IS OF THE TYPE ST'BASE; THAT IS " &
- "THAT IT CAN BE ASSIGNED TO OTHER VARIABLES " &
- "DECLARED WITH SOME OTHER SUBTYPES OF ST");
-
- FOR I IN ONE RANGE D .. G LOOP
- CASE I IS
- WHEN D =>
- VAR_1 := I;
- CHECK_VAR(VAR_1);
- WHEN E =>
- VAR_2 := I;
- CHECK_VAR(VAR_2);
- WHEN F =>
- VAR_3 := I;
- CHECK_VAR(VAR_3);
- WHEN G =>
- VAR_4 := I;
- CHECK_VAR(VAR_4);
- END CASE;
- END LOOP;
-
- RESULT;
-END C55B11A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada b/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada
deleted file mode 100644
index 3d1b488..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C55B11B.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 FORM 'FOR I IN ST RANGE L .. R LOOP' IS ACCEPTED
--- EVEN IF BOTH L AND R ARE OVERLOADED ENUMERATION LITERALS (SO
--- THAT L .. R WOULD BE ILLEGAL WITHOUT ST RANGE).
-
--- HISTORY:
--- DHH 09/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C55B11B IS
- TYPE ST IS (A, B, C, D, E, F, G, H);
- TYPE SI IS (A, B, C, D, F, E, G, H);
-
- GLOBAL : INTEGER := 0;
-
- PROCEDURE CHECK_VAR(T : ST) IS
- BEGIN
- GLOBAL := GLOBAL + 1;
- CASE T IS
- WHEN D =>
- IF GLOBAL /= IDENT_INT(1) THEN
- FAILED("1 WRONG VALUE");
- END IF;
-
- WHEN E =>
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED("2 WRONG VALUE");
- END IF;
-
- WHEN F =>
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED("3 WRONG VALUE");
- END IF;
-
- WHEN G =>
- IF GLOBAL /= IDENT_INT(4) THEN
- FAILED("4 WRONG VALUE");
- END IF;
-
- WHEN OTHERS =>
- FAILED("WRONG VALUE TO PROCEDURE");
-
- END CASE;
- END CHECK_VAR;
-
- PROCEDURE CHECK_VAR(T : SI) IS
- BEGIN
- FAILED("WRONG PROCEDURE CALLED");
- END CHECK_VAR;
-
-BEGIN
- TEST ("C55B11B", "CHECK THAT THE 'FORM FOR I IN ST RANGE L .. R " &
- "LOOP' IS ACCEPTED EVEN IF BOTH L AND R ARE " &
- "OVERLOADED ENUMERATION LITERALS (SO THAT L .. " &
- "R WOULD BE ILLEGAL WITHOUT ST RANGE)");
-
- FOR I IN ST RANGE D .. G LOOP
- CHECK_VAR(I);
- END LOOP;
-
- RESULT;
-END C55B11B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada
deleted file mode 100644
index a049419..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada
+++ /dev/null
@@ -1,207 +0,0 @@
--- C55B15A.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 DISCRETE_RANGE OF THE FORM 'ST RANGE L..R'
--- RAISES AN EXCEPTION BECAUSE L OR R IS A NON-STATIC
--- EXPRESSION WHOSE VALUE IS OUTSIDE THE RANGE OF VALUES
--- ASSOCIATED WITH ST (OR BECAUSE ST'FIRST IS NON-STATIC
--- AND L IS STATIC AND LESS THAN ST'FIRST ; SIMILARLY FOR
--- ST'LAST AND R ), CONTROL DOES NOT ENTER THE LOOP.
-
--- *** 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
-
--- RM 04/13/81
--- SPS 11/01/82
--- BHS 07/13/84
--- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
--- GJD 11/15/95 REMOVED CASE OF POTENTIALLY STATICALLY INCOMPATIBLE RANGE.
-
-WITH SYSTEM;
-WITH REPORT;
-PROCEDURE C55B15A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C55B15A" , "WHEN 'FOR I IN ST RANGE L..R LOOP' " &
- "RAISES AN EXCEPTION, CONTROL DOES NOT ENTER " &
- "THE BODY OF THE LOOP" );
-
- -------------------------------------------------------------------
- ----------------- STATIC (SUB)TYPE, DYNAMIC RANGE -----------------
-
- DECLARE
-
- SUBTYPE ST IS INTEGER RANGE 1..4 ;
-
- FIRST : CONSTANT INTEGER := IDENT_INT( 1) ;
- SECOND : CONSTANT INTEGER := IDENT_INT( 2) ;
- THIRD : CONSTANT INTEGER := IDENT_INT( 3) ;
- FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ;
- FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ;
- TENTH : CONSTANT INTEGER := IDENT_INT(10) ;
- ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ;
-
- BEGIN
-
- BEGIN
-
- FOR I IN ST RANGE 3..TENTH LOOP
- FAILED( "EXCEPTION NOT RAISED (I1)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (I1)" );
-
- END ;
-
-
- BEGIN
-
- FOR I IN ST RANGE 0..THIRD LOOP
- FAILED( "EXCEPTION NOT RAISED (I2)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (I2)" );
-
- END ;
- END ;
-
-
- -------------------------------------------------------------------
- ----------------- DYNAMIC (SUB)TYPE, STATIC RANGE -----------------
-
- DECLARE
-
- TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J );
-
- SUBTYPE ST IS ENUM RANGE ENUM'VAL( IDENT_INT( 1) ) ..
- ENUM'VAL( IDENT_INT( 4) ) ;
-
- FIRST : CONSTANT ENUM := A ;
- SECOND : CONSTANT ENUM := B ;
- THIRD : CONSTANT ENUM := C ;
- FOURTH : CONSTANT ENUM := D ;
- FIFTH : CONSTANT ENUM := E ;
- TENTH : CONSTANT ENUM := J ;
- ZEROTH : CONSTANT ENUM := AMINUS ;
-
- BEGIN
-
- BEGIN
-
- FOR I IN ST RANGE C..TENTH LOOP
- FAILED( "EXCEPTION NOT RAISED (E1)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (E1)" );
-
- END ;
-
-
- BEGIN
-
- FOR I IN ST RANGE AMINUS..THIRD LOOP
- FAILED( "EXCEPTION NOT RAISED (E2)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (E2)" );
-
- END ;
-
- END ;
-
-
- DECLARE
-
- SUBTYPE ST IS CHARACTER RANGE IDENT_CHAR( 'A' ) ..
- IDENT_CHAR( 'D' ) ;
-
- FIRST : CONSTANT CHARACTER := 'A' ;
- SECOND : CONSTANT CHARACTER := 'B' ;
- THIRD : CONSTANT CHARACTER := 'C' ;
- FOURTH : CONSTANT CHARACTER := 'D' ;
- FIFTH : CONSTANT CHARACTER := 'E' ;
- TENTH : CONSTANT CHARACTER := 'J' ;
- ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO; PRECEDES LETTERS
-
- BEGIN
-
- BEGIN
-
- FOR I IN ST RANGE 'C'..TENTH LOOP
- FAILED( "EXCEPTION NOT RAISED (C1)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (C1)" );
-
- END ;
-
-
- BEGIN
-
- FOR I IN ST RANGE '0'..THIRD LOOP -- ZERO..'C'
- FAILED( "EXCEPTION NOT RAISED (C2)" );
- END LOOP;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR => NULL ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED (C2)" );
-
- END ;
-
- END ;
-
-
- RESULT ;
-
-
-END C55B15A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada b/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada
deleted file mode 100644
index c6bf2b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C55B16A.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 THE PROCESSING OF ITERATIONS OVER AN ENUMERATION TYPE
--- WHOSE (USER-DEFINED) REPRESENTATION CONSISTS OF A NON-CONTIGUOUS
--- SET OF INTEGERS.
---
--- (INHERITANCE (AND SUBSEQUENT OVERRIDING) OF REPRESENTATION
--- SPECIFICATIONS WILL BE TESTED ELSEWHERE.)
-
--- HISTORY:
--- RM 08/06/82 CREATED ORIGINAL TEST.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C55B16A IS
-
- I1 : INTEGER := 0 ;
-
- TYPE ENUM IS ( 'A' , 'B' , 'D' , 'C' , Z , X , D , A , C );
- FOR ENUM USE ( -15 , -14 , -11 , -10 ,
- 1 , 3 , 4 , 8 , 9 );
-
-BEGIN
-
- TEST ("C55B16A" , "TEST LOOPING OVER ENUMERATION TYPES WITH" &
- " NON-CONTIGUOUS REPRESENTATION" );
-
- I1 := IDENT_INT(0) ;
-
- FOR X IN ENUM LOOP
-
- IF X /= ENUM'VAL(I1) OR
- ENUM'POS(X) /= I1 -- 0..8
- THEN
- FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (1)" );
- END IF;
-
- I1 := I1 + IDENT_INT(1) ;
-
- END LOOP;
-
-
- I1 := IDENT_INT(6) ;
-
- FOR X IN ENUM RANGE D .. C LOOP
-
- IF X /= ENUM'VAL(I1) OR
- ENUM'POS(X) /= I1 -- 6..8
- THEN
- FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (2)" );
- END IF;
-
- I1 := I1 + IDENT_INT(1) ;
-
- END LOOP;
-
-
- I1 := IDENT_INT(4) ;
-
- FOR X IN REVERSE 'A'..ENUM'(Z) LOOP
-
- IF X /= ENUM'VAL(I1) OR
- ENUM'POS(X) /= I1 -- 4..0
- THEN
- FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY (3)" );
- END IF;
-
- I1 := I1 - IDENT_INT(1) ;
-
- END LOOP;
-
-
- RESULT ;
-
-
-END C55B16A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada b/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada
deleted file mode 100644
index c320edb..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada
+++ /dev/null
@@ -1,49 +0,0 @@
--- C55C02A.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 WHILE LOOPS WITH FALSE CONDITIONS ARE NEVER EXECUTED.
-
--- DAT 1/29/81
--- DLD 8/06/82
-
-WITH REPORT;
-PROCEDURE C55C02A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C55C02A", "INITIAL FALSE CONDITIONS IN WHILE LOOPS");
-
- WHILE FALSE LOOP
- FAILED ("STATIC FALSE WHILE LOOP ENTERED");
- EXIT;
- END LOOP;
-
- WHILE IDENT_BOOL (FALSE) LOOP
- FAILED ("DYNAMIC FALSE WHILE LOOP ENTERED");
- EXIT;
- END LOOP;
-
- RESULT;
-END C55C02A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada b/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada
deleted file mode 100644
index c344838..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C55C02B.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 WHILE CONDITION IS EVALUATED EACH TIME.
-
--- DAT 1/29/81
--- SPS 3/2/83
-
-WITH REPORT;
-PROCEDURE C55C02B IS
-
- USE REPORT;
-
- I : INTEGER := 0;
-
- FT : ARRAY (FALSE .. TRUE) OF BOOLEAN
- := (IDENT_BOOL (FALSE), IDENT_BOOL (TRUE));
-
-BEGIN
- TEST ("C55C02B", "WHILE CONDITION IS EVALUATED EACH TIME THROUGH");
-
- WHILE I /= 10 LOOP
- I := I + 1;
- END LOOP;
- IF I /= 10 THEN
- FAILED ("BAD LOOP FLOW - OPTIMIZABLE CONDITION");
- END IF;
-
- I := 10;
- WHILE FT (IDENT_BOOL (I /= 14)) LOOP
- I := I + 1;
- END LOOP;
- IF I /= 14 THEN
- FAILED ("BAD LOOP FLOW - DYNAMIC CONDITION");
- END IF;
-
- RESULT;
-END C55C02B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c56002a.ada b/gcc/testsuite/ada/acats/tests/c5/c56002a.ada
deleted file mode 100644
index ff368e3..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c56002a.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- C56002A.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 BLOCKS CAN HAVE DECLARATIVE PARTS AND THAT
--- THE EFFECT OF THESE DECLARATIONS IS LIMITED TO THE BLOCKS
--- IN WHICH THEY OCCUR.
-
-
--- RM 04/16/81
--- SPS 3/4/83
-
-WITH REPORT;
-PROCEDURE C56002A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C56002A" , "BLOCKS CAN HAVE DECLARATIVE PARTS AND" &
- " THE EFFECT OF THESE DECLARATIONS IS LIMITED" &
- " TO THE BLOCKS IN WHICH THEY OCCUR" ) ;
-
- DECLARE
-
- FIRST : CONSTANT INTEGER := IDENT_INT( 1) ;
- SECOND : CONSTANT INTEGER := IDENT_INT( 2) ;
- THIRD : CONSTANT INTEGER := IDENT_INT( 3) ;
- FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ;
- FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ;
- TENTH : CONSTANT INTEGER := IDENT_INT(10) ;
- ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ;
-
- BEGIN
-
- IF FIRST /= 1 OR
- SECOND /= 2 OR
- THIRD /= 3 OR
- FOURTH /= 4 OR
- FIFTH /= 5 OR
- TENTH /=10 OR
- ZEROTH /= 0
- THEN
- FAILED( "WRONG VALUES - 1" );
- END IF;
-
- DECLARE
-
- TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J );
-
- FIRST : CONSTANT ENUM := A ;
- SECOND : CONSTANT ENUM := B ;
- THIRD : CONSTANT ENUM := C ;
- FOURTH : CONSTANT ENUM := D ;
- FIFTH : CONSTANT ENUM := E ;
- TENTH : CONSTANT ENUM := J ;
- ZEROTH : CONSTANT ENUM := AMINUS ;
-
- BEGIN
-
- IF FIRST /= ENUM'VAL( IDENT_INT( 1 ) ) OR
- SECOND /= ENUM'VAL( IDENT_INT( 2 ) ) OR
- THIRD /= ENUM'VAL( IDENT_INT( 3 ) ) OR
- FOURTH /= ENUM'VAL( IDENT_INT( 4 ) ) OR
- FIFTH /= ENUM'VAL( IDENT_INT( 5 ) ) OR
- TENTH /= ENUM'VAL( IDENT_INT(10 ) ) OR
- ZEROTH /= ENUM'VAL( IDENT_INT( 0 ) )
- THEN
- FAILED( "WRONG VALUES - 2" );
- END IF;
-
- END ;
-
- IF FIRST /= 1 OR
- SECOND /= 2 OR
- THIRD /= 3 OR
- FOURTH /= 4 OR
- FIFTH /= 5 OR
- TENTH /=10 OR
- ZEROTH /= 0
- THEN
- FAILED( "WRONG VALUES - 3" );
- END IF;
-
- DECLARE
-
- FIRST : CONSTANT CHARACTER := 'A' ;
- SECOND : CONSTANT CHARACTER := 'B' ;
- THIRD : CONSTANT CHARACTER := 'C' ;
- FOURTH : CONSTANT CHARACTER := 'D' ;
- FIFTH : CONSTANT CHARACTER := 'E' ;
- TENTH : CONSTANT CHARACTER := 'J' ;
- ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO < ANY LETTER
-
- BEGIN
-
- IF FIRST /= IDENT_CHAR( 'A' ) OR
- SECOND /= IDENT_CHAR( 'B' ) OR
- THIRD /= IDENT_CHAR( 'C' ) OR
- FOURTH /= IDENT_CHAR( 'D' ) OR
- FIFTH /= IDENT_CHAR( 'E' ) OR
- TENTH /= IDENT_CHAR( 'J' ) OR
- ZEROTH /= IDENT_CHAR( '0' )
- THEN
- FAILED( "WRONG VALUES - 4" );
- END IF;
-
- END ;
-
- IF FIRST /= 1 OR
- SECOND /= 2 OR
- THIRD /= 3 OR
- FOURTH /= 4 OR
- FIFTH /= 5 OR
- TENTH /=10 OR
- ZEROTH /= 0
- THEN
- FAILED( "WRONG VALUES - 5" );
- END IF;
-
-
- END ;
-
-
- RESULT ;
-
-
-END C56002A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c57003a.ada b/gcc/testsuite/ada/acats/tests/c5/c57003a.ada
deleted file mode 100644
index 8ca95e5..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c57003a.ada
+++ /dev/null
@@ -1,334 +0,0 @@
--- C57003A.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 EXIT STATEMENT IS EVALUATED EACH TIME THROUGH A LOOP,
--- AND THAT IT IS EVALUATED CORRECTLY WHETHER POSITIONED AT THE
--- BEGINNING, MIDDLE, OR END OF THE LOOP.
-
-
-
--- EACH TEST IS A LOOP ON J WHERE THE EXIT CONDITIONS ARE TO EVALUATE
--- TO 'FALSE' A CERTAIN NUMBER OF TIMES UNTIL, AT THE APPROPRIATE
--- TIME, ONE OF THEM EVALUATES TO 'TRUE' AND CAUSES THE LOOP TO BE
--- EXITED.
---
---
--- THE TEST IS PERFORMED 30 TIMES FOR EACH OF THE FIRST TWO
--- DATA TYPES CONSIDERED ('INTEGER', USER-DEFINED ENUMERATION)
--- AND 26 TIMES FOR 'CHARACTER' (THUS 86 TIMES ALTOGETHER).
---
---
--- EACH DATA TYPE HAS ITS OWN SEPARATE SECTION OF CODE. ALL SECTIONS
--- FOLLOW THE SAME TESTING ALGORITHM (MUTATIS MUTANDIS). THE CALCU-
--- LATIONS WHICH KEEP TRACK OF THE FLOW OF CONTROL ARE ALL DONE IN
--- INTEGER ARITHMETIC. THERE ARE THREE DATA TYPES, THUS THREE
--- SECTIONS.
---
---
--- FOR EACH DATA TYPE, THE 30 TESTS ARE DIVIDED INTO 3 "SEGMENTS"
---
--- << NOTE: THE NUMBER OF SEGMENTS IS WRITTEN " 3 " ,
--- THE NUMBER OF SECTIONS IS WRITTEN "THREE" >>
---
--- (OF 10 TESTS EACH, EXCEPT 10,10,6 FOR 'CHARACTER'), NUMBERED
--- 0 , 1 , 2 AND CORRESPONDING TO THE 3 SIGNIFICANTLY DIFFERENT
--- POSITIONS OF AN EXIT STATEMENT WITH RESPECT TO THE LOOP IT IS IN
--- ( "AT THE VERY TOP" , "AT THE VERY BOTTOM" , "ANYWHERE IN BETWEEN"
--- ). AT THE BEGINNING OF EACH TEST, THE VARIABLE WHICH_SEGMENT
--- IS UPDATED TO CONTAIN THE NEW VALUE OF THIS IDENTIFYING NUMBER
--- (FOR THE TEST ABOUT TO BEGIN):
---
--- EXIT AT THE TOP ........ WHICH_SEGMENT = 0
--- EXIT FROM THE MIDDLE ........ WHICH_SEGMENT = 1
--- EXIT AT THE BOTTOM ........ WHICH_SEGMENT = 2 .
---
---
--- WITHIN EACH SECTION, THE TESTS ARE NUMBERED FROM 1 TO 30
--- (26 FOR 'CHARACTER'). THIS NUMBER IS STORED IN THE INTEGER
--- VARIABLE INT_I (EQUAL TO THE CURRENT VALUE OF THE OUTER-LOOP
--- INDEX WHEN THAT INDEX IS OF INTEGER TYPE), WHOSE APPROPRIATE VALUE
--- FOR EACH TEST IS SET AT THE BEGINNING OF THE TEST.
---
---
--- AS PART OF THE EVALUATION PROCESS, THE PROGRAM COMPUTES FOR EACH
--- TEST (I.E. FOR EACH VALUE OF I , OR OF INT_I ) THE APPROPRIATE
--- NUMBER OF INNER-LOOP ITERATIONS REQUIRED BEFORE EXIT; THIS IS
--- THE EXPECTED VALUE OF J (EXPRESSED AS AN INTEGER IN THE RANGE
--- 1..10 ) AND STORES IT IN EXPECTED_J . FOR EACH OF THE THREE
--- SECTIONS, THE TIME SEQUENCE OF THESE 30 VALUES IS
---
--- 1 2 3 4 5 6 7 8 9 10 << SEGMENT 1 >>
--- 6 6 7 7 8 8 9 9 10 10 << SEGMENT 2 >>
--- 7 8 8 8 9 9 9 10 10 10 << SEGMENT 3 >>
---
--- (EACH SECTION GETS ALL 3 ROWS, NOT ONE ROW PER SECTION;
--- FOR 'CHARACTER', WHERE ONLY 26 VALUES ARE REQUIRED, THE LAST 4
--- VALUES ARE OMITTED). THIS NUMBER IS COMPARED WITH THE ACTUAL
--- VALUE OF J (ACTUAL NUMBER OF INNER-LOOP ITERATIONS BEFORE THE
--- EXECUTION OF THE EXIT STATEMENT) AS SAVED JUST BEFORE THE EXIT
--- FROM THE LOOP (AGAIN IN THE FORM OF AN INTEGER IN THE RANGE
--- 1..30 , IRRESPECTIVE OF THE DATA TYPE BEING TESTED), I F
--- SUCH SAVED VALUE IS AVAILABLE.
---
---
--- THE ACTUAL VALUE OF INNER-LOOP ITERATIONS (AS SAVED IMMEDIATELY
--- BEFORE THE EXIT, AS OPPOSED TO A VALUE LEFT OVER FROM SOME
--- PREVIOUS ITERATION) IS AVAILABLE ONLY IF WHICH_SEGMENT /= 0 ,
--- AND IS THEN STORED IN SAVE_J .
---
---
--- FOR THE CASE WHICH_SEGMENT = 0 , THE ITERATIONS ARE COUNTED IN
--- THE VARIABLE COUNT , WHOSE VALUE AT THE COMPLETION OF THE
--- I-TH TEST ( I IN 1..10 ) MUST BE EQUAL TO EXPECTED_J - 1 ,
--- AND THUS TO I - 1 (METHODOLOGICALLY AS WELL AS COMPUTATIONALLY
--- THIS IS NO DIFFERENT FROM USING THE MOST RECENT VALUE OF SAVE_J
--- WHEN A CURRENT ONE CANNOT BE OBTAINED). AFTER BEING INCREMENTED
--- BY 1 , COUNT IS CHECKED AGAINST EXPECTED_J .
---
---
--- THIS CONCLUDES THE DESCRIPTION OF THE CASE WHICH_SEGMENT = 0 ,
--- AND THUS OF THE ALGORITHM. THE ONLY REASON FOR SPLITTING THE
--- CASE WHICH_SEGMENT /= 0 INTO TWO IS THE DESIRE TO PROVIDE FOR
--- DISTINCT MESSAGES.
-
-
-
--- RM 04/23/81
--- SPS 3/7/83
-
-WITH REPORT;
-PROCEDURE C57003A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C57003A" , "TEST THAT THE EXIT STATEMENT IS EVALUATED" &
- " EACH TIME THROUGH THE LOOP" );
-
- DECLARE
-
- WHICH_SEGMENT : INTEGER RANGE 0..2 ; -- BOUNDS ARE TIGHT
- SAVE_J : INTEGER RANGE 1..10 ;
- EXPECTED_J : INTEGER RANGE 1..10 ;
- COUNT : INTEGER RANGE 0..100 := 0 ;
- INT_I : INTEGER RANGE 1..30 ;
-
- TYPE ENUM IS ( CHANGE_THE_ORIGIN_FROM_0_TO_1 ,
-
- A1 , A2 , A3 , A4 , A5 , A6 , A7 , A8 , A9 , A10 ,
- A11, A12, A13, A14, A15, A16, A17, A18, A19, A20 ,
- A21, A22, A23, A24, A25, A26, A27, A28, A29, A30 );
-
- BEGIN
-
-
- --------------------------------------------------------------
- ----------------------- INTEGER ----------------------------
-
-
- FOR I IN INTEGER RANGE 1..30 LOOP
-
-
- WHICH_SEGMENT := ( I - 1 ) / 10 ;
- EXPECTED_J := ( I + WHICH_SEGMENT ) /
- ( WHICH_SEGMENT + 1 ) ;
-
- COUNT := 0 ;
-
-
- FOR J IN INTEGER RANGE 1..10 LOOP
-
- -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT)
-
- EXIT WHEN WHICH_SEGMENT = 0 AND
- 1*J >= I ;--COUNT+:=1 ON NXT LINE INSTEAD
- COUNT := COUNT + 1 ;
-
- NULL ;
- NULL ;
- NULL ;
- SAVE_J := J ;
- EXIT WHEN WHICH_SEGMENT = 1 AND
- 2*J >= I ;
-
- NULL ;
- NULL ;
- NULL ;
- SAVE_J := J ;
- EXIT WHEN WHICH_SEGMENT = 2 AND
- 3*J >= I ;
-
- END LOOP;
-
-
- COUNT := COUNT + 1 ; -- SEE HEADER
-
- CASE WHICH_SEGMENT IS
- WHEN 0 =>
- IF COUNT /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; INT, EXIT AT TOP" );
- END IF;
- WHEN 1 => -- WOULD WORK ALSO FOR 0
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; I,EXIT AT MIDDLE" );
- END IF;
- WHEN 2 =>
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; I,EXIT AT BOTTOM" );
- END IF;
- END CASE;
-
- END LOOP;
-
-
-
- --------------------------------------------------------------
- ---------------------- CHARACTER ---------------------------
-
-
- FOR I IN CHARACTER RANGE 'A'..'Z' LOOP
-
- INT_I := CHARACTER'POS(I) - CHARACTER'POS('A') + 1;
-
- WHICH_SEGMENT := ( INT_I - 1 ) / 10 ;
- EXPECTED_J := ( INT_I + WHICH_SEGMENT ) /
- ( WHICH_SEGMENT + 1 ) ;
-
- COUNT := 0 ;
-
-
- FOR J IN CHARACTER RANGE 'A'..'J' LOOP
-
- -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT)
-
- EXIT WHEN WHICH_SEGMENT = 0 AND
- J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD
- COUNT := COUNT + 1 ;
-
- NULL ;
- NULL ;
- NULL ;
- SAVE_J := CHARACTER'POS(J) - CHARACTER'POS('A') + 1;
- EXIT WHEN WHICH_SEGMENT = 1 AND
- 2 * SAVE_J >= INT_I ;
-
- NULL ;
- NULL ;
- NULL ;
- EXIT WHEN WHICH_SEGMENT = 2 AND
- 3 * SAVE_J >= INT_I ;
-
- END LOOP;
-
-
- COUNT := COUNT + 1 ;
-
- CASE WHICH_SEGMENT IS
- WHEN 0 =>
- IF COUNT /= EXPECTED_J THEN
- FAILED( "WRONG COUNT;CHAR, EXIT AT TOP" );
- END IF;
- WHEN 1 => -- WOULD WORK ALSO FOR 0
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; C,EXIT AT MIDDLE" );
- END IF;
- WHEN 2 =>
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; C,EXIT AT BOTTOM" );
- END IF;
- END CASE;
-
- END LOOP;
-
-
-
- --------------------------------------------------------------
- --------------------- ENUMERATION --------------------------
-
-
- FOR I IN ENUM RANGE A1..A30 LOOP
-
-
- INT_I := ENUM'POS(I) ;
-
- WHICH_SEGMENT := ( INT_I - 1 ) / 10 ;
- EXPECTED_J := ( INT_I + WHICH_SEGMENT ) /
- ( WHICH_SEGMENT + 1 ) ;
-
- COUNT := 0 ;
-
-
- FOR J IN ENUM RANGE A1..A10 LOOP
-
- -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT)
-
- EXIT WHEN WHICH_SEGMENT = 0 AND
- J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD
- COUNT := COUNT + 1 ;
-
- NULL ;
- NULL ;
- NULL ;
- SAVE_J := ENUM'POS(J) ;
- EXIT WHEN WHICH_SEGMENT = 1 AND
- 2 * SAVE_J >= INT_I ;
-
- NULL ;
- NULL ;
- NULL ;
- EXIT WHEN WHICH_SEGMENT = 2 AND
- 3 * SAVE_J >= INT_I ;
-
- END LOOP;
-
-
- COUNT := COUNT + 1 ;
-
- CASE WHICH_SEGMENT IS
- WHEN 0 =>
- IF COUNT /= EXPECTED_J THEN
- FAILED( "WRONG COUNT;ENUM, EXIT AT TOP" );
- END IF;
- WHEN 1 => -- WOULD WORK ALSO FOR 0
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; E,EXIT AT MIDDLE" );
- END IF;
- WHEN 2 =>
- IF SAVE_J /= EXPECTED_J THEN
- FAILED( "WRONG COUNT; E,EXIT AT BOTTOM" );
- END IF;
- END CASE;
-
- END LOOP;
-
- --------------------------------------------------------------
-
- END ;
-
-
- RESULT ;
-
-
-END C57003A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c57004a.ada b/gcc/testsuite/ada/acats/tests/c5/c57004a.ada
deleted file mode 100644
index 352528b..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c57004a.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C57004A.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 EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION
--- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER
--- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING
--- THE EXIT STATEMENT.
-
--- CASE 1 : UNCONDITIONAL EXITS.
-
-
--- RM 04/24/81
--- SPS 3/7/83
-
-WITH REPORT;
-PROCEDURE C57004A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C57004A" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" &
- " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" &
- " SITUATED IN-BETWEEN" );
-
- DECLARE
-
- COUNT : INTEGER := 0 ;
-
- BEGIN
-
- OUTERMOST :
- FOR X IN INTEGER RANGE 1..2 LOOP
-
- FOR Y IN INTEGER RANGE 1..2 LOOP
-
- COMMENT( "BEFORE 1" );
-
- LOOP1 :
- FOR I IN 1..10 LOOP
- COMMENT( "INSIDE 1" );
- EXIT LOOP1 ;
- FAILED( "EXIT NOT OBEYED (1)" );
- FOR J IN 1..10 LOOP
- FAILED( "OUTER EXIT NOT OBEYED (1)" );
- EXIT ;
- FAILED( "BOTH EXITS IGNORED (1)" );
- END LOOP;
- END LOOP LOOP1 ;
-
-
- COMMENT( "BEFORE 2" );
- COUNT := COUNT + 1 ;
-
- LOOP2 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
- FOR I IN CHARACTER LOOP
- COMMENT( "INSIDE 2" );
- EXIT LOOP2 ;
- FAILED( "EXIT NOT OBEYED (2)" );
- FOR J IN BOOLEAN LOOP
- FAILED( "OUTER EXIT NOT " &
- "OBEYED (2)");
- EXIT ;
- FAILED( "BOTH EXITS IGNORED " &
- "(2)");
- END LOOP;
- END LOOP;
-
- END LOOP;
- END LOOP LOOP2 ;
-
-
- COMMENT( "BEFORE 3" );
- COUNT := COUNT + 1 ;
-
- LOOP3 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
- FOR I IN BOOLEAN LOOP
- COMMENT( "INSIDE 3" );
- BEGIN
- EXIT LOOP3 ;
- FAILED( "EXIT NOT OBEYED (3)" );
- END ;
- FAILED( "EXIT NOT OBEYED (3BIS)" );
- END LOOP;
-
- END LOOP;
- END LOOP LOOP3 ;
-
-
- COMMENT( "BEFORE 4" );
- COUNT := COUNT + 1 ;
-
- LOOP4 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
-
- FOR I IN INTEGER RANGE 1..10 LOOP
- COMMENT( "INSIDE 4" );
- CASE A IS
- WHEN 1 =>
- EXIT LOOP4 ;
- FAILED("EXIT NOT OBEYED " &
- "(4)" );
- END CASE;
- FAILED( "EXIT NOT OBEYED (4BIS)" );
- END LOOP;
-
- END LOOP;
- END LOOP LOOP4 ;
-
-
- COMMENT( "AFTER 4" );
- COUNT := COUNT + 1 ;
- EXIT OUTERMOST ;
-
- END LOOP;
-
- FAILED( "MISSED FINAL EXIT" );
-
- END LOOP OUTERMOST ;
-
-
- IF COUNT /= 4 THEN
- FAILED( "WRONG FLOW OF CONTROL" );
- END IF;
-
- END ;
-
- RESULT ;
-
-
-END C57004A ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c57004b.ada b/gcc/testsuite/ada/acats/tests/c5/c57004b.ada
deleted file mode 100644
index 63f5760..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c57004b.ada
+++ /dev/null
@@ -1,162 +0,0 @@
--- C57004B.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 EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION
--- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER
--- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING
--- THE EXIT STATEMENT.
-
--- CASE 2 : CONDITIONAL EXITS.
-
-
--- RM 04/27/81
--- SPS 3/7/83
-
-WITH REPORT;
-PROCEDURE C57004B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C57004B" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" &
- " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" &
- " SITUATED IN-BETWEEN" );
-
- DECLARE
-
- COUNT : INTEGER := 0 ;
-
- BEGIN
-
- OUTERMOST :
- FOR X IN INTEGER RANGE 1..2 LOOP
-
- FOR Y IN INTEGER RANGE 1..2 LOOP
-
- COMMENT( "BEFORE 1" );
-
- LOOP1 :
- FOR I IN 1..10 LOOP
- COMMENT( "INSIDE 1" );
- EXIT LOOP1 WHEN EQUAL(1,1) ;
- FAILED( "EXIT NOT OBEYED (1)" );
- FOR J IN 1..10 LOOP
- FAILED( "OUTER EXIT NOT OBEYED (1)" );
- EXIT WHEN EQUAL(1,1) ;
- FAILED( "BOTH EXITS IGNORED (1)" );
- END LOOP;
- END LOOP LOOP1 ;
-
-
- COMMENT( "BEFORE 2" );
- COUNT := COUNT + 1 ;
-
- LOOP2 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
- FOR I IN CHARACTER LOOP
- COMMENT( "INSIDE 2" );
- EXIT LOOP2 WHEN EQUAL(1,1) ;
- FAILED( "EXIT NOT OBEYED (2)" );
- FOR J IN BOOLEAN LOOP
- FAILED( "OUTER EXIT NOT " &
- "OBEYED (2)");
- EXIT WHEN EQUAL(1,1) ;
- FAILED( "BOTH EXITS IGNORED " &
- "(2)");
- END LOOP;
- END LOOP;
-
- END LOOP;
- END LOOP LOOP2 ;
-
-
- COMMENT( "BEFORE 3" );
- COUNT := COUNT + 1 ;
-
- LOOP3 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
- FOR I IN BOOLEAN LOOP
- COMMENT( "INSIDE 3" );
- BEGIN
- EXIT LOOP3 WHEN EQUAL(1,1) ;
- FAILED( "EXIT NOT OBEYED (3)" );
- END ;
- FAILED( "EXIT NOT OBEYED (3BIS)" );
- END LOOP;
-
- END LOOP;
- END LOOP LOOP3 ;
-
-
- COMMENT( "BEFORE 4" );
- COUNT := COUNT + 1 ;
-
- LOOP4 :
- FOR A IN 1..1 LOOP
- FOR B IN 1..1 LOOP
-
-
- FOR I IN INTEGER RANGE 1..10 LOOP
- COMMENT( "INSIDE 4" );
- CASE A IS
- WHEN 1 =>
- EXIT LOOP4 WHEN EQUAL(1,1);
- FAILED("EXIT NOT OBEYED " &
- "(4)" );
- END CASE;
- FAILED( "EXIT NOT OBEYED (4BIS)" );
- END LOOP;
-
- END LOOP;
- END LOOP LOOP4 ;
-
-
- COMMENT( "AFTER 4" );
- COUNT := COUNT + 1 ;
- EXIT OUTERMOST ;
-
- END LOOP;
-
- FAILED( "MISSED FINAL EXIT" );
-
- END LOOP OUTERMOST ;
-
-
- IF COUNT /= 4 THEN
- FAILED( "WRONG FLOW OF CONTROL" );
- END IF;
-
-
- END ;
-
-
- RESULT ;
-
-
-END C57004B ;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004c.ada b/gcc/testsuite/ada/acats/tests/c5/c58004c.ada
deleted file mode 100644
index dcb66e0..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58004c.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- C58004C.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 RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS,
--- BOTH FUNCTIONS AND PROCEDURES.
-
--- DCB 2/8/80
--- SPS 3/7/83
--- JBG 5/17/83
-
-WITH REPORT;
-PROCEDURE C58004C IS
-
- USE REPORT;
-
- I1, I2 : INTEGER := 0; -- INITIAL VALUE IS IMMATERIAL
-
- PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS
-
- BEGIN
- IF IP1 = 1 THEN
- IP2 := 1;
- RETURN;
- ELSE FACTORIALP (IP1 - 1, IP2);
- IP2 := IP1 * IP2;
- RETURN;
- END IF;
-
- IP2 := 0;
-
- END FACTORIALP;
-
- FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS
-
- BEGIN
- IF IF1 = 1 THEN RETURN (1);
- END IF;
-
- RETURN (IF1 * FACTORIALF(IF1 - 1) );
-
- END FACTORIALF;
-
-BEGIN
- TEST ("C58004C", "CHECK THAT THE RETURN STATEMENT WORKS FOR" &
- " RECURSIVE FUNCTIONS AND PROCEDURES");
-
- I1 := FACTORIALF (5);
-
- IF I1 /= 120 THEN
- FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " &
- "WORKING");
- END IF;
-
- FACTORIALP (5, I2);
-
- IF I2 = 0 THEN
- FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " &
- "WORKING");
- ELSIF I2 /= 120 THEN
- FAILED
- ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY");
- END IF;
-
- RESULT;
-END C58004C;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004d.ada b/gcc/testsuite/ada/acats/tests/c5/c58004d.ada
deleted file mode 100644
index c4e3ffb4..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58004d.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C58004D.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 RETURN STATEMENT TERMINATES EXECUTION
--- OF THE INNERMOST ENCLOSING SUBPROGRAM.
-
--- CHECKS GENERIC SUBPROGRAMS.
-
--- SPS 3/7/83
--- JRK 1/31/84
-
-WITH REPORT;
-PROCEDURE C58004D IS
-
- USE REPORT;
-
- I1, I2 : INTEGER;
-
- GENERIC
- PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER);
-
- PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER) IS
-
- GENERIC
- PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER);
-
- PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER) IS
- BEGIN
- IM1 := IM1 * IM2;
-
- IF IM1 > 0 THEN RETURN;
- END IF;
-
- IM1 := 0;
- END MULT;
-
- PROCEDURE MLT IS NEW MULT;
-
- BEGIN
- MLT (IA1, IA2);
- IA1 := IA1 + IA2;
-
- IF IA1 > 0 THEN RETURN;
- END IF;
-
- IA1 := 0;
- END ADDM;
-
- PROCEDURE ADM IS NEW ADDM;
-
-BEGIN
- TEST ("C58004D","CHECK THAT RETURN TERMINATES EXECUTION OF ONLY" &
- " THE INNERMOST ENCLOSING GENERIC SUBPROGRAM");
-
- I1 := 2;
- I2 := 3;
- ADM (I1,I2); -- SAME AS I1 := (I1 * I2) + I2
-
- IF I1 = 0 THEN
- FAILED ("RETURN DOES NOT TERMINATE SUBPROGRAM");
- ELSIF I1 = 6 THEN
- FAILED
- ("RETURN TERMINATES ALL SUBPROGRAMS NOT JUST INNERMOST");
- ELSIF I1 /= 9 THEN
- FAILED ("RETURN STATEMENT NOT WORKING CORRECTLY");
- END IF;
-
- RESULT;
-END C58004D;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58004g.ada b/gcc/testsuite/ada/acats/tests/c5/c58004g.ada
deleted file mode 100644
index 945920a..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58004g.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C58004G.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 RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS,
--- BOTH FUNCTIONS AND PROCEDURES.
-
--- CHECK GENERIC SUBPROGRAMS.
-
--- SPS 3/7/83
--- JBG 9/13/83
-
-WITH REPORT;
-PROCEDURE C58004G IS
-
- USE REPORT;
-
- I1, I2 : INTEGER := 0;
-
- GENERIC
- PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER);
-
- GENERIC
- FUNCTION FACTORIALF (IF1: INTEGER) RETURN INTEGER;
-
- PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS
- BEGIN
- IF IP1 = 1 THEN
- IP2 := 1;
- RETURN;
- ELSE FACTORIALP (IP1 - 1, IP2);
- IP2 := IP1 * IP2;
- RETURN;
- END IF;
-
- IP2 := 0;
-
- END FACTORIALP;
-
- FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS
-
- BEGIN
- IF IF1 = 1 THEN RETURN (1);
- END IF;
-
- RETURN (IF1 * FACTORIALF(IF1 - 1) );
-
- END FACTORIALF;
-
- PROCEDURE FACTP IS NEW FACTORIALP;
- FUNCTION FACTF IS NEW FACTORIALF;
-
-BEGIN
- TEST ("C58004G", "CHECK THAT THE RETURN STATEMENT WORKS FOR" &
- " RECURSIVE GENERIC FUNCTIONS AND PROCEDURES");
-
- I1 := FACTF (5);
-
- IF I1 /= 120 THEN
- FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " &
- "WORKING");
- END IF;
-
- FACTP (5, I2);
-
- IF I2 = 0 THEN
- FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " &
- "WORKING");
- ELSIF I2 /= 120 THEN
- FAILED
- ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY");
- END IF;
-
- RESULT;
-END C58004G;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005a.ada b/gcc/testsuite/ada/acats/tests/c5/c58005a.ada
deleted file mode 100644
index ef6b164..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58005a.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- C58005A.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 A FUNCTION IS READY TO RETURN CONTROL TO ITS INVOKER
--- THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT
--- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS
--- ARE NOT SATISFIED.
-
--- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE
--- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE
--- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED
--- ELSEWHERE.
-
-
--- RM 05/14/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C58005A IS
-
- USE REPORT ;
-
- INTVAR : INTEGER ;
-
-BEGIN
-
- TEST( "C58005A" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" &
- " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" &
- " VIOLATED" );
-
-
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE -10..90;
- SUBTYPE I2 IS INTEGER RANGE 1..10;
- FUNCTION FN1( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN 0 ;
- END FN1 ;
-
- FUNCTION FN2( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN X + IDENT_INT(0) ;
- END FN2 ;
-
- FUNCTION FN3( X : I1 )
- RETURN I2 IS
- HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100) ;
- BEGIN
- RETURN HUNDRED - 90 ;
- END FN3 ;
-
- BEGIN
-
- INTVAR := 0 ;
-
- BEGIN
- INTVAR := FN1( 0 ) + INTVAR ; -- EXCEPTION.
- FAILED( "EXCEPTION NOT RAISED - 1" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ;
- WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" ) ;
- END ;
-
- BEGIN
- INTVAR := FN2( 1 ) + INTVAR ; -- 10+1=11 -- NO EXCEPTION.
- INTVAR := INTVAR + 100 ; -- 11+100=111
- EXCEPTION
- WHEN OTHERS => FAILED( "EXCEPTION RAISED - 2" ) ;
- END ;
-
- BEGIN
- INTVAR := FN2(11 ) + INTVAR ; -- EXCEPTION.
- FAILED( "EXCEPTION NOT RAISED - 3" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ; -- 121
- WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 3" ) ;
- END ;
-
- BEGIN
- INTVAR := FN3( 0 ) + INTVAR ;--121+10=131 --NO EXCEPTION.
- INTVAR := INTVAR + 1000 ;-- 131+1000=1131
- EXCEPTION
- WHEN OTHERS => FAILED( "EXCEPTION RAISED - 4" ) ;
- END ;
-
-
- END ;
-
-
- IF INTVAR /= 1131 THEN
- FAILED("WRONG FLOW OF CONTROL" );
- END IF;
-
-
- RESULT ;
-
-
-END C58005A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005b.ada b/gcc/testsuite/ada/acats/tests/c5/c58005b.ada
deleted file mode 100644
index 05cda70..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58005b.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C58005B.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 A GENERIC FUNCTION IS READY TO RETURN CONTROL TO ITS
--- INVOKER THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT
--- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS
--- ARE NOT SATISFIED.
-
--- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE
--- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE
--- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED
--- ELSEWHERE.
-
--- SPS 3/10/83
--- JBG 9/13/83
--- AH 8/29/86 ADDED CALLS TO "FAILED" AFTER "IF" STATEMENTS.
-
-WITH REPORT;
-PROCEDURE C58005B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C58005B" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" &
- " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" &
- " VIOLATED" );
-
-
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE -10..90;
- SUBTYPE I2 IS INTEGER RANGE 1..10;
-
- GENERIC
- FUNCTION FN1 ( X : I1 ) RETURN I2;
-
- FUNCTION FN1( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN X;
- END FN1;
-
- FUNCTION F1 IS NEW FN1;
-
- BEGIN
-
- BEGIN
- IF F1(IDENT_INT(0)) IN I2 THEN
- FAILED( "EXCEPTION NOT RAISED - 1A" );
- ELSE
- FAILED( "EXCEPTION NOT RAISED - 1B" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" );
- END;
-
- BEGIN
- IF F1(IDENT_INT(11)) IN I2 THEN
- FAILED( "EXCEPTION NOT RAISED - 2A" );
- ELSE
- FAILED( "EXCEPTION NOT RAISED - 2B" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 2" );
- END;
-
- END;
-
- RESULT;
-
-END C58005B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58005h.ada b/gcc/testsuite/ada/acats/tests/c5/c58005h.ada
deleted file mode 100644
index 276d34d..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58005h.ada
+++ /dev/null
@@ -1,172 +0,0 @@
--- C58005H.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 CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE
--- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER.
-
--- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH
--- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES.
-
--- SPS 3/10/83
--- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations.
--- The objects must be used, and must be tied somehow to the
--- calls to Failed.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C58005H IS
-
- PACKAGE PACK IS
- TYPE PV (D : NATURAL) IS PRIVATE;
- TYPE LP (D : NATURAL) IS LIMITED PRIVATE;
- PRIVATE
- TYPE PV (D : NATURAL) IS RECORD
- NULL;
- END RECORD;
- TYPE LP (D : NATURAL) IS RECORD
- NULL;
- END RECORD;
- END PACK;
-
- USE PACK;
-
- TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL;
- TYPE REC (D : NATURAL) IS RECORD
- NULL;
- END RECORD;
-
- TYPE ACC_REC IS ACCESS REC;
- TYPE ACC_ARR IS ACCESS ARR;
- TYPE ACC_PV IS ACCESS PV;
- TYPE ACC_LP IS ACCESS LP;
-
- SUBTYPE ACC_REC1 IS ACC_REC (D => 1);
- SUBTYPE ACC_REC2 IS ACC_REC (D => 2);
-
- SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10);
- SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5);
-
- SUBTYPE ACC_PV1 IS ACC_PV (D => 1);
- SUBTYPE ACC_PV2 IS ACC_PV (D => 2);
-
- SUBTYPE ACC_LP1 IS ACC_LP (D => 1);
- SUBTYPE ACC_LP2 IS ACC_LP (D => 2);
-
- VAR1 : ACC_REC1 := NEW REC(1);
- VAR2 : ACC_REC2 := NEW REC(2);
- VAA1 : ACC_ARR1 := NEW ARR(1 .. 10);
- VAA2 : ACC_ARR2 := NEW ARR(2 .. 5);
- VAP1 : ACC_PV1 := NEW PV(1);
- VAP2 : ACC_PV2 := NEW PV(2);
- VAL1 : ACC_LP1 := NEW LP(1);
- VAL2 : ACC_LP2 := NEW LP(2);
-
- FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS
- BEGIN
- RETURN X;
- END FREC;
-
- FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS
- BEGIN
- RETURN X;
- END FARR;
-
- FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS
- BEGIN
- RETURN X;
- END FPV;
-
- FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS
- BEGIN
- RETURN X;
- END FLP;
-
- PACKAGE BODY PACK IS
- FUNCTION LF (X : LP) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(3);
- END LF;
- BEGIN
- NULL;
- END PACK;
-
-BEGIN
-
- TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " &
- "OF FUNCTIONS");
-
- BEGIN
- VAR2 := FREC (VAR1);
- IF VAR2.D /= REPORT.IDENT_INT(2) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1");
- ELSE
- FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - REC");
- END;
-
- BEGIN
- VAA2 := FARR (VAA1);
- IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1");
- ELSE
- FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - ARR");
- END;
-
- BEGIN
- VAP2 := FPV (VAP1);
- IF VAP2.D /= REPORT.IDENT_INT(2) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1");
- ELSE
- FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PV");
- END;
-
- BEGIN
- VAL2 := FLP (VAL1);
- IF VAL2.D /= REPORT.IDENT_INT(2) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1");
- ELSE
- FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - LP");
- END;
-
- RESULT;
-END C58005H;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58006a.ada b/gcc/testsuite/ada/acats/tests/c5/c58006a.ada
deleted file mode 100644
index f7a2f1c..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58006a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C58006A.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 EVALUATION OF A RETURN STATEMENT'S EXPRESSION
--- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF
--- THE FUNCTION.
-
--- RM 05/11/81
--- SPS 10/26/82
--- SPS 3/8/83
--- JBG 9/13/83
-
-WITH REPORT;
-PROCEDURE C58006A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C58006A" , "CHECK THAT EXCEPTION RAISED BY A RETURN" &
- " STATEMENT CAN BE HANDLED LOCALLY" );
-
-
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE -10..90;
- SUBTYPE I2 IS INTEGER RANGE 1..10;
-
- FUNCTION FN1( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN 0;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F1");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN1");
- END FN1;
-
- FUNCTION FN2( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN X + IDENT_INT(0);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F2");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN2");
- END FN2;
-
- FUNCTION FN3( X : I1 )
- RETURN I2 IS
- HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100);
- BEGIN
- RETURN HUNDRED;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F3");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN3");
- END FN3;
-
- BEGIN
-
- BEGIN
- IF FN1( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - FN1( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - FN1( 0 )");
- END;
-
- BEGIN
- IF FN2( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - FN2( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - FN2( 0 )");
- END;
-
- BEGIN
- IF FN2(11 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - FN2(11 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - FN2(11 )");
- END;
-
- BEGIN
- IF FN3( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - FN3( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - FN3( 0 )");
- END;
-
- END;
-
- RESULT;
-
-END C58006A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c58006b.ada b/gcc/testsuite/ada/acats/tests/c5/c58006b.ada
deleted file mode 100644
index 82b3132..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c58006b.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- C58006B.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 EVALUATION OF A RETURN STATEMENT'S EXPRESSION
--- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF
--- THE FUNCTION.
-
--- CHECKS GENERIC FUNCTIONS.
-
--- SPS 3/8/83
--- JBG 9/13/83
-
-WITH REPORT;
-PROCEDURE C58006B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C58006B" , "CHECK THAT EXCEPTION RAISED BY A RETURN" &
- " STATEMENT CAN BE HANDLED LOCALLY" );
-
-
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE -10..90;
- SUBTYPE I2 IS INTEGER RANGE 1..10;
-
- GENERIC
- FUNCTION FN1 (X : I1) RETURN I2;
-
- GENERIC
- FUNCTION FN2 (X : I1) RETURN I2;
-
- GENERIC
- FUNCTION FN3 (X : I1) RETURN I2;
-
- FUNCTION FN1( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN 0;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F1");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN1");
- END FN1;
-
- FUNCTION FN2( X : I1 )
- RETURN I2 IS
- BEGIN
- RETURN X + IDENT_INT(0);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F2");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN2");
- END FN2;
-
- FUNCTION FN3( X : I1 )
- RETURN I2 IS
- HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100);
- BEGIN
- RETURN HUNDRED;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("EXCEPTION RAISED - F3");
- RETURN 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FN3");
- END FN3;
-
- FUNCTION F1 IS NEW FN1;
- FUNCTION F2 IS NEW FN2;
- FUNCTION F3 IS NEW FN3;
-
- BEGIN
-
- BEGIN
- IF F1( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - F1( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - F1( 0 )");
- END;
-
- BEGIN
- IF F2( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - F2( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - F2( 0 )");
- END;
-
- BEGIN
- IF F2(11 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - F2(11 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - F2(11 )");
- END;
-
- BEGIN
- IF F3( 0 ) /= IDENT_INT(1) THEN
- FAILED ("NO EXCEPTION RAISED - F3( 0 )");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION PROPAGATED - F3( 0 )");
- END;
-
- END;
-
- RESULT;
-
-END C58006B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002a.ada b/gcc/testsuite/ada/acats/tests/c5/c59002a.ada
deleted file mode 100644
index 5210719..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c59002a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C59002A.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 JUMPS OUT OF AN EXCEPTION HANDLER CONTAINED IN A BLOCK
--- TO A STATEMENT IN AN ENCLOSING UNIT ARE ALLOWED AND ARE PERFORMED
--- CORRECTLY.
-
-
--- RM 05/22/81
--- SPS 3/8/83
-
-WITH REPORT;
-PROCEDURE C59002A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C59002A" , "CHECK THAT JUMPS OUT OF EXCEPTION HANDLERS" &
- " ARE ALLOWED" );
-
- DECLARE
-
- FLOW : INTEGER := 1 ;
- EXPON: INTEGER RANGE 0..3 := 0 ;
-
- BEGIN
-
- GOTO START ;
-
- FAILED( "'GOTO' NOT OBEYED" );
-
- << BACK_LABEL >>
- FLOW := FLOW * 3**EXPON ; -- 1*5*9
- EXPON := EXPON + 1 ;
- GOTO FINISH ;
-
- << START >>
- FLOW := FLOW * 7**EXPON ; -- 1
- EXPON := EXPON + 1 ;
-
- DECLARE
- BEGIN
- RAISE CONSTRAINT_ERROR ;
- FAILED( "EXCEPTION NOT RAISED - 1" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- GOTO FORWARD_LABEL ;
- END ;
-
- FAILED( "INNER 'GOTO' NOT OBEYED - 1" );
-
- << FORWARD_LABEL >>
- FLOW := FLOW * 5**EXPON ; -- 1*5
- EXPON := EXPON + 1 ;
-
- DECLARE
- BEGIN
- RAISE CONSTRAINT_ERROR ;
- FAILED( "EXCEPTION NOT RAISED - 2" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- GOTO BACK_LABEL ;
- END ;
-
- FAILED( "INNER 'GOTO' NOT OBETED - 2" );
-
- << FINISH >>
- FLOW := FLOW * 2**EXPON ; -- 1*5*9*8
-
- IF FLOW /= 360 THEN
- FAILED( "WRONG FLOW OF CONTROL" );
- END IF;
-
- END ;
-
-
- RESULT ;
-
-
-END C59002A;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002b.ada b/gcc/testsuite/ada/acats/tests/c5/c59002b.ada
deleted file mode 100644
index aee5839..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c59002b.ada
+++ /dev/null
@@ -1,209 +0,0 @@
--- C59002B.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 JUMPS OUT OF COMPOUND STATEMENTS (OTHER THAN
--- ACCEPT STATEMENTS) ARE POSSIBLE AND ARE CORRECTLY PERFORMED.
-
-
--- FLOW OF CONTROL: A -> B -> C -> D -> E -> F -> G -> H .
--- | | | | | | |
--- IF LOOP CASE BLOCK IF LOOP CASE
--- LOOP CASE BLOCK
-
-
--- A : GOTO B L111 -> L311
--- FAILURE L121
--- E : GOTO F L131 -> L331
-
--- FAILURE L100
-
--- C : GOTO D L211 -> L411
--- FAILURE L221
--- G : GOTO H L231
-
--- FAILURE L200
-
--- B : GOTO C L311 -> L211
--- FAILURE L321
--- F : GOTO G L331
-
--- FAILURE L300
-
--- D : GOTO E L411 -> L131
--- FAILURE L421
--- H : L431 -> (OUT)
-
--- PRINT RESULTS
-
-
--- RM 06/05/81
--- SPS 3/8/83
-
-WITH REPORT;
-PROCEDURE C59002B IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "C59002B" , "CHECK THAT ONE CAN JUMP OUT OF COMPOUND STATE" &
- "MENTS" );
-
-
- DECLARE
-
- FLOW_STRING : STRING(1..8) := "XXXXXXXX" ;
- INDEX : INTEGER := 1 ;
-
- BEGIN
-
- << L111 >>
-
- FLOW_STRING(INDEX) := 'A' ;
- INDEX := INDEX + 1 ;
-
- IF FALSE THEN
- FAILED( "WRONG 'IF' BRANCH" );
- ELSE
- GOTO L311 ;
- END IF;
-
- << L121 >>
-
- FAILED( "AT L121 - WRONGLY" );
-
- << L131 >>
-
- FLOW_STRING(INDEX) := 'E' ;
- INDEX := INDEX + 1 ;
-
- IF FALSE THEN
- FAILED( "WRONG 'IF' BRANCH" );
- ELSE
- FOR J IN 1..1 LOOP
- GOTO L331 ;
- END LOOP;
- END IF;
-
- << L100 >>
-
- FAILED( "AT L100 - WRONGLY" );
-
- << L211 >>
-
- FLOW_STRING(INDEX) := 'C' ;
- INDEX := INDEX + 1 ;
-
- CASE 2 IS
- WHEN 1 =>
- FAILED( "WRONG 'CASE' BRANCH" );
- WHEN OTHERS =>
- GOTO L411 ;
- END CASE;
-
- << L221 >>
-
- FAILED( "AT L221 - WRONGLY" );
-
- << L231 >>
-
- FLOW_STRING(INDEX) := 'G' ;
- INDEX := INDEX + 1 ;
-
- CASE 2 IS
- WHEN 1 =>
- FAILED( "WRONG 'CASE' BRANCH" );
- WHEN OTHERS =>
- DECLARE
- BEGIN
- GOTO L431 ;
- END ;
- END CASE;
-
- << L200 >>
-
- FAILED( "AT L200 - WRONGLY" );
-
- << L311 >>
-
- FLOW_STRING(INDEX) := 'B' ;
- INDEX := INDEX + 1 ;
-
- FOR I IN 1..1 LOOP
- GOTO L211 ;
- END LOOP;
-
- << L321 >>
-
- FAILED( "AT L321 - WRONGLY" );
-
- << L331 >>
-
- FLOW_STRING(INDEX) := 'F' ;
- INDEX := INDEX + 1 ;
-
- FOR I IN 1..1 LOOP
- CASE 2 IS
- WHEN 1 =>
- FAILED( "WRONG 'CASE' BRANCH" );
- WHEN OTHERS =>
- GOTO L231 ;
- END CASE;
- END LOOP;
-
- << L300 >>
-
- FAILED( "AT L300 - WRONGLY" );
-
- << L411 >>
-
- FLOW_STRING(INDEX) := 'D' ;
- INDEX := INDEX + 1 ;
-
- DECLARE
- K : INTEGER := 17 ;
- BEGIN
- GOTO L131 ;
- END;
-
- << L421 >>
-
- FAILED( "AT L421 - WRONGLY" );
-
- << L431 >>
-
- FLOW_STRING(INDEX) := 'H' ;
-
-
- IF FLOW_STRING /= "ABCDEFGH" THEN
- FAILED("WRONG FLOW OF CONTROL" );
- END IF;
-
- END ;
-
-
- RESULT ;
-
-
-END C59002B;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c59002c.ada b/gcc/testsuite/ada/acats/tests/c5/c59002c.ada
deleted file mode 100644
index cc01a7e..0000000
--- a/gcc/testsuite/ada/acats/tests/c5/c59002c.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C59002C.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 JUMPS OUT OF SELECT STATEMENTS (OTHER THAN
--- FROM INSIDE ACCEPT BODIES IN SELECT_ALTERNATIVES)
--- ARE POSSIBLE AND ARE CORRECTLY PERFORMED.
-
--- THIS TEST CONTAINS SHARED VARIABLES.
-
-
--- RM 08/15/82
--- SPS 12/13/82
--- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X.
-
-with Impdef;
-WITH REPORT;
-WITH SYSTEM;
-USE SYSTEM;
-PROCEDURE C59002C IS
-
- USE REPORT ;
-
- FLOW_STRING : STRING(1..2) := "XX" ;
- INDEX : INTEGER := 1 ;
-
-
-BEGIN
-
- TEST( "C59002C" , "CHECK THAT ONE CAN JUMP OUT OF SELECT STATE" &
- "MENTS" );
-
- -------------------------------------------------------------------
-
- DECLARE
-
- TASK T IS
-
-
- ENTRY E1 ;
- ENTRY E2 ;
- END T ;
-
- TASK BODY T IS
- BEGIN
-
- WHILE E2'COUNT <= 0 LOOP
- DELAY 1.0 * Impdef.One_Second;
- END LOOP;
-
- SELECT
- ACCEPT E1 DO
- FAILED( " E1 ACCEPTED; NO ENTRY CALL (1)" );
- END ;
- OR
- ACCEPT E2 ;
- GOTO L123 ;
- FAILED( "'GOTO' NOT OBEYED (1)" );
- OR
- DELAY 10.0 * Impdef.One_Second;
- FAILED( "DELAY ALTERNATIVE SELECTED (1)" );
- END SELECT;
-
- FAILED( "WRONG DESTINATION FOR 'GOTO' (1)" );
-
- << L123 >>
-
- FLOW_STRING(INDEX) := 'A' ;
- INDEX := INDEX + 1 ;
-
- END T;
-
- BEGIN
-
- T.E2 ;
-
- END;
-
- -------------------------------------------------------------------
-
- DECLARE
-
- TASK T IS
- ENTRY E1 ;
- ENTRY E2 ;
- END T ;
-
- TASK BODY T IS
- BEGIN
-
- SELECT
- ACCEPT E1 DO
- FAILED( " E1 ACCEPTED; NO ENTRY CALL (2)" );
- END ;
- OR
- ACCEPT E2 DO
- FAILED( " E2 ACCEPTED; NO ENTRY CALL (2)" );
- END ;
- OR
- DELAY 10.0 * Impdef.One_Second;
- GOTO L321 ;
- FAILED( "'GOTO' NOT OBEYED (2)" );
- END SELECT;
-
- FAILED( "WRONG DESTINATION FOR 'GOTO' (2)" );
-
- << L321 >>
-
- FLOW_STRING(INDEX) := 'B' ;
- INDEX := INDEX + 1 ;
-
- END T;
-
- BEGIN
-
- NULL ;
-
- END;
-
- -------------------------------------------------------------------
-
- IF FLOW_STRING /= "AB" THEN
- FAILED("WRONG FLOW OF CONTROL" );
- END IF;
-
-
- RESULT ;
-
-
-END C59002C ;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61008a.ada b/gcc/testsuite/ada/acats/tests/c6/c61008a.ada
deleted file mode 100644
index eb60e89..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c61008a.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- C61008A.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 IF THE DEFAULT VALUE
--- FOR A FORMAL PARAMETER DOES NOT SATISFY THE CONSTRAINTS OF THE
--- SUBTYPE_INDICATION WHEN THE DECLARATION IS ELABORATED, ONLY WHEN
--- THE DEFAULT IS USED.
-
--- SUBTESTS ARE:
--- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
--- INITIALIZED WITH A STATIC AGGREGATE.
--- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
--- INITIALIZED WITH A STATIC VALUE.
--- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
--- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
--- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--- WITH A STATIC AGGREGATE.
--- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
--- INITIALIZED WITH A STATIC AGGREGATE.
-
--- DAS 1/20/81
--- SPS 10/26/82
--- VKG 1/13/83
--- SPS 2/9/83
--- BHS 7/9/84
-
-WITH REPORT;
-PROCEDURE C61008A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C61008A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
- "AN INITIALIZATION VALUE DOES NOT SATISFY " &
- "CONSTRAINTS ON A FORMAL PARAMETER");
-
- --------------------------------------------------
-
- DECLARE -- (A)
-
- PROCEDURE PA (I1, I2 : INTEGER) IS
-
- TYPE A1 IS ARRAY (1..I1,1..I2) OF INTEGER;
-
- PROCEDURE PA1 (A : A1 := ((1,0),(0,1))) IS
- BEGIN
- FAILED ("BODY OF PA1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PA1");
- END PA1;
-
- BEGIN
- PA1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PA1");
- END PA;
-
- BEGIN -- (A)
- PA (IDENT_INT(1), IDENT_INT(10));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO PA");
- END; -- (A)
-
- --------------------------------------------------
-
- DECLARE -- (B)
-
- PROCEDURE PB (I1, I2 : INTEGER) IS
-
- SUBTYPE INT IS INTEGER RANGE I1..I2;
-
- PROCEDURE PB1 (I : INT := -1) IS
- BEGIN
- FAILED ("BODY OF PB1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PB1");
- END PB1;
-
- BEGIN
- PB1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PB1");
- END PB;
-
- BEGIN -- (B)
- PB (IDENT_INT(0), IDENT_INT(63));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO PB");
- END; -- (B)
-
- --------------------------------------------------
-
- DECLARE -- (C)
-
- PROCEDURE PC (I1, I2 : INTEGER) IS
- TYPE AR1 IS ARRAY (1..3) OF INTEGER RANGE I1..I2;
- TYPE REC IS
- RECORD
- I : INTEGER RANGE I1..I2;
- A : AR1 ;
- END RECORD;
-
- PROCEDURE PC1 (R : REC := (-3,(0,2,3))) IS
- BEGIN
- FAILED ("BODY OF PC1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PC1");
- END PC1;
-
- BEGIN
- PC1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PC1");
- END PC;
-
- BEGIN -- (C)
- PC (IDENT_INT(1), IDENT_INT(3));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO PC");
- END; -- (C)
-
- --------------------------------------------------
-
- DECLARE -- (D1)
-
- PROCEDURE P1D (I1, I2 : INTEGER) IS
-
- TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
-
- PROCEDURE P1D1 (A : A1 := ((1,-1),(1,2))) IS
- BEGIN
- FAILED ("BODY OF P1D1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P1D1");
- END P1D1;
-
- BEGIN
- P1D1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - P1D1");
- END P1D;
-
- BEGIN -- (D1)
- P1D (IDENT_INT(1), IDENT_INT(2));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO P1D");
- END; -- (D1)
-
- --------------------------------------------------
-
- DECLARE -- (D2)
-
- PROCEDURE P2D (I1, I2 : INTEGER) IS
-
- TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
-
- PROCEDURE P2D1 (A : A1 := (3..4 => (1,2))) IS
- BEGIN
- FAILED ("BODY OF P2D1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P2D1");
- END P2D1;
-
- BEGIN
- P2D1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - P2D1");
- END P2D;
-
- BEGIN -- (D2)
- P2D (IDENT_INT(1), IDENT_INT(2));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO P2D");
- END; -- (D2)
-
- --------------------------------------------------
-
- DECLARE -- (E)
-
- PROCEDURE PE (I1, I2 : INTEGER) IS
- SUBTYPE INT IS INTEGER RANGE 0..10;
- TYPE ARR IS ARRAY (1..3) OF INT;
- TYPE REC (I : INT) IS
- RECORD
- A : ARR;
- END RECORD;
-
- SUBTYPE REC4 IS REC(I1);
-
- PROCEDURE PE1 (R : REC4 := (3,(1,2,3))) IS
- BEGIN
- FAILED ("BODY OF PE1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PE1");
- END PE1;
-
- BEGIN
- PE1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PE1");
- END PE;
-
- BEGIN -- (E)
- PE (IDENT_INT(4), IDENT_INT(10));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN CALL TO PE");
- END; -- (E)
-
- --------------------------------------------------
-
- RESULT;
-
-END C61008A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61009a.ada b/gcc/testsuite/ada/acats/tests/c6/c61009a.ada
deleted file mode 100644
index d98674d..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c61009a.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C61009A.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 SUBPROGRAM
--- IS CALLED.
-
--- DAS 1/21/81
--- ABW 7/20/82
--- SPS 12/10/82
-
-WITH REPORT;
-PROCEDURE C61009A 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
-
- PROCEDURE PROC1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) IS
- BEGIN
- IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC1 PARAMETER");
- END IF;
- END PROC1;
-
- -- CONSTANT NAME
-
- PROCEDURE PROC2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) IS
- BEGIN
- IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC2 PARAMETER");
- END IF;
- END PROC2;
-
- -- ATTRIBUTE NAME
-
- PROCEDURE PROC3 (P1 : INT := INT'LAST) IS
- BEGIN
- IF (P1 /= INT (10)) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC3 PARAMETER");
- END IF;
- END PROC3;
-
- -- VARIABLE
-
- PROCEDURE PROC4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) IS
- BEGIN
- IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC4 PARAMETER");
- END IF;
- END PROC4;
-
- --DEREFERENCED ACCESS
-
- PROCEDURE PROC5 (P5 : INTEGER := C_A.ALL) IS
- BEGIN
- IF(P5 /= C_A.ALL) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC5 PARAMETER");
- END IF;
- END PROC5;
-
- --USER-DEFINED OPERATOR
-
- PROCEDURE PROC6 (P6 : INTEGER := 6&4) IS
- BEGIN
- IF (P6 /= IDENT_INT(10)) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC6 PARAMETER");
- END IF;
- END PROC6;
-
- --USER-DEFINED FUNCTION
-
- PROCEDURE PROC7 (P7 : INTEGER := FUNC(10)) IS
- BEGIN
- IF (P7 /= IDENT_INT(10)) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC7 PARAMETER");
- END IF;
- END PROC7;
-
- -- ALLOCATOR
-
- PROCEDURE PROC8 (P8 : A_INT := NEW INTEGER'(7)) IS
- BEGIN
- IF (P8.ALL /= IDENT_INT(7)) THEN
- FAILED ("INCORRECT DEFAULT VALUE FOR PROC8 PARAMETER");
- END IF;
- END PROC8;
-
-BEGIN
- TEST ("C61009A", "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 SUBPROGRAM SPECIFICATION");
-
- PROC1;
- PROC2;
- PROC3;
- PROC4;
- PROC5;
- PROC6;
- PROC7;
- PROC8;
-
- RESULT;
-
-END C61009A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61010a.ada b/gcc/testsuite/ada/acats/tests/c6/c61010a.ada
deleted file mode 100644
index ab35f4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c61010a.ada
+++ /dev/null
@@ -1,246 +0,0 @@
--- C61010A.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 IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A
--- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE.
-
--- DAS 1/22/81
--- JRK 1/20/84 TOTALLY REVISED.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C61010A IS
-
- PACKAGE PKG IS
-
- TYPE ITYPE IS LIMITED PRIVATE;
-
- PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
-
- PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
- M : STRING);
-
- PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER);
-
- SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
- TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;
-
- PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
- S : STRING; M : STRING);
-
- PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
- I : INTEGER; S : STRING;
- M : STRING);
-
- PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
- S : STRING);
-
- 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
-
- PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
- BEGIN
- IF INTEGER (X) /= V THEN
- FAILED ("WRONG SCALAR VALUE - " & M);
- END IF;
- END LOOK_IN_I;
-
- PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
- M : STRING) IS
- BEGIN
- IF INTEGER (X) /= V THEN
- FAILED ("WRONG SCALAR VALUE - " & M);
- END IF;
- END LOOK_INOUT_I;
-
- PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS
- BEGIN
- X := ITYPE (IDENT_INT (V));
- END SET_I;
-
- PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
- S : STRING; M : STRING) IS
- BEGIN
- 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;
-
- PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
- I : INTEGER; S : STRING;
- M : STRING) IS
- BEGIN
- 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;
-
- PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
- S : STRING) IS
- BEGIN
- X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S));
- END SET_VR;
-
- 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;
-
- PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
- BEGIN
- LOOK_IN_I (X, V, M);
- END CHECK_IN_I;
-
- PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
- NV : INTEGER; M : STRING) IS
- BEGIN
- LOOK_INOUT_I (X, OV, M & " - A");
- SET_I (X, NV);
- LOOK_INOUT_I (X, NV, M & " - B");
- LOOK_IN_I (X, NV, M & " - C");
- END CHECK_INOUT_I;
-
- PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I));
- END LOOP;
- END CHECK_IN_A;
-
- PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
- NV : INTEGER; M : STRING) IS
- BEGIN
- FOR I IN X'RANGE LOOP
- LOOK_INOUT_I (X(I), OV+I, M & " - A" &
- INTEGER'IMAGE (I));
- SET_I (X(I), NV+I);
- LOOK_INOUT_I (X(I), NV+I, M & " - B" &
- INTEGER'IMAGE (I));
- LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I));
- END LOOP;
- END CHECK_INOUT_A;
-
- PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
- S : STRING; M : STRING) IS
- BEGIN
- LOOK_IN_VR (X, C, I, S, M);
- END CHECK_IN_VR;
-
- PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE;
- OC : INTEGER; OI : INTEGER; OS : STRING;
- NC : INTEGER; NI : INTEGER; NS : STRING;
- M : STRING) IS
- BEGIN
- LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
- SET_VR (X, NC, NI, NS);
- LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
- LOOK_IN_VR (X, NC, NI, NS, M & " - C");
- END CHECK_INOUT_VR;
-
- PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
- I : INTEGER; S : STRING; M : STRING) IS
- BEGIN
- LOOK_IN_I (X.J, J, M & " - A");
- LOOK_IN_VR (X.R, C, I, S, M & " - B");
- END CHECK_IN_R;
-
- PROCEDURE 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) IS
- BEGIN
- LOOK_INOUT_I (X.J, OJ, M & " - A");
- LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
- SET_I (X.J, NJ);
- SET_VR (X.R, NC, NI, NS);
- LOOK_INOUT_I (X.J, NJ, M & " - C");
- LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
- LOOK_IN_I (X.J, NJ, M & " - E");
- LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
- END CHECK_INOUT_R;
-
-BEGIN
- TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
- "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");
-
- CHECK_IN_I (I1, 2, "IN I");
-
- CHECK_INOUT_I (I1, 2, 5, "INOUT I");
-
- CHECK_IN_A (A1, 3, "IN A");
-
- CHECK_INOUT_A (A1, 3, 17, "INOUT A");
-
- CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");
-
- CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
- "INOUT VR");
-
- CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");
-
- CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ",
- "INOUT R");
-
- RESULT;
-END C61010A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c620001.a b/gcc/testsuite/ada/acats/tests/c6/c620001.a
deleted file mode 100644
index 0f854d1..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c620001.a
+++ /dev/null
@@ -1,340 +0,0 @@
--- C620001.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 elementary parameters are passed by copy.
---
--- Part 1: Integer, float, and access types, procedures and functions.
---
--- TEST DESCRIPTION:
--- Subtests are:
--- (A) Scalar parameters to procedures.
--- (B) Scalar parameters to functions.
--- (C) Access parameters to procedures.
--- (D) Access parameters to functions.
---
--- For the procedure examples, we pass array elements indexed by dynamically
--- determined indexes. Doing this side-steps the check of 6.4.1(6.15/3) and
--- makes the test more realistic.
---
--- To completely test this objective, we should also try in out and out
--- parameters for functions (Ada 2012), in/in out/out parameters for
--- task and protected entries, and a variety of different scalar types
--- (enumeration, modular, fixed, decimal).
---
--- CHANGE HISTORY:
--- 14 Jan 1980 DAS Created test.
--- 26 Oct 1982 SPS
--- 25 May 1984 CPP
--- 29 Oct 1985 EG Eliminate the use of Numeric_Error in the test.
--- 14 Mar 2014 RLB Revised so test cases are legal for Ada 2012, modernized
--- objective, converted to modern format, added float cases.
-
-with Report;
-procedure C620001 is
-
- use Report;
-
-begin
- Test ("C620001", "Check that elementary parameters are passed by copy");
-
- --------------------------------------------------
-
- declare -- (A)
-
- I,J,K : Natural := Report.Ident_Int(1); -- Index values.
- Arr : array (1 .. 4) of Integer;
- E : exception;
-
- procedure P (PI : in Integer;
- PO : out Integer;
- PIO : in out Integer) is
-
- Tmp : Integer;
-
- begin
-
- Tmp := PI; -- Save value of PI at procedure entry.
-
- PO := 10;
- if (PI /= Tmp) then
- Failed ("Assignement to scalar out " &
- "parameter changes the value of " &
- "input parameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- PIO := PIO + 100;
- if (PI /= Tmp) then
- Failed ("Assignment to scalar in out " &
- "parameter changes the value of " &
- "inputparameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1;
- if (PI /= Tmp) then
- Failed ("Assignment to scalar actual " &
- "parameter changes the value of " &
- "input parameter");
- end if;
-
- raise E; -- Check exception handling.
- end P;
-
- begin -- (A)
- Arr := (others => 0);
- P (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - A");
- exception
- when E =>
- if (Arr(I) /= 1) then
- case Arr(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 ("Uundetermined change to global " &
- "value");
- end case;
- end if;
- when others =>
- Failed ("Wrong exception raised - A");
- end; -- (A)
-
- --------------------------------------------------
-
- declare -- (B)
-
- I,J : Integer;
-
- function F (FI : in Integer) return Integer is
-
- Tmp : Integer := FI;
-
- begin
-
- I := I + 1;
- if (FI /= Tmp) then
- Failed ("Assignment to scalar actual function " &
- "parameter changes the value of " &
- "input parameter");
- end if;
-
- return (100);
- end F;
-
- begin -- (B)
- I := 100;
- J := F (I);
- end; -- (B)
-
- --------------------------------------------------
-
- declare -- (C)
-
- type Acctype is access Integer;
-
- I,J,K : Natural := Report.Ident_Int(2); -- Index values.
- Arr : array (1 .. 5) of Acctype;
- E : exception;
-
- procedure P (PI : in Acctype;
- PO : out Acctype;
- PIO : in out Acctype) is
-
- Tmp : Acctype;
-
- begin
-
- Tmp := PI; -- Save value of PI at procedure entry.
-
- Arr(I) := new Integer'(101);
- if (PI /= Tmp) then
- Failed ("Assignment to access actual " &
- "parameter changes the value of " &
- "input parameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- PO := new Integer'(1);
- if (PI /= Tmp) then
- Failed ("Assignment to access out " &
- "parameter changes the value of " &
- "input parameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- PIO := new Integer'(10);
- if (PI /= Tmp) then
- Failed ("Assignment to access in out " &
- "parameter changes the value of " &
- "input parameter");
- end if;
-
- raise E; -- Check exception handling.
- end P;
-
- begin -- (C)
- Arr(I) := new Integer'(100);
- P (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - C");
- exception
- when E =>
- if (Arr(I).all /= 101) then
- Failed ("Out or in out actual procedure " &
- "parameter value changed despite " &
- "raised exception");
- end if;
- when others =>
- Failed ("Wrong exception raised - C");
- end; -- (C)
-
- --------------------------------------------------
-
- declare -- (D)
-
- Type Acctype is access Integer;
-
- I,J : Acctype;
-
- function F (FI : in Acctype) return Acctype is
-
- Tmp : Acctype := FI;
-
- begin
-
- I := new Integer;
- if (FI /= Tmp) then
- Failed ("Assignment to access actual function " &
- "parameter changes the value of " &
- "Input parameter");
- end if;
-
- return null;
- end F;
-
- begin -- (D)
- I := null;
- J := F(I);
- end; -- (D)
-
- --------------------------------------------------
-
- declare -- (E)
-
- I,J,K : Natural := Report.Ident_Int(3); -- Index values.
- Arr : array (1 .. 3) of Float;
- E : exception;
-
- procedure P (PI : in Float;
- PO : out Float;
- PIO : in out Float) is
-
- Tmp : Float;
-
- begin
-
- Tmp := PI; -- Save value of PI at procedure entry.
-
- PO := 0.5;
- if (PI /= Tmp) then
- Failed ("Assignement to float out " &
- "parameter changes the value of " &
- "input parameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- PIO := PIO + 0.25;
- if (PI /= Tmp) then
- Failed ("Assignment to float in out " &
- "parameter changes the value of " &
- "inputparameter");
- Tmp := PI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1.0;
- if (PI /= Tmp) then
- Failed ("Assignment to float actual " &
- "parameter changes the value of " &
- "input parameter");
- end if;
-
- raise E; -- Check exception handling.
- end P;
-
- begin -- (E)
- Arr := (others => 0.0);
- P (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - E");
- exception
- when E =>
- if (Arr(I) /= 1.0) then
- Failed ("Out or in out actual procedure " &
- "parameter value changed despite " &
- "raised exception");
- end if;
- when others =>
- Failed ("Wrong exception raised - E");
- end; -- (E)
-
- --------------------------------------------------
-
- declare -- (F)
-
- I,J : Float;
-
- function F (FI : in Float) return Float is
-
- Tmp : Float := FI;
-
- begin
-
- I := I + 1.0;
- if (FI /= Tmp) then
- Failed ("Assignment to float actual function " &
- "parameter changes the value of " &
- "input parameter");
- end if;
-
- return 100.0;
- end F;
-
- begin -- (F)
- I := 100.0;
- J := F (I);
- end; -- (F)
-
- --------------------------------------------------
-
- Result;
-
-end C620001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c620002.a b/gcc/testsuite/ada/acats/tests/c6/c620002.a
deleted file mode 100644
index b46a04e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c620002.a
+++ /dev/null
@@ -1,509 +0,0 @@
--- C620001.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 elementary parameters are passed by copy.
---
--- Part 2: Integer, float, and access types, task and protected entries.
---
--- TEST DESCRIPTION:
--- Subtests are:
--- (A) Scalar parameters to task entries.
--- (B) Scalar parameters to protected entries.
--- (C) Access parameters to task entries.
--- (D) Access parameters to protected entries.
---
--- For all of these examples, we pass array elements indexed by dynamically
--- determined indexes. Doing this side-steps the check of 6.4.1(6.15/3) and
--- makes the test more realistic.
---
--- Note: This is based on legacy test C95072A.ADA (which was withdrawn).
---
--- CHANGE HISTORY:
--- 22 Jul 1985 DAS Created test.
--- 12 May 2020 RLB Revised so test cases are legal for Ada 2012, modernized
--- objective, converted to modern format, added float
--- and protected cases.
-
-with Report;
-procedure C620002 is
-
- use Report;
-
-begin
- Test ("C620002", "Check that elementary parameters are passed by copy," &
- " part 2 - task and protected entries");
-
- --------------------------------------------------
-
- declare -- (A)
-
- I,J,K : Natural := Report.Ident_Int (1); -- Index values.
- Arr : array (1 .. 4) of 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 ("Assignement to scalar out " &
- "parameter changes the value of " &
- "input parameter - A");
- 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 - A");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1;
- if EI /= Tmp then
- Failed ("Assignment to scalar actual " &
- "parameter changes the value of " &
- "input parameter - A");
- end if;
-
- raise E; -- Check exception handling.
- end EA;
-
- exception
- when others => null;
- end TA;
-
- begin -- (A)
- Arr := (others => 0);
- TA.EA (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - A");
- exception
- when E =>
- if Arr(I) /= 1 then
- case Arr(I) is
- when 11 =>
- Failed ("Out actual scalar parameter " &
- "changed global value - A");
- when 101 =>
- Failed ("In out actual scalar " &
- "parameter changed global value - A");
- when 111 =>
- Failed ("Out and in out actual scalar " &
- "parameters changed global " &
- "value - A");
- when others =>
- Failed ("Undetermined change to global " &
- "value - A");
- end case;
- end if;
- when others =>
- Failed ("Wrong exception raised - A");
- end; -- (A)
-
- --------------------------------------------------
-
- declare -- (B)
-
- I,J,K : Natural := Report.Ident_Int (3); -- Index values.
- Arr : array (1 .. 5) of Integer;
- E : exception;
-
- protected PA is
- entry EA (EI : in Integer;
- EO : out Integer;
- EIO : in out Integer);
- end PA;
-
- protected body PA is
-
- entry EA (EI : in Integer;
- EO : out Integer;
- EIO : in out Integer) when True is
-
- Tmp : Integer;
-
- begin
-
- Tmp := EI; -- Save value of EI at entry.
-
- EO := 10;
- if EI /= Tmp then
- Failed ("Assignement to scalar out " &
- "parameter changes the value of " &
- "input parameter - B");
- 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 - B");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1;
- if EI /= Tmp then
- Failed ("Assignment to scalar actual " &
- "parameter changes the value of " &
- "input parameter - B");
- end if;
-
- raise E; -- Check exception handling.
- end EA;
-
- end PA;
-
- begin -- (B)
- Arr := (others => 0);
- PA.EA (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - B");
- exception
- when E =>
- if Arr(I) /= 1 then
- case Arr(I) is
- when 11 =>
- Failed ("Out actual scalar parameter " &
- "changed global value - B");
- when 101 =>
- Failed ("In out actual scalar " &
- "parameter changed global value - B");
- when 111 =>
- Failed ("Out and in out actual scalar " &
- "parameters changed global " &
- "value - B");
- when others =>
- Failed ("Undetermined change to global " &
- "value - B");
- end case;
- end if;
- when others =>
- Failed ("Wrong exception raised - B");
- end; -- (B)
-
- --------------------------------------------------
-
- declare -- (C)
-
- type Acctype is access Integer;
-
- I,J,K : Natural := Report.Ident_Int (2); -- Index values.
- Arr : array (1 .. 5) of 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.
-
- Arr(I) := new Integer'(101);
- if EI /= Tmp then
- Failed ("Assignment to access actual " &
- "parameter changes the value of " &
- "input parameter - C");
- 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 - C");
- 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 - C");
- end if;
-
- raise E; -- Check exception handling.
- end EB;
-
- exception
- when others => null;
- end TB;
-
- begin -- (C)
- Arr(I) := new Integer'(100);
- TB.EB (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - C");
- exception
- when E =>
- if (Arr(I).all /= 101) then
- Failed ("Out or in out actual " &
- "parameter value changed despite " &
- "raised exception - C");
- end if;
- when others =>
- Failed ("Wrong exception raised - C");
- end; -- (C)
-
- --------------------------------------------------
-
- declare -- (D)
-
- type Acctype is access Integer;
-
- I,J,K : Natural := Report.Ident_Int (4); -- Index values.
- Arr : array (1 .. 6) of Acctype;
- E : exception;
-
- protected PB is
- entry EB (EI : in Acctype;
- EO : out Acctype;
- EIO : in out Acctype);
- end PB;
-
- protected body PB is
-
- entry EB (EI : in Acctype;
- EO : out Acctype;
- EIO : in out Acctype) when True is
-
- Tmp : Acctype;
-
- begin
- Tmp := EI; -- Save value of EI at entry.
-
- Arr(I) := new Integer'(101);
- if EI /= Tmp then
- Failed ("Assignment to access actual " &
- "parameter changes the value of " &
- "input parameter - D");
- 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 - D");
- 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 - D");
- end if;
-
- raise E; -- Check exception handling.
- end EB;
-
- end PB;
-
- begin -- (D)
- Arr(I) := new Integer'(100);
- PB.EB (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - D");
- exception
- when E =>
- if (Arr(I).all /= 101) then
- Failed ("Out or in out actual " &
- "parameter value changed despite " &
- "raised exception - D");
- end if;
- when others =>
- Failed ("Wrong exception raised - D");
- end; -- (D)
-
- --------------------------------------------------
-
- declare -- (E)
-
- I,J,K : Natural := Report.Ident_Int (3); -- Index values.
- Arr : array (1 .. 3) of Float;
- E : exception;
-
- task TC is
- entry EC (EI : in Float;
- EO : out Float;
- EIO : in out Float);
- end TC;
-
- task body TC is
-
- Tmp : Float;
-
- begin
-
- accept EC (EI : in Float;
- EO : out Float;
- EIO : in out Float) do
-
- Tmp := EI; -- Save value of EI at accept.
-
- EO := 0.5;
- if EI /= Tmp then
- Failed ("Assignement to float out " &
- "parameter changes the value of " &
- "input parameter - E");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- EIO := EIO + 0.25;
- if EI /= Tmp then
- Failed ("Assignment to float in out " &
- "parameter changes the value of " &
- "input parameter - E");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1.0;
- if EI /= Tmp then
- Failed ("Assignment to float actual " &
- "parameter changes the value of " &
- "input parameter - E");
- end if;
-
- raise E; -- Check exception handling.
- end EC;
-
- exception
- when others => null;
- end TC;
-
- begin -- (E)
- Arr := (others => 0.0);
- TC.EC (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - E");
- exception
- when E =>
- if (Arr(I) /= 1.0) then
- Failed ("Out or in out actual procedure " &
- "parameter value changed despite " &
- "raised exception - E");
- end if;
- when others =>
- Failed ("Wrong exception raised - E");
- end; -- (E)
-
- --------------------------------------------------
-
- declare -- (F)
-
- I,J,K : Natural := Report.Ident_Int (6); -- Index values.
- Arr : array (1 .. 7) of Float;
- E : exception;
-
- protected PC is
- entry EC (EI : in Float;
- EO : out Float;
- EIO : in out Float);
- end PC;
-
- protected body PC is
-
- entry EC (EI : in Float;
- EO : out Float;
- EIO : in out Float) when True is
-
- Tmp : Float;
-
- begin
-
- Tmp := EI; -- Save value of EI at entry.
-
- EO := 0.5;
- if EI /= Tmp then
- Failed ("Assignement to float out " &
- "parameter changes the value of " &
- "input parameter - F");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- EIO := EIO + 0.25;
- if EI /= Tmp then
- Failed ("Assignment to float in out " &
- "parameter changes the value of " &
- "input parameter - F");
- Tmp := EI; -- Reset Tmp for next case.
- end if;
-
- Arr(I) := Arr(I) + 1.0;
- if EI /= Tmp then
- Failed ("Assignment to float actual " &
- "parameter changes the value of " &
- "input parameter - F");
- end if;
-
- raise E; -- Check exception handling.
- end EC;
-
- end PC;
-
- begin -- (F)
- Arr := (others => 0.0);
- PC.EC (Arr(I), Arr(J), Arr(K));
- Failed ("Exception not raised - F");
- exception
- when E =>
- if (Arr(I) /= 1.0) then
- Failed ("Out or in out actual procedure " &
- "parameter value changed despite " &
- "raised exception - F");
- end if;
- when others =>
- Failed ("Wrong exception raised - F");
- end; -- (F)
-
- --------------------------------------------------
-
- Result;
-
-end C620002;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62002a.ada b/gcc/testsuite/ada/acats/tests/c6/c62002a.ada
deleted file mode 100644
index f15bca7..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c62002a.ada
+++ /dev/null
@@ -1,190 +0,0 @@
--- C62002A.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 COMPONENTS OF ACCESS IN PARAMETERS CAN BE USED AS THE
--- TARGET OF AN ASSIGNMENT STATEMENT OR AS AN ACTUAL PARAMETER OF
--- ANY MODE. SUBTESTS ARE:
--- (A) INTEGER ACCESS TYPE.
--- (B) ARRAY ACCESS TYPE.
--- (C) RECORD ACCESS TYPE.
-
--- DAS 1/23/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C62002A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C62002A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS" &
- " MAY BE USED IN ASSIGNMENT CONTEXTS");
-
- --------------------------------------------------
-
- DECLARE -- (A)
-
- TYPE PTRINT IS ACCESS INTEGER;
- PI : PTRINT;
-
- PROCEDURE PROCA (PI : IN PTRINT) IS
-
- PROCEDURE PROCA1 (I : OUT INTEGER) IS
- BEGIN
- I := 7;
- END PROCA1;
-
- PROCEDURE PROCA2 (I : IN OUT INTEGER) IS
- BEGIN
- I := I + 1;
- END PROCA2;
- BEGIN
-
- PROCA1 (PI.ALL);
- PROCA2 (PI.ALL);
- PI.ALL := PI.ALL + 1;
- IF (PI.ALL /= 9) THEN
- FAILED ("ASSIGNMENT TO COMPONENT OF INTEGER" &
- " ACCESS PARAMETER FAILED");
- END IF;
- END PROCA;
-
- BEGIN -- (A)
-
- PI := NEW INTEGER '(0);
- PROCA (PI);
-
- END; -- (A)
-
- ---------------------------------------------
-
- DECLARE -- (B)
-
- TYPE TBL IS ARRAY (1..3) OF INTEGER;
- TYPE PTRTBL IS ACCESS TBL;
- PT : PTRTBL;
-
- PROCEDURE PROCB (PT : IN PTRTBL) IS
-
- PROCEDURE PROCB1 (I : OUT INTEGER) IS
- BEGIN
- I := 7;
- END PROCB1;
-
- PROCEDURE PROCB2 (I : IN OUT INTEGER) IS
- BEGIN
- I := I + 1;
- END PROCB2;
-
- PROCEDURE PROCB3 (T : OUT TBL) IS
- BEGIN
- T := (1,2,3);
- END PROCB3;
-
- PROCEDURE PROCB4 (T : IN OUT TBL) IS
- BEGIN
- T(3) := T(3) - 1;
- END PROCB4;
-
- BEGIN
-
- PROCB3 (PT.ALL); -- (1,2,3)
- PROCB4 (PT.ALL); -- (1,2,2)
- PROCB1 (PT(2)); -- (1,7,2)
- PROCB2 (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 PROCB;
-
- BEGIN -- (B)
-
- PT := NEW TBL '(0,0,0);
- PROCB (PT);
-
- END; -- (B)
-
- ---------------------------------------------
-
- DECLARE -- (C)
-
- TYPE REC IS
- RECORD
- I1 : INTEGER;
- I2 : INTEGER;
- I3 : INTEGER;
- END RECORD;
- TYPE PTRREC IS ACCESS REC;
- PR : PTRREC;
-
- PROCEDURE PROCC (PR : IN PTRREC) IS
-
- PROCEDURE PROCC1 (I : OUT INTEGER) IS
- BEGIN
- I := 7;
- END PROCC1;
-
- PROCEDURE PROCC2 (I : IN OUT INTEGER) IS
- BEGIN
- I := I + 1;
- END PROCC2;
-
- PROCEDURE PROCC3 (R : OUT REC) IS
- BEGIN
- R := (1,2,3);
- END PROCC3;
-
- PROCEDURE PROCC4 (R : IN OUT REC) IS
- BEGIN
- R.I3 := R.I3 - 1;
- END PROCC4;
-
- BEGIN
-
- PROCC3 (PR.ALL); -- (1,2,3)
- PROCC4 (PR.ALL); -- (1,2,2)
- PROCC1 (PR.I2); -- (1,7,2)
- PROCC2 (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 PROCC;
-
- BEGIN -- (C)
-
- PR := NEW REC '(0,0,0);
- PROCC (PR);
-
- END; -- (C)
-
- ---------------------------------------------
-
- RESULT;
-
-END C62002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62003a.ada b/gcc/testsuite/ada/acats/tests/c6/c62003a.ada
deleted file mode 100644
index e5ab95a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c62003a.ada
+++ /dev/null
@@ -1,234 +0,0 @@
--- C62003A.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.
--- SUBTESTS ARE:
--- (A) SCALAR PARAMETERS TO PROCEDURES.
--- (B) SCALAR PARAMETERS TO FUNCTIONS.
--- (C) ACCESS PARAMETERS TO PROCEDURES.
--- (D) ACCESS PARAMETERS TO FUNCTIONS.
-
--- DAS 01/14/80
--- SPS 10/26/82
--- CPP 05/25/84
--- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
-
-WITH REPORT;
-PROCEDURE C62003A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
- "COPIED");
-
- --------------------------------------------------
-
- DECLARE -- (A)
-
- I : INTEGER;
- E : EXCEPTION;
-
- PROCEDURE P (PI : IN INTEGER; PO : OUT INTEGER;
- PIO : IN OUT INTEGER) IS
-
- TMP : INTEGER;
-
- BEGIN
-
- TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
-
- PO := 10;
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO SCALAR OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TMP := PI; -- RESET TMP FOR NEXT CASE.
- END IF;
-
- PIO := PIO + 100;
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TMP := PI; -- RESET TMP FOR NEXT CASE.
- END IF;
-
- I := I + 1;
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P;
-
- BEGIN -- (A)
- I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
- P (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)
-
- I,J : INTEGER;
-
- FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS
-
- TMP : INTEGER := FI;
-
- BEGIN
-
- I := I + 1;
- IF (FI /= TMP) THEN
- FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RETURN (100);
- END F;
-
- BEGIN -- (B)
- I := 100;
- J := F(I);
- END; -- (B)
-
- --------------------------------------------------
-
- DECLARE -- (C)
-
- TYPE ACCTYPE IS ACCESS INTEGER;
-
- I : ACCTYPE;
- E : EXCEPTION;
-
- PROCEDURE P (PI : IN ACCTYPE; PO : OUT ACCTYPE;
- PIO : IN OUT ACCTYPE) IS
-
- TMP : ACCTYPE;
-
- BEGIN
-
- TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
-
- I := NEW INTEGER'(101);
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TMP := PI; -- RESET TMP FOR NEXT CASE.
- END IF;
-
- PO := NEW INTEGER'(1);
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO ACCESS OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TMP := PI; -- RESET TMP FOR NEXT CASE.
- END IF;
-
- PIO := NEW INTEGER'(10);
- IF (PI /= TMP) THEN
- FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P;
-
- BEGIN -- (C)
- I := NEW INTEGER'(100);
- P (I, I, I);
- FAILED ("EXCEPTION NOT RAISED - C");
- EXCEPTION
- WHEN E =>
- IF (I.ALL /= 101) THEN
- FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
- "PARAMETER VALUE CHANGED DESPITE " &
- "RAISED EXCEPTION");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - C");
- END; -- (C)
-
- --------------------------------------------------
-
- DECLARE -- (D)
-
- TYPE ACCTYPE IS ACCESS INTEGER;
-
- I,J : ACCTYPE;
-
- FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS
-
- TMP : ACCTYPE := FI;
-
- BEGIN
-
- I := NEW INTEGER;
- IF (FI /= TMP) THEN
- FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RETURN (NULL);
- END F;
-
- BEGIN -- (D)
- I := NULL;
- J := F(I);
- END; -- (D)
-
- --------------------------------------------------
-
- RESULT;
-
-END C62003A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62003b.ada b/gcc/testsuite/ada/acats/tests/c6/c62003b.ada
deleted file mode 100644
index f03c774..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c62003b.ada
+++ /dev/null
@@ -1,301 +0,0 @@
--- C62003B.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.
--- SUBTESTS ARE:
--- (A) PRIVATE SCALAR PARAMETERS TO PROCEDURES.
--- (B) PRIVATE SCALAR PARAMETERS TO FUNCTIONS.
--- (C) PRIVATE ACCESS PARAMETERS TO PROCEDURES.
--- (D) PRIVATE ACCESS PARAMETERS TO FUNCTIONS.
-
--- CPP 05/25/84
--- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C62003B IS
-
-BEGIN
- TEST("C62003B", "CHECK THAT PRIVATE SCALAR AND ACCESS " &
- "PARAMETERS ARE COPIED");
-
- ---------------------------------------------------
-
-A_B: DECLARE
-
- 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 -- CONVERT
- RETURN INTEGER(OLD_PRIVATE);
- END CONVERT;
-
- END SCALAR_PKG;
-
- USE SCALAR_PKG;
-
- ---------------------------------------------------
-
- BEGIN -- A_B
-
- A : DECLARE
-
- I : T;
- E : EXCEPTION;
-
- PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
-
- TEMP : T;
-
- BEGIN -- P
-
- TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
-
- PO := C10;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TEMP := PI; -- RESET TEMP FOR NEXT CASE.
- END IF;
-
- PIO := PIO + C100;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) IN " &
- "OUT PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TEMP := PI; -- RESET TEMP FOR NEXT CASE.
- END IF;
-
- I := I + C1;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
- "ACTUAL PARAMETER CHANGES THE " &
- "VALUE OF INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P;
-
- BEGIN -- A
- I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE
- -- DETECTED.
- P (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 A;
-
- ---------------------------------------------------
-
- B : DECLARE
-
- I, J : T;
-
- FUNCTION F (FI : IN T) RETURN T IS
-
- TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
-
- BEGIN -- F
-
- I := I + C1;
- IF (FI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
- "ACTUAL FUNCTION PARAMETER CHANGES " &
- "THE VALUE OF INPUT PARAMETER ");
- END IF;
-
- RETURN C0;
- END F;
-
- BEGIN -- B
- I := C0;
- J := F(I);
- END B;
-
- END A_B;
-
- ---------------------------------------------------
-
-C_D: DECLARE
-
- 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 -- C_D;
-
- C : DECLARE
-
- I : T;
- E : EXCEPTION;
- PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
-
- TEMP : T;
-
- BEGIN -- P
-
- TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
-
- I := C101;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) " &
- "ACTUAL VARIABLE CHANGES THE VALUE " &
- "OF INPUT PARAMETER");
- TEMP := PI; -- RESET TEMP FOR NEXT CASE.
- END IF;
-
- PO := C1;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- TEMP := PI; -- RESET TEMP FOR NEXT CASE.
- END IF;
-
- PIO := C10;
- IF (PI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) IN " &
- "OUT PARAMETER CHANGES THE VALUE " &
- "OF INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P;
-
- BEGIN -- C
- I := C100;
- P (I, I, I);
- FAILED ("EXCEPTION NOT RAISED - C");
- EXCEPTION
- WHEN E =>
- IF (I /= C101) THEN
- FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
- "PARAMETER VALUE CHANGED DESPITE " &
- "RAISED EXCEPTION");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - C");
- END C;
-
- ---------------------------------------------------
-
- D : DECLARE
-
- I, J : T;
-
- FUNCTION F (FI : IN T) RETURN T IS
-
- TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
-
- BEGIN -- F
- I := C100;
- IF (FI /= TEMP) THEN
- FAILED ("ASSIGNMENT TO PRIVATE " &
- "(ACCESS) ACTUAL FUNCTION " &
- "PARAMETER CHANGES THE VALUE " &
- "OF INPUT PARAMETER");
- END IF;
- RETURN C_NULL;
- END F;
-
- BEGIN -- D
- I := C_NULL;
- J := F(I);
- END D;
-
- END C_D;
-
- ---------------------------------------------------
-
- RESULT;
-
-END C62003B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62004a.ada b/gcc/testsuite/ada/acats/tests/c6/c62004a.ada
deleted file mode 100644
index 408a6cd..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c62004a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C62004A.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. (NOTE: ALIASING MAY NOT WORK FOR ARGUMENTS
--- TO ALL SUBROUTINES SINCE PARAMETER PASSING IS IMPLEMENTATION
--- DEPENDENT. HOWEVER, THIS TEST IS NOT ERRONEOUS.)
-
--- DAS 1/26/81
-
-WITH REPORT;
-PROCEDURE C62004A IS
-
- USE REPORT;
-
- TYPE MATRIX IS ARRAY (1..3,1..3) OF INTEGER;
-
- A : MATRIX := ((1,2,3),(4,5,6),(7,8,9));
-
- PROCEDURE MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) IS
- BEGIN
- 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;
-
-BEGIN
-
- TEST ("C62004A", "CHECK THAT ALIASING IS PERMITTED FOR" &
- " PARAMETERS OF COMPOSITE TYPES");
-
- 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 C62004A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62006a.ada b/gcc/testsuite/ada/acats/tests/c6/c62006a.ada
deleted file mode 100644
index c3ca244..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c62006a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C62006A.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 DISCRIMINANTS OF AN OUT FORMAL PARAMETER, AS WELL AS
--- THE DISCRIMINANTS OF THE SUBCOMPONENTS OF AN OUT FORMAL PARAMETER,
--- MAY BE READ INSIDE THE PROCEDURE.
-
--- SPS 2/17/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C62006A IS
-BEGIN
-
- TEST ("C62006A", "CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL " &
- "PARAMETER CAN BE READ INSIDE THE PROCEDURE");
-
- DECLARE
-
- TYPE R1 (D1 : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- TYPE R2 (D2 : POSITIVE) IS RECORD
- C : R1 (2);
- END RECORD;
-
- R : R2 (5);
-
- PROCEDURE P (REC : OUT R2) IS
- BEGIN
-
- IF REC.D2 /= 5 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" &
- " OUT PARAMETER");
- END IF;
-
- IF REC.C.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- " OF THE SUBCOMPONENT OF AN OUT PARAMETER");
- END IF;
- END P;
-
- BEGIN
- P (R);
- END;
-
- RESULT;
-
-END C62006A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c631001.a b/gcc/testsuite/ada/acats/tests/c6/c631001.a
deleted file mode 100644
index f8b0c77..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c631001.a
+++ /dev/null
@@ -1,134 +0,0 @@
--- C631001.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 different forms of a name are used in the default
--- expression of a discriminant part, the selector may be an operator
--- symbol or a character literal.
---
--- TEST DESCRIPTION:
--- This transition test defines private types where their selectors in
--- the default expression of the discriminant parts at the full type
--- declarations are an operator and a literal, respectively.
--- The test also declares procedures that use an operator and a literal
--- as selectors in the formal parts.
---
--- Inspired by B63102A.ADA.
---
---
--- CHANGE HISTORY:
--- 25 Mar 96 SAIC Initial version for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Removed use of function called before elaboration
---!
-
-with Report;
-
-procedure C631001 is
-
- package C631001_0 is
-
- type Int_Type is range 1 .. 100;
- type Enu_Type is ('A', 'B', 'C', 'D');
-
- type Private_Enu (D : Enu_Type := 'B') is private;
-
- function "+" (X, Y : Int_Type) return Int_Type;
-
- procedure Int_Proc (P1 : in Int_Type := "+" (10, 15);
- P2 : out Int_Type);
-
- procedure Enu_Proc (P1 : in Enu_Type := 'C';
- P2 : out Enu_Type);
-
- private
-
- type Private_Enu (D : Enu_Type := C631001_0.'B') is -- OK.
- record
- C2 : Enu_Type := D;
- end record;
-
- -----------------------------------------------------------------
- PE_Obj : C631001_0.Private_Enu;
-
- end C631001_0;
-
- --==================================================================--
-
- package body C631001_0 is
-
- function "+" (X, Y : Int_Type) return Int_Type is
- begin
- return 10;
- end "+";
-
- -----------------------------------------------------------------
- procedure Int_Proc (P1 : in Int_Type := C631001_0."+" (10, 15); -- OK.
- P2 : out Int_Type) is
-
- begin
- P2 := P1;
- end Int_Proc;
-
- -----------------------------------------------------------------
- procedure Enu_Proc (P1 : in Enu_Type := C631001_0.'C'; -- OK.
- P2 : out Enu_Type) is
- begin
- P2 := P1;
- end Enu_Proc;
-
- -----------------------------------------------------------------
-
- end C631001_0;
-
- ---------------------------------------------------------------------------
- Int_Obj : C631001_0.Int_Type := 50;
- Enu_Obj : C631001_0.Enu_Type := C631001_0.'D';
-
- -- Direct visibility to operator symbols
- use type C631001_0.Int_Type;
- use type C631001_0.Enu_Type;
-
-begin -- main
-
- Report.Test ("C631001", "Check that if different forms of a name are " &
- "used in the default expression of a discriminant part, " &
- "the selector may be an operator symbol or a character " &
- "literal");
-
- C631001_0.Int_Proc (P2 => Int_Obj);
-
- if Int_Obj /= 10 then
- Report.Failed ("Wrong result for Int_Obj");
- end if;
-
- C631001_0.Enu_Proc (P2 => Enu_Obj);
-
- if Enu_Obj /= 'C' then
- Report.Failed ("Wrong result for Enu_Obj");
- end if;
-
- Report.Result;
-
-end C631001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c640001.a b/gcc/testsuite/ada/acats/tests/c6/c640001.a
deleted file mode 100644
index 8e25916..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c640001.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- C640001.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 prefix of a subprogram call with an actual parameter
--- part may be an implicit dereference of an access-to-subprogram value.
--- Check that, for an access-to-subprogram type whose designated profile
--- contains parameters of a tagged generic formal type, an access-to-
--- subprogram value may designate dispatching and non-dispatching
--- operations, and that dereferences of such a value call the appropriate
--- subprogram.
---
--- TEST DESCRIPTION:
--- The test declares a tagged type (Table) with a dispatching operation
--- (Clear), as well as a derivative (Table2) which overrides that
--- operation. A subprogram with the same name and profile as Clear is
--- declared in a separate package -- it is therefore not a dispatching
--- operation of Table. For the purposes of the test, each version of Clear
--- modifies the components of its parameter in a unique way.
---
--- Additionally, an operation (Reset) of type Table is declared which
--- makes a re-dispatching call to Clear, i.e.,
---
--- procedure Reset (A: in out Table) is
--- begin
--- ...
--- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual.
--- ...
--- end Reset;
---
--- An access-to-subprogram type is declared within a generic package,
--- with a designated profile which declares a parameter of a generic
--- formal tagged private type.
---
--- The generic is instantiated with type Table. The instance defines an
--- array of access-to-subprogram values (which represents a table of
--- operations to be performed sequentially on a single operand).
--- Access values designating the dispatching version of Clear, the
--- non-dispatching version of Clear, and Reset (which re-dispatches to
--- Clear) are placed in this array.
---
--- In the instance, each subprogram in the array is called by implicitly
--- dereferencing the corresponding access value. For the dispatching and
--- non-dispatching versions of Clear, the actual parameter passed is of
--- type Table. For Reset, the actual parameter passed is a view conversion
--- of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
--- Since the tag of the operand never changes, the call to Clear within
--- Reset should execute Table2's version of Clear.
---
--- The main program verifies that the appropriate version of Clear is
--- called in each case, by checking that the components of the actual are
--- updated as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C640001_0 is
-
- -- Data type artificial for testing purposes.
-
- Row_Len : constant := 10;
-
- T : constant Boolean := True;
- F : constant Boolean := False;
-
- type Row_Type is array (1 .. Row_Len) of Boolean;
-
- function Is_True (A : in Row_Type) return Boolean;
- function Is_False (A : in Row_Type) return Boolean;
-
-
- Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
-
- type Table is tagged record -- Tagged type.
- Row1 : Row_Type := Init;
- Row2 : Row_Type := Init;
- end record;
-
- procedure Clear (A : in out Table); -- Dispatching operation.
-
- procedure Reset (A : in out Table); -- Re-dispatching operation.
-
- -- ...Other operations.
-
-
- type Table2 is new Table with null record; -- Extension of Table (but
- -- structurally identical).
-
- procedure Clear (A : in out Table2); -- Overrides parent's op.
-
- -- ...Other operations.
-
-
-end C640001_0;
-
-
- --===================================================================--
-
-
-package body C640001_0 is
-
- function Is_True (A : in Row_Type) return Boolean is
- begin
- for I in A'Range loop
- if A(I) /= True then -- Return true if all elements
- return False; -- of A are True.
- end if;
- end loop;
- return True;
- end Is_True;
-
-
- function Is_False (A : in Row_Type) return Boolean is
- begin
- return A = Row_Type'(others => False); -- Return true if all elements
- end Is_False; -- of A are False.
-
-
- procedure Clear (A : in out Table) is
- begin
- for I in Row_Type'Range loop -- This version of Clear sets
- A.Row1(I) := False; -- the elements of Row1 only
- end loop; -- to False.
- end Clear;
-
-
- procedure Reset (A : in out Table) is
- begin
- Clear (Table'Class(A)); -- Redispatch to appropriate
- -- ... Other "reset" activities. -- version of Clear.
- end Reset;
-
-
- procedure Clear (A : in out Table2) is
- begin
- for I in Row_Type'Range loop -- This version of Clear sets
- A.Row1(I) := True; -- the elements of Row1 only
- end loop; -- to True.
- end Clear;
-
-
-end C640001_0;
-
-
- --===================================================================--
-
-
-with C640001_0;
-package C640001_1 is
-
- procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation.
-
-end C640001_1;
-
-
- --===================================================================--
-
-
-package body C640001_1 is
-
- procedure Clear (T : in out C640001_0.Table) is
- begin
- for I in C640001_0.Row_Type'Range loop -- This version of Clear sets
- T.Row2(I) := True; -- the elements of Row2 only
- end loop; -- to True.
- end Clear;
-
-end C640001_1;
-
-
- --===================================================================--
-
-
--- This unit represents a support package for table-driven processing of
--- data objects. Process_Operand performs a set of operations are performed
--- sequentially on a single operand. Note that parameters are provided to
--- specify which subset of operations in the operations table are to be
--- performed (ordinarily these might be omitted, but the test requires that
--- each operation be called individually for a single operand).
-
-generic
- type Tag is tagged private;
-package C640001_2 is
-
- type Proc_Ptr is access procedure (P: in out Tag);
-
- type Op_List is private;
-
- procedure Add_Op (Op : in Proc_Ptr; -- Add operation to
- List : in out Op_List); -- to list of ops.
-
- procedure Process_Operand (Operand : in out Tag; -- Execute a subset
- List : in Op_List; -- of a list of
- First_Op : in Positive; -- operations using
- Last_Op : in Positive); -- a given operand.
-
- -- ...Other operations.
-
-private
- type Op_Array is array (1 .. 3) of Proc_Ptr;
-
- type Op_List is record
- Top : Natural := 0;
- Ops : Op_Array;
- end record;
-end C640001_2;
-
-
- --===================================================================--
-
-
-package body C640001_2 is
-
- procedure Add_Op (Op : in Proc_Ptr;
- List : in out Op_List) is
- begin
- List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection.
- List.Ops(List.Top) := Op;
- end Add_Op;
-
-
- procedure Process_Operand (Operand : in out Tag;
- List : in Op_List;
- First_Op : in Positive;
- Last_Op : in Positive) is
- begin
- for I in First_Op .. Last_Op loop
- List.Ops(I)(Operand); -- Implicit dereference of an
- end loop; -- access-to-subprogram value.
- end Process_Operand;
-
-end C640001_2;
-
-
- --===================================================================--
-
-
-with C640001_0;
-with C640001_1;
-with C640001_2;
-
-with Report;
-procedure C640001 is
-
- package Table_Support is new C640001_2 (C640001_0.Table);
-
- Sub_Ptr : Table_Support.Proc_Ptr;
- My_List : Table_Support.Op_List;
- My_Table1 : C640001_0.Table; -- Initial values of both Row1 &
- -- Row2 are (T,F,T,F,T,F,T,F,T,F).
- My_Table2 : C640001_0.Table2; -- Initial values of both Row1 &
- -- Row2 are (T,F,T,F,T,F,T,F,T,F).
-begin
- Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
- "whose designated profile contains parameters " &
- "of a tagged generic formal type, an access-" &
- "to-subprogram value may designate dispatching " &
- "and non-dispatching operations");
-
- --
- -- Add subprogram access values to list:
- --
-
- Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
-
- Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
-
- Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
-
-
- --
- -- Call dispatching operation:
- --
-
- Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op.
-
- if not C640001_0.Is_False (My_Table1.Row1) then
- Report.Failed ("Wrong result after calling dispatching operation");
- end if;
-
-
- --
- -- Call non-dispatching operation:
- --
-
- Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op.
-
- if not C640001_0.Is_True (My_Table1.Row2) then
- Report.Failed ("Wrong result after calling non-dispatching operation");
- end if;
-
-
- --
- -- Call re-dispatching operation:
- --
-
- Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv.
- My_List, 3, 3); -- Call 3rd op.
-
- if not C640001_0.Is_True (My_Table2.Row1) then
- Report.Failed ("Wrong result after calling re-dispatching operation");
- end if;
-
-
- Report.Result;
-end C640001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64002b.ada b/gcc/testsuite/ada/acats/tests/c6/c64002b.ada
deleted file mode 100644
index 2f71f32..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64002b.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C64002B.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 SUBPROGRAMS CAN BE CALLED WITH APPROPRIATE
--- NOTATION.
-
--- DAS 1/27/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64002B IS
-
- USE REPORT;
-
- I : INTEGER := 1;
-
- FUNCTION F0 RETURN INTEGER IS
- BEGIN
- RETURN 7;
- END F0;
-
- PROCEDURE P0 IS
- BEGIN
- I := 15;
- END P0;
-
-BEGIN
-
- TEST ("C64002B", "CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE" &
- " CALLED");
-
- IF (F0 /= 7) THEN
- FAILED ("PARAMETERLESS FUNCTION CALL RETURNS BAD VALUE");
- END IF;
-
- P0;
- IF (I /= 15) THEN
- FAILED ("PARAMETERLESS PROCEDURE CALL YIELDS INCORRECT" &
- " RESULT");
- END IF;
-
- RESULT;
-
-END C64002B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64004g.ada b/gcc/testsuite/ada/acats/tests/c6/c64004g.ada
deleted file mode 100644
index 005a3a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64004g.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C64004G.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 SUBPROGRAMS HAVING AT LEAST ONE DEFAULT
--- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND
--- FORMAL PARAMETERS.
-
--- DAS 1/27/81
-
-
-WITH REPORT;
-PROCEDURE C64004G IS
-
- USE REPORT;
-
- Y1,Y2,Y3 : INTEGER := 0;
- O1,O2 : INTEGER := 0;
-
- PROCEDURE P (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3;
- O1,O2,O3: OUT INTEGER) IS
- BEGIN
- O1 := I1;
- O2 := I2;
- O3 := I3;
- END P;
-
- FUNCTION F (I1: INTEGER := 1; I2: INTEGER) RETURN INTEGER IS
- BEGIN
- C64004G.O1 := I1;
- C64004G.O2 := I2;
- RETURN 1;
- END F;
-
-BEGIN
-
- TEST ("C64004G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL" &
- " PARAMETERS (HAVING DEFAULT VALUES)");
-
- P (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;
-
- P (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;
-
- P (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;
-
- P (41, 42, O1=>Y1, O2=>Y2, O3=>Y3);
- IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN
- FAILED ("INCORRECT PARANETER ASSOCIATION - 4");
- END IF;
-
- P (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;
-
- Y1 := F (I1=>61, I2=>62);
- IF (O1 /= 61) OR (O2 /= 62) THEN
- FAILED ("INCORRECT PARAMETER ASSOCIATION - 6");
- END IF;
-
- Y2 := F (I2=>72, I1=>71);
- IF (O1 /= 71) OR (O2 /= 72) THEN
- FAILED ("INCORRECT PARAMETER ASSOCIATION - 7");
- END IF;
-
- Y3 := F (I2=>82);
- IF (O1 /= 1) OR (O2 /= 82) THEN
- FAILED ("INCORRECT PARAMETER ASSOCIATION - 8");
- END IF;
-
- RESULT;
-
-END C64004G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005a.ada b/gcc/testsuite/ada/acats/tests/c6/c64005a.ada
deleted file mode 100644
index af5584e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C64005A.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 SUBPROGRAM CAN BE CALLED
--- RECURSIVELY AND THAT NON-LOCAL VARIABLES AND
--- CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN
--- RECURSIVE INVOCATIONS.
-
--- CVP 5/1/81
-
-WITH REPORT;
-PROCEDURE C64005A IS
-
- USE REPORT;
-
- TWENTY : CONSTANT INTEGER := 20;
- C1 : CONSTANT INTEGER := 1;
- I1, I2 : INTEGER := 0;
-
- PROCEDURE RECURSE (I1A : INTEGER; I2 : IN OUT INTEGER) IS
- C1 : CONSTANT INTEGER := 5;
- BEGIN
- IF I1A < TWENTY THEN
- RECURSE (I1A+C1, I2);
- I1 := I1 + C64005A.C1;
- I2 := I2 + I1A;
- END IF;
- END RECURSE;
-
-BEGIN
- TEST ("C64005A", "RECURSIVE SUBPROGRAMS WITH " &
- "NON-LOCAL DATA ACCESS");
-
- RECURSE (0, I2);
-
- IF I1 /= 4 OR I2 /= 30 THEN
- FAILED ("RECURSIVE PROCEDURE INVOCATIONS " &
- "WITH GLOBAL DATA ACCESS NOT PERFORMED " &
- "CORRECTLY");
- END IF;
-
- RESULT;
-END C64005A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005b.ada b/gcc/testsuite/ada/acats/tests/c6/c64005b.ada
deleted file mode 100644
index 5e3f4c5..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005b.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C64005B.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 SUBPROGRAM CAN BE CALLED RECURSIVELY AND THAT NON-LOCAL
--- VARIABLES AND CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN RECURSIVE
--- INVOCATIONS.
-
--- CPP 7/2/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64005B IS
-
- COUNT : INTEGER := 0;
- TWENTY : CONSTANT INTEGER := 20;
- C1 : CONSTANT INTEGER := 1;
- G1, G2, G3 : INTEGER := 0;
- G4, G5 : INTEGER := 0;
-
- PROCEDURE R (A1 : INTEGER; A2 : IN OUT INTEGER; A3 : OUT INTEGER)
- IS
- C1 : CONSTANT INTEGER := 5;
- TEN : CONSTANT INTEGER := 10;
- J1, J2 : INTEGER := 1;
- J3 : INTEGER := 0;
-
- PROCEDURE RECURSE (P1 : INTEGER; P2 : IN OUT INTEGER) IS
- C1 : INTEGER := 2;
- BEGIN -- RECURSE
- C1 := IDENT_INT (10);
- IF P1 < TWENTY THEN
- RECURSE (P1 + C1, G2);
- G1 := G1 + C64005B.C1;
- G3 := G3 + P1;
- P2 := P2 + IDENT_INT(2);
- A2 := A2 + IDENT_INT(1);
- J2 := J2 + R.C1;
- END IF;
- END RECURSE;
-
- BEGIN -- R
- IF A2 < TEN THEN
- A2 := A2 + C1;
- RECURSE (0, J1);
- J3 := J3 + TEN;
- COUNT := COUNT + 1;
- COMMENT ("ON PASS # " & INTEGER'IMAGE(COUNT));
- COMMENT ("VALUE OF A2 IS " & INTEGER'IMAGE(A2));
- COMMENT ("VALUE OF J3 IS " & INTEGER'IMAGE(J3));
- R (0, A2, J3);
- J3 := J3 + A2;
- END IF;
- A3 := J1 + J3;
- END R;
-
-BEGIN
- TEST("C64005B", "RECURSIVE SUBPROGRAMS WITH ALL KINDS " &
- "OF DATA ACCESS");
-
- R (0, G4, G5);
-
- IF (COUNT /= 2) OR (G1 /= 4) OR
- (G2 /= 4) OR (G3 /= 20) OR
- (G4 /= 14) OR (G5 /= 35) THEN
- FAILED ("RECURSIVE INVOCATIONS' DATA ACCESS IS NOT" &
- " WORKING CORRECTLY");
- END IF;
-
- COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
- COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
- COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
- COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
- COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
- COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
-
- RESULT;
-
-EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED ("PROGRAM_ERROR RAISED");
- COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
- COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
- COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
- COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
- COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
- COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
- RESULT;
-
-END C64005B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005c.ada b/gcc/testsuite/ada/acats/tests/c6/c64005c.ada
deleted file mode 100644
index ccb0a2a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005c.ada
+++ /dev/null
@@ -1,330 +0,0 @@
--- C64005C.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 NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
--- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
--- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
--- STATIC CHAIN LEVEL CAN BE ACCESSED.
-
--- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES.
-
--- JRK 7/26/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C64005C IS
-
- SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
- SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
-
- MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
- MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
- G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
-
- TYPE TRACE IS
- RECORD
- E : NATURAL := 0;
- S : STRING (1 .. T_LEN);
- END RECORD;
-
- V : CHARACTER := IDENT_CHAR ('<');
- L : CHARACTER := IDENT_CHAR ('>');
- T : TRACE;
- G : STRING (1 .. G_LEN);
-
- PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
- PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
- PROCEDURE C64005CC (L : LEVEL; C : CALL;
- T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
- BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_C);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
- C64005CB.V & C64005CC.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005CA (IDENT_CHAR(LEVEL'FIRST),
- IDENT_CHAR('2'), T);
-
- WHEN '2' =>
- C64005CC (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- -- APPEND MID-POINT SYMBOL TO T.
- T.S (T.E+1) := IDENT_CHAR ('=');
- T.E := T.E + 1;
-
- -- G := CATENATE ALL V, L, C;
- G := C64005C.V & C64005C.L &
- C64005CA.V & C64005CA.L & C64005CA.C &
- C64005CB.V & C64005CB.L & C64005CB.C &
- C64005CC.V & C64005CC.L & C64005CC.C;
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C &
- C64005CB.L & C64005CB.C &
- C64005CA.L & C64005CA.C &
- C64005C.L;
- T.E := T.E + N;
-
- END C64005CC;
-
- BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_B);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
- C64005CB.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
-
- WHEN '2' =>
- C64005CB (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C &
- C64005CA.L & C64005CA.C &
- C64005C.L;
- T.E := T.E + N;
-
- END C64005CB;
-
- BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_A);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
-
- WHEN '2' =>
- C64005CA (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L;
- T.E := T.E + N;
-
- END C64005CA;
-
-BEGIN
- TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
- "PARAMETERS AT ALL LEVELS OF NESTED " &
- "RECURSIVE PROCEDURES ARE ACCESSIBLE");
-
- -- APPEND V TO T.
- T.S (T.E+1) := V;
- T.E := T.E + 1;
-
- C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
-
- -- APPEND L TO T.
- T.S (T.E+1) := L;
- T.E := T.E + 1;
-
- COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
- COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
- COMMENT ("GLOBAL SNAPSHOT IS: " & G);
-
- -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
-
- DECLARE
- SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
- CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
-
- CT : TRACE;
- CG : STRING (1 .. G_LEN);
- BEGIN
- COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
- INTEGER'IMAGE(T_LEN));
-
- IF T.E /= IDENT_INT (T_LEN) THEN
- FAILED ("WRONG FINAL CALL TRACE LENGTH");
-
- ELSE CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR I IN LC_LEVEL LOOP
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '1';
- CT.E := CT.E + 2;
- END LOOP;
- END LOOP;
-
- FOR I IN LC_LEVEL LOOP
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := I;
- CT.S (CT.E+2) := '2';
- CT.E := CT.E + 2;
-
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
- END LOOP;
-
- CT.S (CT.E+1) := '=';
- CT.E := CT.E + 1;
-
- FOR I IN REVERSE LEVEL LOOP
- FOR J IN REVERSE LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
-
- CT.S (CT.E+1) := I;
- CT.S (CT.E+2) := '2';
- CT.E := CT.E + 2;
-
- FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
- END LOOP;
-
- FOR I IN REVERSE LEVEL LOOP
- FOR J IN REVERSE LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '1';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
-
- IF CT.E /= IDENT_INT (T_LEN) THEN
- FAILED ("WRONG ITERATIVE TRACE LENGTH");
-
- ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
-
- IF T.S /= CT.S THEN
- FAILED ("WRONG FINAL CALL TRACE");
- END IF;
- END IF;
- END IF;
-
- DECLARE
- E : NATURAL := 0;
- BEGIN
- CG (1..2) := "<>";
- E := E + 2;
-
- FOR I IN LEVEL LOOP
- CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
- LEVEL'POS(LEVEL'FIRST) +
- LC_LEVEL'POS
- (LC_LEVEL'FIRST));
- CG (E+2) := '3';
- CG (E+3) := I;
- CG (E+4) := '3';
- E := E + 4;
- END LOOP;
-
- COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
-
- IF G /= CG THEN
- FAILED ("WRONG GLOBAL SNAPSHOT");
- END IF;
- END;
- END;
-
- RESULT;
-END C64005C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada b/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada
deleted file mode 100644
index adc8a0b..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada
+++ /dev/null
@@ -1,219 +0,0 @@
--- C64005D0M.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 NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
--- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
--- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
--- STATIC CHAIN LEVEL CAN BE ACCESSED.
-
--- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES (SEPARATELY
--- COMPILED AS SUBUNITS).
-
--- SEPARATE FILES ARE:
--- C64005D0M THE MAIN PROCEDURE.
--- C64005DA A RECURSIVE PROCEDURE SUBUNIT OF C64005D0M.
--- C64005DB A RECURSIVE PROCEDURE SUBUNIT OF C64005DA.
--- C64005DC A RECURSIVE PROCEDURE SUBUNIT OF C64005DB.
-
--- JRK 7/30/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C64005D0M IS
-
- SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
- SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
-
- MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
- MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
- G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
-
- TYPE TRACE IS
- RECORD
- E : NATURAL := 0;
- S : STRING (1 .. T_LEN);
- END RECORD;
-
- V : CHARACTER := IDENT_CHAR ('<');
- L : CHARACTER := IDENT_CHAR ('>');
- T : TRACE;
- G : STRING (1 .. G_LEN);
-
- PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
- SEPARATE;
-
-BEGIN
- TEST ("C64005D", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
- "PARAMETERS AT ALL LEVELS OF NESTED " &
- "RECURSIVE PROCEDURES ARE ACCESSIBLE (FOR " &
- "3 LEVELS OF SEPARATELY COMPILED SUBUNITS)");
-
- -- APPEND V TO T.
- T.S (T.E+1) := V;
- T.E := T.E + 1;
-
- C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
-
- -- APPEND L TO T.
- T.S (T.E+1) := L;
- T.E := T.E + 1;
-
- COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
- COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
- COMMENT ("GLOBAL SNAPSHOT IS: " & G);
-
- -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
-
- DECLARE
- SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
- CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
-
- CT : TRACE;
- CG : STRING (1 .. G_LEN);
- BEGIN
- COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
- INTEGER'IMAGE(T_LEN));
-
- IF T.E /= IDENT_INT (T_LEN) THEN
- FAILED ("WRONG FINAL CALL TRACE LENGTH");
-
- ELSE CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR I IN LC_LEVEL LOOP
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '1';
- CT.E := CT.E + 2;
- END LOOP;
- END LOOP;
-
- FOR I IN LC_LEVEL LOOP
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := I;
- CT.S (CT.E+2) := '2';
- CT.E := CT.E + 2;
-
- CT.S (CT.E+1) := '<';
- CT.E := CT.E + 1;
-
- FOR J IN LC_LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
- END LOOP;
-
- CT.S (CT.E+1) := '=';
- CT.E := CT.E + 1;
-
- FOR I IN REVERSE LEVEL LOOP
- FOR J IN REVERSE LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
-
- CT.S (CT.E+1) := I;
- CT.S (CT.E+2) := '2';
- CT.E := CT.E + 2;
-
- FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '3';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
- END LOOP;
-
- FOR I IN REVERSE LEVEL LOOP
- FOR J IN REVERSE LEVEL'FIRST .. I LOOP
- CT.S (CT.E+1) := J;
- CT.S (CT.E+2) := '1';
- CT.E := CT.E + 2;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
- END LOOP;
-
- CT.S (CT.E+1) := '>';
- CT.E := CT.E + 1;
-
- IF CT.E /= IDENT_INT (T_LEN) THEN
- FAILED ("WRONG ITERATIVE TRACE LENGTH");
-
- ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
-
- IF T.S /= CT.S THEN
- FAILED ("WRONG FINAL CALL TRACE");
- END IF;
- END IF;
- END IF;
-
- DECLARE
- E : NATURAL := 0;
- BEGIN
- CG (1..2) := "<>";
- E := E + 2;
-
- FOR I IN LEVEL LOOP
- CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
- LEVEL'POS(LEVEL'FIRST) +
- LC_LEVEL'POS
- (LC_LEVEL'FIRST));
- CG (E+2) := '3';
- CG (E+3) := I;
- CG (E+4) := '3';
- E := E + 4;
- END LOOP;
-
- COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
-
- IF G /= CG THEN
- FAILED ("WRONG GLOBAL SNAPSHOT");
- END IF;
- END;
- END;
-
- RESULT;
-END C64005D0M;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005da.ada b/gcc/testsuite/ada/acats/tests/c6/c64005da.ada
deleted file mode 100644
index 33a50aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005da.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C64005DA.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.
---*
--- JRK 7/30/84
-
-SEPARATE (C64005D0M)
-
-PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
- PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
- SEPARATE;
-
-BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_A);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005DB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
-
- WHEN '2' =>
- C64005DA (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- C64005DB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005DA.L & C64005DA.C & C64005D0M.L;
- T.E := T.E + N;
-
-END C64005DA;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005db.ada b/gcc/testsuite/ada/acats/tests/c6/c64005db.ada
deleted file mode 100644
index 92a5892a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005db.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- C64005DB.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.
---*
--- JRK 7/30/84
-
-SEPARATE (C64005D0M.C64005DA)
-
-PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
- PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
- SEPARATE;
-
-BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_B);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005DC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
-
- WHEN '2' =>
- C64005DB (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- C64005DC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005DB.L & C64005DB.C &
- C64005DA.L & C64005DA.C &
- C64005D0M.L;
- T.E := T.E + N;
-
-END C64005DB;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada b/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada
deleted file mode 100644
index 45e8a5e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C64005DC.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.
---*
--- JRK 7/30/84
-
-SEPARATE (C64005D0M.C64005DA.C64005DB)
-
-PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
-
- V : STRING (1..2);
-
- M : CONSTANT NATURAL := LEVEL'POS (L) -
- LEVEL'POS (LEVEL'FIRST) + 1;
- N : CONSTANT NATURAL := 2 * M + 1;
-
-BEGIN
-
- V (1) := IDENT_CHAR (ASCII.LC_C);
- V (2) := C;
-
- -- APPEND ALL V TO T.
- T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V &
- C64005DC.V;
- T.E := T.E + N;
-
- CASE C IS
-
- WHEN '1' =>
- C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('2'), T);
-
- WHEN '2' =>
- C64005DC (L, IDENT_CHAR('3'), T);
-
- WHEN '3' =>
- -- APPEND MID-POINT SYMBOL TO T.
- T.S (T.E+1) := IDENT_CHAR ('=');
- T.E := T.E + 1;
-
- -- G := CATENATE ALL V, L, C;
- G := C64005D0M.V & C64005D0M.L &
- C64005DA.V & C64005DA.L & C64005DA.C &
- C64005DB.V & C64005DB.L & C64005DB.C &
- C64005DC.V & C64005DC.L & C64005DC.C;
- END CASE;
-
- -- APPEND ALL L AND C TO T IN REVERSE ORDER.
- T.S (T.E+1 .. T.E+N) := C64005DC.L & C64005DC.C &
- C64005DB.L & C64005DB.C &
- C64005DA.L & C64005DA.C &
- C64005D0M.L;
- T.E := T.E + N;
-
-END C64005DC;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c641001.a b/gcc/testsuite/ada/acats/tests/c6/c641001.a
deleted file mode 100644
index 84ee58a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c641001.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- C641001.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 actual parameters passed by reference are view converted
--- to the nominal subtype of the formal parameter.
---
--- TEST DESCRIPTION:
--- Check that sliding is allowed for formal parameters, especially
--- check cases that would have caused errors in Ada'83.
--- Check that length check for a formal parameter (esp out mode)
--- is performed before the call, not after.
---
--- notes: 6.2; by reference ::= tagged, task, protected,
--- limited (nonprivate), or composite containing such
--- 4.6; view conversion
---
---
--- CHANGE HISTORY:
--- 26 JAN 96 SAIC Initial version
--- 04 NOV 96 SAIC Commentary revision for release 2.1
--- 27 FEB 97 PWB.CTA Corrected reference to the wrong string
---!
-
------------------------------------------------------------------ C641001_0
-
-package C641001_0 is
-
- subtype String_10 is String(1..10);
-
- procedure Check_String_10( S : out String_10; Start, Stop: Natural );
-
- procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
- Index: Natural );
-
- type Tagged_Data(Bound: Natural) is tagged record
- Data_Item : String(1..Bound) := (others => '*');
- end record;
-
- type Tag_List is array(Natural range <>) of Tagged_Data(5);
-
- subtype Tag_List_10 is Tag_List(1..10);
-
- procedure Check_Tag_Slice( TL : in out Tag_List_10 );
-
- procedure Check_Out_Tagged_Data( Formal : out Tagged_Data );
-
-end C641001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C641001_0 is
-
- String_Data : constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
- procedure Check_String_10( S : out String_10; Start, Stop: Natural ) is
- begin
- if S'Length /= 10 then
- Report.Failed("Length check not performed prior to execution");
- end if;
- S := String_Data(Start..Stop);
- exception
- when others => Report.Failed("Exception encountered in Check_String_10");
- end Check_String_10;
-
- procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
- Index: Natural ) is
- begin
- -- essentially "do-nothing" for optimization foilage...
- if Slice_Passed(Index) in Character then
- -- Intent is ^^^^^ should raise Constraint_Error
- Report.Failed("Illegal Slice provided legal character");
- else
- Report.Failed("Illegal Slice provided illegal character");
- end if;
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Illegal_Slice_Reference");
- end Check_Illegal_Slice_Reference;
-
- procedure Check_Tag_Slice( TL : in out Tag_List_10 ) is
- -- if the view conversion is not performed, one of the following checks
- -- will fail (given data passed as 0..9 and then 2..11)
- begin
- Check_Under_Index: -- index 0 should raise C_E
- begin
- TCTouch.Assert( TL(Report.Ident_Int(0)).Data_Item = "*****",
- "Index 0 (illegal); bad data" );
- Report.Failed("Index 0 did not raise Constraint_Error");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Under_Index ");
- end Check_Under_Index;
-
- Check_Over_Index: -- index 11 should raise C_E
- begin
- TCTouch.Assert( TL(Report.Ident_Int(11)).Data_Item = "*****",
- "Index 11 (illegal); bad data" );
- Report.Failed("Index 11 did not raise Constraint_Error");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Over_Index ");
- end Check_Over_Index;
-
- end Check_Tag_Slice;
-
- procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ) is
- begin
- TCTouch.Assert( Formal.Data_Item = "*****", "out formal data bad" );
- Formal.Data_Item(1) := '!';
- end Check_Out_Tagged_Data;
-
-end C641001_0;
-
-------------------------------------------------------------------- C641001
-
-with Report;
-with TCTouch;
-with C641001_0;
-procedure C641001 is
-
- function II( I: Integer ) return Integer renames Report.Ident_Int;
- -- ^^ name chosen to allow embedding in calls
-
- A_String_10 : C641001_0.String_10;
- Slicable : String(1..40);
- Tag_Slices : C641001_0.Tag_List(0..11);
-
- Global_Data : String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
- procedure Check_Out_Sliding( Lo1, Hi1, Lo2, Hi2 : Natural ) is
-
- subtype One_Constrained_String is String(Lo1..Hi1); -- 1 5
- subtype Two_Constrained_String is String(Lo2..Hi2); -- 6 10
-
- procedure Out_Param( Param : out One_Constrained_String ) is
- begin
- Param := Report.Ident_Str( Global_Data(Lo2..Hi2) );
- end Out_Param;
- Object : Two_Constrained_String;
- begin
- Out_Param( Object );
- if Object /= Report.Ident_Str( Global_Data(Lo2..Hi2) ) then
- Report.Failed("Bad result in Check_Out_Sliding");
- end if;
- exception
- when others => Report.Failed("Exception in Check_Out_Sliding");
- end Check_Out_Sliding;
-
- procedure Check_Dynamic_Subtype_Cases(F_Lower,F_Upper: Natural;
- A_Lower,A_Upper: Natural) is
-
- subtype Dyn_String is String(F_Lower..F_Upper);
-
- procedure Check_Dyn_Subtype_Formal_Out( Param : out Dyn_String ) is
- begin
- Param := Global_Data(11..20);
- end Check_Dyn_Subtype_Formal_Out;
-
- procedure Check_Dyn_Subtype_Formal_In( Param : in Dyn_String ) is
- begin
- if Param /= Global_Data(11..20) then
- Report.Failed("Dynamic case, data mismatch");
- end if;
- end Check_Dyn_Subtype_Formal_In;
-
- Stuff: String(A_Lower..A_Upper);
-
- begin
- Check_Dyn_Subtype_Formal_Out( Stuff );
- Check_Dyn_Subtype_Formal_In( Stuff );
- end Check_Dynamic_Subtype_Cases;
-
-begin -- Main test procedure.
-
- Report.Test ("C641001", "Check that actual parameters passed by " &
- "reference are view converted to the nominal " &
- "subtype of the formal parameter" );
-
- -- non error cases for string slices
-
- C641001_0.Check_String_10( A_String_10, 1, 10 );
- TCTouch.Assert( A_String_10 = "1234567890", "Nominal case" );
-
- C641001_0.Check_String_10( A_String_10, 11, 20 );
- TCTouch.Assert( A_String_10 = "ABCDEFGHIJ", "Sliding to subtype" );
-
- C641001_0.Check_String_10( Slicable(1..10), 1, 10 );
- TCTouch.Assert( Slicable(1..10) = "1234567890", "Slice, no sliding" );
-
- C641001_0.Check_String_10( Slicable(1..10), 21, 30 );
- TCTouch.Assert( Slicable(1..10) = "KLMNOPQRST", "Sliding to slice" );
-
- C641001_0.Check_String_10( Slicable(11..20), 11, 20 );
- TCTouch.Assert( Slicable(11..20) = "ABCDEFGHIJ", "Sliding to same" );
-
- C641001_0.Check_String_10( Slicable(21..30), 11, 20 );
- TCTouch.Assert( Slicable(21..30) = "ABCDEFGHIJ", "Sliding up" );
-
- -- error cases for string slices
-
- C641001_0.Check_Illegal_Slice_Reference( Slicable(21..30), 20 );
-
- C641001_0.Check_Illegal_Slice_Reference( Slicable(1..15), Slicable'Last );
-
- -- checks for view converting actuals to formals
-
- -- catch low bound fault
- C641001_0.Check_Tag_Slice( Tag_Slices(II(0)..9) ); -- II ::= Ident_Int
- TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
- TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
-
- -- catch high bound fault
- C641001_0.Check_Tag_Slice( Tag_Slices(2..II(11)) );
- TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
- TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
-
- Check_Formal_Association_Check:
- begin
- C641001_0.Check_String_10( Slicable, 1, 10 ); -- catch length fault
- Report.Failed("Exception not raised at Check_Formal_Association_Check");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception at Check_Formal_Association_Check");
- end Check_Formal_Association_Check;
-
- -- check for constrained actual, unconstrained formal
- C641001_0.Check_Out_Tagged_Data( Tag_Slices(5) );
- TCTouch.Assert( Tag_Slices(5).Data_Item = "!****",
- "formal out returned bad result" );
-
- -- additional checks for out mode formal parameters, dynamic subtypes
-
- Check_Out_Sliding( II(1),II(5), II(6),II(10) );
-
- Check_Out_Sliding( 21,25, 6,10 );
-
- Check_Dynamic_Subtype_Cases(F_Lower => II(1), F_Upper => II(10),
- A_Lower => II(1), A_Upper => II(10));
-
- Check_Dynamic_Subtype_Cases(F_Lower => II(21), F_Upper => II(30),
- A_Lower => II( 1), A_Upper => II(10));
-
- Check_Dynamic_Subtype_Cases(F_Lower => II( 1), F_Upper => II(10),
- A_Lower => II(21), A_Upper => II(30));
-
- Report.Result;
-
-end C641001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103b.ada b/gcc/testsuite/ada/acats/tests/c6/c64103b.ada
deleted file mode 100644
index 3af6c61..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64103b.ada
+++ /dev/null
@@ -1,379 +0,0 @@
--- C64103B.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 IN-OUT PARAMETERS OF A SCALAR TYPE,
--- CONSTRAINT_ERROR IS RAISED:
--- BEFORE A SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL
--- PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL PARAMETER'S
--- SUBTYPE;
--- AFTER A SUBPROGRAM CALL WHEN THE CONVERTED FORMAL PARAMETER
--- IS OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S SUBTYPE.
-
--- HISTORY:
--- CPP 07/18/84 CREATED ORIGINAL TEST.
--- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
--- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
--- SUBTEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64103B IS
-BEGIN
- TEST ("C64103B", "FOR IN-OUT PARAMETERS OF A SCALAR TYPE, " &
- "CONSTRAINT_ERROR IS RAISED: BEFORE A " &
- "SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL " &
- "PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL " &
- "PARAMETER'S SUBTYPE; AFTER A SUBPROGRAM " &
- "CALL WHEN THE CONVERTED FORMAL PARAMETER IS " &
- "OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S " &
- "SUBTYPE");
-
-
- DECLARE
- A0 : INTEGER := -9;
- A1 : INTEGER := IDENT_INT(-1);
- TYPE SUBINT IS RANGE -8 .. -2;
-
- TYPE FLOAT_TYPE IS DIGITS 3 RANGE 0.0 .. 3.0;
- A2 : FLOAT_TYPE := 0.12;
- A3 : FLOAT_TYPE := 2.5;
- TYPE NEW_FLOAT IS DIGITS 3 RANGE 1.0 .. 2.0;
-
- TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
- A4 : FIXED_TYPE := -2.0;
- A5 : FIXED_TYPE := 4.0;
- TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
-
- A6 : CHARACTER := 'A';
- SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
-
- TYPE COLOR IS (RED, BURGUNDY, LILAC, MAROON, MAGENTA);
- SUBTYPE A_COLOR IS COLOR RANGE RED..LILAC;
- SUBTYPE B_COLOR IS COLOR RANGE MAROON..MAGENTA;
- A7 : B_COLOR := MAROON;
-
- PROCEDURE P1 (X : IN OUT SUBINT;
- S : STRING) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (A" &
- S & ")");
- END P1;
-
- PROCEDURE P2 (X : IN OUT NEW_FLOAT;
- S : STRING) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A" &
- S & ")");
- END P2;
-
- PROCEDURE P3 (X : IN OUT NEW_FIXED;
- S : STRING) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P3 (A" &
- S & ")");
- END P3;
-
- PROCEDURE P4 (X : IN OUT SUPER_CHAR;
- S : STRING) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P4 (A" &
- S & ")");
- END P4;
-
- PROCEDURE P5 (X : IN OUT A_COLOR;
- S : STRING) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P5 (A" &
- S & ")");
- END P5;
- BEGIN
- BEGIN
- P1 (SUBINT (A0), "1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (A1)");
- END;
-
- BEGIN
- P1 (SUBINT (A1), "2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (A2)");
- END;
-
- BEGIN
- P2 (NEW_FLOAT (A2), "1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (A1)");
- END;
-
- BEGIN
- P2 (NEW_FLOAT (A3), "2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (A2)");
- END;
-
- BEGIN
- P3 (NEW_FIXED (A4), "1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (A1)");
- END;
-
- BEGIN
- P3 (NEW_FIXED (A5), "2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (A2)");
- END;
-
- BEGIN
- P4 (SUPER_CHAR (A6),"1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P4 (A1)");
- END;
-
- BEGIN
- P5 (A_COLOR (A7), "1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P5 (A1)");
- END;
- END;
-
-
- DECLARE
- CALLED : BOOLEAN;
- TYPE SUBINT IS RANGE -8 .. -2;
- A0 : SUBINT := -3;
- A1 : INTEGER := -9;
- A2 : INTEGER := -1;
-
- TYPE FLOAT IS DIGITS 3 RANGE -1.0 .. 2.0;
- TYPE A_FLOAT IS DIGITS 3 RANGE 0.0 .. 1.0;
- A3 : A_FLOAT := 1.0;
- A4 : FLOAT := -0.5;
- A5 : FLOAT := 1.5;
-
- TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
- A6 : NEW_FIXED := 0.0;
- TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
- A7 : FIXED_TYPE := -2.0;
- A8 : FIXED_TYPE := 4.0;
-
- SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
- A9 : SUPER_CHAR := 'C';
- A10 : CHARACTER := 'A';
- A11 : CHARACTER := 'R';
-
- PROCEDURE P1 (X : IN OUT INTEGER; Y : INTEGER) IS
- BEGIN
- CALLED := TRUE;
- X := IDENT_INT (Y);
- END P1;
-
- PROCEDURE P2 (X : IN OUT FLOAT; Y : FLOAT) IS
- BEGIN
- CALLED := TRUE;
- X := Y;
- END P2;
-
- PROCEDURE P3 ( X : IN OUT FIXED_TYPE; Y : FIXED_TYPE) IS
- BEGIN
- CALLED := TRUE;
- X := Y;
- END P3;
-
- PROCEDURE P4 (X : IN OUT CHARACTER; Y : CHARACTER) IS
- BEGIN
- CALLED := TRUE;
- X := IDENT_CHAR(Y);
- END P4;
- BEGIN
- BEGIN
- CALLED := FALSE;
- P1 (INTEGER(A0), A1);
- IF A0 = -3 THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P1 (B1)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P1 (INTEGER(A0), A2);
- IF A0 = -3 THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B3)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P1 (B2)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P2 (FLOAT (A3), A4);
- IF A3 = 1.0 THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P2 (B1)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (B1)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P2 (FLOAT (A3), A5);
- IF A3 = 1.0 THEN
- FAILED ("EXCEPTION NOT RAISED -P2 (B3)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED -P2 (B4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P2 (B2)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (B2)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P3 (FIXED_TYPE (A6), A7);
- IF A6 = 0.0 THEN
- FAILED ("EXCEPTION NOT RAISED -P3 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED -P3 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P3 (B1)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (B1)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P3 (FIXED_TYPE (A6), A8);
- IF A6 = 0.0 THEN
- FAILED ("EXCEPTION NOT RAISED -P3 (B3)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED -P3 (B4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P3 (B2)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (B2)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P4 (CHARACTER (A9), A10);
- IF A9 = 'C' THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P4 (B1)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P4 (B1)");
- END;
-
- BEGIN
- CALLED := FALSE;
- P4 (CHARACTER (A9), A11);
- IF A9 = 'C' THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B3)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B4)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P4 (B2)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P4 (B2)");
- END;
- END;
-
- RESULT;
-END C64103B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103c.ada b/gcc/testsuite/ada/acats/tests/c6/c64103c.ada
deleted file mode 100644
index c08ef86..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64103c.ada
+++ /dev/null
@@ -1,230 +0,0 @@
--- C64103C.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 APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
--- ON IN OUT ARRAY PARAMETERS. IN PARTICULAR:
--- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
--- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
--- CONSTRAINTS.
--- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
--- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--- OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE
--- AI-00313 FOR MULTIDIMENSIONAL CASE)
--- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
--- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
--- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
--- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
--- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
-
--- *** 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
-
--- CPP 07/19/84
--- JBG 06/05/85
--- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE C64103C IS
-
- BEGIN
- TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
- "TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS");
-
- -----------------------------------------------
-
- DECLARE -- (A)
- BEGIN -- (A)
-
- DECLARE
- TYPE SUBINT IS RANGE 0..8;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
-
- PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS
- BEGIN
- NULL;
- END P2;
- BEGIN
- P2 (ARRAY_TYPE (A0)); -- OK.
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED -P2 (A)");
- END;
-
- END; -- (A)
-
- -----------------------------------------------
-
- DECLARE -- (B1) NON-NULL ACTUAL PARAMETER
-
- TYPE SUBINT IS RANGE 0..8;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A1 : AR1 (-1..7) := (-1..7 => TRUE);
- A2 : AR1 (1..9) := (1..9 => TRUE);
-
- PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
- END P1;
-
- BEGIN -- (B1)
-
- BEGIN
- COMMENT ("CALL TO P1 (B1) ON A1");
- P1 (ARRAY_TYPE (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
- END;
-
- BEGIN
- COMMENT ("CALL TO P1 (B1) ON A2");
- P1 (ARRAY_TYPE (A2));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
- END;
-
- END; -- (B1)
-
- DECLARE -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL
-
- TYPE SUBINT IS RANGE 0..8;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>,
- SUBINT RANGE <>) OF BOOLEAN;
- TYPE AR1 IS ARRAY (INTEGER RANGE <>,
- INTEGER RANGE <>)OF BOOLEAN;
- A1 : AR1 (IDENT_INT(-1)..7, 5..4) :=
- (OTHERS => (OTHERS => TRUE));
- A2 : AR1 (5..4, 1..IDENT_INT(9)) :=
- (OTHERS => (OTHERS => TRUE));
- PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
- END P1;
-
- BEGIN -- (B2)
-
- BEGIN
- COMMENT ("CALL TO P1 (B2) ON A1");
- P1 (ARRAY_TYPE (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
- END;
-
- BEGIN
- COMMENT ("CALL TO P1 (B2) ON A2");
- P1 (ARRAY_TYPE (A2));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
- END;
-
- END; -- (B2)
-
- -----------------------------------------------
-
- BEGIN -- (C)
-
- DECLARE
- TYPE INDEX1 IS RANGE 1..3;
- TYPE INDEX2 IS RANGE 1..4;
- TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
- A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
-
- TYPE I1 IS RANGE 1..4;
- TYPE I2 IS RANGE 1..3;
- TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
-
- PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
- END P1;
- BEGIN
- P1 (ARRAY_TYPE (A0));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
- END;
-
- END; -- (C)
-
- -----------------------------------------------
-
- DECLARE -- (D)
- BEGIN -- (D)
-
- DECLARE
- TYPE SM_INT IS RANGE 0..2;
- TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT;
- SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 ..
- SYSTEM.MAX_INT;
- TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
- TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
- A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
- (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
-
- PROCEDURE P1 (X : IN OUT AR_SMALL) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
- END P1;
- BEGIN
- IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
- P1 (AR_SMALL (A0));
- ELSE
- COMMENT ("NOT APPLICABLE -P1 (D)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
- END;
-
- END; -- (D)
-
- -----------------------------------------------
-
- RESULT;
-
-END C64103C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103d.ada b/gcc/testsuite/ada/acats/tests/c6/c64103d.ada
deleted file mode 100644
index 180dab0..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64103d.ada
+++ /dev/null
@@ -1,187 +0,0 @@
--- C64103D.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 APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
--- ON OUT ARRAY PARAMETERS. IN PARTICULAR:
--- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
--- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
--- CONSTRAINTS.
--- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
--- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--- OUTSIDE OF A FORMAL INDEX SUBTYPE.
--- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
--- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
--- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
--- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
--- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
--- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
-
--- *** 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
-
--- CPP 07/19/84
--- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE C64103D IS
-
- BEGIN
- TEST ("C64103D", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
- "TYPE CONVERSIONS OF OUT ARRAY PARAMETERS");
-
- -----------------------------------------------
-
- DECLARE -- (A)
- BEGIN -- (A)
-
- DECLARE
- TYPE SUBINT IS RANGE 0..8;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
-
- PROCEDURE P2 (X : OUT ARRAY_TYPE) IS
- BEGIN
- NULL;
- END P2;
- BEGIN
- P2 (ARRAY_TYPE (A0)); -- OK.
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED -P2 (A)");
- END;
-
- END; -- (A)
-
- -----------------------------------------------
-
- DECLARE -- (B)
-
- TYPE SUBINT IS RANGE 0..8;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- A1 : AR1 (-1..7) := (-1..7 => TRUE);
- A2 : AR1 (1..9) := (1..9 => TRUE);
-
- PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
- END P1;
-
- BEGIN -- (B)
-
- BEGIN
- COMMENT ("CALL TO P1 (B) ON A1");
- P1 (ARRAY_TYPE (A1));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
- END;
-
- BEGIN
- COMMENT ("CALL TO P1 (B) ON A2");
- P1 (ARRAY_TYPE (A2));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
- END;
-
- END; -- (B)
-
- -----------------------------------------------
-
- DECLARE -- (C)
- BEGIN -- (C)
-
- DECLARE
- TYPE INDEX1 IS RANGE 1..3;
- TYPE INDEX2 IS RANGE 1..4;
- TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
- A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
-
- TYPE I1 IS RANGE 1..4;
- TYPE I2 IS RANGE 1..3;
- TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
-
- PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
- END P1;
- BEGIN
- P1 (ARRAY_TYPE (A0));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
- END;
-
- END; -- (C)
-
- -----------------------------------------------
-
- DECLARE -- (D)
- BEGIN -- (D)
-
- DECLARE
- TYPE SM_INT IS RANGE 0..2;
- TYPE LG_INT IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
- TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
- TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
- A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
- (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
-
- PROCEDURE P1 (X : OUT AR_SMALL) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
- END P1;
- BEGIN
- IF LG_INT (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
- P1 (AR_SMALL (A0));
- ELSE
- COMMENT ("NOT APPLICABLE -P1 (D)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
- END;
-
- END; -- (D)
-
- -----------------------------------------------
-
- RESULT;
-
-END C64103D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103e.ada b/gcc/testsuite/ada/acats/tests/c6/c64103e.ada
deleted file mode 100644
index 7f022df..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64103e.ada
+++ /dev/null
@@ -1,219 +0,0 @@
--- C64103E.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 IN-OUT PARAMETERS OF AN ACCESS TYPE,
--- CONSTRAINT_ERROR IS RAISED:
--- BEFORE A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
--- OF THE ACTUAL DESIGNATED PARAMETER ARE DIFFERENT FROM
--- THOSE OF THE FORMAL DESIGNATED PARAMETER;
--- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
--- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
--- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
-
--- HISTORY:
--- CPP 07/23/84 CREATED ORIGINAL TEST.
--- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
--- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
--- SUBTEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64103E IS
-BEGIN
- TEST ("C64103E", "FOR IN-OUT PARAMETERS OF AN ACCESS TYPE, " &
- "CONSTRAINT_ERROR IS RAISED: BEFORE A " &
- "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
- "DISCRIMINANTS OF THE ACTUAL DESIGNATED " &
- "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
- "FORMAL DESIGNATED PARAMETER; AFTER A " &
- "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
- "DISCRIMINANTS OF THE FORMAL DESIGNATED " &
- "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
- "ACTUAL DESIGNATED PARAMETER");
-
-
- BEGIN
- DECLARE
- TYPE AST IS ACCESS STRING;
- SUBTYPE AST_3 IS AST(1..3);
- SUBTYPE AST_5 IS AST(3..5);
- X_3 : AST_3 := NEW STRING(1..IDENT_INT(3));
-
- PROCEDURE P1 (X : IN OUT AST_5) IS
- BEGIN
- FAILED("EXCEPTION NOT RAISED BEFORE CALL -P1 (A)");
- END P1;
- BEGIN
- P1 (AST_5 (X_3));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
- END;
-
- DECLARE
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
- SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
- TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
- A0 : A1_ARRAY := NEW ARRAY_TYPE (1..3);
-
- PROCEDURE P2 (X : IN OUT A2_ARRAY) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A)");
- END P2;
- BEGIN
- P2 (A2_ARRAY (A0));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
- END;
-
- DECLARE
- TYPE SUBINT IS RANGE 0..8;
- TYPE REC1 (DISC : SUBINT := 8) IS
- RECORD
- FIELD : SUBINT := DISC;
- END RECORD;
- TYPE A1_REC IS ACCESS REC1;
- TYPE A2_REC IS NEW A1_REC(3);
- A0 : A1_REC := NEW REC1(4);
-
- PROCEDURE P3 (X : IN OUT A2_REC) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL " &
- "-P3 (A)");
- END P3;
-
- BEGIN
- P3 (A2_REC (A0));
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
- END;
-
- END;
-
-
- BEGIN
- DECLARE
- TYPE AST IS ACCESS STRING;
- SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
- X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P1 (X : IN OUT AST) IS
- BEGIN
- CALLED := TRUE;
- X := NEW STRING'(3..5 => 'C');
- END P1;
- BEGIN
- P1 (AST (X_3));
- IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL" &
- "-P1 (B)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
- END;
-
- DECLARE
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
- SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
- A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P2 (X : IN OUT A_ARRAY) IS
- BEGIN
- CALLED := TRUE;
- X := NEW ARRAY_TYPE'(2..4 => FALSE);
- END P2;
- BEGIN
- P2 (A_ARRAY (A0));
- IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL" &
- "-P1 (B)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (B)");
- END;
-
- DECLARE
- TYPE SUBINT IS RANGE 0..8;
- TYPE REC1 (DISC : SUBINT := 8) IS
- RECORD
- FIELD : SUBINT := DISC;
- END RECORD;
- TYPE A1_REC IS ACCESS REC1;
- TYPE A2_REC IS NEW A1_REC;
- A0 : A1_REC(4) := NEW REC1(4);
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P3 (X : IN OUT A2_REC) IS
- BEGIN
- CALLED := TRUE;
- X := NEW REC1;
- END P3;
-
- BEGIN
- P3 (A2_REC (A0));
- IF A0.ALL = REC1'(4,4) THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL" &
- "-P1 (B)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (B)");
- END;
-
- END;
-
- RESULT;
-END C64103E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103f.ada b/gcc/testsuite/ada/acats/tests/c6/c64103f.ada
deleted file mode 100644
index ac26400..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64103f.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- C64103F.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 OUT PARAMETERS OF AN ACCESS TYPE,
--- CONSTRAINT_ERROR IS RAISED:
--- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
--- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
--- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
-
--- HISTORY:
--- CPP 07/23/84 CREATED ORIGINAL TEST.
--- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
--- REFERENCE THE ACTUAL PARAMETERS.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64103F IS
-BEGIN
- TEST ("C64103F", "FOR OUT PARAMETERS OF AN ACCESS TYPE, " &
- "CONSTRAINT_ERROR IS RAISED: AFTER A " &
- "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
- "DISCRIMINANTS OF THE FORMAL DESIGNATED " &
- "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
- "ACTUAL DESIGNATED PARAMETER");
-
-
- BEGIN
- DECLARE
- TYPE AST IS ACCESS STRING;
- SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
- SUBTYPE AST_5 IS AST(3..5);
- X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P1 (X : OUT AST_5) IS
- BEGIN
- CALLED := TRUE;
- X := NEW STRING'(3..5 => 'C');
- END P1;
- BEGIN
- P1 (AST_5 (X_3));
- IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P1 (A)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
- END;
-
- DECLARE
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
- SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
- TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
- A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P2 (X : OUT A2_ARRAY) IS
- BEGIN
- CALLED := TRUE;
- X := NEW ARRAY_TYPE'(2..4 => FALSE);
- END P2;
- BEGIN
- P2 (A2_ARRAY (A0));
- IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P1 (A)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
- END;
-
- DECLARE
- TYPE SUBINT IS RANGE 0..8;
- TYPE REC1 (DISC : SUBINT := 8) IS
- RECORD
- FIELD : SUBINT := DISC;
- END RECORD;
- TYPE A1_REC IS ACCESS REC1;
- TYPE A2_REC IS NEW A1_REC (3);
- A0 : A1_REC(4) := NEW REC1(4);
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P3 (X : OUT A2_REC) IS
- BEGIN
- CALLED := TRUE;
- X := NEW REC1(3);
- END P3;
-
- BEGIN
- P3 (A2_REC (A0));
- IF A0.ALL = REC1'(4,4) THEN
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A1)");
- ELSE
- FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A2)");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL " &
- "-P1 (A)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
- END;
- END;
-
- RESULT;
-END C64103F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104a.ada b/gcc/testsuite/ada/acats/tests/c6/c64104a.ada
deleted file mode 100644
index 4a66476..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104a.ada
+++ /dev/null
@@ -1,215 +0,0 @@
--- C64104A.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 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.
-
--- HISTORY:
--- DAS 01/14/81
--- CPP 07/03/84
--- LB 11/20/86 ADDED CODE TO ENSURE IN SUBTESTS WHICH CHECK
--- RETURNED VALUES, THAT SUBPROGRAMS ARE ACTUALLY
--- CALLED.
--- JET 08/04/87 FIXED HEADER FOR STANDARD FORMAT.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64104A IS
-
- SUBTYPE DIGIT IS INTEGER RANGE 0..9;
-
- CALLED : BOOLEAN;
- D : DIGIT;
- I : INTEGER;
- M1 : CONSTANT INTEGER := IDENT_INT(-1);
- COUNT : INTEGER := 0;
- SUBTYPE SI IS INTEGER RANGE M1 .. 10;
-
- PROCEDURE P1 (PIN : IN DIGIT; WHO : STRING) IS -- (A), (B)
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P1 " & WHO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P1 FOR " & WHO);
- END P1;
-
- PROCEDURE P2 (PINOUT : IN OUT DIGIT; WHO : STRING) IS -- (C)
- BEGIN
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P2 " & WHO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P2 FOR " & WHO);
- END P2;
-
- PROCEDURE P3 (POUT : OUT SI; WHO : STRING) IS -- (D)
- BEGIN
- IF WHO = "10" THEN
- POUT := IDENT_INT(10); -- (10 IS NOT A DIGIT)
- ELSE
- POUT := -1;
- END IF;
- CALLED := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P3 FOR " & WHO);
- END P3;
-
- PROCEDURE P4 (PINOUT : IN OUT INTEGER; WHO : STRING) IS -- (E)
- BEGIN
- IF WHO = "10" THEN
- PINOUT := 10; -- (10 IS NOT A DIGIT)
- ELSE
- PINOUT := IDENT_INT(-1);
- END IF;
- CALLED := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN P4 FOR" & WHO);
- END P4;
-
-BEGIN
-
- TEST ("C64104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "FOR OUT OF RANGE SCALAR ARGUMENTS");
-
- BEGIN -- (A)
- P1 (10, "10");
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (10)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P1 (10)");
- END; -- (A)
-
- BEGIN -- (B)
- P1 (IDENT_INT (-1), "-1");
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (" &
- "IDENT_INT (-1))");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P1 (" &
- "IDENT_INT (-1))");
- END; --(B)
-
- BEGIN -- (C)
- I := IDENT_INT (10);
- P2 (I, "10");
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (10)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P2 (10)");
- END; -- (C)
-
- BEGIN -- (C1)
- I := IDENT_INT (-1);
- P2 (I, "-1");
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (-1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P2 (-1)");
- END; -- (C1)
-
- BEGIN -- (D)
- CALLED := FALSE;
- D := IDENT_INT (1);
- P3 (D, "10");
- FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
- " P3 (10)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P3 (10)");
- END; -- (D)
-
- BEGIN -- (D1)
- CALLED := FALSE;
- D := IDENT_INT (1);
- P3 (D, "-1");
- FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
- " P3 (-1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P3 (-1)");
- END; -- (D1)
-
- BEGIN -- (E)
- CALLED := FALSE;
- D := 9;
- P4 (D, "10");
- FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
- " P4 (10)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P4 (10)");
- END; -- (E)
-
- BEGIN -- (E1)
- CALLED := FALSE;
- D := 0;
- P4 (D, "-1");
- FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
- " P4 (-1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COUNT := COUNT + 1;
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR P4 (-1)");
- END; -- (E1)
-
- IF (COUNT /= 8) THEN
- FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED");
- END IF;
-
- RESULT;
-
-END C64104A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104b.ada b/gcc/testsuite/ada/acats/tests/c6/c64104b.ada
deleted file mode 100644
index dc23f70..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104b.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C64104B.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. 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.
-
--- DAS 2/11/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104B IS
-
- USE REPORT;
- 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);
- PROCEDURE P1 (R : IN SREC) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL TO P1");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
- PROCEDURE P2 (R : IN OUT SREC) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL TO P2");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
- END P2;
-
- PROCEDURE P3 (R : OUT SREC) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL TO P3");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
- END P3;
-
-BEGIN
-
- TEST ("C64104B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " &
- "PARAMETERS OF RECORD TYPES");
-
- BEGIN -- (A)
- P1 ((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)
- P1 ((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)
- P1 (R);
- FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)");
- END; -- (C)
-
- DECLARE -- (D)
- R : REC := (IDENT_INT(2), "AA");
- BEGIN -- (D)
- P2 (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;
- BEGIN -- (E)
- P3 (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 C64104B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104c.ada b/gcc/testsuite/ada/acats/tests/c6/c64104c.ada
deleted file mode 100644
index 894182c..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104c.ada
+++ /dev/null
@@ -1,200 +0,0 @@
--- C64104C.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, 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.
-
--- JRK 3/17/81
--- SPS 10/26/82
--- CPP 8/6/84
--- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
-
-WITH REPORT;
-PROCEDURE C64104C IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
- "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
-
- --------------------------------------------------
-
- DECLARE -- (A)
- SUBTYPE ST IS STRING (1..3);
-
- PROCEDURE P (A : ST) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
- END P;
-
- BEGIN -- (A)
-
- P ("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;
-
- PROCEDURE P (A : T) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
- END P;
-
- BEGIN -- (B)
-
- P ((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));
-
- PROCEDURE P (A :ST) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
- END P;
-
- BEGIN -- (C)
-
- P (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)));
-
- PROCEDURE P (A : IN OUT ST) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALLL - (D)");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
- END P;
-
- BEGIN -- (D)
-
- P (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 => ' '));
-
- PROCEDURE P (A : IN OUT ST) IS
- BEGIN
- COMMENT ("OK CASE CALLED CORRECTLY");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
- END P;
-
- BEGIN -- (G)
-
- P (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 C64104C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104d.ada b/gcc/testsuite/ada/acats/tests/c6/c64104d.ada
deleted file mode 100644
index 10dea0e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104d.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- C64104D.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- ABW 6/11/82
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104D IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104D", "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);
-
- PROCEDURE P (X : A1) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- ------------------------------------------------
-
- RESULT;
-
-END C64104D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104e.ada b/gcc/testsuite/ada/acats/tests/c6/c64104e.ada
deleted file mode 100644
index c646346..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104e.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C64104E.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104E IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104E", "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'));
-
- PROCEDURE P (X : A1) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104f.ada b/gcc/testsuite/ada/acats/tests/c6/c64104f.ada
deleted file mode 100644
index f54e116..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104f.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C64104F.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104F IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104F", "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);
-
- PROCEDURE P (X : IN OUT A1) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104g.ada b/gcc/testsuite/ada/acats/tests/c6/c64104g.ada
deleted file mode 100644
index 7655065..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104g.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- C64104G.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104G IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104G", "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);
-
- PROCEDURE P (X : IN OUT SA ) IS
- BEGIN
- FAILED ("EXCEPTION NOT RAISED ON CALL");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104h.ada b/gcc/testsuite/ada/acats/tests/c6/c64104h.ada
deleted file mode 100644
index 4d52280..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104h.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C64104H.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
--- CIRCUMSTANCES FOR ACCESS PARAMETERS, 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.
-
--- HISTORY:
--- JRK 03/18/81 CREATED ORIGINAL TEST.
--- NL 10/13/81
--- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
--- ACTUALLY BEING CALLED.
--- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
-
-
-WITH REPORT;
-PROCEDURE C64104H IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "APPROPRIATELY FOR ACCESS PARAMETERS");
-
- --------------------------------------------------
-
- DECLARE
-
- 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;
-
- CALLED : BOOLEAN;
- TYPE A IS ACCESS T;
-
- V : A (2,'B') := NEW T (2,'B');
-
- PROCEDURE P (X : IN OUT A) IS
- BEGIN
- CALLED := TRUE;
- X := NEW T (2,'A');
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- CALLED := FALSE;
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104H;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104i.ada b/gcc/testsuite/ada/acats/tests/c6/c64104i.ada
deleted file mode 100644
index ecd24e0..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104i.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C64104I.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
--- CIRCUMSTANCES FOR ACCESS PARAMETERS, 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.
-
--- HISTORY:
--- JRK 03/18/81 CREATED ORIGINAL TEST.
--- NL 10/13/81
--- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
--- ACTUALLY BEING CALLED.
--- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
-
-
-WITH REPORT;
-PROCEDURE C64104I IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "APPROPRIATELY FOR ACCESS PARAMETERS");
-
- --------------------------------------------------
-
- DECLARE
-
- CALLED : BOOLEAN;
-
- 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);
-
- PROCEDURE P (X : IN OUT A) IS
- BEGIN
- CALLED := TRUE;
- IF EQUAL (3,3) THEN
- X := NEW T ('A'..'Z', E2..E3, BOOLEAN);
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- CALLED := FALSE;
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104I;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104j.ada b/gcc/testsuite/ada/acats/tests/c6/c64104j.ada
deleted file mode 100644
index 1577fc0..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104j.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- C64104J.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
--- CIRCUMSTANCES FOR ACCESS PARAMETERS, 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.
-
--- HISTORY:
--- JRK 03/18/81 CREATED ORIGINAL TEST.
--- NL 10/13/81
--- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
--- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
-
-WITH REPORT;
-PROCEDURE C64104J IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "APPROPRIATELY FOR ACCESS PARAMETERS");
-
- --------------------------------------------------
-
- DECLARE
-
- TYPE A IS ACCESS STRING;
-
- CALLED : BOOLEAN := FALSE;
-
- V : A (1..3) := NEW STRING (1..3);
-
- PROCEDURE P (X : OUT A) IS
- BEGIN
- CALLED := TRUE;
- X := NEW STRING (2..3);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104J;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104k.ada b/gcc/testsuite/ada/acats/tests/c6/c64104k.ada
deleted file mode 100644
index 8819d3c..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104k.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C64104K.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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
--- CIRCUMSTANCES FOR ACCESS PARAMETERS, 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.
-
--- HISTORY:
--- JRK 03/18/81 CREATED ORIGINAL TEST.
--- NL 10/13/81
--- SPS 10/26/82
--- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
--- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
-
-WITH REPORT;
-PROCEDURE C64104K IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "APPROPRIATELY FOR ACCESS PARAMETERS");
-
- --------------------------------------------------
-
- DECLARE
- 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;
-
- CALLED : BOOLEAN := FALSE;
-
- V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE));
-
- PROCEDURE P (X : OUT A) IS
- BEGIN
- CALLED := TRUE;
- X := NEW T (TRUE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM P WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104K;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104l.ada b/gcc/testsuite/ada/acats/tests/c6/c64104l.ada
deleted file mode 100644
index 1ecabfb..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104l.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C64104L.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104L IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104L", "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; 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);
-
- ENTERED : BOOLEAN := FALSE;
-
- PROCEDURE P (X : OUT SA ) IS
- BEGIN
- ENTERED := TRUE;
- X := NEW T (E2, TRUE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT ENTERED THEN
- FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
- "CALL");
- END IF;
- WHEN OTHERS =>
- IF NOT ENTERED THEN
- FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
- ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
- "RETURN");
- END IF;
- END;
-
- ------------------------------------------------
-
- RESULT;
-
-END C64104L;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104m.ada b/gcc/testsuite/ada/acats/tests/c6/c64104m.ada
deleted file mode 100644
index e089321..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104m.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C64104M.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, 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.
-
--- JRK 3/18/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64104M IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64104M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
- "APPROPRIATELY FOR ACCESS PARAMETERS");
-
- --------------------------------------------------
-
- DECLARE
-
- 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');
-
- ENTERED : BOOLEAN := FALSE;
- Y : CONSTANT CHARACTER := IDENT_CHAR('Y');
- SUBTYPE SA IS A(1..10, 'A'..Y);
- PROCEDURE P (X : OUT SA ) IS
- BEGIN
- ENTERED := TRUE;
- X := NEW T (1..10, 'A'..IDENT_CHAR('Y'));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE");
- END P;
-
- BEGIN
-
- P (V);
- FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT ENTERED THEN
- FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
- "CALL");
- END IF;
- WHEN OTHERS =>
- IF NOT ENTERED THEN
- FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
- ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
- "RETURN");
- END IF;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C64104M;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104n.ada b/gcc/testsuite/ada/acats/tests/c6/c64104n.ada
deleted file mode 100644
index 6ee8ac4..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104n.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C64104N.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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE 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.
-
--- HISTORY:
--- DAVID A. TAFFS
--- CPP 07/23/84
--- RDH 04/18/90 REVISED TO CHECK THAT SUBPROGRAM IS ACTUALLY
--- CALLED.
--- THS 09/21/90 REWORDED COMMENT STATING THAT THE TEST DOES NOT
--- ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64104N IS
-
-BEGIN
- TEST ("C64104N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " &
- "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER " &
- "BOUNDS DIFFER");
-
- 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;
-
- PROCEDURE Q (X : IN OUT P.T) IS
- BEGIN
- CALLED := TRUE;
- X := P.DC;
- IF P. "=" (X, P.DC) THEN
- COMMENT("PROCEDURE Q WAS CALLED");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED INSIDE SUBPROGRAM");
- END Q;
-
- GENERIC
- Y : IN OUT P.T;
- PACKAGE CALL IS
- END CALL;
-
- PACKAGE BODY CALL IS
- BEGIN
- Q (Y);
- END CALL;
-
--- NOTE CALL HAS VARIABLE OF A PRIVATE TYPE AS AN OUT PARAMETER.
--- THIS TEST DOES NOT ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
--- REFER TO ADA IMPLEMENTOR'S GUIDE 6.4.1 SEMANTIC RAMIFICATION 19
--- AND AI-00025 FOR CLARIFICATION AS TO WHY THE LITERAL
--- INTERPRETATION IS REJECTED.
-
- 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; -- EXCEPTION
- BEGIN
- FAILED ("NO EXCEPTION RAISED");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED("SUBPROGRAM Q WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED");
- END;
-
- RESULT;
-
- END;
-END C64104N;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104o.ada b/gcc/testsuite/ada/acats/tests/c6/c64104o.ada
deleted file mode 100644
index 5d390b0..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64104o.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C64104O.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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
--- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE
--- THE ACTUAL BOUNDS OR DISCRIMINANTS OF THE DESIGNATED OBJECT DIFFER
--- FROM THOSE OF THE FORMAL.
-
--- HISTORY
--- CPP 7/23/84 CREATED ORIGINAL TEST.
--- DHH 8/31/87 ADDED COMMENT IN PROCEDURE Q SO THAT CODE WILL NOT BE
--- OPTIMIZED OUT OF EXISTENCE.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64104O IS
-
-BEGIN
-
- TEST ("C64104O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " &
- "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER BOUNDS " &
- "DIFFER");
-
- 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;
-
- PROCEDURE Q (X : IN OUT P.T) IS
-
- BEGIN
-
- CALLED := TRUE;
- X := P.DC;
- IF P. "=" (X, P.DC) THEN
- COMMENT("PROCEDURE Q WAS CALLED");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED INSIDE SUBPROGRAM");
- END Q;
-
- GENERIC
- Y : IN OUT P.T;
- PACKAGE CALL IS
- END CALL;
-
- PACKAGE BODY CALL IS
- BEGIN
- Q(Y);
- 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;
- BEGIN
- FAILED ("NO EXCEPTION RAISED");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("SUBPROGRAM Q WAS NOT CALLED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- RESULT;
- END;
-
-END C64104O;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105a.ada b/gcc/testsuite/ada/acats/tests/c6/c64105a.ada
deleted file mode 100644
index a1739097..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64105a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C64105A.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.
-
--- DAS 1/29/81
--- CPP 8/6/84
-
-WITH REPORT;
-PROCEDURE C64105A IS
-
- USE REPORT;
-
- SUBTYPE SUBINT1 IS INTEGER RANGE -10..10;
- SUBTYPE SUBINT2 IS INTEGER RANGE -20..20;
-
- I10 : SUBINT1 := 10;
- I20 : SUBINT2 := 20;
-
- PROCEDURE P1 (I : OUT SUBINT1) IS
- BEGIN
- I := SUBINT1'FIRST;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
-BEGIN
-
- TEST ("C64105A", "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");
-
- DECLARE
- BEGIN
- P1 (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 P1 - 1");
- END;
-
- DECLARE
- BEGIN
- I20 := IDENT_INT(20);
- P1 (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 P1 - 2");
- END;
-
- RESULT;
-
-END C64105A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105b.ada b/gcc/testsuite/ada/acats/tests/c6/c64105b.ada
deleted file mode 100644
index 4eb217a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64105b.ada
+++ /dev/null
@@ -1,184 +0,0 @@
--- C64105B.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
--- IN THE FOLLOWING CIRCUMSTANCES:
--- (1) BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
--- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
--- FROM THE FORMAL PARAMETER.
--- (2)
--- (3)
--- SUBTESTS ARE:
--- (A) CASE 1, IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
--- (B) CASE 1, 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.
-
--- JRK 3/20/81
--- SPS 10/26/82
--- CPP 8/6/84
-
-WITH REPORT;
-PROCEDURE C64105B IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64105B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
- "BEFORE THE 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;
-
- PROCEDURE P (X : SA ) IS
- BEGIN
- NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
- END P;
-
- BEGIN -- (A)
-
- 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;
-
- PROCEDURE P (X : IN OUT SA ) IS
- BEGIN
- NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
- END P;
-
- BEGIN -- (B)
-
- 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;
-
- PROCEDURE P (X : SA ) IS
- BEGIN
- NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
- END P;
-
- BEGIN -- (C)
-
- 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;
-
- PROCEDURE P (X : IN OUT SA ) IS
- BEGIN
- NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
- END P;
-
- BEGIN -- (D)
-
- P (SA(V));
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - (D)");
- END; -- (D)
-
- --------------------------------------------------
-
- RESULT;
-END C64105B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105c.ada b/gcc/testsuite/ada/acats/tests/c6/c64105c.ada
deleted file mode 100644
index 32fc9b6..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64105c.ada
+++ /dev/null
@@ -1,230 +0,0 @@
--- C64105C.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
--- IN THE FOLLOWING CIRCUMSTANCES:
--- (1)
--- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL
--- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
--- DIFFERENT CONSTRAINTS.
--- (3)
--- SUBTESTS ARE:
--- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
--- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
--- (E) SAME AS (C), WITH TYPE CONVERSION.
--- (F) SAME AS (D), WITH TYPE CONVERSION.
-
--- JRK 3/20/81
--- SPS 10/26/82
--- CPP 8/8/84
-
-WITH REPORT;
-PROCEDURE C64105C IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
- "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " &
- "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
- "DIFFERENT CONSTRAINTS" );
-
- --------------------------------------------------
-
- 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;
-
- PROCEDURE P (X : IN OUT SA) IS
- BEGIN
- ENTERED := TRUE;
- X := NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
- END P;
-
- BEGIN -- (C)
-
- P (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;
-
- PROCEDURE P (X : OUT SA) IS
- BEGIN
- ENTERED := TRUE;
- X := NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
- END P;
-
- BEGIN -- (D)
-
- P (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)
-
- --------------------------------------------------
-
- DECLARE -- (E)
-
- 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;
-
- PROCEDURE P (X : IN OUT SA) IS
- BEGIN
- ENTERED := TRUE;
- X := NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
- END P;
-
- BEGIN -- (E)
-
- P (SA(V));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT ENTERED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
- ELSE
- FAILED ("EXCEPTION RAISED ON RETURN - (E)");
- END IF;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - (E)");
- END; -- (E)
-
- --------------------------------------------------
-
- DECLARE -- (F)
-
- 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;
-
- PROCEDURE P (X : OUT SA) IS
- BEGIN
- ENTERED := TRUE;
- X := NULL;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
- END P;
-
- BEGIN -- (D)
-
- P (SA(V));
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT ENTERED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL - (F)");
- ELSE
- FAILED ("EXCEPTION RAISED ON RETURN - (F)");
- END IF;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - (F)");
- END; -- (F)
-
- --------------------------------------------------
-
- RESULT;
-END C64105C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105d.ada b/gcc/testsuite/ada/acats/tests/c6/c64105d.ada
deleted file mode 100644
index f70b49a..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64105d.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- C64105D.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
--- IN THE FOLLOWING CIRCUMSTANCES:
--- (1)
--- (2)
--- (3) BEFORE OR AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL
--- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE
--- CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL
--- PARAMETER.
--- SUBTESTS ARE:
--- (G) CASE 3, STATIC LIMITED PRIVATE DISCRIMINANT.
--- (H) CASE 3, DYNAMIC ONE DIMENSIONAL BOUNDS.
-
--- JRK 3/20/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C64105D IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64105D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
- "BEFORE AND AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL " &
- "OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE " &
- "CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL " &
- "PARAMETER" );
-
- --------------------------------------------------
-
- DECLARE -- (G)
-
- 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;
-
- PROCEDURE P (X : OUT SA) IS
- BEGIN
- CALLED := TRUE;
- X := NEW T (3);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
- END P;
-
- BEGIN -- (G)
-
- P (V);
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL - (G)");
- ELSE
- FAILED ("EXCEPTION RAISED ON RETURN - (G)");
- END IF;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - (G)");
- END; -- (G)
-
- --------------------------------------------------
-
- DECLARE -- (H)
-
- TYPE A IS ACCESS STRING;
- SUBTYPE SA IS A (1..2);
- V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7));
- CALLED : BOOLEAN := FALSE;
-
- PROCEDURE P (X : OUT SA) IS
- BEGIN
- CALLED := TRUE;
- X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE - (H)");
- END P;
-
- BEGIN -- (H)
-
- P (V);
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF NOT CALLED THEN
- FAILED ("EXCEPTION RAISED BEFORE CALL - (H)");
- ELSE
- FAILED ("EXCEPTION RAISED ON RETURN - (H)");
- END IF;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - (H)");
- END; -- (H)
-
- --------------------------------------------------
-
- RESULT;
-END C64105D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106a.ada b/gcc/testsuite/ada/acats/tests/c6/c64106a.ada
deleted file mode 100644
index a74a91b..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64106a.ada
+++ /dev/null
@@ -1,351 +0,0 @@
--- C64106A.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.
-
--- DAS 1/15/81
--- JBG 5/16/83
--- CPP 5/22/84
-
-WITH REPORT;
-PROCEDURE C64106A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C64106A", "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,"C64106A..........");
- REC3 : RECTYPE := (1,1,"A");
- REC4 : RECTYPE; -- 80
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE);
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
- END PKG;
-
- PACKAGE BODY PKG IS
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE1;
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE2;
- END PKG;
-
- BEGIN -- (A)
-
- PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
- PKG.CHK_RECTYPE2 (PKG.REC4);
-
- END; -- (A)
-
- ---------------------------------------------
-
-B : DECLARE -- (B)
-
- PACKAGE PKG IS
-
- SUBTYPE INT IS INTEGER RANGE 0..100;
-
- TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
-
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE);
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
-
- 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
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE1;
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE2;
-
- BEGIN
- REC1 := (10,10,"0123456789");
- REC2 := (17,7,"C64106A..........");
- REC3 := (1,1,"A");
-
- END PKG;
-
- BEGIN -- (B)
-
- PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
- PKG.CHK_RECTYPE2 (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;
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE);
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
-
- 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
-
- PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
- REC2 : OUT RECTYPE;
- REC3 : IN OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE1;
-
- PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
- BEGIN
- 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 CHK_RECTYPE2;
-
- BEGIN
- REC1 := (10,10,"0123456789");
- REC2 := (17,7,"C64106A..........");
- REC3 := (1,1,"A");
- END PKG;
-
- BEGIN -- (C)
-
- PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
- PKG.CHK_RECTYPE2 (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) := "";
-
- PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE;
- A3 : IN OUT ATYPE) IS
- BEGIN
- 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 CHK_ARRAY1;
-
- PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
- BEGIN
- 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 CHK_ARRAY2;
-
- PROCEDURE CHK_STRING (S1 : IN STRING;
- S2 : IN OUT STRING;
- S3 : OUT STRING) IS
- BEGIN
- 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 CHK_STRING;
-
- BEGIN -- (D)
- CHK_ARRAY1 (A1, A2, A3);
- CHK_ARRAY2 (A4);
- CHK_STRING (S1, S2, S3);
- END D; -- (D)
-
- RESULT;
-END C64106A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106b.ada b/gcc/testsuite/ada/acats/tests/c6/c64106b.ada
deleted file mode 100644
index 95d6fe1..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64106b.ada
+++ /dev/null
@@ -1,237 +0,0 @@
--- C64106B.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 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.
-
--- DAS 1/15/81
--- CPP 8/9/84
-
-WITH REPORT;
-PROCEDURE C64106B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C64106B", "CHECK ASSIGNMENT TO 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;
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE);
- 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
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE) IS
-
- REC4 : CONSTANT RECTYPE(IDENT_INT(4)) :=
- (IDENT_INT(4), 4, "OOPS");
-
- BEGIN
- 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 CHK_RECTYPE;
- END PKG;
-
- BEGIN -- (A)
-
- PKG.CHK_RECTYPE (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;
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE);
- 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
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE) IS
-
- REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
-
- BEGIN
- 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 CHK_RECTYPE;
-
- BEGIN
- REC9 := (9, 9, "123456789");
- REC6 := (6, 5, "AEIOUY");
- END PKG;
-
- BEGIN -- (B)
-
- PKG.CHK_RECTYPE (REC9, REC6);
-
- END; -- (B)
-
- --------------------------------------------------
-
- DECLARE -- (C)
-
- PACKAGE PKG IS
-
- TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE;
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE);
- 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
-
- PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
- REC6 : IN OUT RECTYPE) IS
-
- REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
-
- BEGIN
- 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 CHK_RECTYPE;
-
- BEGIN
- REC6 := (6, 5, "AEIOUY");
- REC9 := (9, 9, "123456789");
- END PKG;
-
- BEGIN -- (C)
-
- PKG.CHK_RECTYPE (REC9, REC6);
-
- END; -- (C)
-
- --------------------------------------------------
-
- RESULT;
-
-END C64106B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106c.ada b/gcc/testsuite/ada/acats/tests/c6/c64106c.ada
deleted file mode 100644
index 9adfa4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64106c.ada
+++ /dev/null
@@ -1,309 +0,0 @@
--- C64106C.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 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.
-
--- DAS 1/16/81
--- VKG 1/7/83
--- CPP 8/9/84
-
-WITH REPORT;
-PROCEDURE C64106C IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C64106C", "CHECK ASSIGNMENTS TO 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);
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
- END PKG;
-
- PACKAGE BODY PKG IS
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
- IF (NOT REC11'CONSTRAINED) OR
- (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
- FAILED ("CONSTRAINT ON RECORD " &
- "TYPE IN PARAMETER " &
- "NOT RECOGNIZED");
- END IF;
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := 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
- REC13 := REC_OOPS;
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "A.2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "A.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- BEGIN -- (A)
-
- PKG.P (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;
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
-
- 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
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
- IF (NOT REC11'CONSTRAINED) OR
- (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
- FAILED ("CONSTRAINT ON PRIVATE " &
- "TYPE IN PARAMETER " &
- "NOT RECOGNIZED");
- END IF;
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := 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
- REC13 := REC_OOPS;
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "B.2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "B.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- BEGIN -- (B)
-
- PKG.P (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;
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
-
- 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
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
- IF (NOT REC11'CONSTRAINED) OR
- (REC11.CONSTRAINT /= 9) THEN
- FAILED ("CONSTRAINT ON LIMITED PRIVATE " &
- "TYPE IN PARAMETER " &
- "NOT RECOGNIZED");
- END IF;
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := 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
- REC13 := REC_OOPS;
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "C.2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "C.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- BEGIN -- (C)
-
- PKG.P (REC91, REC92, REC93);
-
- END; -- (C)
-
- --------------------------------------------------
-
- RESULT;
-
-END C64106C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106d.ada b/gcc/testsuite/ada/acats/tests/c6/c64106d.ada
deleted file mode 100644
index 0b36708..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64106d.ada
+++ /dev/null
@@ -1,280 +0,0 @@
--- C64106D.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 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.
-
--- JRK 4/16/81
--- CPP 8/9/84
--- JRK 11/28/84
-
-WITH REPORT;
-PROCEDURE C64106D IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C64106D", "CHECK ASSIGNMENTS TO 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;
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
- END PKG;
-
- REC91, REC92, REC93 : PKG.RECTYPE :=
- (IDENT_INT(5), 5, IDENT_STR("12345"));
- REC_OOPS : PKG.RECTYPE;
-
- PACKAGE BODY PKG IS
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
-
- IF NOT REC11'CONSTRAINED THEN
- FAILED ("REC11 IS NOT CONSTRAINED - A.1");
- END IF;
- IF REC11.CONSTRAINT /= IDENT_INT(9) THEN
- FAILED ("REC11 CONSTRAINT IS NOT 9 " &
- "- A.1");
- END IF;
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - A.1");
- END;
-
- BEGIN -- ASSIGNMENT TO OUT PARAMETER
- REC13 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - A.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- USE PKG;
-
- BEGIN -- (A)
-
- PKG.P (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;
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
-
- 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
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
-
- IF REC3'CONSTRAINED THEN
- FAILED ("REC3 IS CONSTRAINED - B.1");
- END IF;
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - B.1");
- END;
-
- BEGIN -- ASSIGNMENT TO OUT PARAMETER
- REC13 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - B.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- BEGIN -- (B)
-
- PKG.P (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;
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE);
-
- 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
-
- PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
- REC3 : OUT RECTYPE) IS
-
- PROCEDURE P1 (REC11 : IN RECTYPE;
- REC12 : IN OUT RECTYPE;
- REC13 : OUT RECTYPE) IS
- BEGIN
-
- BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
- REC12 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - C.1");
- END;
-
- BEGIN -- ASSIGNMENT TO OUT PARAMETER
- REC13 := REC_OOPS;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - C.2");
- END;
- END P1;
-
- BEGIN
- P1 (REC1, REC2, REC3);
- END P;
-
- BEGIN
-
- REC91 := (9, 9, "123456789");
- REC92 := REC91;
- REC93 := REC91;
-
- REC_OOPS := (4, 4, "OOPS");
-
- END PKG;
-
- BEGIN -- (C)
-
- PKG.P (REC91, REC92, REC93);
-
- END; -- (C)
-
- --------------------------------------------------
-
- RESULT;
-
-END C64106D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64107a.ada b/gcc/testsuite/ada/acats/tests/c6/c64107a.ada
deleted file mode 100644
index fd846e8..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64107a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C64107A.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.
-
--- DAS 1/29/81
--- SPS 12/13/82
-
-WITH REPORT;
-PROCEDURE C64107A IS
-
- USE REPORT;
-
- 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;
-
- PROCEDURE PROC1 (I : OUT INTEGER; J : OUT INTEGER) IS
- BEGIN
- I := 10;
- J := -1;
- END PROC1;
-
- PROCEDURE PROC2 (P : OUT PTRINT; I : OUT INTEGER) IS
- BEGIN
- P := NEW INTEGER'(3);
- I := 5;
- END PROC2;
-
-BEGIN
-
- TEST ("C64107A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED" &
- " AND IDENTIFIED AT THE TIME OF CALL");
-
- PROC1 (I, A(I));
- IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN
- FAILED ("A(I) EVALUATED UPON RETURN");
- END IF;
-
- PROC2 (P1, P1.ALL);
- IF (P2.ALL /= 5) THEN
- FAILED ("P1.ALL EVALUATED UPON RETURN");
- END IF;
-
- RESULT;
-
-END C64107A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64108a.ada b/gcc/testsuite/ada/acats/tests/c6/c64108a.ada
deleted file mode 100644
index ae69d66..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64108a.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- C64108A.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.
-
--- DAS 2/10/81
--- SPS 10/26/82
--- SPS 11/5/82
-
-WITH REPORT;
-PROCEDURE C64108A IS
-
- USE REPORT;
- 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;
-
- PROCEDURE P1 (S1 : IN STRING; S2: IN OUT STRING;
- S3 : OUT STRING) IS
- BEGIN
- S3 := S2;
- S2 := S1;
- END P1;
-
- PROCEDURE P2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
- C3 : OUT CHARACTER) IS
- BEGIN
- C3 := C2;
- C2 := C1;
- END P2;
-
- 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 ("C64108A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE" &
- " NAMES ARE PERMITTED AS ACTUAL PARAMETERS");
-
- S1 := "AAA";
- S2 := "BBB";
- P1 (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");
- P2 (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";
- P1 (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";
- P1 (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");
- P1 (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");
- P1 ("+"(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");
- P2 (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");
- P1 (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 C64108A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109a.ada b/gcc/testsuite/ada/acats/tests/c6/c64109a.ada
deleted file mode 100644
index 19c3f69..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C64109A.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 SUBPROGRAMS. SPECIFICALLY,
--- (A) CHECK ALL PARAMETER MODES.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109A IS
-
-BEGIN
- TEST ("C64109A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS");
-
- --------------------------------------------
-
- 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;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- 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 P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR'FIRST /= IDENT_INT(1) OR
- ARR'LAST /= IDENT_INT(5) THEN
- FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
- END IF;
-
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
- BEGIN
- 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 P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
- 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 P3;
-
- BEGIN -- (A)
-
- P1 (REC.A);
- IF REC.A /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
-
- BOOL := F1 (REC.A);
- IF REC.A /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
-
- P2 (REC.A);
- IF REC.A /= (5, 5, 5, 5, 5) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
- END IF;
-
- P3 (REC.A);
- IF REC.A /= (3, 3, 3, 3, 3) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY");
- END IF;
-
- END; -- (A)
-
- --------------------------------------------
-
- RESULT;
-END C64109A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109b.ada b/gcc/testsuite/ada/acats/tests/c6/c64109b.ada
deleted file mode 100644
index a644974..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109b.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- C64109B.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 SUBPROGRAMS. SPECIFICALLY,
--- (B) CHECK MULTIDIMENSIONAL ARRAYS.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109B IS
-
-BEGIN
- TEST ("C64109B", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
- "MULTIDIMENSIONAL ARRAYS");
-
- DECLARE -- (B)
-
- TYPE MULTI_TYPE IS ARRAY (POSITIVE RANGE <>,
- POSITIVE RANGE <>) OF BOOLEAN;
- SUBTYPE MULTI_SUBTYPE IS MULTI_TYPE (1..2, 1..3);
- TYPE RECORD_TYPE IS
- RECORD
- I : BOOLEAN;
- A : MULTI_SUBTYPE;
- END RECORD;
- REC : RECORD_TYPE :=
- (I => FALSE,
- A => (1..2 => (1..3 => IDENT_BOOL(TRUE))));
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : MULTI_TYPE) IS
- BEGIN
- IF ARR /= (1..2 => (1..3 => TRUE)) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
- FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER");
- ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
- THEN
- FAILED ("2ND DIM NOT CORRECT - IN PARAMETER");
- END IF;
- END P1;
-
- FUNCTION F1 (ARR : MULTI_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (1..2 => (1..3 => TRUE)) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
- FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER FN");
- ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
- THEN
- FAILED ("2ND DIM NOT CORRECT - IN PARAMETER FN");
- END IF;
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT MULTI_TYPE) IS
- BEGIN
- IF ARR /= (1..2 => (1..3 => TRUE)) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
- FAILED ("FIRST DIM NOT CORRECT - IN OUT PARAMETER");
- ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
- THEN
- FAILED ("2ND DIM NOT CORRECT - IN OUT PARAMETER");
- END IF;
- ARR := (ARR'RANGE(1) => (ARR'RANGE(2) => FALSE));
- END P2;
-
- PROCEDURE P3 (ARR : OUT MULTI_TYPE) IS
- BEGIN
- FOR I IN 1 .. 2 LOOP
- FOR J IN 1 .. 3 LOOP
- IF (J MOD 2) = 0 THEN
- ARR(I, J) := TRUE;
- ELSE
- ARR(I, J) := FALSE;
- END IF;
- END LOOP;
- END LOOP;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
- FAILED ("FIRST DIM NOT CORRECT - OUT PARAMETER");
- ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
- THEN
- FAILED ("2ND DIM NOT CORRECT - OUT PARAMETER");
- END IF;
- END P3;
-
- BEGIN -- (B)
-
- P1 (REC.A);
- IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
-
- BOOL := F1 (REC.A);
- IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
-
- P2 (REC.A);
- IF REC.A /= (1..2 => (1..3 => FALSE)) THEN
- FAILED ("IN OUT PARAM CHANGED BY PROCEDURE");
- END IF;
-
- P3 (REC.A);
- FOR I IN 1 .. 2 LOOP
- FOR J IN 1 .. 3 LOOP
- IF (J MOD 2) = 0 THEN
- IF REC.A(I, J) /= TRUE THEN
- FAILED ("OUT PARAM RETURNED " &
- "INCORRECTLY - (B)");
- END IF;
- ELSE
- IF REC.A(I, J) /= FALSE THEN
- FAILED ("OUT PARAM RETURNED " &
- "INCORRECTLY - (B)2");
- END IF;
- END IF;
- END LOOP;
- END LOOP;
-
- END; -- (B)
-
- RESULT;
-END C64109B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109c.ada b/gcc/testsuite/ada/acats/tests/c6/c64109c.ada
deleted file mode 100644
index 1845f9e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109c.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- C64109C.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 SUBPROGRAMS. SPECIFICALLY,
--- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
--- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
--- DISCRIMINANT.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109C IS
-
-BEGIN
- TEST ("C64109C", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
- "RECORDS WITH DISCRIMINANTS");
-
- DECLARE -- (C)
-
- SUBTYPE SUBINT IS INTEGER RANGE 1..6;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
- TYPE RECORD_TYPE (BOUND : INTEGER) IS
- RECORD
- B : BOOLEAN;
- A : ARRAY_TYPE (1..BOUND);
- AA : ARRAY_TYPE (BOUND..6);
- END RECORD;
- REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
- (BOUND => 4,
- B => TRUE,
- A => (1..IDENT_INT(4) => 6),
- AA => (4..6 => 8));
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER");
- END IF;
- END P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
- END IF;
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (8, 8, 8) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(6) THEN
- FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 10);
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS - OUT PARAMETER");
- END IF;
- ARR := (ARR'RANGE => 4);
- END P3;
-
- BEGIN -- (C)
-
- P1 (REC.A);
- IF REC.A /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
-
- BOOL := F1 (REC.A);
- IF REC.A /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
-
- P2 (REC.AA);
- IF REC.AA /= (10, 10, 10) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- P3 (REC.A);
- IF REC.A /= (4, 4, 4, 4) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- END; -- (C)
-
- RESULT;
-END C64109C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109d.ada b/gcc/testsuite/ada/acats/tests/c6/c64109d.ada
deleted file mode 100644
index c8469be..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109d.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- C64109D.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 SUBPROGRAMS. SPECIFICALLY,
--- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109D IS
-
-BEGIN
- TEST ("C64109D", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
- "OBJECTS DESIGNATED BY ACCESS TYPES");
-
- DECLARE -- (D)
-
- SUBTYPE INDEX IS INTEGER RANGE 1..3;
- TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
- SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(3));
- TYPE NODE_TYPE;
- TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
- TYPE NODE_TYPE IS
- RECORD
- A : ARRAY_SUBTYPE;
- NEXT : ACCESS_TYPE;
- END RECORD;
- PTR : ACCESS_TYPE := NEW NODE_TYPE'
- (A => (IDENT_INT(1)..3 => IDENT_INT(5)),
- NEXT => NULL);
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER");
- END IF;
- END P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
- END IF;
-
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_SUBTYPE) IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
- END IF;
-
- ARR := (OTHERS => 6);
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 7);
- END P3;
-
- BEGIN -- (D)
-
- P1 (PTR.A);
- IF PTR.A /= (5, 5, 5) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
-
- BOOL := F1 (PTR.A);
- IF PTR.A /= (5, 5, 5) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
-
- P2 (PTR.A);
- IF PTR.A /= (6, 6, 6) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- P3 (PTR.A);
- IF PTR.A /= (7, 7, 7) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- END; -- (D)
-
- RESULT;
-END C64109D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109e.ada b/gcc/testsuite/ada/acats/tests/c6/c64109e.ada
deleted file mode 100644
index 5860ac7..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109e.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C64109E.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 SUBPROGRAMS. SPECIFICALLY,
--- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
--- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109E IS
-
-BEGIN
- TEST ("C64109E", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
- "ARRAYS WITH DIFFERENT BOUNDS PASSED TO UNCONSTRAINED " &
- "FORMAL");
-
- DECLARE -- (E)
-
- SUBTYPE SUBINT IS INTEGER RANGE 0..5;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- TYPE RECORD_TYPE IS
- RECORD
- A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(2));
- B : ARRAY_TYPE (1..3);
- END RECORD;
- REC : RECORD_TYPE := (A => (0..2 => IDENT_BOOL(TRUE)),
- B => (1..3 => IDENT_BOOL(FALSE)));
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG IN PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG IN PARAMETER BOUNDS - 2");
- END IF;
- END P1;
-
- FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
- RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
- END IF;
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
- ARR2 : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
- END IF;
- ARR := (ARR'RANGE => FALSE);
- ARR2 := (ARR2'RANGE => TRUE);
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
- END IF;
- ARR := (ARR'RANGE => FALSE);
- ARR2 := (ARR2'RANGE => TRUE);
- END P3;
-
- BEGIN -- (E)
-
- P1 (REC.A, REC.B);
- IF REC.A /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
- IF REC.B /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
- END IF;
-
- BOOL := F1 (REC.A, REC.B);
- IF REC.A /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
- IF REC.B /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
- END IF;
-
- P2 (REC.A, REC.B);
- IF REC.A /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
- END IF;
- IF REC.B /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
- END IF;
-
- P3 (REC.A, REC.B);
- IF REC.A /= (FALSE, FALSE, FALSE) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY");
- END IF;
- IF REC.B /= (TRUE, TRUE, TRUE) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
- END IF;
-
- END; -- (E)
-
- RESULT;
-END C64109E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109f.ada b/gcc/testsuite/ada/acats/tests/c6/c64109f.ada
deleted file mode 100644
index 48a202c..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109f.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- C64109F.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 SUBPROGRAMS. SPECIFICALLY,
--- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
--- ANOTHER CALL.
-
--- CPP 8/20/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109F IS
-
-BEGIN
- TEST ("C64109F", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
- "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
- "FORMAL AS AN ACTUAL");
-
- DECLARE -- (F)
-
- TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- SUBTYPE ARRAY_SUBTYPE IS
- ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
- TYPE RECORD_TYPE IS
- RECORD
- I : INTEGER;
- A : ARRAY_SUBTYPE;
- END RECORD;
- REC : RECORD_TYPE := (I => 23,
- A => (1..3 => 7, 4..5 => 9));
- BOOL : BOOLEAN;
-
- PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF A /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
- END IF;
- IF A'FIRST /= 1 OR A'LAST /= 5 THEN
- FAILED ("BOUNDS WRONG - IN OUT");
- END IF;
- A := (6, 6, 6, 6, 6);
- END P_CALLED;
-
- PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
- BEGIN
- P_CALLED (A);
- END P;
-
- FUNCTION F_CALLED (A : ARRAY_SUBTYPE) RETURN BOOLEAN IS
- GOOD : BOOLEAN;
- BEGIN
- GOOD := (A = (7, 7, 7, 9, 9));
- IF NOT GOOD THEN
- FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
- END IF;
- IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(5) THEN
- FAILED ("BOUNDS WRONG - FUNCTION");
- END IF;
- RETURN GOOD;
- END F_CALLED;
-
- FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- RETURN (F_CALLED (A));
- END F;
-
- PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
- BEGIN
- IF A'FIRST /= 1 OR A'LAST /= 5 THEN
- FAILED ("BOUNDS WRONG - OUT");
- END IF;
- A := (8, 8, 8, 8, 8);
- END P_OUT_CALLED;
-
- PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
- BEGIN
- P_OUT_CALLED (A);
- A := (9, 9, 9, 9, 9);
- END P_OUT;
-
- BEGIN -- (F)
-
- P (REC.A);
- IF REC.A /= (6, 6, 6, 6, 6) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- REC.A := (7, 7, 7, 9, 9);
- BOOL := F (REC.A);
- IF NOT BOOL THEN
- FAILED ("IN PARAM NOT RETURNED CORRECTLY");
- END IF;
-
- REC.A := (7, 7, 7, 9, 9);
- P_OUT (REC.A);
- IF REC.A /= (9, 9, 9, 9, 9) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
- END IF;
-
- END; -- (F)
-
- --------------------------------------------
-
- RESULT;
-END C64109F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109g.ada b/gcc/testsuite/ada/acats/tests/c6/c64109g.ada
deleted file mode 100644
index df6a827..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109g.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- C64109G.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 SLICES OF ARRAYS ARE PASSED CORRECTLY TO SUBPROGRAMS.
--- SPECIFICALLY,
--- (A) CHECK ALL PARAMETER MODES.
-
--- CPP 8/28/84
--- PWN 05/31/96 Corrected spelling problem.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109G IS
-
-BEGIN
- TEST ("C64109G", "CHECK THAT SLICES OF ARRAYS ARE PASSED " &
- "CORRECTLY TO SUBPROGRAMS");
-
- --------------------------------------------
-
- DECLARE -- (A)
-
- SUBTYPE SUBINT IS INTEGER RANGE 1..5;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
- ARR : ARRAY_TYPE (1..5) := (1..3 => 7, 4..5 => 9);
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (S : ARRAY_TYPE) IS
- BEGIN
- IF S(IDENT_INT(3)) /= 7 THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
- END IF;
- IF S(4) /= 9 THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
- END IF;
- END P1;
-
- FUNCTION F1 (S : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF S(3) /= 7 THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
- END IF;
- IF S(IDENT_INT(4)) /= 9 THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
- END IF;
- RETURN TRUE;
- END F1;
-
- PROCEDURE P2 (S : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF S(3) /= 7 THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)");
- END IF;
- IF S(4) /= 9 THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)2");
- END IF;
- FOR I IN 3 .. 4 LOOP
- S(I) := 5;
- END LOOP;
- END P2;
-
- PROCEDURE P3 (S : OUT ARRAY_TYPE) IS
- BEGIN
- FOR I IN 3 .. 4 LOOP
- S(I) := 3;
- END LOOP;
- END P3;
-
- BEGIN -- (A)
-
- P1 (ARR(3..4));
- IF ARR(3) /= 7 THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)");
- END IF;
- IF ARR(4) /= 9 THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)2");
- END IF;
-
- BOOL := F1 (ARR(IDENT_INT(3)..IDENT_INT(4)));
- IF ARR(3) /= 7 THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION - (A)");
- END IF;
- IF ARR(4) /= 9 THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION - (A)2");
- END IF;
-
- P2 (ARR(3..4));
- FOR I IN 3 .. 4 LOOP
- IF ARR(I) /= 5 THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY - (A)");
- END IF;
- END LOOP;
-
- P3 (ARR(IDENT_INT(3)..4));
- FOR I IN 3 .. 4 LOOP
- IF ARR(I) /= 3 THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY - (A)");
- END IF;
- END LOOP;
-
- END;
-
- RESULT;
-
-END C64109G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109h.ada b/gcc/testsuite/ada/acats/tests/c6/c64109h.ada
deleted file mode 100644
index 1828563..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109h.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C64109H.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
--- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
--- (A) CHECK ALL PARAMETER MODES.
-
--- HISTORY:
--- TBN 07/11/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 MODIFIED REC.A REFERENCES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109H IS
-
-BEGIN
- TEST ("C64109H", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
- "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
- "TO SUBPROGRAMS");
-
- 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;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (7, 9, 9) THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(3) OR
- ARR'LAST /= IDENT_INT(5) THEN
- FAILED ("WRONG BOUNDS FOR IN PARAMETER");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (7, 7, 9) THEN
- FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR'FIRST /= IDENT_INT(2) OR
- ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
- END IF;
-
- RETURN TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F1");
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (7, 7, 7, 9) THEN
- FAILED ("IN OUT PARAMETER NOT PASSED " &
- "CORRECTLY");
- END IF;
- IF ARR'FIRST /= IDENT_INT(1) OR
- ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
- END IF;
- ARR := (ARR'RANGE => 5);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR'FIRST /= IDENT_INT(3) OR
- ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 3);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
- END P3;
-
- BEGIN -- (A)
-
- BEGIN -- (B)
- P1 (REC.A (3..5));
- IF REC.A /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P1");
- END; -- (B)
-
- BEGIN -- (C)
- BOOL := F1 (REC.A (2..4));
- IF REC.A /= (7, 7, 7, 9, 9) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF F1");
- END; -- (C)
-
- BEGIN -- (D)
- P2 (REC.A (1..4));
- IF REC.A /= (5, 5, 5, 5, 9) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P2");
- END; -- (D)
-
- BEGIN -- (E)
- P3 (REC.A (3..4));
- IF REC.A /= (5, 5, 3, 3, 9) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P3");
- END; -- (E)
-
- END; -- (A)
-
- RESULT;
-END C64109H;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109i.ada b/gcc/testsuite/ada/acats/tests/c6/c64109i.ada
deleted file mode 100644
index de7ede6..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109i.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- C64109I.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
--- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
--- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
--- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
--- DISCRIMINANT.
-
--- HISTORY:
--- TBN 07/10/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 REMOVED PARTIAL ARRAY REFERENCES IN
--- RECORD FIELDS.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109I IS
-
-BEGIN
- TEST ("C64109I", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
- "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
- "TO SUBPROGRAMS - RECORDS WITH DISCRIMINANTS");
-
- DECLARE -- (C)
-
- SUBTYPE SUBINT IS INTEGER RANGE 1..6;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
- TYPE RECORD_TYPE (BOUND : INTEGER) IS
- RECORD
- B : BOOLEAN;
- A : ARRAY_TYPE (1..BOUND);
- AA : ARRAY_TYPE (BOUND..6);
- END RECORD;
- REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
- (BOUND => 4,
- B => TRUE,
- A => (1..IDENT_INT(4) => 6),
- AA => (4..6 => 8));
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (6, 6, 6) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (6, 6, 6) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
-
- IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
- END IF;
- RETURN TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F1");
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (8, 8) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(5) THEN
- FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG BOUNDS - OUT PARAMETER");
- END IF;
- ARR := (ARR'RANGE => 4);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
- END P3;
-
- BEGIN -- (C)
-
- BEGIN -- (D)
- P1 (REC.A (1..3));
- IF REC.A /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P1");
- END; -- (D)
-
- BEGIN -- (E)
- BOOL := F1 (REC.A (2..4));
- IF REC.A /= (6, 6, 6, 6) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF F1");
- END; -- (E)
-
- BEGIN -- (F)
- P2 (REC.AA (4..5));
- IF REC.AA /= (10, 10, 8) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P2");
- END; -- (F)
-
- BEGIN -- (G)
- P3 (REC.A (2..3));
- IF REC.A /= (6, 4, 4, 6) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P3");
- END; -- (G)
-
- END; -- (C)
-
- RESULT;
-END C64109I;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109j.ada b/gcc/testsuite/ada/acats/tests/c6/c64109j.ada
deleted file mode 100644
index c326ef2..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109j.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C64109J.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
--- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
--- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
-
--- HISTORY:
--- TBN 07/10/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 MODIFIED PTR.A REFERENCES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109J IS
-
-BEGIN
- TEST ("C64109J", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
- "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
- "TO SUBPROGRAMS - OBJECTS DESIGNATED BY ACCESS " &
- "TYPES");
-
- DECLARE -- (D)
-
- SUBTYPE INDEX IS INTEGER RANGE 1..5;
- TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
- SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
- TYPE NODE_TYPE;
- TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
- TYPE NODE_TYPE IS
- RECORD
- A : ARRAY_SUBTYPE;
- NEXT : ACCESS_TYPE;
- END RECORD;
- PTR : ACCESS_TYPE := NEW NODE_TYPE'
- (A => (IDENT_INT(1)..5 => IDENT_INT(5)),
- NEXT => NULL);
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
- FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
- FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
- END IF;
-
- RETURN TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F1");
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (5, 5, 5) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
-
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 6);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
- BEGIN
-
- IF ARR'FIRST /= IDENT_INT(3) OR ARR'LAST /= 5 THEN
- FAILED ("WRONG BOUNDS - OUT PARAMETER");
- END IF;
-
- ARR := (ARR'RANGE => 7);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
- END P3;
-
- BEGIN -- (D)
-
- BEGIN -- (E)
- P1 (PTR.A (1..3));
- IF PTR.A /= (5, 5, 5, 5, 5) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P1");
- END; -- (E)
-
- BEGIN -- (F)
- BOOL := F1 (PTR.A (2..4));
- IF PTR.A /= (5, 5, 5, 5, 5) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF F1");
- END; -- (F)
-
- BEGIN -- (G)
- P2 (PTR.A (1..3));
- IF PTR.A /= (6, 6, 6, 5, 5) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P2");
- END; -- (G)
-
- BEGIN -- (H)
- P3 (PTR.A (3..5));
- IF PTR.A /= (6, 6, 7, 7, 7) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P3");
- END; -- (H)
-
- END; -- (D)
-
- RESULT;
-END C64109J;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109k.ada b/gcc/testsuite/ada/acats/tests/c6/c64109k.ada
deleted file mode 100644
index d72d8ec..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109k.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- C64109K.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
--- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
--- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
--- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
-
--- HISTORY:
--- TBN 07/11/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 MODIFIED REC.A REFERENCES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109K IS
-
-BEGIN
- TEST ("C64109K", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
- "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
- "TO SUBPROGRAMS - ARRAYS WITH DIFFERENT BOUNDS " &
- "PASSED TO UNCONSTRAINED FORMAL");
-
- DECLARE -- (E)
-
- SUBTYPE SUBINT IS INTEGER RANGE 0..5;
- TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
- TYPE RECORD_TYPE IS
- RECORD
- A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(4));
- B : ARRAY_TYPE (1..5);
- END RECORD;
- REC : RECORD_TYPE := (A => (0..4 => IDENT_BOOL(TRUE)),
- B => (1..5 => IDENT_BOOL(FALSE)));
- BOOL : BOOLEAN;
-
- PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG IN PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG IN PARAMETER BOUNDS - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
- END P1;
-
- FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
- RETURN BOOLEAN IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
- FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
- END IF;
- IF ARR2'FIRST /= 3 OR ARR2'LAST /= IDENT_INT(5) THEN
- FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
- END IF;
- RETURN TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F1");
- END F1;
-
- PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
- ARR2 : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR /= (TRUE, TRUE, TRUE) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
- FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2 /= (FALSE, FALSE, FALSE) THEN
- FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
- END IF;
- IF ARR2'FIRST /= 2 OR ARR2'LAST /= IDENT_INT(4) THEN
- FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
- END IF;
- ARR := (ARR'RANGE => FALSE);
- ARR2 := (ARR2'RANGE => TRUE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
- END P2;
-
- PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
- BEGIN
- IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
- FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
- END IF;
- IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
- FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
- END IF;
- ARR := (ARR'RANGE => FALSE);
- ARR2 := (ARR2'RANGE => TRUE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
- END P3;
-
- BEGIN -- (E)
-
- BEGIN -- (F)
- P1 (REC.A (0..2), REC.B (1..3));
- IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE");
- END IF;
- IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P1");
- END; -- (F)
-
- BEGIN -- (G)
- BOOL := F1 (REC.A (1..3), REC.B (3..5));
- IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION");
- END IF;
- IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
- FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF F1");
- END; -- (G)
-
- BEGIN -- (H)
- P2 (REC.A (2..4), REC.B (2..4));
- IF REC.A /= (TRUE, TRUE, FALSE, FALSE, FALSE) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
- END IF;
- IF REC.B /= (FALSE, TRUE, TRUE, TRUE, FALSE) THEN
- FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P2");
- END; -- (H)
-
- BEGIN -- (I)
- P3 (REC.A (0..2), REC.B (1..3));
- IF REC.A /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY");
- END IF;
- IF REC.B /= (TRUE, TRUE, TRUE, TRUE, FALSE) THEN
- FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P3");
- END; -- (I)
-
- END; -- (E)
-
- RESULT;
-END C64109K;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109l.ada b/gcc/testsuite/ada/acats/tests/c6/c64109l.ada
deleted file mode 100644
index 7bdb170..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64109l.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- C64109L.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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
--- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
--- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
--- ANOTHER SUBPROGRAM CALL.
-
--- HISTORY:
--- TBN 07/11/86 CREATED ORIGINAL TEST.
--- JET 08/04/87 MODIFIED REC.A REFERENCES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64109L IS
-
-BEGIN
- TEST ("C64109L", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
- "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
- "TO SUBPROGRAMS - FORMAL AS AN ACTUAL");
-
- DECLARE -- (F)
-
- TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- SUBTYPE ARRAY_SUBTYPE IS
- ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
- TYPE RECORD_TYPE IS
- RECORD
- I : INTEGER;
- A : ARRAY_SUBTYPE;
- END RECORD;
- REC : RECORD_TYPE := (I => 23,
- A => (1..3 => 7, 4..5 => 9));
- BOOL : BOOLEAN;
-
- PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
- BEGIN
- IF A /= (7, 7, 7) THEN
- FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
- END IF;
- IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(3) THEN
- FAILED ("BOUNDS WRONG - IN OUT");
- END IF;
- A := (A'RANGE => 6);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P_CALLED");
- END P_CALLED;
-
- PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
- BEGIN
- P_CALLED (A);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P");
- END P;
-
- FUNCTION F_CALLED (A : ARRAY_TYPE) RETURN BOOLEAN IS
- GOOD : BOOLEAN;
- BEGIN
- GOOD := (A = (6, 9, 9));
- IF NOT GOOD THEN
- FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
- END IF;
- IF A'FIRST /= 3 OR A'LAST /= IDENT_INT(5) THEN
- FAILED ("BOUNDS WRONG - FUNCTION");
- END IF;
- RETURN GOOD;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F_CALLED");
- END F_CALLED;
-
- FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
- BEGIN
- RETURN (F_CALLED (A));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN FUNCTION F");
- END F;
-
- PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
- BEGIN
- IF A'FIRST /= IDENT_INT(2) OR A'LAST /= 4 THEN
- FAILED ("BOUNDS WRONG - OUT");
- END IF;
- A := (8, 8, 8);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE " &
- "P_OUT_CALLED");
- END P_OUT_CALLED;
-
- PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
- BEGIN
- P_OUT_CALLED (A);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED IN PROCEDURE P_OUT");
- END P_OUT;
-
- BEGIN -- (F)
-
- BEGIN -- (G)
- P (REC.A (1..3));
- IF REC.A /= (6, 6, 6, 9, 9) THEN
- FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P");
- END; -- (G)
-
- BEGIN -- (H)
- BOOL := F (REC.A (3..5));
- IF NOT BOOL THEN
- FAILED ("IN PARAM NOT RETURNED CORRECTLY");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF F");
- END; -- (H)
-
- BEGIN -- (I)
- P_OUT (REC.A (2..4));
- IF REC.A /= (6, 8, 8, 8, 9) THEN
- FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING CALL OF P_OUT");
- END; -- (I)
-
- END; -- (F)
-
- RESULT;
-END C64109L;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64201b.ada b/gcc/testsuite/ada/acats/tests/c6/c64201b.ada
deleted file mode 100644
index e550b34..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64201b.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C64201B.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 INITALIZATION OF IN PARAMETERS OF A TASK
--- TYPE IS PERMITTED.
--- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
-
--- CVP 5/14/81
--- ABW 7/1/82
--- BHS 7/9/84
-
-WITH REPORT;
-PROCEDURE C64201B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C64201B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " &
- "OF A TASK TYPE IS PERMITTED" );
-
- DECLARE
-
- GLOBAL : INTEGER := 10;
-
- TASK TYPE T_TYPE IS
- ENTRY E (X : IN OUT INTEGER);
- END;
-
- TSK1, TSK2 : T_TYPE;
-
- TASK BODY T_TYPE IS
- BEGIN
- ACCEPT E (X : IN OUT INTEGER) DO
- X := X - 1;
- END E;
- ACCEPT E (X : IN OUT INTEGER) DO
- X := X + 1;
- END E;
- END T_TYPE;
-
-
- PROCEDURE PROC1 (T : T_TYPE := TSK1) IS
- BEGIN
- T.E (X => GLOBAL);
- END PROC1;
-
- PROCEDURE PROC2 (T : T_TYPE := TSK1) IS
- BEGIN
- T.E (X => GLOBAL);
- IF (GLOBAL /= IDENT_INT(8)) THEN
- FAILED( "TASK NOT PASSED IN PROC1, " &
- "DEFAULT TSK1 EMPLOYED" );
- END IF;
- END PROC2;
-
- PROCEDURE TERM (T : T_TYPE; NUM : CHARACTER) IS
- BEGIN
- IF NOT T'TERMINATED THEN
- ABORT T;
- COMMENT ("ABORTING TASK " & NUM);
- END IF;
- END TERM;
-
- BEGIN
-
- PROC1(TSK2);
- IF GLOBAL /= 9 THEN
- FAILED ("INCORRECT GLOBAL VALUE AFTER PROC1");
- ELSE
- PROC2;
- END IF;
-
- TERM(TSK1, '1');
- TERM(TSK2, '2');
- END;
-
- RESULT;
-
-END C64201B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64201c.ada b/gcc/testsuite/ada/acats/tests/c6/c64201c.ada
deleted file mode 100644
index ac7fec8..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64201c.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- C64201C.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 INITIALIZATION OF IN PARAMETERS OF A COMPOSITE
--- TYPE HAVING AT LEAST ONE COMPONENT (INCLUDING COMPONENTS
--- OF COMPONENTS) OF A TASK TYPE IS PERMITTED.
--- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
-
--- CVP 5/14/81
--- ABW 7/1/82
--- BHS 7/9/84
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C64201C IS
-
-
- GLOBAL : INTEGER := 10;
-
-
- TASK TYPE T IS
- ENTRY E (X : IN OUT INTEGER);
- END;
-
- TYPE REC_T IS
- RECORD
- TT : T;
- BB : BOOLEAN := TRUE;
- END RECORD;
-
- TYPE REC_REC_T IS
- RECORD
- RR : REC_T;
- END RECORD;
-
- TYPE ARR_T IS ARRAY (1 .. 2) OF T;
-
- TYPE ARR_REC_T IS ARRAY (1 .. 2) OF REC_T;
-
- RT1, RT2 : REC_T;
- RRT1, RRT2 : REC_REC_T;
- AT1, AT2 : ARR_T;
- ART1, ART2 : ARR_REC_T;
-
-
- TASK BODY T IS
- BEGIN
- ACCEPT E (X : IN OUT INTEGER) DO
- X := X - 1;
- END E;
- ACCEPT E (X : IN OUT INTEGER) DO
- X := X + 1;
- END E;
- END T;
-
-
- PROCEDURE PROC1A (P1X : REC_T := RT1) IS
- BEGIN
- IF P1X.BB THEN -- EXPECT RT2 PASSED.
- FAILED( "RECORD OF TASK NOT PASSED, DEFAULT EMPLOYED" );
- END IF;
- END PROC1A;
-
- PROCEDURE PROC1B (P1X : REC_T := RT1) IS
- BEGIN
- IF NOT P1X.BB THEN -- EXPECT DEFAULT USED.
- FAILED( "DEFAULT RECORD OF TASK NOT EMPLOYED" );
- END IF;
- END PROC1B;
-
-
- PROCEDURE PROC2A (P2X : REC_REC_T := RRT1) IS
- BEGIN
- IF P2X.RR.BB THEN -- EXPECT RRT2 PASSED.
- FAILED( "RECORD OF RECORD OF TASK NOT PASSED, " &
- "DEFAULT EMPLOYED" );
- END IF;
- END PROC2A;
-
- PROCEDURE PROC2B (P2X : REC_REC_T := RRT1) IS
- BEGIN
- IF NOT P2X.RR.BB THEN -- EXPECT DEFAULT USED.
- FAILED( "DEFAULT RECORD OF RECORD OF TASK " &
- "NOT EMPLOYED" );
- END IF;
- END PROC2B;
-
-
- PROCEDURE PROC3 (P3X : ARR_T := AT1) IS
- BEGIN
- P3X(1).E (X => GLOBAL); -- CALL TO AT2(1).E,
- -- GLOBAL => GLOBAL - 1.
- END PROC3;
-
- PROCEDURE PROC4 (P4X : ARR_T := AT1) IS
- BEGIN
- P4X(1).E (X => GLOBAL); -- CALL TO DEFAULT AT1(1).E,
- -- GLOBAL => GLOBAL - 1.
- IF GLOBAL /= IDENT_INT(8) THEN
- FAILED( "ARRAY OF TASKS NOT PASSED " &
- "CORRECTLY IN PROC3" );
- END IF;
- END PROC4;
-
- PROCEDURE PROC5 (P5X : ARR_REC_T := ART1) IS
- BEGIN
- P5X(1).TT.E (X => GLOBAL); -- CALL TO ART2(1).TT.E,
- -- GLOBAL => GLOBAL - 1.
- END PROC5;
-
- PROCEDURE PROC6 (P6X : ARR_REC_T := ART1) IS
- BEGIN
- P6X(1).TT.E (X => GLOBAL); -- CALL DEFAULT ART1(1).TT.E,
- -- GLOBAL => GLOBAL - 1.
- IF GLOBAL /= IDENT_INT(8) THEN
- FAILED( "ARRAY OF RECORDS OF TASKS NOT " &
- "PASSED IN PROC5" );
- END IF;
- END PROC6;
-
- PROCEDURE TERM (TSK : T; NUM : CHARACTER) IS
- BEGIN
- IF NOT TSK'TERMINATED THEN
- ABORT TSK;
- COMMENT ("ABORTING TASK " & NUM);
- END IF;
- END TERM;
-
-
-BEGIN
-
- TEST( "C64201C" , "CHECK THAT INITIALIZATION OF IN " &
- "PARAMETERS OF A COMPOSITE TYPE " &
- "IS PERMITTED" );
-
- RT2.BB := FALSE;
- RRT2.RR.BB := FALSE;
-
- PROC1A(RT2); -- NO ENTRY CALL
- PROC1B; -- NO ENTRY CALL
- PROC2A(RRT2); -- NO ENTRY CALL
- PROC2B; -- NO ENTRY CALL
-
- PROC3(AT2); -- CALL AT2(1).E
- IF GLOBAL /= 9 THEN
- FAILED ("INCORRECT GLOBAL VALUE AFTER PROC3");
- ELSE
- PROC4; -- CALL AT1(1).E
- END IF;
-
- GLOBAL := 10;
- PROC5(ART2); -- CALL ART2(1).TT.E
- IF GLOBAL /= 9 THEN
- FAILED ("INCORRECT GLOBAL VALUE AFTER PROC5");
- ELSE
- PROC6; -- CALL ART1(1).TT.E
- END IF;
-
--- MAKE SURE ALL TASKS TERMINATED
- TERM (RT1.TT, '1');
- TERM (RT2.TT, '2');
- TERM (RRT1.RR.TT, '3');
- TERM (RRT2.RR.TT, '4');
- TERM (AT1(1), '5');
- TERM (AT2(1), '6');
- TERM (AT1(2), '7');
- TERM (AT2(2), '8');
- TERM (ART1(1).TT, '9');
- TERM (ART2(1).TT, 'A');
- TERM (ART1(2).TT, 'B');
- TERM (ART2(2).TT, 'C');
-
- RESULT;
-
-END C64201C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64202a.ada b/gcc/testsuite/ada/acats/tests/c6/c64202a.ada
deleted file mode 100644
index 3c4af8e..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c64202a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- C64202A.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.
-
--- SPS 2/22/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C64202A IS
-BEGIN
-
- TEST ("C64202A", "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;
-
- PROCEDURE P (CALL : POSITIVE; X, Y : INTEGER := F) IS
- BEGIN
- IF CALL = 1 THEN
- IF X = Y OR Y /= 2 THEN
- FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 1" &
- " X =" & INTEGER'IMAGE(X) & " Y =" &
- INTEGER'IMAGE(Y));
- END IF;
- ELSIF CALL = 2 THEN
- 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 IF;
- END P;
-
- BEGIN
- COMMENT ("FIRST CALL");
- P (1, 3);
- COMMENT ("SECOND CALL");
- P(2);
- END;
-
- RESULT;
-
-END C64202A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c650001.a b/gcc/testsuite/ada/acats/tests/c6/c650001.a
deleted file mode 100644
index 595e81d..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c650001.a
+++ /dev/null
@@ -1,412 +0,0 @@
--- C650001.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, for a function result type that is a return-by-reference
--- type, Program_Error is raised if the return expression is a name that
--- denotes an object view whose accessibility level is deeper than that
--- of the master that elaborated the function body.
---
--- Check for cases where the result type is:
--- (a) A tagged limited type.
--- (b) A task type.
--- (c) A protected type.
--- (d) A composite type with a subcomponent of a
--- return-by-reference type (task type).
---
--- TEST DESCRIPTION:
--- The accessibility level of the master that elaborates the body of a
--- return-by-reference function will always be less deep than that of
--- the function (which is itself a master).
---
--- Thus, the return object may not be any of the following, since each
--- has an accessibility level at least as deep as that of the function:
---
--- (1) An object declared local to the function.
--- (2) The result of a local function.
--- (3) A parameter of the function.
---
--- Verify that Program_Error is raised within the return-by-reference
--- function if the return object is any of (1)-(3) above, for various
--- subsets of the return types (a)-(d) above. Include cases where (1)-(3)
--- are operands of parenthesized expressions.
---
--- Verify that no exception is raised if the return object is any of the
--- following:
---
--- (4) An object declared at a less deep level than that of the
--- master that elaborated the function body.
--- (5) The result of a function declared at the same level as the
--- original function (assuming the new function is also legal).
--- (6) A parameter of the master that elaborated the function body.
---
--- For (5), pass the new function as an actual via an access-to-
--- subprogram parameter of the original function. Check for cases where
--- the new function does and does not raise an exception.
---
--- Since the functions to be tested cannot be part of an assignment
--- statement (since they return values of a limited type), pass each
--- function result as an actual parameter to a dummy procedure, e.g.,
---
--- Dummy_Proc ( Function_Call );
---
---
--- CHANGE HISTORY:
--- 03 May 95 SAIC Initial prerelease version.
--- 08 Feb 99 RLB Removed subcase with two errors.
---
---!
-
-package C650001_0 is
-
- type Tagged_Limited is tagged limited record
- C: String (1 .. 10);
- end record;
-
- task type Task_Type;
-
- protected type Protected_Type is
- procedure Op;
- end Protected_Type;
-
- type Task_Array is array (1 .. 10) of Task_Type;
-
- type Variant_Record (Toggle: Boolean) is record
- case Toggle is
- when True =>
- T: Task_Type; -- Return-by-reference component.
- when False =>
- I: Integer; -- Non-return-by-reference component.
- end case;
- end record;
-
- -- Limited type even though variant contains no limited components:
- type Non_Task_Variant is new Variant_Record (Toggle => False);
-
-end C650001_0;
-
-
- --==================================================================--
-
-
-package body C650001_0 is
-
- task body Task_Type is
- begin
- null;
- end Task_Type;
-
- protected body Protected_Type is
- procedure Op is
- begin
- null;
- end Op;
- end Protected_Type;
-
-end C650001_0;
-
-
- --==================================================================--
-
-
-with C650001_0;
-package C650001_1 is
-
- type TC_Result_Kind is (OK, P_E, O_E);
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-
- -- Dummy procedures:
-
- procedure Check_Tagged (P: C650001_0.Tagged_Limited);
- procedure Check_Task (P: C650001_0.Task_Type);
- procedure Check_Protected (P: C650001_0.Protected_Type);
- procedure Check_Composite (P: C650001_0.Non_Task_Variant);
-
-end C650001_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C650001_1 is
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK =>
- Report.Failed ("No exception raised: " & Message);
- when P_E =>
- Report.Failed ("Program_Error raised: " & Message);
- when O_E =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Display_Results;
-
-
- procedure Check_Tagged (P: C650001_0.Tagged_Limited) is
- begin
- null;
- end;
-
- procedure Check_Task (P: C650001_0.Task_Type) is
- begin
- null;
- end;
-
- procedure Check_Protected (P: C650001_0.Protected_Type) is
- begin
- null;
- end;
-
- procedure Check_Composite (P: C650001_0.Non_Task_Variant) is
- begin
- null;
- end;
-
-end C650001_1;
-
-
-
- --==================================================================--
-
-
-with C650001_0;
-with C650001_1;
-
-with Report;
-procedure C650001 is
-begin
-
- Report.Test ("C650001", "Check that, for a function result type that " &
- "is a return-by-reference type, Program_Error is raised " &
- "if the return expression is a name that denotes an " &
- "object view whose accessibility level is deeper than " &
- "that of the master that elaborated the function body");
-
-
-
- SUBTEST1:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- PO : C650001_0.Protected_Type;
-
- function Return_Prot (P: C650001_0.Protected_Type)
- return C650001_0.Protected_Type is
- begin
- Result := C650001_1.OK;
- return P; -- Formal parameter (3).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return PO;
- when others =>
- Result := C650001_1.O_E;
- return PO;
- end Return_Prot;
-
- begin -- SUBTEST1.
- C650001_1.Check_Protected ( Return_Prot(PO) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1");
- exception
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception in outer block");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- Comp : C650001_0.Non_Task_Variant;
-
- function Return_Composite return C650001_0.Non_Task_Variant is
- Local: C650001_0.Non_Task_Variant;
- begin
- Result := C650001_1.OK;
- return (Local); -- Parenthesized local object (1).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return Comp;
- when others =>
- Result := C650001_1.O_E;
- return Comp;
- end Return_Composite;
-
- begin -- SUBTEST2.
- C650001_1.Check_Composite ( Return_Composite );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2");
- exception
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception in outer block");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- Tsk : C650001_0.Task_Type;
- TskArr: C650001_0.Task_Array;
-
- function Return_Task (P: C650001_0.Task_Array)
- return C650001_0.Task_Type is
-
- function Inner return C650001_0.Task_Type is
- begin
- return P(P'First); -- OK: should not raise exception (6).
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly " &
- "raised within function Inner");
- return Tsk;
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception " &
- "raised within function Inner");
- return Tsk;
- end Inner;
-
- begin -- Return_Task.
- Result := C650001_1.OK;
- return Inner; -- Call to local function (2).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return Tsk;
- when others =>
- Result := C650001_1.O_E;
- return Tsk;
- end Return_Task;
-
- begin -- SUBTEST3.
- C650001_1.Check_Task ( Return_Task(TskArr) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3");
- exception
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception in outer block");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- TagLim: C650001_0.Tagged_Limited;
-
- function Return_TagLim (P: C650001_0.Tagged_Limited'Class)
- return C650001_0.Tagged_Limited is
- begin
- Result := C650001_1.OK;
- return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return TagLim;
- when others =>
- Result := C650001_1.O_E;
- return TagLim;
- end Return_TagLim;
-
- begin -- SUBTEST4.
- C650001_1.Check_Tagged ( Return_TagLim(TagLim) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E,
- "SUBTEST #4 (root type)");
- exception
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception in outer block");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare
- Tsk : C650001_0.Task_Type;
- begin -- SUBTEST5.
-
- declare
- Result: C650001_1.TC_Result_Kind;
-
- type AccToFunc is access function return C650001_0.Task_Type;
-
- function Return_Global return C650001_0.Task_Type is
- begin
- return Tsk; -- OK: should not raise exception (4).
- end Return_Global;
-
- function Return_Local return C650001_0.Task_Type is
- Local : C650001_0.Task_Type;
- begin
- return Local; -- Propagate Program_Error.
- end Return_Local;
-
-
- function Return_Func (P: AccToFunc) return C650001_0.Task_Type is
- begin
- Result := C650001_1.OK;
- return P.all; -- Function call (5).
- exception
- when Program_Error =>
- Result := C650001_1.P_E;
- return Tsk;
- when others =>
- Result := C650001_1.O_E;
- return Tsk;
- end Return_Func;
-
- RG : AccToFunc := Return_Global'Access;
- RL : AccToFunc := Return_Local'Access;
-
- begin
- C650001_1.Check_Task ( Return_Func(RG) );
- C650001_1.TC_Display_Results (Result, C650001_1.OK,
- "SUBTEST #5 (global task)");
-
- C650001_1.Check_Task ( Return_Func(RL) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E,
- "SUBTEST #5 (local task)");
- exception
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception in outer block");
- end;
-
- end SUBTEST5;
-
-
-
- Report.Result;
-
-end C650001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c65003a.ada b/gcc/testsuite/ada/acats/tests/c6/c65003a.ada
deleted file mode 100644
index 49cd2b5..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c65003a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C65003A.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 NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
--- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
-
--- THIS LACK OF AN EXECUTABLE RETURN IS DETECTABLE AT COMPILE TIME IN
--- THIS TEST.
-
--- JBG 10/14/83
--- SPS 2/22/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C65003A IS
-
- EXCEPTION_RAISED : BOOLEAN := FALSE;
- FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
- BEGIN
- IF FALSE THEN
- RETURN 5;
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY - " &
- "RETURN_IN_EXCEPTION");
- EXCEPTION_RAISED := TRUE;
- RETURN 5;
- END RETURN_IN_EXCEPTION;
-
- FUNCTION NO_RETURN RETURN INTEGER IS
- NO_RETURN_EXCEPTION : EXCEPTION;
- BEGIN
- RAISE NO_RETURN_EXCEPTION;
- RETURN 5;
- EXCEPTION
- WHEN NO_RETURN_EXCEPTION =>
- NULL;
- END NO_RETURN;
-
-BEGIN
-
- TEST ("C65003A", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
- "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
- "STATEMENT");
-
- BEGIN
-
- IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
- IF NOT EXCEPTION_RAISED THEN
- FAILED ("PROGRAM_ERROR NOT RAISED - " &
- "RETURN_IN_EXCEPTION");
- END IF;
- END IF;
-
- EXCEPTION
-
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL " &
- "- RETURN_IN_EXCEPTION");
-
- END;
-
-
- BEGIN
-
- IF NO_RETURN = NO_RETURN THEN
- FAILED ("PROGRAM_ERROR NOT RAISED - NO_RETURN");
- END IF;
-
- EXCEPTION
-
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED WHEN NO RETURN IN " &
- "EXCEPTION HANDLER");
- END;
-
- RESULT;
-
-END C65003A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c65003b.ada b/gcc/testsuite/ada/acats/tests/c6/c65003b.ada
deleted file mode 100644
index d93d1b4..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c65003b.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- C65003B.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 NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
--- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
-
--- THIS LACK OF AN EXECUTABLE RETURN IS NOT DETECTABLE AT COMPILE TIME.
-
--- JBG 10/14/83
--- SPS 2/22/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C65003B IS
-
- EXCEPTION_RAISED : BOOLEAN := FALSE;
-
- FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
- BEGIN
- WHILE NOT EQUAL (1, 1) LOOP
- RETURN 5;
- END LOOP;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY");
- EXCEPTION_RAISED := TRUE;
- RETURN 5;
- END RETURN_IN_EXCEPTION;
-
-BEGIN
-
- TEST ("C65003B", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
- "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
- "STATEMENT");
-
- BEGIN
-
- IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
- IF NOT EXCEPTION_RAISED THEN
- FAILED ("PROGRAM_ERROR NOT RAISED");
- END IF;
- END IF;
-
- EXCEPTION
-
- WHEN PROGRAM_ERROR =>
- COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL");
-
- END;
-
- RESULT;
-
-END C65003B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002a.ada b/gcc/testsuite/ada/acats/tests/c6/c66002a.ada
deleted file mode 100644
index 8afec99..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- C66002A.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (A) ONE SUBPROGRAM IS A FUNCTION; THE OTHER IS A PROCEDURE.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
--- SPS 11/2/82
-
-WITH REPORT;
-PROCEDURE C66002A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002A", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- ONE SUBPROGRAM IS A PROCEDURE; THE OTHER IS
- -- A FUNCTION. BOTH PARAMETERIZED AND PARAMETERLESS
- -- SUBPROGRAMS ARE TESTED.
-
- DECLARE
- I, J, K : INTEGER := 0;
- S : STRING (1..2) := "12";
-
- PROCEDURE P1 (I1, I2 : INTEGER) IS
- BEGIN
- S(1) := 'A';
- END P1;
-
- FUNCTION P1 (I1, I2 : INTEGER) RETURN INTEGER IS
- BEGIN
- S(2) := 'B';
- RETURN I1; -- RETURNED VALUE IS IRRELEVENT.
- END P1;
-
- PROCEDURE P2 IS
- BEGIN
- S(1) := 'C';
- END P2;
-
- FUNCTION P2 RETURN INTEGER IS
- BEGIN
- S(2) := 'D';
- RETURN I; -- RETURNED VALUE IS IRRELEVENT.
- END P2;
-
- BEGIN
- P1 (I, J);
- K := P1 (I, J);
-
- IF S /= "AB" THEN
- FAILED ("PARAMETERIZED OVERLOADED " &
- "SUBPROGRAMS, ONE A PROCEDURE AND " &
- "THE OTHER A FUNCTION, CAUSED " &
- "CONFUSION");
- END IF;
-
- S := "12";
- P2;
- K := P2 ;
-
- IF S /= "CD" THEN
- FAILED ("PARAMETERLESS OVERLOADED " &
- "SUBPROGRAMS, ONE A PROCEDURE AND " &
- "THE OTHER A FUNCTION, CAUSED " &
- "CONFUSION");
- END IF;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002c.ada b/gcc/testsuite/ada/acats/tests/c6/c66002c.ada
deleted file mode 100644
index d646f06..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002c.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C66002C.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (C) ONE SUBPROGRAM HAS ONE LESS PARAMETER THAN THE OTHER.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
-
-WITH REPORT;
-PROCEDURE C66002C IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002C", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- ONE PROCEDURE 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";
-
- PROCEDURE P1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN) IS
- BEGIN
- S(1) := 'A';
- END P1;
-
- PROCEDURE P1 (I1, I2 : INTEGER) IS
- BEGIN
- S(2) := 'B';
- END P1;
-
- PROCEDURE P2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0) IS
- BEGIN
- S(1) := 'C';
- END P2;
-
- PROCEDURE P2 (B1 : IN OUT BOOLEAN) IS
- BEGIN
- S(2) := 'D';
- END P2;
-
- BEGIN
- P1 (I, J, B);
- P1 (I, J);
-
- IF S /= "AB" THEN
- FAILED ("PROCEDURES DIFFERING ONLY IN " &
- "NUMBER OF PARAMETERS (NO DEFAULTS) " &
- "CAUSED CONFUSION");
- END IF;
-
- S := "12";
- P2 (B, I);
- -- NOTE THAT A CALL TO P2 WITH ONLY
- -- ONE PARAMETER IS AMBIGUOUS.
-
- IF S /= "C2" THEN
- FAILED ("PROCEDURES DIFFERING ONLY IN " &
- "EXISTENCE OF ONE PARAMETER (WITH " &
- "DEFAULT) CAUSED CONFUSION");
- END IF;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002d.ada b/gcc/testsuite/ada/acats/tests/c6/c66002d.ada
deleted file mode 100644
index fe42098..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002d.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- C66002D.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (D) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT
--- OF THE CORRESPONDING ONE.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
-
-WITH REPORT;
-PROCEDURE C66002D IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002D", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- THE BASE TYPE OF ONE PARAMETER IS
- -- DIFFERENT FROM THAT OF THE CORRESPONDING
- -- ONE.
-
- DECLARE
- I, J, K : INTEGER := 0;
- B : BOOLEAN;
- S : STRING (1..2) := "12";
-
- PROCEDURE P (I1 : INTEGER; BI : OUT BOOLEAN;
- I2 : IN OUT INTEGER) IS
- BEGIN
- S(1) := 'A';
- BI := TRUE; -- THIS VALUE IS IRRELEVENT.
- END P;
-
- PROCEDURE P (I1 : INTEGER; BI : OUT INTEGER;
- I2 : IN OUT INTEGER) IS
- BEGIN
- S(2) := 'B';
- BI := 0; -- THIS VALUE IS IRRELEVENT.
- END P;
-
- BEGIN
- P (I, B, K);
- P (I, J, K);
-
- IF S /= "AB" THEN
- FAILED ("PROCEDURES DIFFERING ONLY BY " &
- "THE BASE TYPE OF A PARAMETER " &
- "CAUSED CONFUSION");
- END IF;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002e.ada b/gcc/testsuite/ada/acats/tests/c6/c66002e.ada
deleted file mode 100644
index d2b5096..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002e.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- C66002E.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (E) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE
--- PART, THE OTHER IN AN INNER PART, AND THE PARAMETERS ARE
--- ORDERED DIFFERENTLY.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
-
-WITH REPORT;
-PROCEDURE C66002E IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002E", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- ONE SUBPROGRAM IS DECLARED IN AN OUTER
- -- DECLARATIVE PART, THE OTHER IN AN INNER
- -- PART, AND THE PARAMETERS ARE ORDERED
- -- DIFFERENTLY.
-
- DECLARE
- S : STRING (1..2) := "12";
-
- PROCEDURE P (I1 : INTEGER; I2 : IN OUT INTEGER;
- B1 : BOOLEAN) IS
- BEGIN
- S(1) := 'A';
- END P;
-
- BEGIN
- DECLARE
- I : INTEGER := 0;
-
- PROCEDURE P (B1 : BOOLEAN; I1 : INTEGER;
- I2 : IN OUT INTEGER) IS
- BEGIN
- S(2) := 'B';
- END P;
-
- BEGIN
- P (5, I, TRUE);
- P (TRUE, 5, I);
- -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS
- -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS.
-
- IF S /= "AB" THEN
- FAILED ("PROCEDURES IN " &
- "ENCLOSING-ENCLOSED SCOPES " &
- "DIFFERING ONLY IN PARAMETER " &
- "TYPE ORDER CAUSED CONFUSION");
- END IF;
- END;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002f.ada b/gcc/testsuite/ada/acats/tests/c6/c66002f.ada
deleted file mode 100644
index a628977..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002f.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- C66002F.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (F) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART,
--- THE OTHER IN AN INNER PART, AND ONE HAS ONE MORE PARAMETER
--- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
-
-WITH REPORT;
-PROCEDURE C66002F IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002F", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- ONE SUBPROGRAM IS IN AN OUTER DECLARATIVE
- -- PART, THE OTHER IN AN INNER PART, AND ONE
- -- HAS ONE MORE PARAMETER (WITH A DEFAULT
- -- VALUE) THAN THE OTHER.
-
- BF :
- DECLARE
- S : STRING (1..3) := "123";
-
- PROCEDURE P (I1, I2, I3 : INTEGER := 1) IS
- C : CONSTANT STRING := "CXA";
- BEGIN
- S(I3) := C(I3);
- END P;
-
- PROCEDURE ENCLOSE IS
-
- PROCEDURE P (I1, I2 : INTEGER := 1) IS
- BEGIN
- S(2) := 'B';
- END P;
-
- BEGIN -- ENCLOSE
- P (1, 2, 3);
- ENCLOSE.P (1, 2); -- NOTE THAT THESE CALLS
- BF.P (1, 2); -- MUST BE DISAMBIGUATED.
-
- IF S /= "CBA" THEN
- FAILED ("PROCEDURES IN ENCLOSING-" &
- "ENCLOSED SCOPES DIFFERING " &
- "ONLY IN EXISTENCE OF ONE " &
- "DEFAULT-VALUED PARAMETER CAUSED " &
- "CONFUSION");
- END IF;
- END ENCLOSE;
-
- BEGIN
- ENCLOSE;
- END BF;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002g.ada b/gcc/testsuite/ada/acats/tests/c6/c66002g.ada
deleted file mode 100644
index 06c6ea3..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c66002g.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C66002G.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 DECLARATIONS
--- ARE PERMITTED IN WHICH THERE IS A MINIMAL
--- DIFFERENCE BETWEEN THE DECLARATIONS.
-
--- (G) THE RESULT TYPE OF TWO FUNCTION DECLARATIONS IS DIFFERENT.
-
--- CVP 5/4/81
--- JRK 5/8/81
--- NL 10/13/81
--- SPS 10/26/82
-
-WITH REPORT;
-PROCEDURE C66002G IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C66002G", "SUBPROGRAM OVERLOADING WITH " &
- "MINIMAL DIFFERENCES ALLOWED");
-
- --------------------------------------------------
-
- -- THE RESULT TYPES OF TWO FUNCTION
- -- DECLARATIONS ARE DIFFERENT.
-
- DECLARE
- I : INTEGER;
- B : BOOLEAN;
- S : STRING (1..2) := "12";
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- S(1) := 'A';
- RETURN IDENT_INT (0); -- THIS VALUE IS IRRELEVENT.
- END F;
-
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- S(2) := 'B';
- RETURN IDENT_BOOL (TRUE); -- THIS VALUE IS IRRELEVANT.
- END F;
-
- BEGIN
- I := F;
- B := F;
-
- IF S /= "AB" THEN
- FAILED ("FUNCTIONS DIFFERING ONLY IN " &
- "BASE TYPE OF RETURNED VALUE " &
- "CAUSED CONFUSION");
- END IF;
- END;
-
- --------------------------------------------------
-
- RESULT;
-
-END C66002G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002a.ada b/gcc/testsuite/ada/acats/tests/c6/c67002a.ada
deleted file mode 100644
index da29599..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67002a.ada
+++ /dev/null
@@ -1,426 +0,0 @@
--- C67002A.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
--- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
--- SUBTESTS ARE:
--- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
--- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
--- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
--- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
--- WITH ONE PARAMETER.
-
--- CVP 5/7/81
--- JRK 6/1/81
--- CPP 6/25/84
-
-WITH REPORT;
-PROCEDURE C67002A IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C67002A", "USE OF OPERATOR SYMBOLS IN " &
- "(OVERLOADED) FUNCTION SPECIFICATIONS");
-
- -------------------------------------------------
-
- DECLARE -- (A)
- PACKAGE EQU IS
- TYPE LP IS LIMITED PRIVATE;
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- END EQU;
- USE EQU;
-
- LP1, LP2 : LP;
-
- PACKAGE BODY EQU IS
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN LPA > LPB;
- END "=";
- BEGIN
- LP1 := LP (IDENT_INT (7));
- LP2 := LP (IDENT_INT (8));
- END EQU;
-
- BEGIN -- (A)
- IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
- (LP1 = LP1) OR (LP2 /= LP1) THEN
- FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (A)
-
- -------------------------------------------------
-
- DECLARE -- (B)
- FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "AND";
-
- BEGIN -- (B)
- IF (IDENT_INT (10) AND 1) /= 'G' OR
- (5 AND 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (B)
-
- -------------------------------------------------
-
- DECLARE -- (C)
- FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "OR";
-
- BEGIN -- (C)
- IF (IDENT_INT (10) OR 1) /= 'G' OR
- (5 OR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (C)
-
- -------------------------------------------------
-
- DECLARE -- (D)
- FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "XOR";
-
- BEGIN -- (D)
- IF (IDENT_INT (10) XOR 1) /= 'G' OR
- (5 XOR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (D)
-
- -------------------------------------------------
-
- DECLARE -- (E)
- FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "<";
-
- BEGIN -- (E)
- IF (IDENT_INT (10) < 1) /= 'G' OR
- (5 < 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (E)
-
- -------------------------------------------------
-
- DECLARE -- (F)
- FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "<=";
-
- BEGIN -- (F)
- IF (IDENT_INT (10) <= 1) /= 'G' OR
- (5 <= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (F)
-
- -------------------------------------------------
-
- DECLARE -- (G)
- FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END ">";
-
- BEGIN -- (G)
- IF (IDENT_INT (10) > 1) /= 'G' OR
- (5 > 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (G)
-
- -------------------------------------------------
-
- DECLARE -- (H)
- FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END ">=";
-
- BEGIN -- (H)
- IF (IDENT_INT (10) >= 1) /= 'G' OR
- (5 >= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (H)
-
- -------------------------------------------------
-
- DECLARE -- (I)
- FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "&";
-
- BEGIN -- (I)
- IF (IDENT_INT (10) & 1) /= 'G' OR
- (5 & 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (I)
-
- -------------------------------------------------
-
- DECLARE -- (J)
- FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "*";
-
- BEGIN -- (J)
- IF (IDENT_INT (10) * 1) /= 'G' OR
- (5 * 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (J)
-
- -------------------------------------------------
-
- DECLARE -- (K)
- FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "/";
-
- BEGIN -- (K)
- IF (IDENT_INT (10) / 1) /= 'G' OR
- (5 / 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (K)
-
- -------------------------------------------------
-
- DECLARE -- (L)
- FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "MOD";
-
- BEGIN -- (L)
- IF (IDENT_INT (10) MOD 1) /= 'G' OR
- (5 MOD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (L)
-
- -------------------------------------------------
-
- DECLARE -- (M)
- FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "REM";
-
- BEGIN -- (M)
- IF (IDENT_INT (10) REM 1) /= 'G' OR
- (5 REM 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (M)
-
- -------------------------------------------------
-
- DECLARE -- (N)
- FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "**";
-
- BEGIN -- (N)
- IF (IDENT_INT (10) ** 1) /= 'G' OR
- (5 ** 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (N)
-
- -------------------------------------------------
-
- DECLARE -- (O)
- FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "+";
-
- BEGIN -- (O)
- IF (IDENT_INT (10) + 1) /= 'G' OR
- (5 + 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (O)
-
- -------------------------------------------------
-
- DECLARE -- (P)
- FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "-";
-
- BEGIN -- (P)
- IF (IDENT_INT (10) - 1) /= 'G' OR
- (5 - 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (P)
-
- -------------------------------------------------
-
- DECLARE -- (Q)
- FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "+";
-
- BEGIN -- (Q)
- IF (+ IDENT_INT(25) /= 'P') OR
- (+ (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""+"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (Q)
-
- -------------------------------------------------
-
- DECLARE -- (R)
- FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "-";
-
- BEGIN -- (R)
- IF (- IDENT_INT(25) /= 'P') OR
- (- (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""-"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (R)
-
- -------------------------------------------------
-
- DECLARE -- (S)
- FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "NOT";
-
- BEGIN -- (S)
- IF (NOT IDENT_INT(25) /= 'P') OR
- (NOT (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""NOT"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (S)
-
- -------------------------------------------------
-
- DECLARE -- (T)
- FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "ABS";
-
- BEGIN -- (T)
- IF (ABS IDENT_INT(25) /= 'P') OR
- (ABS (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""ABS"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (T)
-
- -------------------------------------------------
-
- RESULT;
-END C67002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002b.ada b/gcc/testsuite/ada/acats/tests/c6/c67002b.ada
deleted file mode 100644
index d716fb3..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67002b.ada
+++ /dev/null
@@ -1,176 +0,0 @@
--- C67002B.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
--- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
--- THIS TEST CHECKS THE CASE OF CERTAIN OPERATOR SYMBOLS.
--- SUBTESTS ARE:
--- (A) THROUGH (E): "AND", "OR", "XOR", "MOD", "REM"
--- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
--- (F) AND (G): "NOT" AND "ABS", RESPECTIVELY,
--- WITH ONE PARAMETER.
-
--- CPP 6/26/84
-
-WITH REPORT;
-PROCEDURE C67002B IS
-
- USE REPORT;
-
-BEGIN
- TEST ("C67002B", "USE OF OPERATOR SYMBOLS IN " &
- "(OVERLOADED) FUNCTION SPECIFICATIONS");
-
- -------------------------------------------------
-
- DECLARE -- (A)
- FUNCTION "And" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "And";
-
- BEGIN -- (A)
- IF (IDENT_INT (10) AND 1) /= 'G' OR
- (5 AnD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""And"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (A)
-
- -------------------------------------------------
-
- DECLARE -- (B)
- FUNCTION "or" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "or";
-
- BEGIN -- (B)
- IF (IDENT_INT (10) Or 1) /= 'G' OR
- (5 OR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""or"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (B)
-
- -------------------------------------------------
-
- DECLARE -- (C)
- FUNCTION "xOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "xOR";
-
- BEGIN -- (C)
- IF (IDENT_INT (10) XoR 1) /= 'G' OR
- (5 xOR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""xOR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (C)
-
- -------------------------------------------------
-
- DECLARE -- (D)
- FUNCTION "mOd" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "mOd";
-
- BEGIN -- (D)
- IF (IDENT_INT (10) MoD 1) /= 'G' OR
- (5 moD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""mOd"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (D)
-
- -------------------------------------------------
-
- DECLARE -- (E)
- FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END "REM";
-
- BEGIN -- (E)
- IF (IDENT_INT (10) rem 1) /= 'G' OR
- (5 Rem 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (E)
-
- -------------------------------------------------
-
- DECLARE -- (F)
- FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "NOT";
-
- BEGIN -- (F)
- IF (Not IDENT_INT(25) /= 'P') OR
- (noT (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""NOT"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (F)
-
- -------------------------------------------------
-
- DECLARE -- (G)
- FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT (0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END "ABS";
-
- BEGIN -- (G)
- IF (abs IDENT_INT(25) /= 'P') OR
- (Abs (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""ABS"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (T)
-
- -------------------------------------------------
-
- RESULT;
-END C67002B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002c.ada b/gcc/testsuite/ada/acats/tests/c6/c67002c.ada
deleted file mode 100644
index 4a40231..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67002c.ada
+++ /dev/null
@@ -1,548 +0,0 @@
--- C67002C.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
--- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
--- THIS TEST CHECKS FORMAL SUBPROGRAM PARAMETERS.
--- SUBTESTS ARE:
--- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
--- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
--- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
--- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
--- WITH ONE PARAMETER.
-
--- CPP 6/26/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67002C IS
-
- FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END TWO_PARAMS;
-
- FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT(0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END ONE_PARAM;
-
-BEGIN
- TEST ("C67002C", "USE OF OPERATOR SYMBOLS IN " &
- "(OVERLOADED) FUNCTION SPECIFICATIONS");
-
- -------------------------------------------------
-
- DECLARE -- (A)
-
- PACKAGE EQU IS
- TYPE LP IS LIMITED PRIVATE;
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- END EQU;
- USE EQU;
-
- LP1, LP2 : LP;
-
- PACKAGE BODY EQU IS
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN LPA > LPB;
- END "=";
- BEGIN
- LP1 := LP (IDENT_INT (7));
- LP2 := LP (IDENT_INT (8));
- END EQU;
-
- GENERIC
- WITH FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
- (LP1 = LP1) OR (LP2 /= LP1) THEN
- FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE EQUAL IS NEW PKG ("=" => EQU."=");
-
- BEGIN -- (A)
- NULL;
- END; -- (A)
-
- -------------------------------------------------
-
- DECLARE -- (B)
-
- GENERIC
- WITH FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) AND 1) /= 'G' OR
- (5 AND 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("AND" => TWO_PARAMS);
-
- BEGIN -- (B)
- NULL;
- END; -- (B)
-
- -------------------------------------------------
-
- DECLARE -- (C)
-
- GENERIC
- WITH FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) OR 1) /= 'G' OR
- (5 OR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("OR" => TWO_PARAMS);
-
- BEGIN -- (C)
- NULL;
- END; -- (C)
-
- -------------------------------------------------
-
- DECLARE -- (D)
-
- GENERIC
- WITH FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) XOR 1) /= 'G' OR
- (5 XOR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("XOR" => TWO_PARAMS);
-
- BEGIN -- (D)
- NULL;
- END; -- (D)
-
- -------------------------------------------------
-
- DECLARE -- (E)
-
- GENERIC
- WITH FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) < 1) /= 'G' OR
- (5 < 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("<" => TWO_PARAMS);
-
- BEGIN -- (E)
- NULL;
- END; -- (E)
-
- -------------------------------------------------
-
- DECLARE -- (F)
-
- GENERIC
- WITH FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) <= 1) /= 'G' OR
- (5 <= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("<=" => TWO_PARAMS);
-
- BEGIN -- (F)
- NULL;
- END; -- (F)
-
- -------------------------------------------------
-
- DECLARE -- (G)
-
- GENERIC
- WITH FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) > 1) /= 'G' OR
- (5 > 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG (">" => TWO_PARAMS);
-
- BEGIN -- (G)
- NULL;
- END; -- (G)
-
- -------------------------------------------------
-
- DECLARE -- (H)
-
- GENERIC
- WITH FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) >= 1) /= 'G' OR
- (5 >= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG (">=" => TWO_PARAMS);
-
- BEGIN -- (H)
- NULL;
- END; -- (H)
-
- -------------------------------------------------
-
- DECLARE -- (I)
-
- GENERIC
- WITH FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) & 1) /= 'G' OR
- (5 & 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("&" => TWO_PARAMS);
-
- BEGIN -- (I)
- NULL;
- END; -- (I)
-
- -------------------------------------------------
-
- DECLARE -- (J)
-
- GENERIC
- WITH FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) * 1) /= 'G' OR
- (5 * 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("*" => TWO_PARAMS);
-
- BEGIN -- (J)
- NULL;
- END; -- (J)
-
- -------------------------------------------------
-
- DECLARE -- (K)
-
- GENERIC
- WITH FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) / 1) /= 'G' OR
- (5 / 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("/" => TWO_PARAMS);
-
- BEGIN -- (K)
- NULL;
- END; -- (K)
-
- -------------------------------------------------
-
- DECLARE -- (L)
-
- GENERIC
- WITH FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) MOD 1) /= 'G' OR
- (5 MOD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("MOD" => TWO_PARAMS);
-
- BEGIN -- (L)
- NULL;
- END; -- (L)
-
- -------------------------------------------------
-
- DECLARE -- (M)
-
- GENERIC
- WITH FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) REM 1) /= 'G' OR
- (5 REM 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("REM" => TWO_PARAMS);
-
- BEGIN -- (M)
- NULL;
- END; -- (M)
-
- -------------------------------------------------
-
- DECLARE -- (N)
-
- GENERIC
- WITH FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) ** 1) /= 'G' OR
- (5 ** 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("**" => TWO_PARAMS);
-
- BEGIN -- (N)
- NULL;
- END; -- (N)
-
- -------------------------------------------------
-
- DECLARE -- (O)
-
- GENERIC
- WITH FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) + 1) /= 'G' OR
- (5 + 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("+" => TWO_PARAMS);
-
- BEGIN -- (O)
- NULL;
- END; -- (O)
-
- -------------------------------------------------
-
- DECLARE -- (P)
-
- GENERIC
- WITH FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (IDENT_INT (10) - 1) /= 'G' OR
- (5 - 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("-" => TWO_PARAMS);
-
- BEGIN -- (P)
- NULL;
- END; -- (P)
-
- -------------------------------------------------
-
- DECLARE -- (Q)
-
- GENERIC
- WITH FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (+ IDENT_INT(25) /= 'P') OR
- (+ (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""+"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("+" => ONE_PARAM);
-
- BEGIN -- (Q)
- NULL;
- END; -- (Q)
-
- -------------------------------------------------
-
- DECLARE -- (R)
-
- GENERIC
- WITH FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (- IDENT_INT(25) /= 'P') OR
- (- (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""-"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("-" => ONE_PARAM);
-
- BEGIN -- (R)
- NULL;
- END; -- (R)
-
- -------------------------------------------------
-
- DECLARE -- (S)
-
- GENERIC
- WITH FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (NOT IDENT_INT(25) /= 'P') OR
- (NOT (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""NOT"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("NOT" => ONE_PARAM);
-
- BEGIN -- (S)
- NULL;
- END; -- (S)
-
- -------------------------------------------------
-
- DECLARE -- (T)
-
- GENERIC
- WITH FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER;
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF (ABS IDENT_INT(25) /= 'P') OR
- (ABS (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""ABS"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG ("ABS" => ONE_PARAM);
-
- BEGIN -- (T)
- NULL;
- END; -- (T)
-
- -------------------------------------------------
-
- RESULT;
-END C67002C;
-
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002d.ada b/gcc/testsuite/ada/acats/tests/c6/c67002d.ada
deleted file mode 100644
index 3d82980..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67002d.ada
+++ /dev/null
@@ -1,354 +0,0 @@
--- C67002D.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
--- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
--- THIS TEST CHECKS GENERIC INSTANTIATIONS FOR THESE FUNCTIONS.
--- SUBTESTS ARE:
--- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
--- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
--- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
--- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
--- WITH ONE PARAMETER.
-
--- CPP 6/25/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67002D IS
-
- GENERIC
- TYPE ELEMENT IS (<>);
- FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER;
- FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END TWO_PARAMS;
-
- GENERIC
- TYPE ELEMENT IS (<>);
- FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER;
- FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER IS
- BEGIN
- IF I1 < ELEMENT'VAL(IDENT_INT(0)) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END ONE_PARAM;
-
-BEGIN
- TEST ("C67002D", "USE OF OPERATOR SYMBOLS IN " &
- "(OVERLOADED) FUNCTION SPECIFICATIONS");
-
- -------------------------------------------------
-
- DECLARE -- (A)
- GENERIC
- TYPE LP IS LIMITED PRIVATE;
- WITH FUNCTION ">" (L, R : LP) RETURN BOOLEAN IS <>;
- PACKAGE PKG IS
- LP1, LP2 : LP;
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
- END PKG;
-
- PACKAGE BODY PKG IS
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN LPA > LPB;
- END "=";
- END PKG;
-
- BEGIN -- (A)
- DECLARE
- PACKAGE PACK IS NEW PKG (LP => INTEGER);
- USE PACK;
- FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN
- RENAMES PACK."=";
- BEGIN
- LP1 := IDENT_INT(7);
- LP2 := IDENT_INT(8);
- IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
- (LP1 = LP1) OR (LP2 /= LP1) THEN
- FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
- END IF;
- END;
- END; -- (A)
-
- -------------------------------------------------
-
- DECLARE -- (B)
- FUNCTION "AND" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (B)
- IF (IDENT_INT (10) AND 1) /= 'G' OR
- (5 AND 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (B)
-
- -------------------------------------------------
-
- DECLARE -- (C)
- FUNCTION "OR" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (C)
- IF (IDENT_INT (10) OR 1) /= 'G' OR
- (5 OR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (C)
-
- -------------------------------------------------
-
- DECLARE -- (D)
- FUNCTION "XOR" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (D)
- IF (IDENT_INT (10) XOR 1) /= 'G' OR
- (5 XOR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (D)
-
- -------------------------------------------------
-
- DECLARE -- (E)
- FUNCTION "<" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (E)
- IF (IDENT_INT (10) < 1) /= 'G' OR
- (5 < 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (E)
-
- -------------------------------------------------
-
- DECLARE -- (F)
- FUNCTION "<=" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (F)
- IF (IDENT_INT (10) <= 1) /= 'G' OR
- (5 <= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (F)
-
- -------------------------------------------------
-
- DECLARE -- (G)
- FUNCTION ">" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (G)
- IF (IDENT_INT (10) > 1) /= 'G' OR
- (5 > 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (G)
-
- -------------------------------------------------
-
- DECLARE -- (H)
- FUNCTION ">=" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (H)
- IF (IDENT_INT (10) >= 1) /= 'G' OR
- (5 >= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (H)
-
- -------------------------------------------------
-
- DECLARE -- (I)
- FUNCTION "&" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (I)
- IF (IDENT_INT (10) & 1) /= 'G' OR
- (5 & 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (I)
-
- -------------------------------------------------
-
- DECLARE -- (J)
- FUNCTION "*" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (J)
- IF (IDENT_INT (10) * 1) /= 'G' OR
- (5 * 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (J)
-
- -------------------------------------------------
-
- DECLARE -- (K)
- FUNCTION "/" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (K)
- IF (IDENT_INT (10) / 1) /= 'G' OR
- (5 / 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (K)
-
- -------------------------------------------------
-
- DECLARE -- (L)
- FUNCTION "MOD" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (L)
- IF (IDENT_INT (10) MOD 1) /= 'G' OR
- (5 MOD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (L)
-
- -------------------------------------------------
-
- DECLARE -- (M)
- FUNCTION "REM" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (M)
- IF (IDENT_INT (10) REM 1) /= 'G' OR
- (5 REM 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (M)
-
- -------------------------------------------------
-
- DECLARE -- (N)
- FUNCTION "**" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (N)
- IF (IDENT_INT (10) ** 1) /= 'G' OR
- (5 ** 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (N)
-
- -------------------------------------------------
-
- DECLARE -- (O)
- FUNCTION "+" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (O)
- IF (IDENT_INT (10) + 1) /= 'G' OR
- (5 + 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (O)
-
- -------------------------------------------------
-
- DECLARE -- (P)
- FUNCTION "-" IS NEW TWO_PARAMS
- (ELEMENT => INTEGER);
-
- BEGIN -- (P)
- IF (IDENT_INT (10) - 1) /= 'G' OR
- (5 - 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (P)
-
- -------------------------------------------------
-
- DECLARE -- (Q)
- FUNCTION "+" IS NEW ONE_PARAM
- (ELEMENT => INTEGER);
-
- BEGIN -- (Q)
- IF (+ IDENT_INT(25) /= 'P') OR
- (+ (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""+"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (Q)
-
- -------------------------------------------------
-
- DECLARE -- (R)
- FUNCTION "-" IS NEW ONE_PARAM
- (ELEMENT => INTEGER);
-
- BEGIN -- (R)
- IF (- IDENT_INT(25) /= 'P') OR
- (- (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""-"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (R)
-
- -------------------------------------------------
-
- DECLARE -- (S)
- FUNCTION "NOT" IS NEW ONE_PARAM
- (ELEMENT => INTEGER);
-
- BEGIN -- (S)
- IF (NOT IDENT_INT(25) /= 'P') OR
- (NOT (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""NOT"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (S)
-
- -------------------------------------------------
-
- DECLARE -- (T)
- FUNCTION "ABS" IS NEW ONE_PARAM
- (ELEMENT => INTEGER);
-
- BEGIN -- (T)
- IF (ABS IDENT_INT(25) /= 'P') OR
- (ABS (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""ABS"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (T)
-
- -------------------------------------------------
-
- RESULT;
-END C67002D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002e.ada b/gcc/testsuite/ada/acats/tests/c6/c67002e.ada
deleted file mode 100644
index aa36952..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67002e.ada
+++ /dev/null
@@ -1,348 +0,0 @@
--- C67002E.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 OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
--- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
--- THIS TEST CHECKS RENAMING DECLARATIONS FOR THESE FUNCTIONS.
--- SUBTESTS ARE:
--- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
--- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
--- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
--- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
--- WITH ONE PARAMETER.
-
--- CPP 6/26/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67002E IS
-
- FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 > I2 THEN
- RETURN 'G';
- ELSE RETURN 'L';
- END IF;
- END TWO_PARAMS;
-
- FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF I1 < IDENT_INT(0) THEN
- RETURN 'N';
- ELSE RETURN 'P';
- END IF;
- END ONE_PARAM;
-
-BEGIN
- TEST ("C67002E", "USE OF OPERATOR SYMBOLS IN " &
- "(OVERLOADED) FUNCTION SPECIFICATIONS");
-
- -------------------------------------------------
-
- DECLARE -- (A)
-
- PACKAGE PKG IS
- TYPE LP IS LIMITED PRIVATE;
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- END PKG;
- USE PKG;
-
- LP1, LP2 : LP;
-
- FUNCTION "=" (LPA, LPB : LP)
- RETURN BOOLEAN RENAMES PKG."=";
-
- PACKAGE BODY PKG IS
- FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN LPA > LPB;
- END "=";
- BEGIN
- LP1 := LP (IDENT_INT (7));
- LP2 := LP (IDENT_INT (8));
- END PKG;
-
- BEGIN -- (A)
- IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
- (LP1 = LP1) OR (LP2 /= LP1) THEN
- FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (A)
-
- -------------------------------------------------
-
- DECLARE -- (B)
- FUNCTION "AND" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (B)
- IF (IDENT_INT (10) AND 1) /= 'G' OR
- (5 AND 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (B)
-
- -------------------------------------------------
-
- DECLARE -- (C)
- FUNCTION "OR" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (C)
- IF (IDENT_INT (10) OR 1) /= 'G' OR
- (5 OR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (C)
-
- -------------------------------------------------
-
- DECLARE -- (D)
- FUNCTION "XOR" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (D)
- IF (IDENT_INT (10) XOR 1) /= 'G' OR
- (5 XOR 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (D)
-
- -------------------------------------------------
-
- DECLARE -- (E)
- FUNCTION "<" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (E)
- IF (IDENT_INT (10) < 1) /= 'G' OR
- (5 < 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (E)
-
- -------------------------------------------------
-
- DECLARE -- (F)
- FUNCTION "<=" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (F)
- IF (IDENT_INT (10) <= 1) /= 'G' OR
- (5 <= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (F)
-
- -------------------------------------------------
-
- DECLARE -- (G)
- FUNCTION ">" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (G)
- IF (IDENT_INT (10) > 1) /= 'G' OR
- (5 > 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (G)
-
- -------------------------------------------------
-
- DECLARE -- (H)
- FUNCTION ">=" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (H)
- IF (IDENT_INT (10) >= 1) /= 'G' OR
- (5 >= 10) /= 'L' THEN
- FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
- END IF;
- END; -- (H)
-
- -------------------------------------------------
-
- DECLARE -- (I)
- FUNCTION "&" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (I)
- IF (IDENT_INT (10) & 1) /= 'G' OR
- (5 & 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (I)
-
- -------------------------------------------------
-
- DECLARE -- (J)
- FUNCTION "*" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (J)
- IF (IDENT_INT (10) * 1) /= 'G' OR
- (5 * 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (J)
-
- -------------------------------------------------
-
- DECLARE -- (K)
- FUNCTION "/" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (K)
- IF (IDENT_INT (10) / 1) /= 'G' OR
- (5 / 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (K)
-
- -------------------------------------------------
-
- DECLARE -- (L)
- FUNCTION "MOD" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (L)
- IF (IDENT_INT (10) MOD 1) /= 'G' OR
- (5 MOD 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (L)
-
- -------------------------------------------------
-
- DECLARE -- (M)
- FUNCTION "REM" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (M)
- IF (IDENT_INT (10) REM 1) /= 'G' OR
- (5 REM 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (M)
-
- -------------------------------------------------
-
- DECLARE -- (N)
- FUNCTION "**" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (N)
- IF (IDENT_INT (10) ** 1) /= 'G' OR
- (5 ** 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (N)
-
- -------------------------------------------------
-
- DECLARE -- (O)
- FUNCTION "+" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (O)
- IF (IDENT_INT (10) + 1) /= 'G' OR
- (5 + 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (O)
-
- -------------------------------------------------
-
- DECLARE -- (P)
- FUNCTION "-" (I1, I2 : INTEGER)
- RETURN CHARACTER RENAMES TWO_PARAMS;
-
- BEGIN -- (P)
- IF (IDENT_INT (10) - 1) /= 'G' OR
- (5 - 10) /= 'L' THEN
- FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
- END IF;
- END; -- (P)
-
- -------------------------------------------------
-
- DECLARE -- (Q)
- FUNCTION "+" (I1 : INTEGER)
- RETURN CHARACTER RENAMES ONE_PARAM;
-
- BEGIN -- (Q)
- IF (+ IDENT_INT(25) /= 'P') OR
- (+ (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""+"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (Q)
-
- -------------------------------------------------
-
- DECLARE -- (R)
- FUNCTION "-" (I1 : INTEGER)
- RETURN CHARACTER RENAMES ONE_PARAM;
-
- BEGIN -- (R)
- IF (- IDENT_INT(25) /= 'P') OR
- (- (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""-"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (R)
-
- -------------------------------------------------
-
- DECLARE -- (S)
- FUNCTION "NOT" (I1 : INTEGER)
- RETURN CHARACTER RENAMES ONE_PARAM;
-
- BEGIN -- (S)
- IF (NOT IDENT_INT(25) /= 'P') OR
- (NOT (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""NOT"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (S)
-
- -------------------------------------------------
-
- DECLARE -- (T)
- FUNCTION "ABS" (I1 : INTEGER)
- RETURN CHARACTER RENAMES ONE_PARAM;
-
- BEGIN -- (T)
- IF (ABS IDENT_INT(25) /= 'P') OR
- (ABS (0-25) /= 'N') THEN
- FAILED ("OVERLOADING OF ""ABS"" " &
- "OPERATOR (ONE OPERAND) DEFECTIVE");
- END IF;
- END; -- (T)
-
- -------------------------------------------------
-
- RESULT;
-END C67002E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67003f.ada b/gcc/testsuite/ada/acats/tests/c6/c67003f.ada
deleted file mode 100644
index fde865c..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67003f.ada
+++ /dev/null
@@ -1,319 +0,0 @@
--- C67003F.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 PREDEFINED OPERATORS FOR THE PREDEFINED TYPES CAN BE
--- REDEFINED.
--- CHECK THAT THE REDEFINED OPERATOR IS INVOKED WHEN INFIX OR PREFIX
--- NOTATION IS USED.
-
--- HISTORY:
--- WMC 03/21/92 TEST CREATED FROM CONSOLIDATION OF C67003[A-E].ADA
-
-
-WITH REPORT;
-
-PROCEDURE C67003F IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C67003F", "CHECK THAT REDEFINITION OF " &
- "OPERATORS FOR PREDEFINED TYPES WORKS");
-
- DECLARE -- INTEGER OPERATORS.
-
- -- INTEGER INFIX OPERATORS.
-
- FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= Y THEN
- RETURN 1;
- ELSE RETURN 0;
- END IF;
- END "*";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= Y THEN
- RETURN 2;
- ELSE RETURN 0;
- END IF;
- END "+";
-
- FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= Y THEN
- RETURN 3;
- ELSE RETURN 0;
- END IF;
- END "REM";
-
- -- INTEGER PREFIX OPERATORS.
-
- FUNCTION "+" (X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= 0 THEN
- RETURN 4;
- ELSE RETURN 0;
- END IF;
- END "+";
-
- FUNCTION "ABS" (X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= 0 THEN
- RETURN 5;
- ELSE RETURN 0;
- END IF;
- END "ABS";
-
- -- INTEGER RELATIONAL OPERATOR.
-
- FUNCTION "<" (X, Y : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END "<";
-
- BEGIN
-
- IF IDENT_INT (3) * IDENT_INT (5) /= 1 THEN
- FAILED ("REDEFINITION OF INTEGER ""*"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_INT (1) + IDENT_INT (30) /= 2 THEN
- FAILED ("REDEFINITION OF INTEGER ""+"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_INT (7) REM IDENT_INT (8) /= 3 THEN
- FAILED ("REDEFINITION OF ""REM"" IS DEFECTIVE");
- END IF;
-
- IF + (IDENT_INT (10)) /= 4 THEN
- FAILED ("REDEFINITION OF INTEGER UNARY ""+"" IS DEFECTIVE");
- END IF;
-
- IF ABS (IDENT_INT (2)) /= 5 THEN
- FAILED ("REDEFINITION OF INTEGER ""ABS"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_INT (7) < IDENT_INT (8) THEN
- FAILED ("REDEFINITION OF INTEGER ""<"" IS DEFECTIVE");
- END IF;
-
- END;
-
- DECLARE -- FLOAT OPERATORS.
-
- -- NOTE THAT ALL LITERAL VALUES USED SHOULD BE
- -- REPRESENTABLE EXACTLY.
-
- FUNCTION IDENT_FLOAT (X : FLOAT) RETURN FLOAT IS
- I : INTEGER := INTEGER (X);
- BEGIN
- IF EQUAL (I, I) THEN -- ALWAYS EQUAL.
- RETURN X;
- END IF;
- RETURN 0.0;
- END IDENT_FLOAT;
-
- -- FLOAT INFIX OPERATORS.
-
- FUNCTION "-" (X, Y : FLOAT) RETURN FLOAT IS
- BEGIN
- IF X /= Y THEN
- RETURN 1.0;
- ELSE RETURN 0.0;
- END IF;
- END "-";
-
- FUNCTION "/" (X, Y : FLOAT) RETURN FLOAT IS
- BEGIN
- IF X /= Y THEN
- RETURN 2.0;
- ELSE RETURN 0.0;
- END IF;
- END "/";
-
- FUNCTION "**" (X : FLOAT; Y : INTEGER) RETURN FLOAT IS
- BEGIN
- IF INTEGER (X) /= Y THEN
- RETURN 3.0;
- ELSE RETURN 0.0;
- END IF;
- END "**";
-
- -- FLOAT PREFIX OPERATOR.
-
- FUNCTION "-" (X : FLOAT) RETURN FLOAT IS
- BEGIN
- IF X /= 0.0 THEN
- RETURN 4.0;
- ELSE RETURN 0.0;
- END IF;
- END "-";
-
- -- FLOAT RELATIONAL OPERATOR.
-
- FUNCTION "<=" (X, Y : FLOAT) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END "<=";
-
- BEGIN
-
- IF IDENT_FLOAT (50.0) - IDENT_FLOAT (100.0) /= 1.0 THEN
- FAILED ("REDEFINITION OF FLOAT ""-"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_FLOAT (5.0) / IDENT_FLOAT (1.0) /= 2.0 THEN
- FAILED ("REDEFINITION OF FLOAT ""/"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_FLOAT (3.0) ** IDENT_INT (2) /= 3.0 THEN
- FAILED ("REDEFINITION OF FLOAT ""**"" IS DEFECTIVE");
- END IF;
-
- IF -(IDENT_FLOAT (5.0)) /= 4.0 THEN
- FAILED ("REDEFINITION OF FLOAT UNARY ""-"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_FLOAT (1.0) <= IDENT_FLOAT (5.0) THEN
- FAILED ("REDEFINITION OF FLOAT ""<="" IS DEFECTIVE");
- END IF;
-
- END;
-
- DECLARE -- BOOLEAN OPERATORS.
-
- -- BOOLEAN LOGICAL OPERATORS.
-
- FUNCTION "AND" (X, Y : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- IF X AND THEN Y THEN
- RETURN FALSE;
- ELSE RETURN TRUE;
- END IF;
- END "AND";
-
- FUNCTION "XOR" (X, Y : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END "XOR";
-
- -- BOOLEAN RELATIONAL OPERATOR.
-
- FUNCTION ">" (X, Y : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END ">";
-
- BEGIN
-
- IF IDENT_BOOL (TRUE) AND IDENT_BOOL (TRUE) THEN
- FAILED ("REDEFINITION OF ""AND"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_BOOL (TRUE) XOR IDENT_BOOL (FALSE) THEN
- FAILED ("REDEFINITION OF ""XOR"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_BOOL (TRUE) > IDENT_BOOL (FALSE) THEN
- FAILED ("REDEFINITION OF BOOLEAN "">"" IS DEFECTIVE");
- END IF;
-
- END;
-
- DECLARE -- STRING OPERATORS.
-
- S1 : STRING (1..2) := "A" & IDENT_CHAR ('B');
- S2 : STRING (1..2) := "C" & IDENT_CHAR ('D');
-
- FUNCTION "&" (X, Y : STRING) RETURN STRING IS
- Z : STRING (1 .. X'LENGTH + Y'LENGTH);
- BEGIN
- Z (1 .. Y'LENGTH) := Y;
- Z (Y'LENGTH + 1 .. Z'LAST) := X;
- RETURN Z;
- END "&";
-
- FUNCTION "&" (X : CHARACTER; Y : STRING) RETURN STRING IS
- Z : STRING (1 .. Y'LENGTH + 1);
- BEGIN
- Z (1 .. Y'LENGTH) := Y;
- Z (Z'LAST) := X;
- RETURN Z;
- END "&";
-
- -- STRING RELATIONAL OPERATOR.
-
- FUNCTION ">=" (X, Y : STRING) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END ">=";
-
- BEGIN
-
- IF S1 & S2 /= "CDAB" THEN
- FAILED ("BAD REDEFINITION OF ""&"" (S,S)");
- END IF;
-
- IF IDENT_CHAR ('C') & S1 /= "ABC" THEN
- FAILED ("BAD REDEFINITION OF ""&"" (C,S)");
- END IF;
-
- IF S2 >= S1 THEN
- FAILED ("BAD REDEFINITION OF STRING "">=""");
- END IF;
-
- END;
-
- DECLARE -- CHARACTER OPERATORS.
-
- -- CHARACTER RELATIONAL OPERATORS.
-
- FUNCTION ">" (X, Y : CHARACTER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END ">";
-
- FUNCTION "<=" (X, Y : CHARACTER) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y;
- END "<=";
-
- BEGIN
-
- IF IDENT_CHAR ('C') > IDENT_CHAR ('B') THEN
- FAILED ("REDEFINITION OF CHARACTER "">"" IS DEFECTIVE");
- END IF;
-
- IF IDENT_CHAR ('A') <= IDENT_CHAR ('E') THEN
- FAILED ("REDEFINITION OF CHARACTER ""<="" IS DEFECTIVE");
- END IF;
-
- END;
-
- RESULT;
-
-END C67003F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005a.ada b/gcc/testsuite/ada/acats/tests/c6/c67005a.ada
deleted file mode 100644
index e83d8d1..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67005a.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C67005A.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 IF A RENAMING DECLARATION DECLARES AN EQUALITY OPERATOR, THE
--- TYPES OF THE PARAMETERS NEED NOT BE LIMITED TYPES.
-
--- JBG 9/28/83
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67005A IS
-BEGIN
- TEST ("C67005A", "CHECK THAT AN EQUALITY OPERATOR DECLARED BY " &
- "A RENAMING DECLARATION NEED NOT HAVE " &
- "PARAMETERS OF A LIMITED TYPE");
- DECLARE
- GENERIC
- TYPE LP IS LIMITED PRIVATE;
- WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
- PACKAGE EQUALITY_OPERATOR IS
- FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
- END EQUALITY_OPERATOR;
-
- PACKAGE BODY EQUALITY_OPERATOR IS
- FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN EQUAL(L, R);
- END "=";
- END EQUALITY_OPERATOR;
-
- PACKAGE POLAR_COORDINATES IS
- TYPE POLAR_COORD IS
- RECORD
- R : INTEGER;
- THETA : INTEGER;
- END RECORD;
- FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN;
- PACKAGE POLAR_EQUAL IS NEW EQUALITY_OPERATOR
- (POLAR_COORD, EQUAL);
- FUNCTION "=" (L, R : POLAR_COORD) RETURN BOOLEAN
- RENAMES POLAR_EQUAL."=";
- END POLAR_COORDINATES;
-
- PACKAGE BODY POLAR_COORDINATES IS
- FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN IS
- BEGIN
- RETURN (L.THETA MOD 360) = (R.THETA MOD 360) AND
- L.R = R.R;
- END EQUAL;
- END POLAR_COORDINATES;
-
- USE POLAR_COORDINATES;
-
- PACKAGE VARIABLES IS
- P270 : POLAR_COORD := (R => 3, THETA => 270);
- P360 : POLAR_COORD := (R => 3, THETA => IDENT_INT(360));
- END VARIABLES;
-
- USE VARIABLES;
-
- BEGIN
-
- IF P270 /= (3, -90) THEN
- FAILED ("INCORRECT INEQUALITY OPERATOR");
- END IF;
-
- IF P360 = (3, 0) THEN
- NULL;
- ELSE
- FAILED ("INCORRECT EQUALITY OPERATOR");
- END IF;
-
- RESULT;
-
- END;
-END C67005A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005b.ada b/gcc/testsuite/ada/acats/tests/c6/c67005b.ada
deleted file mode 100644
index 2757960..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67005b.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C67005B.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 EQUALITY IS REDEFINED FOR A SCALAR TYPE, CASE
--- STATEMENTS STILL USE THE PREDEFINED EQUALITY OPERATION.
-
--- JBG 9/28/83
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67005B IS
-
- GENERIC
- TYPE LP IS LIMITED PRIVATE;
- WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
- PACKAGE EQUALITY_OPERATOR IS
- FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
- END EQUALITY_OPERATOR;
-
- PACKAGE BODY EQUALITY_OPERATOR IS
- FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN EQUAL(L, R);
- END "=";
- END EQUALITY_OPERATOR;
-
-BEGIN
- TEST ("C67005B", "CHECK THAT REDEFINING EQUALITY FOR A " &
- "SCALAR TYPE DOES NOT AFFECT CASE STATEMENTS");
-
- DECLARE
- TYPE MY IS NEW INTEGER;
- CHECK : MY;
-
- VAR : INTEGER RANGE 1..3 := 3;
-
- PACKAGE INTEGER_EQUALS IS
- FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN;
- PACKAGE INTEGER_EQUAL IS NEW EQUALITY_OPERATOR
- (INTEGER, EQUAL);
- END INTEGER_EQUALS;
-
- FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
- INTEGER_EQUALS.INTEGER_EQUAL."=";
-
- PACKAGE BODY INTEGER_EQUALS IS
- FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END EQUAL;
- END INTEGER_EQUALS;
-
- BEGIN
-
- IF VAR = 3 THEN
- FAILED ("DID NOT USE REDEFINED '=' - 1");
- END IF;
-
- IF VAR /= 3 THEN
- NULL;
- ELSE
- FAILED ("DID NOT USE REDEFINED '/=' - 1");
- END IF;
-
- IF VAR = IDENT_INT(3) THEN
- FAILED ("DID NOT USE REDEFINED '=' - 2");
- END IF;
-
- IF VAR /= IDENT_INT(3) THEN
- NULL;
- ELSE
- FAILED ("DID NOT USE REDEFINED '/=' - 2");
- END IF;
-
- CHECK := MY(IDENT_INT(0));
- IF CHECK /= 0 THEN
- FAILED ("USING WRONG EQUALITY FOR DERIVED TYPE");
- END IF;
-
- CASE VAR IS
- WHEN 1..3 => CHECK := MY(IDENT_INT(1));
- WHEN OTHERS => NULL;
- END CASE;
-
- IF CHECK /= 1 THEN
- FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 1");
- END IF;
-
- CASE IDENT_INT(VAR) IS
- WHEN 1 => CHECK := 4;
- WHEN 2 => CHECK := 5;
- WHEN 3 => CHECK := 6;
- WHEN OTHERS => CHECK := 7;
- END CASE;
-
- IF CHECK /= 6 THEN
- FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 2");
- END IF;
-
- END;
-
- RESULT;
-
-END C67005B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005c.ada b/gcc/testsuite/ada/acats/tests/c6/c67005c.ada
deleted file mode 100644
index b52c40d..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67005c.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C67005C.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 OF "=" NEED NOT HAVE PARAMETERS
--- OF A LIMITED TYPE IN A RENAMING DECLARATION. THIS TEST CHECKS
--- ACCESS TYPES.
-
--- BRYCE BARDIN (HUGHES AIRCRAFT) 7/2/84
--- CPP 7/12/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67005C IS
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- WITH FUNCTION EQUAL (LEFT, RIGHT : T) RETURN BOOLEAN IS <>;
- PACKAGE EQUALITY IS
- FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN;
- -- PRAGMA INLINE ("=");
- END EQUALITY;
-
- PACKAGE BODY EQUALITY IS
- FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
- BEGIN
- RETURN EQUAL (LEFT, RIGHT);
- END "=";
- END EQUALITY;
-
- PACKAGE STARTER IS
- TYPE INT IS PRIVATE;
- FUNCTION VALUE_OF (I : INTEGER) RETURN INT;
- FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN;
- PRIVATE
- TYPE INT IS ACCESS INTEGER;
- END STARTER;
-
- PACKAGE BODY STARTER IS
- FUNCTION VALUE_OF (I : INTEGER) RETURN INT IS
- BEGIN
- RETURN NEW INTEGER'(I);
- END VALUE_OF;
-
- FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN IS
- BEGIN
- RETURN LEFT.ALL = RIGHT.ALL;
- END EQUAL;
- END STARTER;
-
- PACKAGE ABSTRACTION IS
- TYPE INT IS NEW STARTER.INT;
- PACKAGE INT_EQUALITY IS NEW EQUALITY (INT, EQUAL);
- FUNCTION "=" (LEFT, RIGHT : INT) RETURN BOOLEAN
- RENAMES INT_EQUALITY."=";
- END ABSTRACTION;
- USE ABSTRACTION;
-
-BEGIN
-
- TEST ("C67005C", "RENAMING OF EQUALITY OPERATOR WITH " &
- "NON-LIMITED PARAMETERS");
-
- DECLARE
-
- I : INT := VALUE_OF(1);
- J : INT := VALUE_OF(0);
-
- PROCEDURE CHECK (B : BOOLEAN) IS
- BEGIN
- IF I = J AND B THEN
- COMMENT ("I = J");
- ELSIF I /= J AND NOT B THEN
- COMMENT ("I /= J");
- ELSE
- FAILED ("WRONG ""="" OPERATOR");
- END IF;
- END CHECK;
-
- BEGIN
-
- CHECK(FALSE);
- I := VALUE_OF(0);
- CHECK(TRUE);
-
- RESULT;
-
- END;
-
-END C67005C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005d.ada b/gcc/testsuite/ada/acats/tests/c6/c67005d.ada
deleted file mode 100644
index 95eafe2..0000000
--- a/gcc/testsuite/ada/acats/tests/c6/c67005d.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- C67005D.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 EQUALITY CAN BE REDEFINED FOR AN ARBITRARY TYPE BY USING A
--- SEQUENCE OF RENAMING DECLARATIONS.
-
--- JBG 9/11/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C67005D IS
-
- FUNCTION MY_EQUALS (L, R : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END MY_EQUALS;
-
- GENERIC
- TYPE LP IS LIMITED PRIVATE;
- WITH FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
- PACKAGE EQUALITY_OPERATOR IS
- PACKAGE INNER IS
- FUNCTION "=" (L, R : LP) RETURN BOOLEAN RENAMES
- EQUALITY_OPERATOR."=";
- END INNER;
- END EQUALITY_OPERATOR;
-
-BEGIN
- TEST ("C67005D", "CHECK REDEFINITION OF ""="" BY RENAMING");
-
- DECLARE
-
- CHK1 : BOOLEAN := 3 = IDENT_INT(3); -- PREDEFINED "="
-
- -- REDEFINE INTEGER "=".
-
- PACKAGE INT_EQUALITY IS NEW
- EQUALITY_OPERATOR (INTEGER, MY_EQUALS);
- FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
- INT_EQUALITY.INNER."=";
-
- CHK2 : BOOLEAN := 3 = IDENT_INT(3); -- REDEFINED "=".
-
- BEGIN
-
- IF NOT CHK1 THEN
- FAILED ("PREDEFINED ""="" NOT USED");
- END IF;
-
- IF CHK2 THEN
- FAILED ("REDEFINED ""="" NOT USED");
- END IF;
-
- END;
-
- RESULT;
-
-END C67005D;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c72001b.ada b/gcc/testsuite/ada/acats/tests/c7/c72001b.ada
deleted file mode 100644
index 41a1a2c..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c72001b.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- C72001B.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 PACKAGE BODY CAN BE PROVIDED FOR A PACKAGE SPECIFICATION
--- THAT DOES NOT CONTAIN ANY SUBPROGRAM OR TASK DECLARATIONS AND THAT
--- STATEMENTS WITHIN THE PACKAGE BODIES CAN BE USED TO INITIALIZE
--- VARIABLES VISIBLE WITHIN THE PACKAGE BODY.
-
--- RM 04/30/81
--- RM 05/07/81 (TO INCORPORATE OLD TEST OBJECTIVE 7.1/T1 )
--- ABW 6/10/82
--- SPS 11/4/82
--- JBG 9/15/83
-
-WITH REPORT;
-PROCEDURE C72001B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C72001B" , "CHECK: PACKAGE BODIES CAN INITIALIZE VISIBLE" &
- " VARIABLES" );
-
- DECLARE
-
-
- PACKAGE P5 IS
-
- A : CHARACTER := 'B';
- B : BOOLEAN := FALSE;
-
- PACKAGE P6 IS
- I : INTEGER := IDENT_INT(6);
- END P6;
-
- END P5;
-
-
- PACKAGE BODY P5 IS
- PACKAGE BODY P6 IS
- BEGIN
- A := 'C';
- I := 17;
- B := IDENT_BOOL(TRUE);
- END P6;
- BEGIN
- A := 'A';
- END P5;
-
-
- USE P5;
- USE P6;
-
- BEGIN
-
- IF A /= 'A' THEN
- FAILED ("INITIALIZATIONS NOT CORRECT - 1");
- END IF;
-
- IF B /= TRUE THEN
- FAILED ("INITIALIZATIONS NOT CORRECT - 2");
- END IF;
-
- IF I /= 17 THEN
- FAILED ("INITIALIZATIONS NOT CORRECT - 3");
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C72001B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c72002a.ada b/gcc/testsuite/ada/acats/tests/c7/c72002a.ada
deleted file mode 100644
index 491f074..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c72002a.ada
+++ /dev/null
@@ -1,229 +0,0 @@
--- C72002A.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 DECLARATIVE ITEMS IN A PACKAGE SPECIFICATION ARE
--- ELABORATED IN THE ORDER DECLARED.
-
--- HISTORY:
--- DHH 03/09/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C72002A IS
-
- A : INTEGER := 0;
- TYPE ORDER_ARRAY IS ARRAY(1 .. 14) OF INTEGER;
- OBJECT_ARRAY : ORDER_ARRAY;
- TYPE REAL IS DIGITS 4;
- TYPE ENUM IS (RED,YELLOW,BLUE);
-
- TYPE ARR IS ARRAY(1 ..2) OF BOOLEAN;
- D : ARR := (TRUE, TRUE);
- E : ARR := (FALSE, FALSE);
-
- TYPE REC IS
- RECORD
- I : INTEGER;
- END RECORD;
- B : REC := (I => IDENT_INT(1));
- C : REC := (I => IDENT_INT(2));
-
- FUNCTION GIVEN_ORDER(X : INTEGER) RETURN INTEGER IS
- Y : INTEGER;
- BEGIN
- Y := X + 1;
- RETURN Y;
- END GIVEN_ORDER;
-
- FUNCTION BOOL(X : INTEGER) RETURN BOOLEAN IS
- BEGIN
- IF X = IDENT_INT(1) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN TRUE;
- ELSIF X = IDENT_INT(8) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN FALSE;
- END IF;
- END BOOL;
-
- FUNCTION INT(X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X = IDENT_INT(2) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN IDENT_INT(1);
- ELSIF X = IDENT_INT(9) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN IDENT_INT(2);
- END IF;
- END INT;
-
- FUNCTION FLOAT(X : INTEGER) RETURN REAL IS
- BEGIN
- IF X = IDENT_INT(3) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN 1.0;
- ELSIF X = IDENT_INT(10) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN 2.0;
- END IF;
- END FLOAT;
-
- FUNCTION CHAR(X : INTEGER) RETURN CHARACTER IS
- BEGIN
- IF X = IDENT_INT(4) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN 'A';
- ELSIF X = IDENT_INT(11) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN 'Z';
- END IF;
- END CHAR;
-
- FUNCTION ENUMR(X : INTEGER) RETURN ENUM IS
- BEGIN
- IF X = IDENT_INT(5) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN RED;
- ELSIF X = IDENT_INT(12) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN YELLOW;
- END IF;
- END ENUMR;
-
- FUNCTION ARRY(X : INTEGER) RETURN ARR IS
- BEGIN
- IF X = IDENT_INT(6) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN D;
- ELSIF X = IDENT_INT(13) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN E;
- END IF;
- END ARRY;
-
- FUNCTION RECOR(X : INTEGER) RETURN REC IS
- BEGIN
- IF X = IDENT_INT(7) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN B;
- ELSIF X = IDENT_INT(14) THEN
- A := GIVEN_ORDER(A);
- OBJECT_ARRAY(X) := A;
- RETURN C;
- END IF;
- END RECOR;
-
- PACKAGE PACK IS
- A : BOOLEAN := BOOL(1);
- B : INTEGER := INT(2);
- C : REAL := FLOAT(3);
- D : CHARACTER := CHAR(4);
- E : ENUM := ENUMR(5);
- F : ARR := ARRY(6);
- G : REC := RECOR(7);
- H : BOOLEAN := BOOL(8);
- I : INTEGER := INT(9);
- J : REAL := FLOAT(10);
- K : CHARACTER := CHAR(11);
- L : ENUM := ENUMR(12);
- M : ARR := ARRY(13);
- N : REC := RECOR(14);
- END PACK;
-
-BEGIN
- TEST("C72002A", "CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE " &
- "SPECIFICATION ARE ELABORATED IN THE ORDER " &
- "DECLARED");
-
- IF OBJECT_ARRAY(1) /= IDENT_INT(1) THEN
- FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(2) /= IDENT_INT(2) THEN
- FAILED("INTEGER 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(3) /= IDENT_INT(3) THEN
- FAILED("REAL 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(4) /= IDENT_INT(4) THEN
- FAILED("CHARACTER 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(5) /= IDENT_INT(5) THEN
- FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(6) /= IDENT_INT(6) THEN
- FAILED("ARRAY 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(7) /= IDENT_INT(7) THEN
- FAILED("RECORD 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(8) /= IDENT_INT(8) THEN
- FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(9) /= IDENT_INT(9) THEN
- FAILED("INTEGER 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(10) /= IDENT_INT(10) THEN
- FAILED("REAL 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(11) /= IDENT_INT(11) THEN
- FAILED("CHARACTER 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(12) /= IDENT_INT(12) THEN
- FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(13) /= IDENT_INT(13) THEN
- FAILED("ARRAY 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF OBJECT_ARRAY(14) /= IDENT_INT(14) THEN
- FAILED("RECORD 2 ELABORATED OUT OF ORDER");
- END IF;
-
- RESULT;
-END C72002A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730001.a b/gcc/testsuite/ada/acats/tests/c7/c730001.a
deleted file mode 100644
index 24cf8e0..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730001.a
+++ /dev/null
@@ -1,437 +0,0 @@
--- C730001.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 full view of a private extension may be derived
--- indirectly from the ancestor type (i.e., the parent type of the full
--- type may be any descendant of the ancestor type). Check that, for
--- a primitive subprogram of the private extension that is inherited from
--- the ancestor type and not overridden, the formal parameter names and
--- default expressions come from the corresponding primitive subprogram
--- of the ancestor type, while the body comes from that of the parent
--- type. Check both dispatching and non-dispatching cases.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Ancestor is tagged ...
--- procedure Op (P1: Ancestor; P2: Boolean := True);
--- end P;
---
--- with P;
--- package Q is
--- type Derived is new P.Ancestor with ...
--- procedure Op (X: Ancestor; Y: Boolean := False);
--- end Q;
---
--- with P, Q;
--- package R is
--- type Priv_Ext is new P.Ancestor with private; -- (A)
--- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
--- -- But body executed is that of Q.Op.
--- private
--- type Priv_Ext is new Q.Derived with record ... -- (B)
--- end R;
---
--- The ancestor type in (A) differs from the parent type in (B); the
--- parent of the full type is descended from the ancestor type of the
--- private extension. For a call to Op (from outside the scope of the
--- full view) with an operand of type Priv_Ext, the formal parameter
--- names and default expression come from that of P.Op (the ancestor
--- type's version), but the body executed will be that of
--- Q.Op (the parent type's version)
---
--- One half of the test mirrors the above template, where an inherited
--- subprogram (Set_Display) is called using the formal parameter
--- name (C) and default parameter expression of the ancestor type's
--- version (type Clock), but the version of the body executed is from
--- the parent type.
---
--- The test also includes an examination of the dynamic evaluation
--- case, where correct body associations are required through dispatching
--- calls. As described for the non-dispatching case above, the formal
--- parameter name and default values of the ancestor type's (Phone)
--- version of the inherited subprogram (Answer) are used in the
--- dispatching call, but the body executed is from the parent type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C730001_0 is
-
- type Display_Kind is (None, Analog, Digital);
- type Illumination_Type is (None, Light, Phosphorescence);
- type Capability_Type is (Available, In_Use, Call_Waiting, Conference);
- type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem);
-
- type Clock is abstract tagged record -- ancestor type associated
- Display : Display_Kind := None; -- with non-dispatching case.
- Illumination : Illumination_Type := None;
- end record;
-
- type Phone is tagged record -- ancestor type associated
- Status : Capability_Type := Available; -- with dispatching case.
- Indicator : Indicator_Type := None;
- end record;
-
- -- The Set_Display procedure for type Clock implements a basic, no-frills
- -- clock display.
- procedure Set_Display (C : in out Clock;
- Disp: in Display_Kind := Digital);
-
- -- The Answer procedure for type Phone implements a phone status change
- -- operation.
- procedure Answer (The_Phone : in out Phone;
- Ind : in Indicator_Type := Light);
- -- ...Other general clock and/or phone operations (not specified in this
- -- test scenario).
-
-end C730001_0;
-
-
- --==================================================================--
-
-
-package body C730001_0 is
-
- procedure Set_Display (C : in out Clock;
- Disp: in Display_Kind := Digital) is
- begin
- C.Display := Disp;
- C.Illumination := Light;
- end Set_Display;
-
- procedure Answer (The_Phone : in out Phone;
- Ind : in Indicator_Type := Light) is
- begin
- The_Phone.Status := In_Use;
- The_Phone.Indicator := Ind;
- end Answer;
-
-end C730001_0;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-package C730001_1 is
-
- type Power_Supply_Type is (Spring, Battery, AC_Current);
- type Speaker_Type is (None, Present, Adjustable, Stereo);
-
- type Wall_Clock is new Clock with record
- Power_Source : Power_Supply_Type := Spring;
- end record;
-
- type Office_Phone is new Phone with record
- Speaker : Speaker_Type := Present;
- end record;
-
- -- Note: Both procedures below, parameter names and defaults differ from
- -- parent's version.
-
- -- The Set_Display procedure for type Wall_Clock improves upon the
- -- basic Set_Display procedure of type Clock.
-
- procedure Set_Display (WC: in out Wall_Clock;
- D : in Display_Kind := Analog);
-
- procedure Answer (OP : in out Office_Phone;
- OI : in Indicator_Type := Buzzer);
-
- -- ...Other wall clock and/or Office_Phone operations (not specified in
- -- this test scenario).
-
-end C730001_1;
-
-
- --==================================================================--
-
-
-package body C730001_1 is
-
- -- Note: This body is the one that should be executed in the test block
- -- below, not the version of the body corresponding to type Clock.
-
- procedure Set_Display (WC: in out Wall_Clock;
- D : in Display_Kind := Analog) is
- begin
- WC.Display := D;
- WC.Illumination := Phosphorescence;
- end Set_Display;
-
-
- procedure Answer (OP : in out Office_Phone;
- OI : in Indicator_Type := Buzzer) is
- begin
- OP.Status := Call_Waiting;
- OP.Indicator := OI;
- end Answer;
-
-end C730001_1;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-package C730001_2 is
-
- type Alarm_Type is (Buzzer, Radio, Both);
- type Video_Type is (None, TV_Monitor, Wall_Projection);
-
- type Alarm_Clock is new Clock with private;
- -- Inherits proc Set_Display (C : in out Clock;
- -- Disp: in Display_Kind := Digital); -- (A)
- --
- -- Would also inherit other general clock operations (if present).
-
-
- type Conference_Room_Phone is new Office_Phone with record
- Display : Video_Type := TV_Monitor;
- end record;
-
- procedure Answer (CP : in out Conference_Room_Phone;
- CI : in Indicator_Type := Modem);
-
-
- function TC_Get_Display (C: Alarm_Clock) return Display_Kind;
- function TC_Get_Display_Illumination (C: Alarm_Clock)
- return Illumination_Type;
-
-private
-
- -- ...however, certain of the wall clock's operations (Set_Display, in
- -- this example) improve on the implementations provided for the general
- -- clock. We want to call the improved implementations, so we
- -- derive from Wall_Clock in the private part.
-
- type Alarm_Clock is new Wall_Clock with record
- Alarm : Alarm_Type := Buzzer;
- end record;
-
- -- Inherits proc Set_Display (WC: in out Wall_Clock;
- -- D : in Display_Kind := Analog); -- (B)
-
- -- The implicit Set_Display at (B) overrides the implicit Set_Display at
- -- (A), but only within the scope of the full view.
- --
- -- Outside the scope of the full view, only (A) is visible, so calls
- -- from outside the scope will get the formal parameter names and default
- -- from (A). Both inside and outside the scope, however, the body executed
- -- will be that corresponding to Set_Display of the parent type.
-
-end C730001_2;
-
-
- --==================================================================--
-
-
-package body C730001_2 is
-
- procedure Answer (CP : in out Conference_Room_Phone;
- CI : in Indicator_Type := Modem)is
- begin
- CP.Status := Conference;
- CP.Indicator := CI;
- end Answer;
-
-
- function TC_Get_Display (C: Alarm_Clock) return Display_Kind is
- begin
- return C.Display;
- end TC_Get_Display;
-
-
- function TC_Get_Display_Illumination (C: Alarm_Clock)
- return Illumination_Type is
- begin
- return C.Illumination;
- end TC_Get_Display_Illumination;
-
-end C730001_2;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-with C730001_2; use C730001_2;
-
-package C730001_3 is
-
- -- Types extended from the ancestor (Phone) type in the specification.
-
- type Secure_Phone_Type is new Phone with private;
- type Auditorium_Phone_Type is new Phone with private;
- -- Inherit versions of Answer from ancestor (Phone).
-
- function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type;
- function TC_Get_Indicator (P : Phone'Class) return Indicator_Type;
-
-private
-
- -- Types extended from descendents of Phone_Type in the private part.
-
- type Secure_Phone_Type is new Office_Phone with record
- Scrambled_Communication : Boolean := True;
- end record;
-
- type Auditorium_Phone_Type is new Conference_Room_Phone with record
- Volume_Control : Boolean := True;
- end record;
-
-end C730001_3;
-
- --==================================================================--
-
-package body C730001_3 is
-
- function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is
- begin
- return P.Status;
- end TC_Get_Phone_Status;
-
- function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is
- begin
- return P.Indicator;
- end TC_Get_Indicator;
-
-end C730001_3;
-
- --==================================================================--
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-with C730001_2; use C730001_2;
-with C730001_3; use C730001_3;
-
-with Report;
-
-procedure C730001 is
-begin
-
- Report.Test ("C730001","Check that the full view of a private extension " &
- "may be derived indirectly from the ancestor " &
- "type. Check that, for a primitive subprogram " &
- "of the private extension that is inherited from " &
- "the ancestor type and not overridden, the " &
- "formal parameter names and default expressions " &
- "come from the corresponding primitive " &
- "subprogram of the ancestor type, while the body " &
- "comes from that of the parent type");
-
- Test_Block:
- declare
-
- Alarm : Alarm_Clock;
- Hot_Line : Secure_Phone_Type;
- TeleConference_Phone : Auditorium_Phone_Type;
-
- begin
-
- -- Evaluate non-dispatching case:
-
- -- Call Set_Display using formal parameter name from
- -- C730001_0.Set_Display.
- -- Give no 2nd parameter so that default expression must be used.
-
- Set_Display (C => Alarm);
-
- -- The value of the Display component should equal Digital, which is
- -- the default value from the ancestor's version of Set_Display,
- -- and not the default value from the parent's version of Set_Display.
-
- if TC_Get_Display (Alarm) /= Digital then
- Report.Failed ("Default expression for ancestor op not used " &
- "in non-dispatching case");
- end if;
-
- -- However, the value of the Illumination component should equal
- -- Phosphorescence, which is assigned in the parent type's version of
- -- the body of Set_Display.
-
- if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then
- Report.Failed ("Wrong body was executed in non-dispatching case");
- end if;
-
-
- -- Evaluate dispatching case:
- declare
-
- Hot_Line : Secure_Phone_Type;
- TeleConference_Phone : Auditorium_Phone_Type;
-
- procedure Answer_The_Phone (P : in out Phone'Class) is
- begin
- -- Give no 2nd parameter so that default expression must be used.
- Answer (P);
- end Answer_The_Phone;
-
- begin
-
- Answer_The_Phone (Hot_Line);
- Answer_The_Phone (TeleConference_Phone);
-
- -- The value of the Indicator field shold equal "Light", the default
- -- value from the ancestor's version of Answer, and not the default
- -- from either of the parent versions of Answer.
-
- if TC_Get_Indicator(Hot_Line) /= Light or
- TC_Get_Indicator(TeleConference_Phone) /= Light
- then
- Report.Failed("Default expression from ancestor operation " &
- "not used in dispatching case");
- end if;
-
- -- However, the value of the Status component should equal
- -- Call_Waiting or Conference respectively, based on the assignment
- -- in the parent type's version of the body of Answer.
-
- if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then
- Report.Failed("Wrong body executed in dispatching case - 1");
- end if;
-
- if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then
- Report.Failed("Wrong body executed in dispatching case - 2");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end C730001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730002.a b/gcc/testsuite/ada/acats/tests/c7/c730002.a
deleted file mode 100644
index 9213a7d..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730002.a
+++ /dev/null
@@ -1,383 +0,0 @@
--- C730002.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 full view of a private extension may be derived
--- indirectly from the ancestor type (i.e., the parent type of the full
--- type may be any descendant of the ancestor type). Check that, for
--- a primitive subprogram of the private extension that is inherited from
--- the ancestor type and not overridden, the formal parameter names and
--- default expressions come from the corresponding primitive subprogram
--- of the ancestor type, while the body comes from that of the parent
--- type.
--- Check for a case where the parent type is derived from the ancestor
--- type through a series of types produced by generic instantiations.
--- Examine both the static and dynamic binding cases.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Ancestor is tagged ...
--- procedure Op (P1: Ancestor; P2: Boolean := True);
--- end P;
---
--- with P;
--- generic
--- type T is new P.Ancestor with private;
--- package Gen1 is
--- type Enhanced is new T with private;
--- procedure Op (A: Enhanced; B: Boolean := True);
--- -- other specific procedures...
--- private
--- type Enhanced is new T with ...
--- end Gen1;
---
--- with P, Gen1;
--- package N is new Gen1 (P.Ancestor);
---
--- with N;
--- generic
--- type T is new N.Enhanced with private;
--- package Gen2 is
--- type Enhanced_Again is new T with private;
--- procedure Op (X: Enhanced_Again; Y: Boolean := False);
--- -- other specific procedures...
--- private
--- type Enhanced_Again is new T with ...
--- end Gen2;
---
--- with N, Gen2;
--- package Q is new Gen2 (N.Enhanced);
---
--- with P, Q;
--- package R is
--- type Priv_Ext is new P.Ancestor with private; -- (A)
--- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
--- -- But body executed is that of Q.Op.
--- private
--- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
--- end R;
---
--- The ancestor type in (A) differs from the parent type in (B); the
--- parent of the full type is descended from the ancestor type of the
--- private extension, in this case through a series of types produced
--- by generic instantiations. Gen1 redefines the implementation of Op
--- for any type that has one. N is an instance of Gen1 for the ancestor
--- type. Gen2 again redefines the implementation of Op for any type that
--- has one. Q is an instance of Gen2 for the extension of the P.Ancestor
--- declared in N. Both N and Q could define other operations which we
--- don't want to be available in R. For a call to Op (from outside the
--- scope of the full view) with an operand of type R.Priv_Ext, the body
--- executed will be that of Q.Op (the parent type's version), but the
--- formal parameter names and default expression come from that of P.Op
--- (the ancestor type's version).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 CTA.PWB Added elaboration pragmas.
---!
-
-package C730002_0 is
-
- type Hours_Type is range 0..1000;
- type Personnel_Type is range 0..10;
- type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);
-
- type Engine_Type is tagged record
- Ave_Repair_Time : Hours_Type := 0; -- Default init. for
- Personnel_Required : Personnel_Type := 0; -- component fields.
- Specialist : Specialist_ID := Manny;
- end record;
-
- procedure Routine_Maintenance (Engine : in out Engine_Type ;
- Specialist : in Specialist_ID := Moe);
-
- -- The Routine_Maintenance procedure implements the processing required
- -- for an engine.
-
-end C730002_0;
-
- --==================================================================--
-
-package body C730002_0 is
-
- procedure Routine_Maintenance (Engine : in out Engine_Type ;
- Specialist : in Specialist_ID := Moe) is
- begin
- Engine.Ave_Repair_Time := 3;
- Engine.Personnel_Required := 1;
- Engine.Specialist := Specialist;
- end Routine_Maintenance;
-
-end C730002_0;
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-generic
- type T is new C730002_0.Engine_Type with private;
-package C730002_1 is
-
- -- This generic package contains types/procedures specific to engines
- -- of the diesel variety.
-
- type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);
-
- type Diesel_Series is new T with private;
-
- procedure Routine_Maintenance (Eng : in out Diesel_Series;
- Spec_Req : in Specialist_ID := Jack);
-
- -- Other diesel specific operations... (not required in this test).
-
-private
-
- type Diesel_Series is new T with record
- Repair_Facility_Required : Repair_Facility_Type := On_Site;
- end record;
-
-end C730002_1;
-
- --==================================================================--
-
-package body C730002_1 is
-
- procedure Routine_Maintenance (Eng : in out Diesel_Series;
- Spec_Req : in Specialist_ID := Jack) is
- begin
- Eng.Ave_Repair_Time := 6;
- Eng.Personnel_Required := 2;
- Eng.Specialist := Spec_Req;
- Eng.Repair_Facility_Required := On_Site;
- end Routine_Maintenance;
-
-end C730002_1;
-
- --==================================================================--
-
-with C730002_0;
-with C730002_1;
-pragma Elaborate (C730002_1);
-package C730002_2 is new C730002_1 (C730002_0.Engine_Type);
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-with C730002_2; use C730002_2;
-generic
- type T is new C730002_2.Diesel_Series with private;
-package C730002_3 is
-
- type Time_Of_Operation_Type is range 0..100_000;
-
- type Electric_Series is new T with private;
-
- procedure Routine_Maintenance (E : in out Electric_Series;
- SR : in Specialist_ID := Curly);
-
- -- Other electric specific operations... (not required in this test).
-
-private
-
- type Electric_Series is new T with record
- Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
- end record;
-
-end C730002_3;
-
- --==================================================================--
-
-package body C730002_3 is
-
- procedure Routine_Maintenance (E : in out Electric_Series;
- SR : in Specialist_ID := Curly) is
- begin
- E.Ave_Repair_Time := 9;
- E.Personnel_Required := 3;
- E.Specialist := SR;
- E.Mean_Time_Between_Repair := 1000;
- end Routine_Maintenance;
-
-end C730002_3;
-
- --==================================================================--
-
-with C730002_2;
-with C730002_3;
-pragma Elaborate (C730002_3);
-package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-with C730002_4; use C730002_4;
-
-package C730002_5 is
-
- type Inspection_Type is (AAA, MIL_STD, NRC);
-
- type Nuclear_Series is new Engine_Type with private; -- (A)
-
- -- Inherits procedure Routine_Maintenance from ancestor; does not override.
- -- (Engine : in out Nuclear_Series;
- -- Specialist : in Specialist_ID := Moe);
- -- But body executed will be that of C730002_4.Routine_Maintenance,
- -- the parent type.
-
- function TC_Specialist (E : Nuclear_Series) return Specialist_ID;
- function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
- function TC_Time_Required (E : Nuclear_Series) return Hours_Type;
-
- -- Dispatching subprogram.
- procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);
-
-private
-
- type Nuclear_Series is new Electric_Series with record -- (B)
- Inspector_Rep : Inspection_Type := NRC;
- end record;
-
- -- The ancestor type is used in the type extension (A), while the parent
- -- of the full type (B) is a descendent of the ancestor type, through a
- -- series of types produced by generic instantiation.
-
-end C730002_5;
-
- --==================================================================--
-
-package body C730002_5 is
-
- function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
- begin
- return E.Specialist;
- end TC_Specialist;
-
- function TC_Personnel_Required (E : Nuclear_Series)
- return Personnel_Type is
- begin
- return E.Personnel_Required;
- end TC_Personnel_Required;
-
- function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
- begin
- return E.Ave_Repair_Time;
- end TC_Time_Required;
-
- -- Dispatching subprogram.
- procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
- begin
- Routine_Maintenance (The_Engine);
- end Maintain_The_Engine;
-
-
-end C730002_5;
-
- --==================================================================--
-
-with Report;
-with C730002_0; use C730002_0;
-with C730002_2; use C730002_2;
-with C730002_4; use C730002_4;
-with C730002_5; use C730002_5;
-
-procedure C730002 is
-begin
-
- Report.Test ("C730002", "Check that the full view of a private " &
- "extension may be derived indirectly from " &
- "the ancestor type. Check for a case where " &
- "the parent type is derived from the ancestor " &
- "type through a series of types produced by " &
- "generic instantiations");
-
- Test_Block:
- declare
- Nuclear_Drive : Nuclear_Series;
- Warp_Drive : Nuclear_Series;
- begin
-
- -- Non-Dispatching Case:
- -- Call Routine_Maintenance using formal parameter name from
- -- C730002_0.Routine_Maintenance (ancestor version).
- -- Give no second parameter so that the default expression must be
- -- used.
-
- Routine_Maintenance (Engine => Nuclear_Drive);
-
- -- The value of the Specialist component should equal "Moe",
- -- which is the default value from the ancestor's version of
- -- Routine_Maintenance, and not the default value from the parent's
- -- version of Routine_Maintenance.
-
- if TC_Specialist (Nuclear_Drive) /= Moe then
- Report.Failed
- ("Default expression for ancestor op not used " &
- " - non-dispatching case");
- end if;
-
- -- However the value of the Ave_Repair_Time and Personnel_Required
- -- components should be those assigned in the parent type's version
- -- of the body of Routine_Maintenance.
- -- Note: Only components associated with the ancestor type are
- -- evaluated for the purposes of this test.
-
- if TC_Personnel_Required (Nuclear_Drive) /= 3 or
- TC_Time_Required (Nuclear_Drive) /= 9
- then
- Report.Failed("Wrong body was executed - non-dispatching case");
- end if;
-
- -- Dispatching Case:
- -- Use a dispatching subprogram to ensure that the correct body is
- -- used at runtime.
-
- Maintain_The_Engine (Warp_Drive);
-
- -- The resulting assignments to the fields of the Warp_Drive variable
- -- should be the same as those of the Nuclear_Drive above, indicating
- -- that the body of the parent version of the inherited subprogram
- -- was used.
-
- if TC_Specialist (Warp_Drive) /= Moe then
- Report.Failed
- ("Default expression for ancestor op not used - dispatching case");
- end if;
-
- if TC_Personnel_Required (Nuclear_Drive) /= 3 or
- TC_Time_Required (Nuclear_Drive) /= 9
- then
- Report.Failed("Wrong body was executed - dispatching case");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end C730002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730003.a b/gcc/testsuite/ada/acats/tests/c7/c730003.a
deleted file mode 100644
index 47002f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730003.a
+++ /dev/null
@@ -1,283 +0,0 @@
--- C730003.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 WHATSOVER, 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 characteristics of a type derived from a private
--- extension (outside the scope of the full view) are those defined by
--- the partial view of the private extension.
--- In particular, check that a component of the derived type may be
--- explicitly declared with the same name as a component declared for
--- the full view of the private extension.
--- Check that a component defined in the private extension of a type
--- may be updated through a view conversion of a type derived from
--- the type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type T is tagged record
--- ...
--- end record;
---
--- type DT is new T with private;
--- procedure Op1 (P: in out DT);
---
--- private
--- type DT is new T with record
--- Y: ...; -- (A)
--- end record;
--- end Parent;
---
--- package body Parent is
--- function Op1 (P: in DT) return ... is
--- begin
--- return P.Y;
--- end Op1;
--- end Parent;
---
--- package Unrelated is
--- type Intermediate is new DT with record
--- Y: ...; -- Note: same name as component of -- (B)
--- -- parent's full view.
--- end record;
--- end Unrelated;
---
--- package Parent.Child is
--- type DDT is new Intermediate with null record;
--- -- Implicit declared Op1 (P.DDT); -- (C)
---
--- procedure Op2 (P: in out DDT);
--- end Parent.Child;
---
--- package body Parent.Child is
--- procedure Op2 (P: in out DDT) is
--- Obj : DT renames DT(P);
--- begin
--- ...
--- P.Y := ...; -- Updates DDT's Y. -- (D)
--- DT(P).Y := ...; -- Updates DT's Y. -- (E)
--- Obj.Y := ...; -- Updates DT's Y. -- (F)
--- end Op2;
--- end Parent.Child;
---
--- Types DT and DDT both declare a component Y at (A) and (B),
--- respectively. The component Y of the full view of DT is not visible
--- at the place where DDT is declared. Therefore, it is invisible for
--- all views of DDT (although it still exists for objects of DDT), and
--- it is legal to declare another component for DDT with the same name.
---
--- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
--- the component Y; for calls with an operand of type DDT, Op1 returns
--- the Y inherited from DT, not the new Y explicitly declared for DDT,
--- even though the inherited Y is not visible for any view of DDT.
---
--- Within the body of Op2, the assignment statement at (D) updates the
--- Y explicitly declared for DDT. At (E) and (F), however, a view
--- conversion denotes a new view of P as an object of type DT, which
--- enables access to the Y from the full view of DT. Thus, the
--- assignment statements at (E) and (F) update the (invisible) Y from DT.
---
--- Note that the above analysis would be wrong if the new component Y
--- were declared directly in Child. In that case, the two same-named
--- components would be illegal -- see AI-150.
---
---
--- CHANGE HISTORY:
--- 06 Dec 1994 SAIC ACVC 2.0
--- 29 JUN 1999 RAD Declare same-named component in an
--- unrelated package -- see AI-150.
---
---!
-
-package C730003_0 is
-
- type Suit_Kind is (Clubs, Diamonds, Hearts, Spades);
- type Face_Kind is (Up, Down);
-
- type Playing_Card is tagged record
- Face: Face_Kind;
- Suit: Suit_Kind;
- end record;
-
- procedure Turn_Over_Card (Card : in out Playing_Card);
-
- type Disp_Card is new Playing_Card with private;
-
- subtype ASCII_Representation is Natural range 1..14;
-
- function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation;
-
-private
-
- type Disp_Card is new Playing_Card with record
- View: ASCII_Representation; -- (A)
- end record;
-
-end C730003_0;
-
---==================================================================--
-
-package body C730003_0 is
-
- procedure Turn_Over_Card (Card: in out Playing_Card) is
- begin
- Card.Face := Up;
- end Turn_Over_Card;
-
- function Get_Private_View (A_Card : Disp_Card)
- return ASCII_Representation is
- begin
- return A_Card.View;
- end Get_Private_View;
-
-end C730003_0;
-
---==================================================================--
-
-with C730003_0; use C730003_0;
-package C730003_1 is
-
- subtype Graphic_Representation is String (1 .. 2);
-
- type Graphic_Card is new Disp_Card with record
- View : Graphic_Representation; -- (B)
- -- "Duplicate" component field name.
- end record;
-
-end C730003_1;
-
---==================================================================--
-
-with C730003_1; use C730003_1;
-package C730003_0.C730003_2 is
-
- Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12;
- Ace_Of_Hearts : constant String := "AH";
- Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14;
- Read_Em_And_Weep : constant String := "AA";
-
- type Graphic_Card is new C730003_1.Graphic_Card with null record;
-
- -- Implicit function Get_Private_View -- (C)
- -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
-
- function Get_View (Card : Graphic_Card) return String;
- procedure Update_View (Card : in out Graphic_Card);
- procedure Hide_From_View (Card : in out Graphic_Card);
-
-end C730003_0.C730003_2;
-
---==================================================================--
-
-package body C730003_0.C730003_2 is
-
- function Get_View (Card : Graphic_Card) return String is
- begin
- return Card.View;
- end Get_View;
-
- procedure Update_View (Card : in out Graphic_Card) is
- ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion.
- begin
- ASCII_View.View := Queen_Of_Spades; -- (F)
- -- Assignment to "hidden" field.
- Card.View := Ace_Of_Hearts; -- (D)
- -- Assignment to Graphic_Card declared field.
- end Update_View;
-
- procedure Hide_From_View (Card : in out Graphic_Card) is
- begin
- -- Update both of Card's View components.
- Disp_Card(Card).View := Close_To_The_Vest; -- (E)
- -- Assignment to "hidden" field.
- Card.View := Read_Em_And_Weep; -- (D)
- -- Assignment to Graphic_Card declared field.
- end Hide_From_View;
-
-end C730003_0.C730003_2;
-
---==================================================================--
-
-with C730003_0;
-with C730003_0.C730003_2;
-with Report;
-
-procedure C730003 is
-begin
-
- Report.Test ("C730003", "Check that the characteristics of a type " &
- "derived from a private extension (outside " &
- "the scope of the full view) are those " &
- "defined by the partial view of the private " &
- "extension");
-
- Check_Your_Cards:
- declare
- use C730003_0;
- use C730003_0.C730003_2;
-
- Top_Card_On_The_Deck : Graphic_Card;
-
- begin
-
- -- Update value in the components of the card. There are two
- -- component fields named View, although one is not visible for
- -- any view of a Graphic_Card.
-
- Update_View(Top_Card_On_The_Deck);
-
- -- Verify that both "View" components of the card have been updated.
-
- if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then
- Report.Failed ("Incorrect value in visible component - 1");
- end if;
-
- if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades
- then
- Report.Failed ("Incorrect value in non-visible component - 1");
- end if;
-
- -- Again, update the components of the card (to blank values).
-
- Hide_From_View(Top_Card_On_The_Deck);
-
- -- Verify that both components have been updated.
-
- if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then
- Report.Failed ("Incorrect value in visible component - 2");
- end if;
-
- if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest
- then
- Report.Failed ("Incorrect value in non-visible component - 2");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in test block");
- end Check_Your_Cards;
-
- Report.Result;
-
-end C730003;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730004.a b/gcc/testsuite/ada/acats/tests/c7/c730004.a
deleted file mode 100644
index c2a2323..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730004.a
+++ /dev/null
@@ -1,327 +0,0 @@
--- C730004.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 for a type declared in a package, descendants of the package
--- use the full view of type. Specifically check that full view of the
--- limited type is visible only in private descendants (children) and in
--- the private parts and bodies of public descendants (children).
--- Check that a limited type may be used as an out parameter outside
--- the package that defines the type.
---
--- TEST DESCRIPTION:
--- This test defines a parent package containing limited private type
--- definitions. Children packages are defined (one public, one private)
--- that use the nonlimited full view of the types defined in the private
--- part of the parent specification.
--- The main declares a procedure with an out parameter that was defined
--- as limited in the specification of the parent package.
---
---
--- CHANGE HISTORY:
--- 15 Sep 95 SAIC Initial prerelease version.
--- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File.
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report.
---
---!
-
-package C730004_0 is
-
- -- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are
- -- are nonlimited.
-
- type File_Descriptor is limited private;
-
- type File_Mode is limited private;
-
- Active_Mode : constant File_Mode;
-
- type File_Name is limited private;
-
- type File_Type is limited private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Descriptor is new Integer;
-
- Null_File : constant File_Descriptor := 0;
- First_File : constant File_Descriptor := 1;
-
- type File_Mode is
- (Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost);
-
- Default_Mode : constant File_Mode := Read_Only;
- Active_Mode : constant File_Mode := Read_Write;
-
- type File_Name is array (1 .. 6) of Character;
-
- Null_String : File_Name := " ";
- String1 : File_Name := "ACVC ";
- String2 : File_Name := " 1995";
-
- type File_Type is
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- Name : File_Name := Null_String;
- end record;
-
-end C730004_0;
-
- --=================================================================--
-
-package body C730004_0 is
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count)); -- Type conversion.
- end Next_Available_File;
-
-end C730004_0;
-
- --=================================================================--
-
-private
-package C730004_0.C730004_1 is -- private child
-
- -- Since full view of the nontagged File_Name is nonlimited in the parent
- -- package, it is not limited in the private child, so concatenation is
- -- available.
-
- System_File_Name : constant File_Name
- := String1(1..4) & String2(5..6);
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private child, so a default expression
- -- is available.
-
- function New_File_Validated (File : File_Type
- := (Descriptor => First_File,
- Mode => Active_Mode,
- Name => System_File_Name))
- return Boolean;
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private child, so initialization
- -- expression in an object declaration is available.
-
- System_File : File_Type
- := (Null_File, Read_Only, System_File_Name);
-
-
-end C730004_0.C730004_1;
-
- --=================================================================--
-
-package body C730004_0.C730004_1 is
-
- function New_File_Validated (File : File_Type
- := (Descriptor => First_File,
- Mode => Active_Mode,
- Name => System_File_Name))
- return Boolean is
- Result : Boolean := False;
- begin
- if (File.Descriptor > System_File.Descriptor) and
- (File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95")
- then
- Result := True;
- end if;
-
- return (Result);
-
- end New_File_Validated;
-
-end C730004_0.C730004_1;
-
- --=================================================================--
-
-package C730004_0.C730004_2 is -- public child
-
- -- File_Type is limited here.
-
- procedure Create_File (File : out File_Type);
-
- procedure Modify_File (File : out File_Type);
-
- type File_Dir is limited private;
-
- -- The following three validation functions provide the capability to
- -- check the limited private types defined in the parent and the
- -- private child package from within the client program.
-
- function Validate_Create (File : in File_Type) return Boolean;
-
- function Validate_Modification (File : in File_Type)
- return Boolean;
-
- function Validate_Dir (Dir : in File_Dir) return Boolean;
-
-private
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private part of the public child, so
- -- aggregates are available.
-
- Child_File : File_Type
- := File_Type'(Descriptor => Null_File,
- Mode => Write_Only,
- Name => String2);
-
- -- Since full view of the nontagged component File_Type is nonlimited in
- -- the parent package, it is not limited in the private part of the public
- -- child, so default expressions are available.
-
- type File_Dir is
- record
- Comp : File_Type := Child_File;
- end record;
-
-end C730004_0.C730004_2;
-
- --=================================================================--
-
-with C730004_0.C730004_1;
-
-package body C730004_0.C730004_2 is
-
- procedure Create_File (File : out File_Type) is
- New_File : File_Type;
-
- begin
- New_File.Descriptor := Next_Available_File;
- New_File.Mode := Default_Mode;
- New_File.Name := C730004_0.C730004_1.System_File_Name;
-
- if C730004_0.C730004_1.New_File_Validated (New_File) then
- File := New_File;
- else
- File := (Null_File, Lost, "MISSED");
- end if;
-
- end Create_File;
-
- --------------------------------------------------------------
- procedure Modify_File (File : out File_Type) is
- begin
- File.Descriptor := Next_Available_File;
- File.Mode := Active_Mode;
- File.Name := String1;
- end Modify_File;
-
- --------------------------------------------------------------
- function Validate_Create (File : in File_Type) return Boolean is
- begin
- if ((File.Descriptor /= Child_File.Descriptor) and
- (File.Mode = Read_Only) and (File.Name = "ACVC95"))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Create;
-
- ------------------------------------------------------------------------
- function Validate_Modification (File : in File_Type)
- return Boolean is
- begin
- if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and
- (File.Mode = Read_Write) and (File.Name = "ACVC "))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Modification;
-
- ------------------------------------------------------------------------
- function Validate_Dir (Dir : in File_Dir) return Boolean is
- begin
- if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor)
- and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Dir;
-
-end C730004_0.C730004_2;
-
- --=================================================================--
-
-with C730004_0.C730004_2;
-with Report;
-
-procedure C730004 is
-
- package File renames C730004_0;
- package File_Ops renames C730004_0.C730004_2;
-
- Validation_File : File.File_Type;
-
- Validation_Dir : File_Ops.File_Dir;
-
- ------------------------------------------------------------------------
- -- Limited File_Type is allowed as an out parameter outside package File.
-
- procedure Call_Modify_File (Modified_File : out File.File_Type) is
- begin
- File_Ops.Modify_File (Modified_File);
- end Call_Modify_File;
-
-begin
-
- Report.Test ("C730004", "Check that for a type declared in a package, " &
- "descendants of the package use the full view " &
- "of the type. Specifically check that full " &
- "view of the limited type is visible only in " &
- "private children and in the private parts and " &
- "bodies of public children");
-
- File_Ops.Create_File (Validation_File);
-
- if not File_Ops.Validate_Create (Validation_File) then
- Report.Failed ("Incorrect creation of file");
- end if;
-
- Call_Modify_File (Validation_File);
-
- if not File_Ops.Validate_Modification (Validation_File) then
- Report.Failed ("Incorrect modification of file");
- end if;
-
- if not File_Ops.Validate_Dir (Validation_Dir) then
- Report.Failed ("Incorrect creation of directory");
- end if;
-
- Report.Result;
-
-end C730004;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c73002a.ada b/gcc/testsuite/ada/acats/tests/c7/c73002a.ada
deleted file mode 100644
index 8bbc4af..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c73002a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C73002A.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 STATEMENTS IN A PACKAGE BODY ARE EXECUTED AFTER THE
--- ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY).
-
-
--- RM 05/15/81
--- JBG 9/21/83
-
-WITH REPORT;
-PROCEDURE C73002A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C73002A" , "CHECK: EXECUTION OF STATEMENTS IN A PACKAGE " &
- "BODY FOLLOWS ELABORATION OF THE DECLARATIONS");
-
- DECLARE
-
- PACKAGE P1 IS
-
- A : INTEGER := IDENT_INT(7);
-
- PACKAGE P2 IS
- B : INTEGER := IDENT_INT(11);
- END P2;
-
- END P1;
-
-
- PACKAGE BODY P1 IS -- A AA B BB
-
- AA : INTEGER := IDENT_INT(7); -- 7 7 11 (11)
-
- PACKAGE BODY P2 IS
- BB : INTEGER := IDENT_INT(11);-- 7 11 11
- BEGIN
-
- B := 2*B ; -- 7 7 22 11
- BB := 2*BB; -- 7 7 22 22
- A := 5*A ; -- 35 7 22 22
- AA := 2*AA; -- 35 14 22 22
-
- IF BB /= 22 OR
- AA /= 14 OR
- A /= 35 OR
- B /= 22
- THEN
- FAILED( "ASSIGNED VALUES INCORRECT - 1" );
- END IF;
-
- END P2;
-
- BEGIN
-
- A := A + 20; -- 55 14 22 22
- AA := AA + 20; -- 55 34 22 22
-
- IF AA /= 34 OR
- A /= 55 OR
- P2.B /= 22
- THEN
- FAILED( "ASSIGNED VALUES INCORRECT - 2" );
- END IF;
-
- END P1;
-
-
- USE P1;
- USE P2;
-
- BEGIN
-
- IF A /= 55 OR
- B /= 22
- THEN
- FAILED( "ASSIGNED VALUES INCORRECT - 3" );
- END IF;
-
- END;
-
-
- RESULT;
-
-
-END C73002A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a01.a b/gcc/testsuite/ada/acats/tests/c7/c730a01.a
deleted file mode 100644
index 43f16f9..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730a01.a
+++ /dev/null
@@ -1,176 +0,0 @@
--- C730A01.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 tagged type declared in a package specification
--- may be passed as a generic formal (tagged) private type to a generic
--- package declaration. Check that the formal type may be extended with
--- a private extension in the generic package.
---
--- Check that, in the instance, the private extension inherits the
--- user-defined primitive subprograms of the tagged actual.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a generic package
--- which takes a tagged type as a formal parameter, and then extends
--- it with a private extension (foundation code).
---
--- Instantiate the generic package with the tagged type from the first
--- package (the "generic" extension should now have inherited
--- the primitive subprogram of the tagged type from the first
--- package).
---
--- In the main program, call the primitive subprogram inherited by the
--- "generic" extension, and verify the correctness of the components.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F730A000.A
--- F730A001.A
--- => C730A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with F730A001; -- Book definitions.
-package C730A01_0 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
-end C730A01_0;
-
-
- --==================================================================--
-
-
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is tagged record.
-
-with F730A001; -- Book definitions.
-with F730A000; -- Singly-linked list abstraction.
-package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with F730A001; -- Book definitions.
-with C730A01_0; -- Raw book data.
-with C730A01_1; -- Instance.
-
-use F730A001; -- Primitive operations of Book_Type directly visible.
-use C730A01_1; -- Operations inherited by Node_Type directly visible.
-
-procedure C730A01 is
-
-
- List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C730A01_0.Data_List;
- Head : in out Priv_Node_Ptr) is
-
- Book : Priv_Node_Type; -- Object of extended type.
- Book_Ptr : Priv_Node_Ptr;
-
- begin
- for I in C730A01_0.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call inherited
- -- operation.
- Book_Ptr := new Priv_Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- Book1_Ptr : Priv_Node_Ptr;
- Book2_Ptr : Priv_Node_Ptr;
- Book3_Ptr : Priv_Node_Ptr;
- begin
- Remove (List_Of_Books, Book1_Ptr);
- Remove (List_Of_Books, Book2_Ptr);
- Remove (List_Of_Books, Book3_Ptr);
- return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
- Book1_Ptr.Author.all /= "Joyce, James" or -- components
- Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
- Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in
- Book3_Ptr.Title.all /= "Wuthering Heights" or -- private
- Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension.
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C730A01", "Inheritance of primitive operations: private " &
- "extension of formal tagged private type; actual is " &
- "an ultimate ancestor type");
-
- -- Create linked list using inherited operation:
- Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operation");
- end if;
-
- Report.Result;
-
-end C730A01;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a02.a b/gcc/testsuite/ada/acats/tests/c7/c730a02.a
deleted file mode 100644
index 97d04b6..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730a02.a
+++ /dev/null
@@ -1,252 +0,0 @@
--- C730A02.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 private extension (declared in a package specification) of
--- a tagged type (declared in a different package specification) may be
--- passed as a generic formal (tagged) private type to a generic package
--- declaration. Check that the formal type may be further extended with a
--- private extension in the generic package.
---
--- Check that the (visible) components inherited by the "generic"
--- extension are visible outside the generic package.
---
--- Check that, in the instance, the private extension inherits the
--- user-defined primitive subprograms of the tagged actual, including
--- those inherited by the actual from its parent.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a private extension
--- of the tagged type and an associated primitive subprogram in a second
--- package specification. Declare a generic package which takes a tagged
--- type as a formal parameter, and then extends it with a private
--- extension (foundation code).
---
--- Instantiate the generic package with the private extension from the
--- second package (the "generic" extension should now have inherited
--- the primitive subprograms of the private extension from the second
--- package).
---
--- In the main program, call the primitive subprograms inherited by the
--- "generic" extension. There are two: (1) Create_Book, declared for
--- the root tagged type in the first package (inherited by the private
--- extension of the second package, and then in turn by the "generic"
--- extension), and (2) Update_Pages, declared for the private extension
--- in the second package. Verify the correctness of the components.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F730A000.A
--- F730A001.A
--- => C730A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F730A001; -- Book definitions.
-package C730A02_0 is -- Extended book abstraction.
-
-
- type Detailed_Book_Type is new F730A001.Book_Type -- Private ext.
- with private; -- of root tagged
- -- type.
-
- -- Inherits Create_Book from Book_Type.
-
- procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op.
- Pages : in Natural); -- of extension.
-
-
- -- The following function is needed to verify the value of the
- -- extension's private component. It will be inherited by extensions
- -- of Detailed_Book_Type.
-
- function Get_Pages (Book : in Detailed_Book_Type) return Natural;
-
-private
-
- type Detailed_Book_Type is new F730A001.Book_Type with record
- Pages : Natural;
- end record;
-
-end C730A02_0;
-
-
- --==================================================================--
-
-
-package body C730A02_0 is
-
-
- procedure Update_Pages (Book : in out Detailed_Book_Type;
- Pages : in Natural) is
- begin
- Book.Pages := Pages;
- end Update_Pages;
-
-
- function Get_Pages (Book : in Detailed_Book_Type) return Natural is
- begin
- return (Book.Pages);
- end Get_Pages;
-
-
-end C730A02_0;
-
-
- --==================================================================--
-
-
-with F730A001; -- Book definitions.
-package C730A02_1 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
- type Page_Counts is array (Number_Of_Books) of Natural;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
- Page_List : Page_Counts := (237, 215, 456);
-
-end C730A02_1;
-
-
--- No body for C730A02_1.
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is private extension.
-
-with C730A02_0; -- Extended book abstraction.
-with F730A000; -- Singly-linked list abstraction.
-package C730A02_2 is new F730A000
- (Parent_Type => C730A02_0.Detailed_Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with C730A02_0; -- Extended book abstraction.
-with C730A02_1; -- Raw book data.
-with C730A02_2; -- Instance.
-
-use C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
-use C730A02_2; -- Operations inherited by Priv_Node_Type directly visible.
-
-procedure C730A02 is
-
-
- List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C730A02_1.Data_List;
- Pages : in C730A02_1.Page_Counts;
- Head : in out Priv_Node_Ptr) is
-
- Book : Priv_Node_Type; -- Object of extended type.
- Book_Ptr : Priv_Node_Ptr;
-
- begin
- for I in C730A02_1.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call twice-inherited
- -- operation.
- Update_Pages (Book, Pages (I)); -- Call inherited op.
- Book_Ptr := new Priv_Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- Book1_Ptr : Priv_Node_Ptr;
- Book2_Ptr : Priv_Node_Ptr;
- Book3_Ptr : Priv_Node_Ptr;
- begin
-
- Remove (List_Of_Books, Book1_Ptr);
- Remove (List_Of_Books, Book2_Ptr);
- Remove (List_Of_Books, Book3_Ptr);
-
- return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
- Book1_Ptr.Author.all /= "Joyce, James" or -- components
- Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
- Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible
- Book3_Ptr.Title.all /= "Wuthering Heights" or -- in private
- Book3_Ptr.Author.all /= "Bronte, Emily" or -- "generic"
- -- extension.
- -- Call inherited operations using dereferenced pointers.
- Get_Pages (Book1_Ptr.all) /= 456 or
- Get_Pages (Book2_Ptr.all) /= 215 or
- Get_Pages (Book3_Ptr.all) /= 237);
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C730A02", "Inheritance of primitive operations: private " &
- "extension of formal tagged private type; actual is " &
- "a private extension");
-
- -- Create linked list using inherited operation:
- Create_List (C730A02_1.Title_List, C730A02_1.Author_List,
- C730A02_1.Page_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operations");
- end if;
-
- Report.Result;
-
-end C730A02;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c731001.a b/gcc/testsuite/ada/acats/tests/c7/c731001.a
deleted file mode 100644
index 0cfce32..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c731001.a
+++ /dev/null
@@ -1,407 +0,0 @@
--- C731001.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 WHATSOVER, 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 inherited operations can be overridden, even when they are
--- inherited in a body.
--- The test cases here are inspired by the AARM examples given in
--- the discussion of AARM-7.3.1(7.a-7.v).
--- This discussion was confirmed by AI95-00035.
---
--- TEST DESCRIPTION
--- See AARM-7.3.1.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 20 AUG 2001 RLB Corrected 'verbose' flag.
---
---!
-
-with Report; use Report; pragma Elaborate_All(Report);
-package C731001_1 is
- pragma Elaborate_Body;
-private
- procedure Check_String(X, Y: String);
- function Check_String(X, Y: String) return String;
- -- This one is a function, so we can call it in package specs.
-end C731001_1;
-
-package body C731001_1 is
-
- Verbose: Boolean := False;
-
- procedure Check_String(X, Y: String) is
- begin
- if Verbose then
- Comment("""" & X & """ = """ & Y & """?");
- end if;
- if X /= Y then
- Failed("""" & X & """ should be """ & Y & """");
- end if;
- end Check_String;
-
- function Check_String(X, Y: String) return String is
- begin
- Check_String(X, Y);
- return X;
- end Check_String;
-
-end C731001_1;
-
-private package C731001_1.Parent is
-
- procedure Call_Main;
-
- type Root is tagged null record;
- subtype Renames_Root is Root;
- subtype Root_Class is Renames_Root'Class;
- function Make return Root;
- function Op1(X: Root) return String;
- function Call_Op2(X: Root'Class) return String;
-private
- function Op2(X: Root) return String;
-end C731001_1.Parent;
-
-procedure C731001_1.Parent.Main;
-
-with C731001_1.Parent.Main;
-package body C731001_1.Parent is
-
- procedure Call_Main is
- begin
- Main;
- end Call_Main;
-
- function Make return Root is
- Result: Root;
- begin
- return Result;
- end Make;
-
- function Op1(X: Root) return String is
- begin
- return "Parent.Op1 body";
- end Op1;
-
- function Op2(X: Root) return String is
- begin
- return "Parent.Op2 body";
- end Op2;
-
- function Call_Op2(X: Root'Class) return String is
- begin
- return Op2(X);
- end Call_Op2;
-
-begin
-
- Check_String(Op1(Root'(Make)), "Parent.Op1 body");
- Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
-
- Check_String(Op2(Root'(Make)), "Parent.Op2 body");
- Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
-
-end C731001_1.Parent;
-
-with C731001_1.Parent; use C731001_1.Parent;
-private package C731001_1.Unrelated is
-
- type T2 is new Root with null record;
- subtype T2_Class is T2'Class;
- function Make return T2;
- function Op2(X: T2) return String;
-end C731001_1.Unrelated;
-
-with C731001_1.Parent; use C731001_1.Parent;
- pragma Elaborate(C731001_1.Parent);
-package body C731001_1.Unrelated is
-
- function Make return T2 is
- Result: T2;
- begin
- return Result;
- end Make;
-
- function Op2(X: T2) return String is
- begin
- return "Unrelated.Op2 body";
- end Op2;
-begin
-
- Check_String(Op1(T2'(Make)), "Parent.Op1 body");
- Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
- Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
-
- Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
- Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
- Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
- Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
-
-end C731001_1.Unrelated;
-
-package C731001_1.Parent.Child is
- pragma Elaborate_Body;
-
- type T3 is new Root with null record;
- subtype T3_Class is T3'Class;
- function Make return T3;
-
- T3_Obj: T3;
- T3_Class_Obj: T3_Class := T3_Obj;
- T3_Root_Class_Obj: Root_Class := T3_Obj;
-
- X3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- package Nested is
- type T4 is new Root with null record;
- subtype T4_Class is T4'Class;
- function Make return T4;
-
- T4_Obj: T4;
- T4_Class_Obj: T4_Class := T4_Obj;
- T4_Root_Class_Obj: Root_Class := T4_Obj;
-
- X4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- private
-
- XX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- end Nested;
-
- use Nested;
-
- XXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-private
-
- XX3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- XXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-end C731001_1.Parent.Child;
-
-with C731001_1.Unrelated; use C731001_1.Unrelated;
- pragma Elaborate(C731001_1.Unrelated);
-package body C731001_1.Parent.Child is
-
- XXX3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- XXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- function Make return T3 is
- Result: T3;
- begin
- return Result;
- end Make;
-
- package body Nested is
- function Make return T4 is
- Result: T4;
- begin
- return Result;
- end Make;
-
- XXXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- end Nested;
-
- type T5 is new T2 with null record;
- subtype T5_Class is T5'Class;
- function Make return T5;
-
- function Make return T5 is
- Result: T5;
- begin
- return Result;
- end Make;
-
- XXXXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-end C731001_1.Parent.Child;
-
-procedure C731001_1.Main;
-
-with C731001_1.Parent;
-procedure C731001_1.Main is
-begin
- C731001_1.Parent.Call_Main;
-end C731001_1.Main;
-
-with C731001_1.Parent.Child;
- use C731001_1.Parent;
- use C731001_1.Parent.Child;
- use C731001_1.Parent.Child.Nested;
-with C731001_1.Unrelated; use C731001_1.Unrelated;
-procedure C731001_1.Parent.Main is
-
- Root_Obj: Root := Make;
- Root_Class_Obj: Root_Class := Root'(Make);
-
- T2_Obj: T2 := Make;
- T2_Class_Obj: T2_Class := T2_Obj;
- T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
-
- T3_Obj: T3 := Make;
- T3_Class_Obj: T3_Class := T3_Obj;
- T3_Root_Class_Obj: Root_Class := T3_Obj;
-
- T4_Obj: T4 := Make;
- T4_Class_Obj: T4_Class := T4_Obj;
- T4_Root_Class_Obj: Root_Class := T4_Obj;
-
-begin
- Test("C731001_1", "Check that inherited operations can be overridden, even"
- & " when they are inherited in a body");
-
- Check_String(Op1(Root_Obj), "Parent.Op1 body");
- Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T2_Obj), "Parent.Op1 body");
- Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
- Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
- Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T3_Obj), "Parent.Op1 body");
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T4_Obj), "Parent.Op1 body");
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- Result;
-end C731001_1.Parent.Main;
-
-with C731001_1.Main;
-procedure C731001 is
-begin
- C731001_1.Main;
-end C731001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74004a.ada b/gcc/testsuite/ada/acats/tests/c7/c74004a.ada
deleted file mode 100644
index f2a016b..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74004a.ada
+++ /dev/null
@@ -1,375 +0,0 @@
--- C74004A.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 OPERATIONS DEPENDING ON THE FULL DECLARATION OF A
--- PRIVATE TYPE ARE AVAILABLE WITHIN THE PACKAGE BODY.
-
--- HISTORY:
--- BCB 04/05/88 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74004A IS
-
- PACKAGE P IS
- TYPE PR IS PRIVATE;
- TYPE ARR1 IS LIMITED PRIVATE;
- TYPE ARR2 IS PRIVATE;
- TYPE REC (D : INTEGER) IS PRIVATE;
- TYPE ACC IS PRIVATE;
- TYPE TSK IS LIMITED PRIVATE;
- TYPE FLT IS LIMITED PRIVATE;
- TYPE FIX IS LIMITED PRIVATE;
-
- TASK TYPE T IS
- ENTRY ONE(V : IN OUT INTEGER);
- END T;
-
- PROCEDURE CHECK (V : ARR2);
- PRIVATE
- TYPE PR IS NEW INTEGER;
-
- TYPE ARR1 IS ARRAY(1..5) OF INTEGER;
-
- TYPE ARR2 IS ARRAY(1..5) OF BOOLEAN;
-
- TYPE REC (D : INTEGER) IS RECORD
- COMP1 : INTEGER;
- COMP2 : BOOLEAN;
- END RECORD;
-
- TYPE ACC IS ACCESS INTEGER;
-
- TYPE TSK IS NEW T;
-
- TYPE FLT IS DIGITS 5;
-
- TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0;
- END P;
-
- PACKAGE BODY P IS
- X1, X2, X3 : PR;
- BOOL : BOOLEAN := IDENT_BOOL(FALSE);
- VAL : INTEGER := IDENT_INT(0);
- FVAL : FLOAT := 0.0;
- ST : STRING(1..2);
- O1 : ARR1 := (1,2,3,4,5);
- Y1 : ARR2 := (FALSE,TRUE,FALSE,TRUE,FALSE);
- Y2 : ARR2 := (OTHERS => TRUE);
- Y3 : ARR2 := (OTHERS => FALSE);
- Z1 : REC(0) := (0,1,FALSE);
- W1, W2 : ACC := NEW INTEGER'(0);
- V1 : TSK;
-
- TASK BODY T IS
- BEGIN
- ACCEPT ONE(V : IN OUT INTEGER) DO
- V := IDENT_INT(10);
- END ONE;
- END T;
-
- PROCEDURE CHECK (V : ARR2) IS
- BEGIN
- IF V /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
- FAILED ("IMPROPER VALUE PASSED AS AGGREGATE");
- END IF;
- END CHECK;
- BEGIN
- TEST ("C74004A", "CHECK THAT OPERATIONS DEPENDING ON THE " &
- "FULL DECLARATION OF A PRIVATE TYPE ARE " &
- "AVAILABLE WITHIN THE PACKAGE BODY");
-
- X1 := 10;
- X2 := 5;
-
- X3 := X1 + X2;
-
- IF X3 /= 15 THEN
- FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR");
- END IF;
-
- X3 := X1 - X2;
-
- IF X3 /= 5 THEN
- FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR");
- END IF;
-
- X3 := X1 * X2;
-
- IF X3 /= 50 THEN
- FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR");
- END IF;
-
- X3 := X1 / X2;
-
- IF X3 /= 2 THEN
- FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR");
- END IF;
-
- X3 := X1 ** 2;
-
- IF X3 /= 100 THEN
- FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR");
- END IF;
-
- BOOL := X1 < X2;
-
- IF BOOL THEN
- FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR");
- END IF;
-
- BOOL := X1 > X2;
-
- IF NOT BOOL THEN
- FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR");
- END IF;
-
- BOOL := X1 <= X2;
-
- IF BOOL THEN
- FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " &
- "OPERATOR");
- END IF;
-
- BOOL := X1 >= X2;
-
- IF NOT BOOL THEN
- FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " &
- "TO OPERATOR");
- END IF;
-
- X3 := X1 MOD X2;
-
- IF X3 /= 0 THEN
- FAILED ("IMPROPER RESULT FROM MOD OPERATOR");
- END IF;
-
- X3 := X1 REM X2;
-
- IF X3 /= 0 THEN
- FAILED ("IMPROPER RESULT FROM REM OPERATOR");
- END IF;
-
- X3 := ABS(X1);
-
- IF X3 /= 10 THEN
- FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 1");
- END IF;
-
- X1 := -10;
-
- X3 := ABS(X1);
-
- IF X3 /= 10 THEN
- FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 2");
- END IF;
-
- X3 := PR'BASE'FIRST;
-
- IF X3 /= PR(INTEGER'FIRST) THEN
- FAILED ("IMPROPER RESULT FROM 'BASE'FIRST");
- END IF;
-
- X3 := PR'FIRST;
-
- IF X3 /= PR(INTEGER'FIRST) THEN
- FAILED ("IMPROPER RESULT FROM 'FIRST");
- END IF;
-
- VAL := PR'WIDTH;
-
- IF NOT EQUAL(VAL,INTEGER'WIDTH) THEN
- FAILED ("IMPROPER RESULT FROM 'WIDTH");
- END IF;
-
- VAL := PR'POS(X3);
-
- IF NOT EQUAL(VAL,INTEGER'FIRST) THEN
- FAILED ("IMPROPER RESULT FROM 'POS");
- END IF;
-
- X3 := PR'VAL(VAL);
-
- IF X3 /= PR(INTEGER'FIRST) THEN
- FAILED ("IMPROPER RESULT FROM 'VAL");
- END IF;
-
- X3 := PR'SUCC(X2);
-
- IF X3 /= 6 THEN
- FAILED ("IMPROPER RESULT FROM 'SUCC");
- END IF;
-
- X3 := PR'PRED(X2);
-
- IF X3 /= 4 THEN
- FAILED ("IMPROPER RESULT FROM 'PRED");
- END IF;
-
- ST := PR'IMAGE(X3);
-
- IF ST /= INTEGER'IMAGE(INTEGER(X3)) THEN
- FAILED ("IMPROPER RESULT FROM 'IMAGE");
- END IF;
-
- X3 := PR'VALUE(ST);
-
- IF X3 /= PR(INTEGER'VALUE(ST)) THEN
- FAILED ("IMPROPER RESULT FROM 'VALUE");
- END IF;
-
- CHECK ((TRUE,FALSE,TRUE,FALSE,TRUE));
-
- IF O1(2) /= IDENT_INT(2) THEN
- FAILED ("IMPROPER VALUE FROM INDEXING");
- END IF;
-
- IF O1(2..4) /= (2,3,4) THEN
- FAILED ("IMPROPER VALUES FROM SLICING");
- END IF;
-
- IF VAL IN O1'RANGE THEN
- FAILED ("IMPROPER RESULT FROM 'RANGE");
- END IF;
-
- VAL := O1'LENGTH;
-
- IF NOT EQUAL(VAL,5) THEN
- FAILED ("IMPROPER RESULT FROM 'LENGTH");
- END IF;
-
- Y3 := Y1(1..2) & Y2(3..5);
-
- IF Y3 /= (FALSE,TRUE,TRUE,TRUE,TRUE) THEN
- FAILED ("IMPROPER RESULT FROM CATENATION");
- END IF;
-
- Y3 := NOT Y1;
-
- IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
- FAILED ("IMPROPER RESULT FROM NOT OPERATOR");
- END IF;
-
- Y3 := Y1 AND Y2;
-
- IF Y3 /= (FALSE,TRUE,FALSE,TRUE,FALSE) THEN
- FAILED ("IMPROPER RESULT FROM AND OPERATOR");
- END IF;
-
- Y3 := Y1 OR Y2;
-
- IF Y3 /= (TRUE,TRUE,TRUE,TRUE,TRUE) THEN
- FAILED ("IMPROPER RESULT FROM OR OPERATOR");
- END IF;
-
- Y3 := Y1 XOR Y2;
-
- IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
- FAILED ("IMPROPER RESULT FROM XOR OPERATOR");
- END IF;
-
- VAL := Z1.COMP1;
-
- IF NOT EQUAL(VAL,1) THEN
- FAILED ("IMPROPER RESULT FROM SELECTION OF RECORD " &
- "COMPONENTS");
- END IF;
-
- W1 := NEW INTEGER'(0);
-
- IF NOT EQUAL(W1.ALL,0) THEN
- FAILED ("IMPROPER RESULT FROM ALLOCATION");
- END IF;
-
- W1 := NULL;
-
- IF W1 /= NULL THEN
- FAILED ("IMPROPER RESULT FROM NULL LITERAL");
- END IF;
-
- VAL := W2.ALL;
-
- IF NOT EQUAL(VAL,0) THEN
- FAILED ("IMPROPER RESULT FROM SELECTED COMPONENT");
- END IF;
-
- BOOL := V1'CALLABLE;
-
- IF NOT BOOL THEN
- FAILED ("IMPROPER RESULT FROM 'CALLABLE");
- END IF;
-
- BOOL := V1'TERMINATED;
-
- IF BOOL THEN
- FAILED ("IMPROPER RESULT FROM 'TERMINATED");
- END IF;
-
- V1.ONE(VAL);
-
- IF NOT EQUAL(VAL,10) THEN
- FAILED ("IMPROPER RESULT RETURNED FROM ENTRY SELECTION");
- END IF;
-
- IF NOT (FLT(1.0) IN FLT) THEN
- FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION");
- END IF;
-
- VAL := FLT'DIGITS;
-
- IF NOT EQUAL(VAL,5) THEN
- FAILED ("IMPROPER RESULT FROM 'DIGITS");
- END IF;
-
- BOOL := FLT'MACHINE_ROUNDS;
-
- BOOL := FLT'MACHINE_OVERFLOWS;
-
- VAL := FLT'MACHINE_RADIX;
-
- VAL := FLT'MACHINE_MANTISSA;
-
- VAL := FLT'MACHINE_EMAX;
-
- VAL := FLT'MACHINE_EMIN;
-
- FVAL := FIX'DELTA;
-
- IF FVAL /= 2.0**(-1) THEN
- FAILED ("IMPROPER RESULT FROM 'DELTA");
- END IF;
-
- VAL := FIX'FORE;
-
- VAL := FIX'AFT;
-
- END P;
-
- USE P;
-
-BEGIN
- RESULT;
-END C74004A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74203a.ada b/gcc/testsuite/ada/acats/tests/c7/c74203a.ada
deleted file mode 100644
index 82cfe92..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74203a.ada
+++ /dev/null
@@ -1,263 +0,0 @@
--- C74203A.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 MEMBERSHIP TESTS, QUALIFICATION, AND EXPLICIT
--- CONVERSION ARE AVAILABLE FOR LIMITED AND NON-LIMITED PRIVATE
--- TYPES. INCLUDE TYPES WITH DISCRIMINANTS AND TYPES
--- WITH LIMITED COMPONENTS.
-
--- HISTORY:
--- BCB 03/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74203A IS
-
- PACKAGE PP IS
- TYPE LIM IS LIMITED PRIVATE;
- PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER);
-
- TYPE A IS PRIVATE;
- SUBTYPE SUBA IS A;
- A1 : CONSTANT A;
-
- TYPE B IS LIMITED PRIVATE;
- B1 : CONSTANT B;
-
- TYPE C IS PRIVATE;
- C1 : CONSTANT C;
-
- TYPE D IS LIMITED PRIVATE;
- D1 : CONSTANT D;
-
- TYPE E (DISC1 : INTEGER := 5) IS PRIVATE;
- SUBTYPE SUBE IS E;
- E1 : CONSTANT E;
-
- TYPE F (DISC2 : INTEGER := 15) IS LIMITED PRIVATE;
- F1 : CONSTANT F;
-
- TYPE G (DISC3 : INTEGER) IS PRIVATE;
- G1 : CONSTANT G;
-
- TYPE H (DISC4 : INTEGER) IS LIMITED PRIVATE;
- H1 : CONSTANT H;
-
- TYPE I IS RECORD
- COMPI : LIM;
- END RECORD;
- SUBTYPE SUBI IS I;
-
- TYPE J IS ARRAY(1..5) OF LIM;
- SUBTYPE SUBJ IS J;
-
- TYPE S1 IS (VINCE, TOM, PHIL, JODIE, ROSA, TERESA);
- TYPE S2 IS (THIS, THAT, THESE, THOSE, THEM);
- TYPE S3 IS RANGE 1 .. 100;
- TYPE S4 IS RANGE 1 .. 100;
- PRIVATE
- TYPE LIM IS RANGE 1 .. 100;
-
- TYPE A IS (RED, BLUE, GREEN, YELLOW, BLACK, WHITE);
- A1 : CONSTANT A := BLUE;
-
- TYPE B IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
- B1 : CONSTANT B := THREE;
-
- TYPE C IS RANGE 1 .. 100;
- C1 : CONSTANT C := 50;
-
- TYPE D IS RANGE 1 .. 100;
- D1 : CONSTANT D := 50;
-
- TYPE E (DISC1 : INTEGER := 5) IS RECORD
- COMPE : S1;
- END RECORD;
- E1 : CONSTANT E := (DISC1 => 5, COMPE => TOM);
-
- TYPE F (DISC2 : INTEGER := 15) IS RECORD
- COMPF : S2;
- END RECORD;
- F1 : CONSTANT F := (DISC2 => 15, COMPF => THAT);
-
- TYPE G (DISC3 : INTEGER) IS RECORD
- COMPG : S3;
- END RECORD;
- G1 : CONSTANT G := (DISC3 => 25, COMPG => 50);
-
- TYPE H (DISC4 : INTEGER) IS RECORD
- COMPH : S4;
- END RECORD;
- H1 : CONSTANT H := (DISC4 => 30, COMPH => 50);
- END PP;
-
- USE PP;
-
- AVAR : SUBA := A1;
- EVAR : SUBE := E1;
-
- IVAR : SUBI;
- JVAR : SUBJ;
-
- PACKAGE BODY PP IS
- PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER) IS
- BEGIN
- Z1 := LIM (Z2);
- END INIT;
- BEGIN
- NULL;
- END PP;
-
- PROCEDURE QUAL_PRIV (W : A) IS
- BEGIN
- NULL;
- END QUAL_PRIV;
-
- PROCEDURE QUAL_LIM_PRIV (X : B) IS
- BEGIN
- NULL;
- END QUAL_LIM_PRIV;
-
- PROCEDURE EXPL_CONV_PRIV_1 (Y : C) IS
- BEGIN
- NULL;
- END EXPL_CONV_PRIV_1;
-
- PROCEDURE EXPL_CONV_LIM_PRIV_1 (Z : D) IS
- BEGIN
- NULL;
- END EXPL_CONV_LIM_PRIV_1;
-
- PROCEDURE EXPL_CONV_PRIV_2 (Y2 : G) IS
- BEGIN
- NULL;
- END EXPL_CONV_PRIV_2;
-
- PROCEDURE EXPL_CONV_LIM_PRIV_2 (Z2 : H) IS
- BEGIN
- NULL;
- END EXPL_CONV_LIM_PRIV_2;
-
- PROCEDURE EXPL_CONV_PRIV_3 (Y3 : I) IS
- BEGIN
- NULL;
- END EXPL_CONV_PRIV_3;
-
- PROCEDURE EXPL_CONV_PRIV_4 (Y4 : J) IS
- BEGIN
- NULL;
- END EXPL_CONV_PRIV_4;
-
-BEGIN
- TEST ("C74203A", "CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, " &
- "AND EXPLICIT CONVERSION ARE AVAILABLE FOR " &
- "LIMITED AND NON-LIMITED PRIVATE TYPES. " &
- "INCLUDE TYPES WITH DISCRIMINANTS AND " &
- "TYPES WITH LIMITED COMPONENTS");
-
- INIT (IVAR.COMPI, 50);
-
- FOR K IN IDENT_INT (1) .. IDENT_INT (5) LOOP
- INIT (JVAR(K), 25);
- END LOOP;
-
- IF NOT (AVAR IN A) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "PRIVATE TYPE - 1");
- END IF;
-
- IF (AVAR NOT IN A) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "PRIVATE TYPE - 1");
- END IF;
-
- IF NOT (B1 IN B) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "LIMITED PRIVATE TYPE - 1");
- END IF;
-
- IF (B1 NOT IN B) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "LIMITED PRIVATE TYPE - 1");
- END IF;
-
- QUAL_PRIV (A'(AVAR));
-
- QUAL_LIM_PRIV (B'(B1));
-
- EXPL_CONV_PRIV_1 (C(C1));
-
- EXPL_CONV_LIM_PRIV_1 (D(D1));
-
- IF NOT (EVAR IN E) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "PRIVATE TYPE - 2");
- END IF;
-
- IF (EVAR NOT IN E) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "PRIVATE TYPE - 2");
- END IF;
-
- IF NOT (F1 IN F) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "LIMITED PRIVATE TYPE - 2");
- END IF;
-
- IF (F1 NOT IN F) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "LIMITED PRIVATE TYPE - 2");
- END IF;
-
- EXPL_CONV_PRIV_2 (G(G1));
-
- EXPL_CONV_LIM_PRIV_2 (H(H1));
-
- IF NOT (IVAR IN I) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "PRIVATE TYPE - 3");
- END IF;
-
- IF (IVAR NOT IN I) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "PRIVATE TYPE - 3");
- END IF;
-
- EXPL_CONV_PRIV_3 (I(IVAR));
-
- IF NOT (JVAR IN J) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
- "PRIVATE TYPE - 4");
- END IF;
-
- IF (JVAR NOT IN J) THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
- "PRIVATE TYPE - 4");
- END IF;
-
- EXPL_CONV_PRIV_4 (J(JVAR));
-
- RESULT;
-END C74203A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74206a.ada b/gcc/testsuite/ada/acats/tests/c7/c74206a.ada
deleted file mode 100644
index 6a0dfbf..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74206a.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- C74206A.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 COMPOSITE TYPE IS DECLARED IN THE PACKAGE AS A
--- PRIVATE TYPE AND CONTAINS A COMPONENT OF THE PRIVATE TYPE, OPERATIONS
--- OF THE COMPOSITE TYPE WHICH DO NOT DEPEND ON CHARACTERISTICS OF THE
--- PRIVATE TYPE ARE AVAILABLE AFTER THE FULL DECLARATION OF THE PRIVATE
--- TYPE, BUT BEFORE THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
--- DECLARATION OF THE COMPOSITE TYPE THAT IS AFTER THE FULL DECLARATION
--- OF THE PRIVATE TYPE. IN PARTICULAR, CHECK FOR THE FOLLOWING :
-
--- 'FIRST, 'LAST, 'RANGE, AND 'LENGTH FOR ARRAY TYPES
--- SELECTED COMPONENTS FOR DISCRIMINANTS AND COMPONENTS OF RECORDS
--- INDEXED COMPONENTS AND SLICES FOR ARRAYS
-
--- DSJ 5/5/83
--- JBG 3/8/84
-
-WITH REPORT;
-PROCEDURE C74206A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C74206A", "CHECK THAT ADDITIONAL OPERATIONS FOR "
- & "COMPOSITE TYPES OF PRIVATE TYPES ARE "
- & "AVAILABLE AT THE EARLIEST PLACE AFTER THE "
- & "FULL DECLARATION OF THE PRIVATE TYPE EVEN "
- & "IF BEFORE THE EARLIEST PLACE WITHIN THE "
- & "IMMEDIATE SCOPE OF THE COMPOSITE TYPE");
-
- DECLARE
-
- PACKAGE PACK1 IS
- TYPE P1 IS PRIVATE;
- TYPE LP1 IS LIMITED PRIVATE;
-
- PACKAGE PACK_LP IS
- TYPE LP_ARR IS ARRAY (1 .. 2) OF LP1;
- TYPE LP_REC (D : INTEGER) IS
- RECORD
- C1, C2 : LP1;
- END RECORD;
- END PACK_LP;
-
- PACKAGE PACK2 IS
- TYPE ARR IS ARRAY ( 1 .. 2 ) OF P1;
- TYPE REC (D : INTEGER) IS
- RECORD
- C1, C2 : P1;
- END RECORD;
- END PACK2;
- PRIVATE
- TYPE P1 IS NEW BOOLEAN;
- TYPE LP1 IS NEW BOOLEAN;
- END PACK1;
-
- PACKAGE BODY PACK1 IS
-
- USE PACK_LP;
- USE PACK2;
-
- A1 : ARR;
- L1 : LP_ARR;
-
- N1 : INTEGER := ARR'FIRST; -- LEGAL
- N2 : INTEGER := ARR'LAST; -- LEGAL
- N3 : INTEGER := A1'LENGTH; -- LEGAL
- N4 : INTEGER := LP_ARR'FIRST; -- LEGAL
- N5 : INTEGER := LP_ARR'LAST; -- LEGAL
- N6 : INTEGER := L1'LENGTH; -- LEGAL
- B1 : BOOLEAN := 1 IN ARR'RANGE; -- LEGAL
- B2 : BOOLEAN := 5 IN LP_ARR'RANGE; -- LEGAL
-
- N7 : INTEGER := A1(1)'SIZE; -- LEGAL: A1(1)
- N8 : INTEGER := L1(2)'SIZE; -- LEGAL: L1(2)
-
- R1 : REC(1);
- Q1 : LP_REC(1);
-
- K1 : INTEGER := R1.D'SIZE; -- LEGAL: R1.D
- K2 : INTEGER := R1.C1'SIZE; -- LEGAL: R1.C1
- K3 : INTEGER := Q1.D'SIZE; -- LEGAL: Q1.D
- K4 : INTEGER := Q1.C2'SIZE; -- LEGAL: Q1.C2
-
- BEGIN
-
- IF N1 /= 1 OR N4 /= 1 THEN
- FAILED ("WRONG VALUE FOR 'FIRST");
- END IF;
-
- IF N2 /= 2 OR N5 /= 2 THEN
- FAILED ("WRONG VALUE FOR 'LAST");
- END IF;
-
- IF N3 /= 2 OR N6 /= 2 THEN
- FAILED ("WRONG VALUE FOR 'LENGTH");
- END IF;
-
- IF B1 /= TRUE OR B2 /= FALSE THEN
- FAILED ("INCORRECT RANGE TEST");
- END IF;
-
- IF N7 /= N8 THEN
- FAILED ("INCORRECT INDEXED COMPONENTS");
- END IF;
-
- IF K1 /= K3 OR K2 /= K4 THEN
- FAILED ("INCORRECT COMPONENT SELECTION");
- END IF;
-
- END PACK1;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END C74206A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74207b.ada b/gcc/testsuite/ada/acats/tests/c7/c74207b.ada
deleted file mode 100644
index a5284a6..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74207b.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C74207B.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 'CONSTRAINED CAN BE APPLIED AFTER THE FULL DECLARATION OF
--- A PRIVATE TYPE THAT IS DERIVED FROM A PRIVATE TYPE.
-
--- BHS 6/18/84
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE C74207B IS
-BEGIN
- TEST ("C74207B", "AFTER THE FULL DECLARATION OF A PRIVATE " &
- "TYPE DERIVED FROM A PRIVATE TYPE, " &
- "'CONSTRAINED MAY BE APPLIED");
-
- DECLARE
- PACKAGE P1 IS
- TYPE PREC (D : INTEGER) IS PRIVATE;
- TYPE P IS PRIVATE;
- PRIVATE
- TYPE PREC (D : INTEGER) IS RECORD
- NULL;
- END RECORD;
- TYPE P IS NEW INTEGER;
- END P1;
-
- PACKAGE P2 IS
- TYPE LP1 IS LIMITED PRIVATE;
- TYPE LP2 IS LIMITED PRIVATE;
- PRIVATE
- TYPE LP1 IS NEW P1.PREC(3);
- TYPE LP2 IS NEW P1.P;
- B1 : BOOLEAN := LP1'CONSTRAINED;
- B2 : BOOLEAN := LP2'CONSTRAINED;
- END P2;
-
- PACKAGE BODY P2 IS
- BEGIN
- IF NOT IDENT_BOOL(B1) THEN
- FAILED ("WRONG VALUE FOR LP1'CONSTRAINED");
- END IF;
- IF NOT IDENT_BOOL(B2) THEN
- FAILED ("WRONG VALUE FOR LP2'CONSTRAINED");
- END IF;
- END P2;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-END C74207B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74208a.ada b/gcc/testsuite/ada/acats/tests/c7/c74208a.ada
deleted file mode 100644
index 36607d2..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74208a.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C74208A.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 'SIZE AND 'ADDRESS FOR OBJECTS OF LIMITED AND
--- NON-LIMITED TYPES ARE AVAILABLE BOTH INSIDE AND OUTSIDE THE
--- PACKAGE DECLARING THE TYPES.
-
--- HISTORY:
--- BCB 03/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE C74208A IS
-
- PACKAGE P IS
- TYPE T IS PRIVATE;
- TYPE U IS LIMITED PRIVATE;
- PRIVATE
- TYPE T IS RANGE 1 .. 100;
- TYPE U IS RANGE 1 .. 100;
- END P;
-
- A : P.T;
- B : P.U;
- ASIZE, BSIZE : INTEGER;
- AADDRESS, BADDRESS : ADDRESS;
-
- FUNCTION IDENT_ADR(X : ADDRESS) RETURN ADDRESS IS
- Y : P.T;
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- END IF;
- RETURN Y'ADDRESS;
- END IDENT_ADR;
-
- PACKAGE BODY P IS
- X : T;
- Y : U;
- XSIZE, YSIZE : INTEGER;
- XADDRESS, YADDRESS : ADDRESS;
- BEGIN
- TEST ("C74208A", "CHECK THAT 'SIZE AND 'ADDRESS FOR " &
- "OBJECTS OF LIMITED AND NON-LIMITED TYPES " &
- "ARE AVAILABLE BOTH INSIDE AND OUTSIDE " &
- "THE PACKAGE DECLARING THE TYPES");
-
- XSIZE := X'SIZE;
- YSIZE := Y'SIZE;
- XADDRESS := X'ADDRESS;
- YADDRESS := Y'ADDRESS;
-
- IF NOT EQUAL(XSIZE,X'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR X'SIZE");
- END IF;
-
- IF XADDRESS /= IDENT_ADR(X'ADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR X'ADDRESS");
- END IF;
-
- IF NOT EQUAL(YSIZE,Y'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR Y'SIZE");
- END IF;
-
- IF YADDRESS /= IDENT_ADR(Y'ADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR Y'ADDRESS");
- END IF;
- END P;
-
-BEGIN
- ASIZE := A'SIZE;
- BSIZE := B'SIZE;
- AADDRESS := A'ADDRESS;
- BADDRESS := B'ADDRESS;
-
- IF NOT EQUAL(ASIZE,A'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR A'SIZE");
- END IF;
-
- IF AADDRESS /= IDENT_ADR(A'ADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR A'ADDRESS");
- END IF;
-
- IF NOT EQUAL(BSIZE,B'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR B'SIZE");
- END IF;
-
- IF BADDRESS /= IDENT_ADR(B'ADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR B'ADDRESS");
- END IF;
-
- RESULT;
-END C74208A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74208b.ada b/gcc/testsuite/ada/acats/tests/c7/c74208b.ada
deleted file mode 100644
index c4c00bf..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74208b.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- C74208B.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 'CONSTRAINED FOR OBJECTS OF A PRIVATE TYPE WITH
--- VISIBLE DISCRIMINANTS IS AVAILABLE OUTSIDE THE PACKAGE DECLARING
--- THE TYPE AND IS AVAILABLE BEFORE AND AFTER THE FULL DECLARATION.
-
--- HISTORY:
--- BCB 07/14/88 CREATED ORIGINAL TEST.
--- GJD 11/15/95 MOVED REC2_VAR OUT OF P DUE TO ADA 95 FREEZING RULES.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74208B IS
-
- PACKAGE P IS
- TYPE REC (D : INTEGER := 0) IS PRIVATE;
- R1 : CONSTANT REC;
- TYPE REC2 IS RECORD
- COMP : BOOLEAN := R1'CONSTRAINED;
- END RECORD;
- PRIVATE
- TYPE REC (D : INTEGER := 0) IS RECORD
- NULL;
- END RECORD;
- R1 : CONSTANT REC := (D => 5);
- R2 : REC := (D => 0);
- R2A : REC(3);
- R2CON : CONSTANT REC := (D => 3);
- C : BOOLEAN := R2'CONSTRAINED;
- D : BOOLEAN := R2A'CONSTRAINED;
- E : BOOLEAN := R2CON'CONSTRAINED;
- END P;
-
- REC2_VAR : P.REC2;
-
- R3 : P.REC(0);
- R3A : P.REC;
-
- A : BOOLEAN := R3'CONSTRAINED;
- B : BOOLEAN := R3A'CONSTRAINED;
-
- PACKAGE BODY P IS
- BEGIN
- TEST ("C74208B", "CHECK THAT 'CONSTRAINED FOR OBJECTS OF A " &
- "PRIVATE TYPE WITH VISIBLE DISCRIMINANTS " &
- "IS AVAILABLE OUTSIDE THE PACKAGE " &
- "DECLARING THE TYPE AND IS AVAILABLE " &
- "BEFORE AND AFTER THE FULL DECLARATION");
-
- IF NOT REC2_VAR.COMP THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED BEFORE THE " &
- "FULL DECLARATION OF THE PRIVATE TYPE");
- END IF;
-
- IF C THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
- "FULL DECLARATION OF THE PRIVATE TYPE - 1");
- END IF;
-
- IF NOT D THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
- "FULL DECLARATION OF THE PRIVATE TYPE - 2");
- END IF;
-
- IF NOT E THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
- "FULL DECLARATION OF THE PRIVATE TYPE - 3");
- END IF;
- END P;
-
-BEGIN
- IF NOT A THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " &
- "PACKAGE DECLARING THE PRIVATE TYPE - 1");
- END IF;
-
- IF B THEN
- FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " &
- "PACKAGE DECLARING THE PRIVATE TYPE - 2");
- END IF;
-
- RESULT;
-END C74208B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74209a.ada b/gcc/testsuite/ada/acats/tests/c7/c74209a.ada
deleted file mode 100644
index eef77fd..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74209a.ada
+++ /dev/null
@@ -1,224 +0,0 @@
--- C74209A.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 OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED
--- PRIVATE TYPES IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE
--- THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A
--- LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION
--- SUBPROGRAMS).
-
--- RM 07/14/81
-
-
-WITH REPORT;
-PROCEDURE C74209A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " &
- "PRIVATE TYPES" );
-
- DECLARE
-
- PACKAGE PACK IS
-
- TYPE LIM_PRIV IS LIMITED PRIVATE;
- TYPE PRIV IS PRIVATE;
- PRIV_CONST_IN : CONSTANT PRIV;
- PRIV_CONST_OUT : CONSTANT PRIV;
- FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV;
- FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ;
- PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV );
-
- PRIVATE
-
- TYPE LIM_PRIV IS NEW INTEGER;
- TYPE PRIV IS NEW STRING( 1..5 );
- PRIV_CONST_IN : CONSTANT PRIV := "ABCDE";
- PRIV_CONST_OUT : CONSTANT PRIV := "FGHIJ";
-
- END PACK;
-
-
- PRIV_VAR_1 , PRIV_VAR_2 : PACK.PRIV;
- LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2 : PACK.LIM_PRIV;
-
-
- USE PACK;
-
-
- PACKAGE BODY PACK IS
-
- FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV IS
- BEGIN
- RETURN LIM_PRIV(X);
- END PACKAGED;
-
- FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN IS
- BEGIN
- RETURN X = Y ;
- END EQUALS;
-
- PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV) IS
- BEGIN
- Y := X;
- END ASSIGN;
-
- END PACK;
-
-
- PROCEDURE PROC1( X : IN OUT PACK.PRIV;
- Y : IN PACK.PRIV := PACK.PRIV_CONST_IN;
- Z : OUT PACK.PRIV;
- U : PACK.PRIV ) IS
- BEGIN
-
- IF X /= PACK.PRIV_CONST_IN OR
- Y /= PACK.PRIV_CONST_IN OR
- U /= PACK.PRIV_CONST_IN
- THEN
- FAILED( "WRONG INPUT VALUES - PROC1" );
- END IF;
-
- X := PACK.PRIV_CONST_OUT;
- Z := PACK.PRIV_CONST_OUT;
-
- END PROC1;
-
-
- PROCEDURE PROC2( X : IN OUT LIM_PRIV;
- Y : IN LIM_PRIV;
- Z : IN OUT LIM_PRIV;
- U : LIM_PRIV ) IS
- BEGIN
-
- IF NOT(EQUALS( X , PACKAGED(17) )) OR
- NOT(EQUALS( Y , PACKAGED(17) )) OR
- NOT(EQUALS( U , PACKAGED(17) ))
- THEN
- FAILED( "WRONG INPUT VALUES - PROC2" );
- END IF;
-
- ASSIGN( PACKAGED(13) , X );
- ASSIGN( PACKAGED(13) , Z );
-
- END PROC2;
-
-
- FUNCTION FUNC1( Y : IN PRIV := PRIV_CONST_IN;
- U : PRIV ) RETURN PRIV IS
- BEGIN
-
- IF Y /= PRIV_CONST_IN OR
- U /= PRIV_CONST_IN
- THEN
- FAILED( "WRONG INPUT VALUES - FUNC1" );
- END IF;
-
- RETURN PRIV_CONST_OUT;
-
- END FUNC1;
-
-
- FUNCTION FUNC2( Y : IN LIM_PRIV;
- U : LIM_PRIV ) RETURN LIM_PRIV IS
- BEGIN
-
- IF NOT(EQUALS( Y , PACKAGED(17) )) OR
- NOT(EQUALS( U , PACKAGED(17) ))
- THEN
- FAILED( "WRONG INPUT VALUES - FUNC2" );
- END IF;
-
- RETURN PACKAGED(13);
-
- END FUNC2;
-
-
- BEGIN
-
- --------------------------------------------------------------
-
- PRIV_VAR_1 := PRIV_CONST_IN;
- PRIV_VAR_2 := PRIV_CONST_IN;
-
- PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN );
-
- IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT OR
- PRIV_VAR_2 /= PACK.PRIV_CONST_OUT
- THEN
- FAILED( "WRONG OUTPUT VALUES - PROC1" );
- END IF;
-
- --------------------------------------------------------------
-
- ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
- ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
-
- PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) ,
- LIM_PRIV_VAR_2 , PACKAGED(17) );
-
- IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) OR
- NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) ))
- THEN
- FAILED( "WRONG OUTPUT VALUES - PROC2" );
- END IF;
-
- --------------------------------------------------------------
-
- PRIV_VAR_1 := PRIV_CONST_IN;
- PRIV_VAR_2 := PRIV_CONST_IN;
-
- PRIV_VAR_1 :=
- FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN );
-
- IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT
- THEN
- FAILED( "WRONG OUTPUT VALUES - FUNC1" );
- END IF;
-
- --------------------------------------------------------------
-
- ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
- ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
-
- ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) ,
- LIM_PRIV_VAR_1 );
-
- IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))
- THEN
- FAILED( "WRONG OUTPUT VALUES - FUNC2" );
- END IF;
-
- --------------------------------------------------------------
-
- END;
-
-
- RESULT;
-
-
-END C74209A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74210a.ada b/gcc/testsuite/ada/acats/tests/c7/c74210a.ada
deleted file mode 100644
index f3496b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74210a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C74210A.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 OPERATOR SYMBOLS OVERLOADED IN A PACKAGE ARE
--- USED AND DERIVED IN PREFERENCE TO THOSE OF THE PARENT OF A DERIVED
--- PRIVATE TYPE.
-
--- CHECK THAT OPERATOR DEFINITIONS FOR A PRIVATE TYPE MAY BE
--- OVERLOADED OUTSIDE THE PACKAGE.
-
--- CHECK THAT EQUALITY CAN BE DEFINED FOR LIMITED TYPES AND COMPOSITE
--- TYPES WITH LIMITED COMPONENTS.
-
--- DAT 5/11/81
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74210A IS
-BEGIN
- TEST ("C74210A", "OVERLOADED OPERATORS FOR PRIVATE TYPES");
-
- DECLARE
- PACKAGE P IS
- TYPE T IS PRIVATE;
- FUNCTION "+" (X, Y : T) RETURN T;
- ONE, TWO : CONSTANT T;
-
- TYPE L IS LIMITED PRIVATE;
- TYPE A IS ARRAY (0 .. 0) OF L;
- TYPE R IS RECORD
- C : L;
- END RECORD;
- FUNCTION "=" (X, Y : L) RETURN BOOLEAN;
- PRIVATE
- TYPE T IS NEW INTEGER;
- ONE : CONSTANT T := T(IDENT_INT(1));
- TWO : CONSTANT T := T(IDENT_INT(2));
- TYPE L IS (ENUM);
- END P;
- USE P;
-
- VR : R;
- VA : A;
-
- PACKAGE BODY P IS
- FUNCTION "+" (X, Y : T) RETURN T IS
- BEGIN
- RETURN 1;
- END "+";
-
- FUNCTION "=" (X, Y : L) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL(FALSE);
- END "=";
- BEGIN
- VR := (C => ENUM);
- VA := (0 => VR.C);
- END P;
- BEGIN
- IF ONE + TWO /= ONE THEN
- FAILED ("WRONG ""+"" OPERATOR");
- END IF;
-
- DECLARE
- TYPE NEW_T IS NEW T;
-
- FUNCTION "=" (X, Y : A) RETURN BOOLEAN;
- FUNCTION "=" (X, Y : R) RETURN BOOLEAN;
-
- FUNCTION "+" (X, Y : T) RETURN T IS
- BEGIN
- RETURN TWO;
- END "+";
-
- FUNCTION "=" (X, Y : A) RETURN BOOLEAN IS
- BEGIN
- RETURN X(0) = Y(0);
- END "=";
-
- FUNCTION "=" (X, Y : R) RETURN BOOLEAN IS
- BEGIN
- RETURN X.C = Y.C;
- END "=";
- BEGIN
- IF ONE + TWO /= TWO THEN
- FAILED ("WRONG DERIVED ""+"" OPERATOR");
- END IF;
-
- IF VR = VR OR VA = VA THEN
- FAILED ("CANNOT OVERLOAD ""="" CORRECTLY");
- END IF;
- END;
- END;
-
- RESULT;
-END C74210A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74211a.ada b/gcc/testsuite/ada/acats/tests/c7/c74211a.ada
deleted file mode 100644
index d4a1caf..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74211a.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C74211A.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 WITHIN THE PACKAGE SPECIFICATION AND BODY, ANY EXPLICIT
--- DECLARATIONS OF OPERATORS AND SUBPROGRAMS HIDE ANY OPERATIONS WHICH
--- ARE IMPLICITLY DECLARED AT THE POINT OF THE FULL DECLARATION,
--- REGARDLESS OF THE ORDER OF OCCURENCE OF THE DECLARATIONS.
-
--- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS HIDE IMPLICITLY
--- DECLARED PREDEFINED OPERATORS, REGARDLESS OF THE ORDER OF OCCURENCE
--- OF THE DECLARATIONS.
-
--- DSJ 4/28/83
--- JBG 9/23/83
-
--- A) EXPLICIT DECLARATION HIDES LATER IMPLICIT DECL OF PREDEFINED OP.
--- B) " " " LATER " " " DERIVED OP.
--- C) " " " EARLIER " " " PREDEFINED OP.
--- D) " " " EARLIER " " " DERIVED OP.
-
-WITH REPORT;
-PROCEDURE C74211A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST ("C74211A", "CHECK THAT HIDING OF IMPLICITLY DECLARED " &
- "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " &
- "CORRECTLY REGARDLESS OF ORDER OF DECL'S");
-
- DECLARE
-
- PACKAGE P1 IS
- TYPE T1 IS RANGE 1 .. 50;
- C1 : CONSTANT T1 := T1(IDENT_INT(2));
- D1 : CONSTANT T1 := C1 + C1; -- PREDEFINED "+"
- FUNCTION "+" (L, R : T1) RETURN T1; -- C) FOR "+".
- FUNCTION "-" (L, R : T1) RETURN T1; -- C) FOR "-".
- FUNCTION "/" (L, R : T1) RETURN T1;
- END P1;
-
- USE P1;
-
- PACKAGE BODY P1 IS
- A,B : T1 := 3;
-
- FUNCTION "+" (L, R : T1) RETURN T1 IS
- BEGIN
- IF L = R THEN
- RETURN 1;
- ELSE RETURN 2;
- END IF;
- END "+";
-
- FUNCTION "-" (L, R : T1) RETURN T1 IS
- BEGIN
- IF L = R THEN
- RETURN 3;
- ELSE RETURN 4;
- END IF;
- END "-";
-
- FUNCTION "/" (L, R : T1) RETURN T1 IS
- BEGIN
- IF L = R THEN
- RETURN T1(IDENT_INT(INTEGER(L)));
- ELSE
- RETURN T1(IDENT_INT(50));
- END IF;
- END "/";
-
- BEGIN
- IF D1 /= 4 THEN
- FAILED ("WRONG PREDEFINED OPERATION - '+' ");
- END IF;
-
- IF D1 + C1 /= 2 THEN
- FAILED ("IMPLICIT '+' NOT HIDDEN BY EXPLICIT '+'");
- END IF;
-
- IF A + B /= 1 THEN
- FAILED ("IMPLICIT DECLARATION NOT HIDDEN " &
- "BY EXPLICIT DECLARATION - '+' ");
- END IF;
-
- IF A - B /= 3 THEN
- FAILED ("IMPLICIT DECLARATION NOT HIDDEN " &
- "BY EXPLICIT DECLARATION - '-' ");
- END IF;
-
- IF A * B /= 9 THEN
- FAILED ("WRONG PREDEFINED OPERATION - '*' ");
- END IF;
-
- IF B / A /= T1(IDENT_INT(3)) THEN
- FAILED ("NOT REDEFINED '/' ");
- END IF;
- END P1;
-
- PACKAGE P2 IS
- TYPE T2 IS PRIVATE;
- X , Y : CONSTANT T2;
- FUNCTION "+" (L, R : T2) RETURN T2; -- B)
- FUNCTION "*" (L, R : T2) RETURN T2; -- A)
- PRIVATE
- TYPE T2 IS NEW T1; -- B) +; A) *
- Z : T2 := T2(IDENT_INT(3))/4; -- Z = 50 USING
- -- DERIVED /
- FUNCTION "/" (L, R : T2) RETURN T2; -- D) FOR /
- X , Y : CONSTANT T2 := 3;
- END P2;
-
- PACKAGE BODY P2 IS
- FUNCTION "+" (L, R : T2) RETURN T2 IS
- BEGIN
- IF L = R THEN
- RETURN T2(IDENT_INT(5));
- ELSE RETURN T2(IDENT_INT(6));
- END IF;
- END "+";
-
- FUNCTION "*" (L, R : T2) RETURN T2 IS
- BEGIN
- IF L = R THEN
- RETURN T2(IDENT_INT(7));
- ELSE RETURN T2(IDENT_INT(8));
- END IF;
- END "*";
-
- FUNCTION "/" (L, R : T2) RETURN T2 IS
- BEGIN
- IF L = R THEN
- RETURN T2(IDENT_INT(9));
- ELSE RETURN T2(IDENT_INT(10));
- END IF;
- END "/";
- BEGIN
- IF X + Y /= 5 THEN
- FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
- "EXPLICIT DECLARATION - '+' ");
- END IF;
-
- IF Y - X /= 3 THEN
- FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
- "DERIVED SUBPROGRAM - '-' ");
- END IF;
-
- IF X * Y /= 7 THEN
- FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
- "EXPLICIT DECLARATION - '*' ");
- END IF;
-
- IF Y / X /= T2(IDENT_INT(9)) THEN
- FAILED ("DERIVED OPERATOR NOT HIDDEN BY " &
- "EXPLICIT DECLARATION - '/' ");
- END IF;
-
- IF Z /= 50 THEN
- FAILED ("DERIVED OPERATOR HIDDEN PREMATURELY " &
- " BY REDECLARED OPERATOR");
- END IF;
-
- END P2;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END C74211A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74211b.ada b/gcc/testsuite/ada/acats/tests/c7/c74211b.ada
deleted file mode 100644
index d4b9ef7..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74211b.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C74211B.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 IMPLICITLY DECLARED INEQUALITY WHICH ACCOMPANIES AN
--- EXPLICIT DECLARATION OF EQUALITY HIDES OTHER IMPLICITLY DECLARED
--- HOMOGRAPHS, AND THAT DERIVED INEQUALITY HIDES PREDEFINED INEQUALITY.
-
--- DSJ 4/29/83
--- JBG 9/23/83
-
-WITH REPORT;
-PROCEDURE C74211B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C74211B", "CHECK THAT HIDING OF IMPLICITLY DECLARED " &
- "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " &
- "CORRECTLY REGARDLESS OF ORDER OF DECL'S");
-
- DECLARE
-
- PACKAGE P1 IS
- TYPE LT1 IS LIMITED PRIVATE;
- FUNCTION "="(L, R : LT1) RETURN BOOLEAN;
- FUNCTION LT1_VALUE_2 RETURN LT1;
- FUNCTION LT1_VALUE_4 RETURN LT1;
- TYPE LT2 IS LIMITED PRIVATE;
- PRIVATE
- TYPE LT1 IS RANGE 1 .. 10;
- TYPE LT2 IS RANGE 1 .. 10;
- END P1;
-
- USE P1;
-
- PACKAGE P2 IS
- TYPE LT3 IS LIMITED PRIVATE;
- TYPE LT4 IS NEW LT1;
- PRIVATE
- FUNCTION "=" (L, R : LT3) RETURN BOOLEAN;
- TYPE LT3 IS NEW LT1;
- END P2;
-
- USE P2;
-
- PACKAGE BODY P1 IS
- A , B : CONSTANT LT1 := 4;
- C , D : CONSTANT LT2 := 6;
-
- FUNCTION "=" (L, R : LT1) RETURN BOOLEAN IS
- BEGIN
- RETURN INTEGER(L) /= INTEGER(R);
- END "=";
-
- FUNCTION LT1_VALUE_2 RETURN LT1 IS
- BEGIN
- RETURN 2;
- END LT1_VALUE_2;
-
- FUNCTION LT1_VALUE_4 RETURN LT1 IS
- BEGIN
- RETURN 4;
- END LT1_VALUE_4;
-
- BEGIN
- IF A = B THEN
- FAILED ("PREDEFINED EQUALITY NOT HIDDEN BY " &
- "EXPLICIT DECLARATION - LT1");
- END IF;
-
- IF C /= D THEN
- FAILED ("WRONG PREDEFINED OPERATION - T2");
- END IF;
- END P1;
-
- PACKAGE BODY P2 IS
- FUNCTION U RETURN LT3 IS
- BEGIN
- RETURN LT1_VALUE_2;
- END U;
-
- FUNCTION V RETURN LT3 IS
- BEGIN
- RETURN LT1_VALUE_4;
- END V;
-
- FUNCTION W RETURN LT4 IS
- BEGIN
- RETURN LT1_VALUE_2;
- END W;
-
- FUNCTION X RETURN LT4 IS
- BEGIN
- RETURN LT1_VALUE_4;
- END X;
-
- FUNCTION "=" (L, R : LT3) RETURN BOOLEAN IS
- BEGIN
- RETURN NOT (LT1(L) = LT1(R));
- END "=";
-
- BEGIN
- IF NOT (U /= V) THEN
- FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
- "IMPLICITLY DECLARED INEQUALITY " &
- "FROM EXPLICITLY DECLARED EQUALITY");
- END IF;
-
- IF NOT (LT3(W) = U) THEN
- FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
- "EXPLICIT DECLARATION - '=' ");
- END IF;
-
- IF W /= X THEN
- FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
- "DERIVED SUBPROGRAM - '/=' ");
- END IF;
-
- IF NOT ( X = W ) THEN
- FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
- "DERIVED SUBPROGRAM - '=' ");
- END IF;
-
- END P2;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END C74211B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74302a.ada b/gcc/testsuite/ada/acats/tests/c7/c74302a.ada
deleted file mode 100644
index a772e50..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74302a.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C74302A.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 MULTIPLE DECLARATIONS MAY BE USED FOR DEFERRED CONSTANT
--- DECLARATIONS, EVEN IF THE FULL DECLARATIONS ARE GIVEN INDIVIDUALLY.
-
--- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR THE FULL
--- DECLARATIONS, EVEN IF THE DEFERRED CONSTANT DECLARATIONS ARE GIVEN
--- INDIVIDUALLY.
-
-
--- DSJ 5/09/83
--- SPS 10/24/83
--- EG 12/19/83
--- JRK 12/20/83
-
--- DTN 11/19/91 DELETED SUBPART (C).
-
-WITH REPORT;
-PROCEDURE C74302A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C74302A", "CHECK THAT MULTIPLE DECLARATIONS MAY BE USED " &
- "FOR DEFERRED CONSTANT DECLARATIONS");
-
- DECLARE
-
- PACKAGE PACK1 IS
-
- TYPE T IS PRIVATE;
-
- B, E : CONSTANT T;
-
- F : CONSTANT T;
- PRIVATE
-
- TYPE T IS NEW INTEGER;
-
- E : CONSTANT T := T(IDENT_INT(4));
-
- B, F : CONSTANT T := T(IDENT_INT(2));
-
- END PACK1;
-
- USE PACK1;
-
- BEGIN
-
- IF B/=F THEN
- FAILED("VALUES OF DEFERRED CONSTANTS B AND F NOT EQUAL");
- END IF;
-
- END;
-
- RESULT;
-
-END C74302A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74302b.ada b/gcc/testsuite/ada/acats/tests/c7/c74302b.ada
deleted file mode 100644
index 16b0803..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74302b.ada
+++ /dev/null
@@ -1,308 +0,0 @@
--- C74302B.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 WHEN THE FULL DECLARATION OF A DEFERRED CONSTANT IS
--- GIVEN AS A MULTIPLE DECLARATION, THE INITIALIZATION EXPRESSION
--- IS EVALUATED ONCE FOR EACH DEFERRED CONSTANT. (USE ENUMERATION,
--- INTEGER, FIXED POINT, FLOATING POINT, ARRAY, RECORD (INCLUDING
--- USE OF DEFAULT EXPRESSIONS FOR COMPONENTS), ACCESS, AND PRIVATE
--- TYPES AS FULL DECLARATION OF PRIVATE TYPE)
-
--- HISTORY:
--- BCB 07/25/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74302B IS
-
- TYPE ARR_RAN IS RANGE 1..2;
-
- BUMP : INTEGER := IDENT_INT(0);
-
- GENERIC
- TYPE DT IS (<>);
- FUNCTION F1 RETURN DT;
-
- GENERIC
- TYPE FE IS DELTA <>;
- FUNCTION F2 RETURN FE;
-
- GENERIC
- TYPE FLE IS DIGITS <>;
- FUNCTION F3 RETURN FLE;
-
- GENERIC
- TYPE CA IS ARRAY(ARR_RAN) OF INTEGER;
- FUNCTION F4 RETURN CA;
-
- GENERIC
- TYPE GP IS LIMITED PRIVATE;
- FUNCTION F5 (V : GP) RETURN GP;
-
- GENERIC
- TYPE GP1 IS LIMITED PRIVATE;
- FUNCTION F6 (V1 : GP1) RETURN GP1;
-
- GENERIC
- TYPE AC IS ACCESS INTEGER;
- FUNCTION F7 RETURN AC;
-
- GENERIC
- TYPE PP IS PRIVATE;
- FUNCTION F8 (P1 : PP) RETURN PP;
-
- FUNCTION F1 RETURN DT IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN DT'VAL(BUMP);
- END F1;
-
- FUNCTION F2 RETURN FE IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN FE(BUMP);
- END F2;
-
- FUNCTION F3 RETURN FLE IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN FLE(BUMP);
- END F3;
-
- FUNCTION F4 RETURN CA IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN ((BUMP,BUMP-1));
- END F4;
-
- FUNCTION F5 (V : GP) RETURN GP IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN V;
- END F5;
-
- FUNCTION F6 (V1 : GP1) RETURN GP1 IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN V1;
- END F6;
-
- FUNCTION F7 RETURN AC IS
- VAR : AC;
- BEGIN
- BUMP := BUMP + 1;
- VAR := NEW INTEGER'(BUMP);
- RETURN VAR;
- END F7;
-
- FUNCTION F8 (P1 : PP) RETURN PP IS
- BEGIN
- BUMP := BUMP + 1;
- RETURN P1;
- END F8;
-
- PACKAGE PACK IS
- TYPE SP IS PRIVATE;
- CONS : CONSTANT SP;
- PRIVATE
- TYPE SP IS RANGE 1 .. 100;
- CONS : CONSTANT SP := 50;
- END PACK;
-
- USE PACK;
-
- PACKAGE P IS
- TYPE INT IS PRIVATE;
- TYPE ENUM IS PRIVATE;
- TYPE FIX IS PRIVATE;
- TYPE FLT IS PRIVATE;
- TYPE CON_ARR IS PRIVATE;
- TYPE REC IS PRIVATE;
- TYPE REC1 IS PRIVATE;
- TYPE ACC IS PRIVATE;
- TYPE PRIV IS PRIVATE;
-
- GENERIC
- TYPE LP IS PRIVATE;
- FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN;
-
- I1, I2, I3, I4 : CONSTANT INT;
- E1, E2, E3, E4 : CONSTANT ENUM;
- FI1, FI2, FI3, FI4 : CONSTANT FIX;
- FL1, FL2, FL3, FL4 : CONSTANT FLT;
- CA1, CA2, CA3, CA4 : CONSTANT CON_ARR;
- R1, R2, R3, R4 : CONSTANT REC;
- R1A, R2A, R3A, R4A : CONSTANT REC1;
- A1, A2, A3, A4 : CONSTANT ACC;
- PR1, PR2, PR3, PR4 : CONSTANT PRIV;
- PRIVATE
- TYPE INT IS RANGE 1 .. 100;
-
- TYPE ENUM IS (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE);
-
- TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0;
-
- TYPE FLT IS DIGITS 5 RANGE -100.0 .. 100.0;
-
- TYPE CON_ARR IS ARRAY(ARR_RAN) OF INTEGER;
-
- TYPE REC IS RECORD
- COMP1 : INTEGER;
- COMP2 : INTEGER;
- COMP3 : BOOLEAN;
- END RECORD;
-
- TYPE REC1 IS RECORD
- COMP1 : INTEGER := 10;
- COMP2 : INTEGER := 20;
- COMP3 : BOOLEAN := FALSE;
- END RECORD;
-
- TYPE ACC IS ACCESS INTEGER;
-
- TYPE PRIV IS NEW SP;
-
- FUNCTION DDT IS NEW F1 (INT);
- FUNCTION EDT IS NEW F1 (ENUM);
- FUNCTION FDT IS NEW F2 (FIX);
- FUNCTION FLDT IS NEW F3 (FLT);
- FUNCTION CADT IS NEW F4 (CON_ARR);
- FUNCTION RDT IS NEW F5 (REC);
- FUNCTION R1DT IS NEW F6 (REC1);
- FUNCTION ADT IS NEW F7 (ACC);
- FUNCTION PDT IS NEW F8 (PRIV);
-
- REC_OBJ : REC := (1,2,TRUE);
- REC1_OBJ : REC1 := (3,4,FALSE);
-
- I1, I2, I3, I4 : CONSTANT INT := DDT;
- E1, E2, E3, E4 : CONSTANT ENUM := EDT;
- FI1, FI2, FI3, FI4 : CONSTANT FIX := FDT;
- FL1, FL2, FL3, FL4 : CONSTANT FLT := FLDT;
- CA1, CA2, CA3, CA4 : CONSTANT CON_ARR := CADT;
- R1, R2, R3, R4 : CONSTANT REC := RDT(REC_OBJ);
- R1A, R2A, R3A, R4A : CONSTANT REC1 := R1DT(REC1_OBJ);
- A1, A2, A3, A4 : CONSTANT ACC := ADT;
- PR1, PR2, PR3, PR4 : CONSTANT PRIV := PDT(PRIV(CONS));
- END P;
-
- PACKAGE BODY P IS
- AVAR1 : ACC := NEW INTEGER'(29);
- AVAR2 : ACC := NEW INTEGER'(30);
- AVAR3 : ACC := NEW INTEGER'(31);
- AVAR4 : ACC := NEW INTEGER'(32);
-
- FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN Z1 = Z2;
- END GEN_EQUAL;
-
- FUNCTION INT_EQUAL IS NEW GEN_EQUAL (INT);
- FUNCTION ENUM_EQUAL IS NEW GEN_EQUAL (ENUM);
- FUNCTION FIX_EQUAL IS NEW GEN_EQUAL (FIX);
- FUNCTION FLT_EQUAL IS NEW GEN_EQUAL (FLT);
- FUNCTION ARR_EQUAL IS NEW GEN_EQUAL (CON_ARR);
- FUNCTION REC_EQUAL IS NEW GEN_EQUAL (REC);
- FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
- FUNCTION ACC_EQUAL IS NEW GEN_EQUAL (INTEGER);
- FUNCTION PRIV_EQUAL IS NEW GEN_EQUAL (PRIV);
- BEGIN
- TEST ("C74302B", "CHECK THAT WHEN THE FULL DECLARATION OF " &
- "A DEFERRED CONSTANT IS GIVEN AS A " &
- "MULTIPLE DECLARATION, THE INITIALIZATION " &
- "EXPRESSION IS EVALUATED ONCE FOR EACH " &
- "DEFERRED CONSTANT");
-
- IF NOT EQUAL(BUMP,36) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED CONSTANTS IN A MULIPLE DECLARATION");
- END IF;
-
- IF NOT INT_EQUAL(I1,1) OR NOT INT_EQUAL(I2,2) OR
- NOT INT_EQUAL(I3,3) OR NOT INT_EQUAL(I4,4) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED INTEGER CONSTANTS");
- END IF;
-
- IF NOT ENUM_EQUAL(E1,SIX) OR NOT ENUM_EQUAL(E2,SEVEN) OR
- NOT ENUM_EQUAL(E3,EIGHT) OR NOT ENUM_EQUAL(E4,NINE) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED ENUMERATION CONSTANTS");
- END IF;
-
- IF NOT FIX_EQUAL(FI1,9.0) OR NOT FIX_EQUAL(FI2,10.0) OR
- NOT FIX_EQUAL(FI3,11.0) OR NOT FIX_EQUAL(FI4,12.0) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED FIXED POINT CONSTANTS");
- END IF;
-
- IF NOT FLT_EQUAL(FL1,13.0) OR NOT FLT_EQUAL(FL2,14.0) OR
- NOT FLT_EQUAL(FL3,15.0) OR NOT FLT_EQUAL(FL4,16.0) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED FLOATING POINT CONSTANTS");
- END IF;
-
- IF NOT ARR_EQUAL(CA1,(17,16)) OR NOT ARR_EQUAL(CA2,(18,17))
- OR NOT ARR_EQUAL(CA3,(19,18)) OR NOT ARR_EQUAL(CA4,(20,19))
- THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED ARRAY CONSTANTS");
- END IF;
-
- IF NOT REC_EQUAL(R1,REC_OBJ) OR NOT REC_EQUAL(R2,REC_OBJ)
- OR NOT REC_EQUAL(R3,REC_OBJ) OR NOT REC_EQUAL(R4,REC_OBJ)
- THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED RECORD CONSTANTS");
- END IF;
-
- IF NOT REC1_EQUAL(R1A,REC1_OBJ) OR NOT REC1_EQUAL(R2A,
- REC1_OBJ) OR NOT REC1_EQUAL(R3A,REC1_OBJ) OR NOT
- REC1_EQUAL(R4A,REC1_OBJ) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED RECORD CONSTANTS WITH DEFAULT " &
- "EXPRESSIONS");
- END IF;
-
- IF NOT ACC_EQUAL(A1.ALL,AVAR1.ALL) OR NOT ACC_EQUAL(A2.ALL,
- AVAR2.ALL) OR NOT ACC_EQUAL(A3.ALL,AVAR3.ALL) OR NOT
- ACC_EQUAL(A4.ALL,AVAR4.ALL) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED ACCESS CONSTANTS");
- END IF;
-
- IF NOT PRIV_EQUAL(PR1,PRIV(CONS)) OR NOT PRIV_EQUAL(PR2,
- PRIV(CONS)) OR NOT PRIV_EQUAL(PR3,PRIV(CONS)) OR NOT
- PRIV_EQUAL(PR4,PRIV(CONS)) THEN
- FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
- "DEFERRED PRIVATE CONSTANTS");
- END IF;
-
- RESULT;
- END P;
-
- USE P;
-
-BEGIN
- NULL;
-END C74302B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74305a.ada b/gcc/testsuite/ada/acats/tests/c7/c74305a.ada
deleted file mode 100644
index b1233cb..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74305a.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- C74305A.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 DEFERRED CONSTANT CAN BE USED AS A DEFAULT
--- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA-
--- LIZATION FOR A COMPONENT (NON GENERIC CASE).
-
--- DAT 4/06/81
--- RM 5/21/81
--- SPS 8/23/82
--- SPS 2/10/83
--- SPS 10/20/83
--- EG 12/20/83
--- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY.
-
-WITH REPORT;
-
-PROCEDURE C74305A IS
-
- USE REPORT;
-
- PACKAGE PK IS
- TYPE T1 IS PRIVATE;
- TYPE T2 IS PRIVATE;
- C1 : CONSTANT T1; -- OK.
-
- PROCEDURE P1 (P : T1 := C1); -- OK.
-
- TYPE R1 IS RECORD
- C : T1 := C1; -- OK.
- END RECORD;
- PRIVATE
- PROCEDURE PROC2 (P : T1 := C1); -- OK.
-
- TYPE R2 IS RECORD
- C : T1 := C1; -- OK.
- D : INTEGER := C1'SIZE; -- OK.
- END RECORD;
-
- FUNCTION F1 (P : T1) RETURN T1;
-
- TYPE T1 IS NEW INTEGER;
- TYPE T2 IS ARRAY (1..2) OF INTEGER; -- OK.
-
- FUNCTION F2 (P : T1) RETURN T1;
-
- PROCEDURE P3 (P : T1 := C1+1); -- OK.
-
- PROCEDURE P4 (P : T1 := F1(C1));
-
- TYPE R5 IS RECORD
- C : T1 := F2(C1);
- END RECORD;
-
- PROCEDURE P5 (P : T1 := C1+2) RENAMES P3;
-
- TYPE R3 IS RECORD
- C : T1 := C1; -- OK.
- END RECORD;
-
- C1 : CONSTANT T1 := 1; -- OK.
- C2 : CONSTANT T2 := (1,1); -- OK.
- END PK;
-
- USE PK;
-
- PACKAGE BODY PK IS
-
- R11 : R1;
-
- PROCEDURE P1 (P : T1 := C1) IS
- BEGIN
- IF ( P /= 1 ) THEN
- FAILED ("PARAMETER DEFAULT OF P1 NOT PROPERLY " &
- "INITIALIZED");
- END IF;
- END P1;
-
- PROCEDURE PROC2 (P : T1 := C1) IS
- BEGIN NULL; END PROC2;
-
- PROCEDURE P3 (P : T1 := C1+1) IS
- BEGIN
- IF ( P /= 3 ) THEN
- FAILED ("PARAMETER DEFAULT OF P5 NOT PROPERLY " &
- "INITIALIZED");
- END IF;
- END P3;
-
- FUNCTION F1 (P : T1) RETURN T1 IS
- BEGIN
- RETURN P+10;
- END F1;
-
- PROCEDURE P4 (P : T1 := F1(C1)) IS
- BEGIN
- IF ( P /= 11 ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED");
- END IF;
- END P4;
-
- FUNCTION F2 (P : T1) RETURN T1 IS
- BEGIN
- RETURN P+20;
- END F2;
-
- BEGIN -- PK BODY.
-
- DECLARE
-
- R55 : R5;
-
- BEGIN
- TEST ("C74305A","CHECK THAT A DEFERRED CONSTANT CAN " &
- "BE USED AS A DEFAULT INITIALIZATION " &
- "FOR A PARAMETER OR AS A DEFAULT " &
- "INITIALIZATION FOR A COMPONENT (NON " &
- "GENERIC CASE)");
-
- IF ( R11.C /= 1 ) THEN
- FAILED ("RECORD R11 NOT PROPERLY INITIALIZED");
- END IF;
-
- P4;
-
- IF ( R55.C /= 21 ) THEN
- FAILED ("RECORD R55 NOT PROPERLY INITIALIZED");
- END IF;
-
- P5;
- END;
- END PK;
-
-BEGIN
-
- P1;
-
- RESULT;
-END C74305A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74305b.ada b/gcc/testsuite/ada/acats/tests/c7/c74305b.ada
deleted file mode 100644
index fa9ae1e..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74305b.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C74305B.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 DEFERRED CONSTANT CAN BE USED AS A DEFAULT
--- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA-
--- LIZATION FOR A COMPONENT (GENERIC CASE).
-
--- EG 12/20/83
-
-WITH REPORT;
-
-PROCEDURE C74305B IS
-
- USE REPORT;
-
- PACKAGE PK IS
- TYPE TD IS PRIVATE;
- CD : CONSTANT TD;
- DD : CONSTANT TD;
-
- GENERIC
- TYPE T1 IS PRIVATE;
- C1 : T1;
- WITH PROCEDURE P2 (A1 : T1 := C1; A2 : TD := CD);
- PROCEDURE P1 (A1 : TD := CD);
-
- PRIVATE
- TYPE TD IS NEW INTEGER;
- CD : CONSTANT TD := 2;
- DD : CONSTANT TD := 3;
- END PK;
-
- USE PK;
-
- PACKAGE BODY PK IS
-
- PROCEDURE P1 (A1 : TD := CD) IS
- BEGIN
- IF ( A1 /= 2 ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED (1)");
- END IF;
- P2;
- END P1;
-
- PROCEDURE P3 (X : TD := DD; Y : TD := DD) IS
- BEGIN
- IF ( X /= 2 ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED (2)");
- END IF;
- IF ( Y /= 2 ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED (3)");
- END IF;
- END P3;
-
- PROCEDURE P4 IS NEW P1 (TD,CD,P3);
-
- BEGIN
- TEST ("C74305B","CHECK THAT A DEFERRED CONSTANT CAN BE " &
- "USED AS A DEFAULT INITIALIZATION FOR A " &
- "PARAMETER OR AS A DEFAULT INITIALIZATION " &
- "FOR A COMPONENT (GENERIC CASE)");
- P4;
- END PK;
-
- PROCEDURE P5 (X : TD := DD; Y : TD := DD) IS
- BEGIN
- IF ( X /= CD ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED (4)");
- END IF;
- IF ( Y /= CD ) THEN
- FAILED ("WRONG ACTUAL PARAMETER RECEIVED (5)");
- END IF;
- END P5;
-
- PROCEDURE P6 IS NEW P1 (TD,CD,P5);
-
-BEGIN
- P6;
- RESULT;
-END C74305B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74306a.ada b/gcc/testsuite/ada/acats/tests/c7/c74306a.ada
deleted file mode 100644
index c6ebad3..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74306a.ada
+++ /dev/null
@@ -1,279 +0,0 @@
--- C74306A.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:
--- AFTER THE FULL DECLARATION OF A DEFERRED CONSTANT, THE VALUE OF
--- THE CONSTANT MAY BE USED IN ANY EXPRESSION, PARTICULARLY
--- EXPRESSIONS IN WHICH THE USE WOULD BE ILLEGAL BEFORE THE FULL
--- DECLARATION.
-
--- HISTORY:
--- BCB 03/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74306A IS
-
- GENERIC
- TYPE GENERAL_PURPOSE IS LIMITED PRIVATE;
- Y : IN OUT GENERAL_PURPOSE;
- FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE;
-
- FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- END IF;
- RETURN Y;
- END IDENT;
-
- PACKAGE P IS
- TYPE T IS PRIVATE;
- C : CONSTANT T;
- PRIVATE
- TYPE T IS RANGE 1 .. 100;
-
- TYPE A IS ARRAY(1..2) OF T;
-
- TYPE B IS ARRAY(INTEGER RANGE <>) OF T;
-
- TYPE D (DISC : T) IS RECORD
- NULL;
- END RECORD;
-
- C : CONSTANT T := 50;
-
- PARAM : T := 99;
-
- FUNCTION IDENT_T IS NEW IDENT (T, PARAM);
-
- FUNCTION F (X : T := C) RETURN T;
-
- SUBTYPE RAN IS T RANGE 1 .. C;
-
- SUBTYPE IND IS B(1..INTEGER(C));
-
- SUBTYPE DIS IS D (DISC => C);
-
- OBJ : T := C;
-
- CON : CONSTANT T := C;
-
- ARR : A := (5, C);
-
- PAR : T := IDENT_T (C);
-
- RANOBJ : T RANGE 1 .. C := C;
-
- INDOBJ : B(1..INTEGER(C));
-
- DIS_VAL : DIS;
-
- REN : T RENAMES C;
-
- GENERIC
- FOR_PAR : T := C;
- PACKAGE GENPACK IS
- VAL : T;
- END GENPACK;
-
- GENERIC
- IN_PAR : IN T;
- PACKAGE NEWPACK IS
- IN_VAL : T;
- END NEWPACK;
- END P;
-
- USE P;
-
- PACKAGE BODY P IS
- TYPE A1 IS ARRAY(1..2) OF T;
-
- TYPE B1 IS ARRAY(INTEGER RANGE <>) OF T;
-
- TYPE D1 (DISC1 : T) IS RECORD
- NULL;
- END RECORD;
-
- SUBTYPE RAN1 IS T RANGE 1 .. C;
-
- SUBTYPE IND1 IS B1(1..INTEGER(C));
-
- SUBTYPE DIS1 IS D1 (DISC1 => C);
-
- OBJ1 : T := C;
-
- FUNCVAR : T;
-
- CON1 : CONSTANT T := C;
-
- ARR1 : A1 := (5, C);
-
- PAR1 : T := IDENT_T (C);
-
- RANOBJ1 : T RANGE 1 .. C := C;
-
- INDOBJ1 : B1(1..INTEGER(C));
-
- DIS_VAL1 : DIS1;
-
- REN1 : T RENAMES C;
-
- FUNCTION F (X : T := C) RETURN T IS
- BEGIN
- RETURN C;
- END F;
-
- PACKAGE BODY GENPACK IS
- BEGIN
- VAL := FOR_PAR;
- END GENPACK;
-
- PACKAGE BODY NEWPACK IS
- BEGIN
- IN_VAL := IN_PAR;
- END NEWPACK;
-
- PACKAGE PACK IS NEW GENPACK (FOR_PAR => C);
-
- PACKAGE NPACK IS NEW NEWPACK (IN_PAR => C);
- BEGIN
- TEST ("C74306A", "AFTER THE FULL DECLARATION OF A DEFERRED " &
- "CONSTANT, THE VALUE OF THE CONSTANT MAY " &
- "BE USED IN ANY EXPRESSION, PARTICULARLY " &
- "EXPRESSIONS IN WHICH THE USE WOULD BE " &
- "ILLEGAL BEFORE THE FULL DECLARATION");
-
- IF OBJ /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR OBJ");
- END IF;
-
- IF CON /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR CON");
- END IF;
-
- IF ARR /= (IDENT_T(5), IDENT_T(50)) THEN
- FAILED ("IMPROPER VALUES FOR ARR");
- END IF;
-
- IF PAR /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR PAR");
- END IF;
-
- IF OBJ1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR OBJ1");
- END IF;
-
- IF CON1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR CON1");
- END IF;
-
- IF ARR1 /= (IDENT_T(5), IDENT_T(50)) THEN
- FAILED ("IMPROPER VALUES FOR ARR1");
- END IF;
-
- IF PAR1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR PAR1");
- END IF;
-
- IF PACK.VAL /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR PACK.VAL");
- END IF;
-
- IF NPACK.IN_VAL /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR NPACK.IN_VAL");
- END IF;
-
- IF RAN'LAST /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR RAN'LAST");
- END IF;
-
- IF RANOBJ /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR RANOBJ");
- END IF;
-
- IF IND'LAST /= IDENT_INT(50) THEN
- FAILED ("IMPROPER VALUE FOR IND'LAST");
- END IF;
-
- IF INDOBJ'LAST /= IDENT_INT(50) THEN
- FAILED ("IMPROPER VALUE FOR INDOBJ'LAST");
- END IF;
-
- IF DIS_VAL.DISC /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR DIS_VAL.DISC");
- END IF;
-
- IF REN /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR REN");
- END IF;
-
- IF RAN1'LAST /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR RAN1'LAST");
- END IF;
-
- IF RANOBJ1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR RANOBJ1");
- END IF;
-
- IF IND1'LAST /= IDENT_INT(50) THEN
- FAILED ("IMPROPER VALUE FOR IND1'LAST");
- END IF;
-
- IF INDOBJ1'LAST /= IDENT_INT(50) THEN
- FAILED ("IMPROPER VALUE FOR INDOBJ1'LAST");
- END IF;
-
- IF DIS_VAL1.DISC1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR DIS_VAL1.DISC1");
- END IF;
-
- IF REN1 /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR REN1");
- END IF;
-
- FUNCVAR := F(C);
-
- IF FUNCVAR /= IDENT_T(50) THEN
- FAILED ("IMPROPER VALUE FOR FUNCVAR");
- END IF;
-
- RESULT;
- END P;
-
-BEGIN
- DECLARE
- TYPE ARR IS ARRAY(1..2) OF T;
-
- VAL1 : T := C;
-
- VAL2 : ARR := (C, C);
-
- VAL3 : T RENAMES C;
- BEGIN
- NULL;
- END;
-
- NULL;
-END C74306A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74307a.ada b/gcc/testsuite/ada/acats/tests/c7/c74307a.ada
deleted file mode 100644
index aaddc05..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74307a.ada
+++ /dev/null
@@ -1,58 +0,0 @@
--- C74307A.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 EXPLICIT CONSTRAINT MAY BE GIVEN IN THE SUBTYPE
--- INDICATION OF THE FULL DECLARATION OF A DEFERRED CONSTANT.
-
--- HISTORY:
--- BCB 03/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74307A IS
-
- PACKAGE P IS
- TYPE T (D : INTEGER) IS PRIVATE;
- C : CONSTANT T;
- PRIVATE
- TYPE T (D : INTEGER) IS RECORD
- NULL;
- END RECORD;
- C : CONSTANT T(2) := (D => 2);
- END P;
-
- USE P;
-
-BEGIN
- TEST ("C74307A", "CHECK THAT AN EXPLICIT CONSTRAINT MAY BE " &
- "GIVEN IN THE SUBTYPE INDICATION OF THE FULL " &
- "DECLARATION OF A DEFERRED CONSTANT");
-
- IF C.D /= 2 THEN
- FAILED ("IMPROPER RESULTS FOR C.D");
- END IF;
-
- RESULT;
-END C74307A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401d.ada b/gcc/testsuite/ada/acats/tests/c7/c74401d.ada
deleted file mode 100644
index 024e677..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74401d.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C74401D.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 OUT PARAMETER HAVING A LIMITED TYPE IS ALLOWED FOR
--- FORMAL SUBPROGRAM PARAMETERS. (ONLY THE CASE OF PRACTICAL INTEREST,
--- NAMELY, LIMITED PRIVATE TYPES, IS CHECKED HERE.)
-
--- CHECK THAT AN OUT PARAMETER IN A RENAMING DECLARATION CAN HAVE A
--- LIMITED PRIVATE TYPE WHEN IT RENAMES A GENERIC FORMAL SUBPROGRAM.
-
--- JBG 5/1/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C74401D IS
-
- PACKAGE P IS
- TYPE LP IS LIMITED PRIVATE;
- PROCEDURE P1 (X : OUT LP);
- PROCEDURE P2 (X : OUT LP);
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
- VAL1 : CONSTANT LP;
- VAL2 : CONSTANT LP;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- VAL1 : CONSTANT LP := LP(IDENT_INT(3));
- VAL2 : CONSTANT LP := LP(IDENT_INT(-3));
- END P;
-
- PACKAGE BODY P IS
- PROCEDURE P1 (X : OUT LP) IS
- BEGIN
- X := 3;
- END P1;
-
- PROCEDURE P2 (X : OUT LP) IS
- BEGIN
- X := -3;
- END P2;
-
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN L = R;
- END EQ;
- END P;
-
- GENERIC
- WITH PROCEDURE P3 (Y : OUT P.LP);
- TYPE GLP IS LIMITED PRIVATE;
- WITH PROCEDURE P4 (Y : OUT GLP);
- VAL_P3 : IN OUT P.LP;
- VAL_P4 : IN OUT GLP;
- PACKAGE GPACK IS
- PROCEDURE RENAMED (X : OUT GLP) RENAMES P4; -- OK. RENAMING.
- END GPACK;
-
- PACKAGE BODY GPACK IS
- BEGIN
- P3 (VAL_P3);
- P4 (VAL_P4);
- END GPACK;
-
-BEGIN
-
- TEST ("C74401D", "CHECK THAT GENERIC FORMAL SUBPROGRAMS CAN HAVE "&
- "LIMITED PRIVATE OUT PARAMETERS");
-
- DECLARE
- VAR1 : P.LP;
- VAR2 : P.LP;
- PACKAGE PACK IS NEW GPACK (P.P1, P.LP, P.P2, VAR1, VAR2);
- BEGIN
- IF NOT P.EQ (VAR1, P.VAL1) THEN
- FAILED ("P1 INVOCATION INCORRECT");
- END IF;
-
- IF NOT P.EQ (VAR2, P.VAL2) THEN
- FAILED ("P2 INVOCATION INCORRECT");
- END IF;
-
- P.P1 (VAR2); -- RESET VALUE OF VAR2.
- PACK.RENAMED (VAR2);
-
- IF NOT P.EQ (VAR2, P.VAL2) THEN
- FAILED ("RENAMED INVOCATION INCORRECT");
- END IF;
- END;
-
- RESULT;
-
-END C74401D;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401e.ada b/gcc/testsuite/ada/acats/tests/c7/c74401e.ada
deleted file mode 100644
index df0c990..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74401e.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- C74401E.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 OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE
--- DECLARED IN A PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES
--- NESTED IN A VISIBLE PART.
-
--- CHECK THAT A RENAMING DECLARATION CAN RENAME A PROCEDURE DECLARED
--- WITH AN OUT PARAMETER.
-
--- JBG 5/1/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C74401E IS
-
- PACKAGE PKG IS
- TYPE LP IS LIMITED PRIVATE;
- PROCEDURE P20 (X : OUT LP); -- OK.
- PROCEDURE RESET (X : OUT LP);
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
- VAL1 : CONSTANT LP;
-
- PACKAGE NESTED IS
- PROCEDURE NEST1 (X : OUT LP);
- PRIVATE
- PROCEDURE NEST2 (X : OUT LP);
- END NESTED;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- VAL1 : CONSTANT LP := LP(IDENT_INT(3));
- END PKG;
-
- VAR : PKG.LP;
-
- PACKAGE BODY PKG IS
- PROCEDURE P20 (X : OUT LP) IS
- BEGIN
- X := 3;
- END P20;
-
- PROCEDURE RESET (X : OUT LP) IS
- BEGIN
- X := LP(IDENT_INT(0));
- END RESET;
-
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN L = R;
- END EQ;
-
- PACKAGE BODY NESTED IS
- PROCEDURE NEST1 (X : OUT LP) IS
- BEGIN
- X := 3;
- END NEST1;
-
- PROCEDURE NEST2 (X : OUT LP) IS
- BEGIN
- X := LP(IDENT_INT(3));
- END NEST2;
- END NESTED;
- BEGIN
- VAR := LP(IDENT_INT(0));
- END PKG;
-
- PACKAGE PKG1 IS
- PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20; -- OK:
- -- RENAMING.
- END PKG1;
-
-BEGIN
-
- TEST ("C74401E", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
- "PARAMETER WITH A LIMITED PRIVATE TYPE");
-
- PKG.RESET (VAR);
- PKG.P20 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("DIRECT CALL NOT CORRECT");
- END IF;
-
- PKG.RESET (VAR);
- PKG1.P21 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("RENAMED CALL NOT CORRECT");
- END IF;
-
- PKG.RESET (VAR);
- PKG.NESTED.NEST1 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("NESTED CALL NOT CORRECT");
- END IF;
-
- RESULT;
-
-END C74401E;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401k.ada b/gcc/testsuite/ada/acats/tests/c7/c74401k.ada
deleted file mode 100644
index 55f153e..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74401k.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C74401K.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 OUT PARAMETERS OF AN ENTRY DECLARATION CAN HAVE A LIMITED
--- PRIVATE TYPE IF THE ENTRY DECLARATION OCCURS IN THE VISIBLE PART OF A
--- PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE
--- PART.
-
--- CHECK THAT A RENAMING DECLARATION CAN RENAME AN ENTRY DECLARED
--- WITH AN OUT PARAMETER.
-
--- JBG 5/1/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C74401K IS
-
- PACKAGE PKG IS
- TYPE LP IS LIMITED PRIVATE;
- TASK P20 IS
- ENTRY TP20 (X : OUT LP); -- OK.
- ENTRY RESET (X : OUT LP);
- END P20;
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
- VAL1 : CONSTANT LP;
-
- PACKAGE NESTED IS
- TASK NEST1 IS
- ENTRY TNEST1 (X : OUT LP);
- END NEST1;
- PRIVATE
- TASK NEST2 IS
- ENTRY TNEST2 (X : OUT LP);
- END NEST2;
- END NESTED;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- VAL1 : CONSTANT LP := LP(IDENT_INT(3));
- END PKG;
-
- VAR : PKG.LP;
-
- PACKAGE BODY PKG IS
- TASK BODY P20 IS
- BEGIN
- LOOP
- SELECT
- ACCEPT TP20 (X : OUT LP) DO
- X := 3;
- END TP20;
- OR
- ACCEPT RESET (X : OUT LP) DO
- X := 0;
- END RESET;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END P20;
-
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN L = R;
- END EQ;
-
- PACKAGE BODY NESTED IS
- TASK BODY NEST1 IS
- BEGIN
- ACCEPT TNEST1 (X : OUT LP) DO
- X := 3;
- END TNEST1;
- END NEST1;
-
- TASK BODY NEST2 IS
- BEGIN
- NULL;
- END NEST2;
- END NESTED;
- BEGIN
- VAR := LP(IDENT_INT(0));
- END PKG;
-
- PACKAGE PKG1 IS
- PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20.TP20; -- OK:
- -- RENAMING.
- END PKG1;
-
-BEGIN
-
- TEST ("C74401K", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
- "PARAMETER WITH A LIMITED PRIVATE TYPE");
-
- PKG.P20.RESET (VAR);
- PKG.P20.TP20 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("DIRECT CALL NOT CORRECT");
- END IF;
-
- PKG.P20.RESET (VAR);
- PKG1.P21 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("RENAMED CALL NOT CORRECT");
- END IF;
-
- PKG.P20.RESET (VAR);
- PKG.NESTED.NEST1.TNEST1 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("NESTED CALL NOT CORRECT");
- END IF;
-
- RESULT;
-
-END C74401K;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401q.ada b/gcc/testsuite/ada/acats/tests/c7/c74401q.ada
deleted file mode 100644
index 7576721..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74401q.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- C74401Q.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 OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE
--- DECLARED FOR A GENERIC SUBPROGRAM IN A PACKAGE SPECIFICATION,
--- INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE PART.
-
--- JBG 5/1/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE C74401Q IS
-
- PACKAGE PKG IS
- TYPE LP IS LIMITED PRIVATE;
-
- GENERIC
- PROCEDURE P20 (X : OUT LP); -- OK.
- PROCEDURE RESET (X : OUT LP);
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
- VAL1 : CONSTANT LP;
-
- PACKAGE NESTED IS
- GENERIC
- PROCEDURE NEST1 (X : OUT LP);
- PRIVATE
- GENERIC
- PROCEDURE NEST2 (X : OUT LP);
- END NESTED;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- VAL1 : CONSTANT LP := LP(IDENT_INT(3));
- END PKG;
-
- VAR : PKG.LP;
-
- PACKAGE BODY PKG IS
- PROCEDURE P20 (X : OUT LP) IS
- BEGIN
- X := 3;
- END P20;
-
- PROCEDURE RESET (X : OUT LP) IS
- BEGIN
- X := 0;
- END RESET;
-
- FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN L = R;
- END EQ;
-
- PACKAGE BODY NESTED IS
- PROCEDURE NEST1 (X : OUT LP) IS
- BEGIN
- X := 3;
- END NEST1;
-
- PROCEDURE NEST2 (X : OUT LP) IS
- BEGIN
- X := LP(IDENT_INT(3));
- END NEST2;
- END NESTED;
- BEGIN
- VAR := LP(IDENT_INT(0));
- END PKG;
-
- PACKAGE INSTANCES IS
- PROCEDURE NP20 IS NEW PKG.P20;
- PROCEDURE NNEST1 IS NEW PKG.NESTED.NEST1;
- END INSTANCES;
- USE INSTANCES;
-
- PACKAGE PKG1 IS
- PROCEDURE P21 (X : OUT PKG.LP) RENAMES INSTANCES.NP20;
- END PKG1;
-
-BEGIN
-
- TEST ("C74401Q", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
- "PARAMETER WITH A LIMITED PRIVATE TYPE");
-
- PKG.RESET (VAR);
- NP20 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("DIRECT CALL NOT CORRECT");
- END IF;
-
- PKG.RESET (VAR);
- PKG1.P21 (VAR);
-
- IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
- FAILED ("RENAMED CALL NOT CORRECT");
- END IF;
-
- RESULT;
-
-END C74401Q;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74402a.ada b/gcc/testsuite/ada/acats/tests/c7/c74402a.ada
deleted file mode 100644
index 3dac5c7..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74402a.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- C74402A.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 SUBPROGRAM PARAMETER OF A LIMITED TYPE MAY HAVE A
--- DEFAULT EXPRESSION, EVEN IF THE SUBPROGRAM IS DECLARED OUTSIDE
--- THE PACKAGE THAT DECLARES THE LIMITED TYPE.
--- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.)
-
--- DSJ 5/6/83
--- SPS 10/24/83
-
-WITH REPORT;
-PROCEDURE C74402A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C74402A", "CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED " &
- "TYPE MAY HAVE A DEFAULT EXPRESSION, EVEN IF " &
- "THE SUBPROGRAM IS DECLARED OUTSIDE THE PACKAGE " &
- "THAT DECLARES THE LIMITED TYPE");
-
- DECLARE
-
- PACKAGE PACK1 IS
-
- TYPE LP1 IS LIMITED PRIVATE;
- TYPE LP2 IS ARRAY (1 .. 2) OF LP1;
- TYPE LP3 IS
- RECORD
- C1, C2 : LP2;
- END RECORD;
-
- FUNCTION F1 RETURN LP1;
- FUNCTION F2 RETURN LP2;
- FUNCTION F3 RETURN LP3;
-
- PROCEDURE G1 (X : LP1 := F1); -- LEGAL
- PROCEDURE G2 (X : LP2 := F2); -- LEGAL
- PROCEDURE G3 (X : LP3 := F3); -- LEGAL
-
- PRIVATE
-
- TYPE LP1 IS NEW INTEGER;
-
- END PACK1;
-
- PACKAGE BODY PACK1 IS
-
- FUNCTION F1 RETURN LP1 IS
- BEGIN
- RETURN LP1'(1);
- END F1;
-
- FUNCTION F2 RETURN LP2 IS
- BEGIN
- RETURN LP2'(2,3);
- END F2;
-
- FUNCTION F3 RETURN LP3 IS
- BEGIN
- RETURN LP3'((4,5),(6,7));
- END F3;
-
- PROCEDURE G1 (X : LP1 := F1) IS
- BEGIN
- IF X /= LP1'(1) THEN
- FAILED("WRONG DEFAULT VALUE - LP1");
- END IF;
- END G1;
-
- PROCEDURE G2 (X : LP2 := F2) IS
- BEGIN
- IF X /= LP2'(2,3) THEN
- FAILED("WRONG DEFAULT VALUE - LP2");
- END IF;
- END G2;
-
- PROCEDURE G3 (X : LP3 := F3) IS
- BEGIN
- IF X /= LP3'((4,5),(6,7)) THEN
- FAILED("WRONG DEFAULT VALUE - LP3");
- END IF;
- END G3;
-
- BEGIN
-
- G1; -- LEGAL, DEFAULT USED
- G2; -- LEGAL, DEFAULT USED
- G3; -- LEGAL, DEFAULT USED
-
- G1(F1); -- LEGAL
- G2(F2); -- LEGAL
- G3(F3); -- LEGAL
-
- END PACK1;
-
- USE PACK1;
-
- PROCEDURE G4 (X : LP1 := F1) IS
- BEGIN
- G1; -- LEGAL, DEFAULT USED
- G1(X);
- END G4;
-
- PROCEDURE G5 (X : LP2 := F2) IS
- BEGIN
- G2; -- LEGAL, DEFAULT USED
- G2(X);
- END G5;
-
- PROCEDURE G6 (X : LP3 := F3) IS
- BEGIN
- G3; -- DEFAULT USED
- G3(X);
- END G6;
-
- BEGIN
-
- G4; -- LEGAL, DEFAULT USED
- G5; -- LEGAL, DEFAULT USED
- G6; -- LEGAL, DEFAULT USED
-
- G4(F1); -- LEGAL
- G5(F2); -- LEGAL
- G6(F3); -- LEGAL
-
- END;
-
- RESULT;
-
-END C74402A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74402b.ada b/gcc/testsuite/ada/acats/tests/c7/c74402b.ada
deleted file mode 100644
index 45597a9..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74402b.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- C74402B.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 INITIALIZATION OF IN PARAMETERS THAT ARE OF
--- LIMITED PRIVATE TYPE IS PERMITTED.
--- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.)
-
--- DAS 1/21/81
--- ABW 6/30/82
--- BHS 7/10/84
-
-WITH REPORT;
-PROCEDURE C74402B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST( "C74402B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " &
- "OF LIMITED PRIVATE TYPE IS PERMITTED" );
-
- DECLARE
-
- PACKAGE PKG IS
-
- TYPE LPTYPE IS LIMITED PRIVATE;
- CLP : CONSTANT LPTYPE;
- XLP : CONSTANT LPTYPE;
- FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN;
- FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN;
-
- PRIVATE
-
- TYPE LPTYPE IS NEW INTEGER RANGE 0..127;
- CLP : CONSTANT LPTYPE := 127;
- XLP : CONSTANT LPTYPE := 0;
-
- END;
-
- PACKAGE BODY PKG IS
-
- FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN IS
- BEGIN
- RETURN (L = CLP);
- END EQCLP;
-
- FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN IS
- BEGIN
- RETURN (L = XLP);
- END EQXLP;
-
- END PKG;
-
- USE PKG;
-
- PROCEDURE PROC1 (Y : IN LPTYPE := CLP) IS
- BEGIN
- IF (EQCLP (Y)) THEN
- FAILED( "LIMITED PRIVATE NOT PASSED, " &
- "DEFAULT CLP EMPLOYED" );
- ELSIF (NOT EQXLP (Y)) THEN
- FAILED( "NO LIMITED PRIVATE FOUND" );
- END IF;
- END PROC1;
-
- PROCEDURE PROC2 (Y : IN LPTYPE := CLP) IS
- BEGIN
- IF (NOT EQCLP(Y)) THEN
- FAILED( "DEFAULT NOT EMPLOYED" );
- END IF;
- END PROC2;
-
- BEGIN
-
- PROC1(XLP);
- PROC2;
-
- END;
-
- RESULT;
-
-END C74402B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74406a.ada b/gcc/testsuite/ada/acats/tests/c7/c74406a.ada
deleted file mode 100644
index 69ddd41..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74406a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- C74406A.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 FULL DECLARATION OF A LIMITED PRIVATE TYPE CAN
--- DECLARE A TASK TYPE, A TYPE DERIVED FROM A LIMITED PRIVATE TYPE,
--- AND A COMPOSITE TYPE WITH A COMPONENT OF A LIMITED TYPE.
-
--- HISTORY:
--- BCB 03/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74406A IS
-
- PACKAGE TP IS
- TYPE T IS LIMITED PRIVATE;
- PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER);
- FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN;
- PRIVATE
- TYPE T IS RANGE 1 .. 100;
- END TP;
-
- PACKAGE BODY TP IS
- PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER) IS
- BEGIN
- Z1 := T (Z2);
- END INIT;
-
- FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN ONE = TWO;
- ELSE
- RETURN ONE /= TWO;
- END IF;
- END EQUAL_T;
- BEGIN
- NULL;
- END TP;
-
- USE TP;
-
- PACKAGE P IS
- TYPE T1 IS LIMITED PRIVATE;
- TYPE T2 IS LIMITED PRIVATE;
- TYPE T3 IS LIMITED PRIVATE;
- TYPE T4 IS LIMITED PRIVATE;
- PRIVATE
- TASK TYPE T1 IS
- ENTRY HERE(VAL1 : IN OUT INTEGER);
- END T1;
-
- TYPE T2 IS NEW T;
-
- TYPE T3 IS RECORD
- INT : T;
- END RECORD;
-
- TYPE T4 IS ARRAY(1..5) OF T;
- END P;
-
- PACKAGE BODY P IS
- X1 : T1;
- X3 : T3;
- X4 : T4;
- VAR : INTEGER := 25;
-
- TASK BODY T1 IS
- BEGIN
- ACCEPT HERE(VAL1 : IN OUT INTEGER) DO
- VAL1 := VAL1 * 2;
- END HERE;
- END T1;
-
- BEGIN
- TEST ("C74406A", "CHECK THAT THE FULL DECLARATION OF A " &
- "LIMITED PRIVATE TYPE CAN DECLARE A TASK " &
- "TYPE, A TYPE DERIVED FROM A LIMITED " &
- "PRIVATE TYPE, AND A COMPOSITE TYPE WITH " &
- "A COMPONENT OF A LIMITED TYPE");
-
- X1.HERE(VAR);
-
- IF NOT EQUAL(VAR,IDENT_INT(50)) THEN
- FAILED ("IMPROPER VALUE FOR VAL");
- END IF;
-
- INIT (X3.INT, 50);
-
- IF X3.INT NOT IN T THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
- END IF;
-
- INIT (X4(3), 17);
-
- IF NOT EQUAL_T(T'(X4(3)),T(X4(3))) THEN
- FAILED ("IMPROPER RESULT FROM QUALIFICATION AND " &
- "EXPLICIT CONVERSION");
- END IF;
-
- RESULT;
- END P;
-
- USE P;
-
-BEGIN
- NULL;
-END C74406A;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74407b.ada b/gcc/testsuite/ada/acats/tests/c7/c74407b.ada
deleted file mode 100644
index d8f6508..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74407b.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- C74407B.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, FOR A LIMITED PRIVATE TYPE, THAT PRE-DEFINED EQUALITY AND
--- ASSIGNMENT ARE DEFINED AND AVAILABLE WITHIN THE PRIVATE PART AND
--- THE BODY OF A PACKAGE, AFTER THE FULL DECLARATION, IF THE FULL
--- DECLARATION IS NOT LIMITED.
-
--- HISTORY:
--- BCB 07/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C74407B IS
-
- PACKAGE PP IS
- TYPE PRIV IS PRIVATE;
- C1 : CONSTANT PRIV;
- C2 : CONSTANT PRIV;
- PRIVATE
- TYPE PRIV IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
- C1 : CONSTANT PRIV := ONE;
- C2 : CONSTANT PRIV := TWO;
- END PP;
-
- USE PP;
-
- PACKAGE P IS
- TYPE INT IS LIMITED PRIVATE;
- TYPE COMP IS LIMITED PRIVATE;
- TYPE DER IS LIMITED PRIVATE;
- PRIVATE
- TYPE INT IS RANGE 1 .. 100;
- TYPE COMP IS ARRAY(1..5) OF INTEGER;
- TYPE DER IS NEW PRIV;
- D, E : INT := 10;
- F : INT := 20;
- CONS_INT1 : CONSTANT INT := 30;
- G : BOOLEAN := D = E;
- H : BOOLEAN := D /= F;
- CONS_BOOL1 : CONSTANT BOOLEAN := D = E;
- CONS_BOOL2 : CONSTANT BOOLEAN := D /= F;
- I : COMP := (1,2,3,4,5);
- CONS_COMP1 : CONSTANT COMP := (6,7,8,9,10);
- J : DER := DER(C1);
- CONS_DER1 : CONSTANT DER := DER(C2);
- END P;
-
- PACKAGE BODY P IS
- A, B, C : INT;
- X, Y, Z : COMP;
- L, M, N : DER;
- CONS_INT2 : CONSTANT INT := 10;
- CONS_COMP2 : CONSTANT COMP := (1,2,3,4,5);
- CONS_DER2 : CONSTANT DER := DER(C1);
- BEGIN
- TEST ("C74407B", "CHECK, FOR A LIMITED PRIVATE TYPE, THAT " &
- "PRE-DEFINED EQUALITY AND ASSIGNMENT ARE " &
- "DEFINED AND AVAILABLE WITHIN THE PRIVATE " &
- "PART AND THE BODY OF A PACKAGE, AFTER " &
- "THE FULL DECLARATION, IF THE FULL " &
- "DECLARATION IS NOT LIMITED");
-
- A := 10;
-
- B := 10;
-
- C := 20;
-
- IF A = C THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 1");
- END IF;
-
- IF A /= B THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 1");
- END IF;
-
- IF CONS_INT2 = C THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 2");
- END IF;
-
- IF CONS_INT2 /= B THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 2");
- END IF;
-
- IF NOT G THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PRIVATE PART OF THE " &
- "PACKAGE - 1");
- END IF;
-
- IF NOT H THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PRIVATE PART OF THE " &
- "PACKAGE - 1");
- END IF;
-
- IF NOT CONS_BOOL1 THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PRIVATE PART OF THE " &
- "PACKAGE - 2");
- END IF;
-
- IF NOT CONS_BOOL2 THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PRIVATE PART OF THE " &
- "PACKAGE - 2");
- END IF;
-
- X := (1,2,3,4,5);
-
- Y := (1,2,3,4,5);
-
- Z := (5,4,3,2,1);
-
- IF X = Z THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 3");
- END IF;
-
- IF X /= Y THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 3");
- END IF;
-
- IF CONS_COMP2 = Z THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 4");
- END IF;
-
- IF CONS_COMP2 /= Y THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 4");
- END IF;
-
- L := DER(C1);
-
- M := DER(C1);
-
- N := DER(C2);
-
- IF L = N THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 5");
- END IF;
-
- IF L /= M THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 5");
- END IF;
-
- IF CONS_DER2 = N THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 6");
- END IF;
-
- IF CONS_DER2 /= M THEN
- FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
- "OPERATION WITHIN THE PACKAGE BODY - 6");
- END IF;
-
- RESULT;
- END P;
-
- USE P;
-
-BEGIN
- NULL;
-END C74407B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c74409b.ada b/gcc/testsuite/ada/acats/tests/c7/c74409b.ada
deleted file mode 100644
index 0bd2a06..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c74409b.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- C74409B.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 COMPOSITE TYPE IS DECLARED IN THE SAME PACKAGE
--- AS A LIMITED PRIVATE TYPE AND HAS A COMPONENT OF THAT TYPE,
--- THE COMPOSITE TYPE IS TREATED AS A LIMITED TYPE UNTIL THE
--- EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION
--- OF THE COMPOSITE TYPE AND AFTER THE FULL DECLARATION OF THE
--- LIMITED PRIVATE TYPE
-
--- DSJ 5/5/83
--- JBG 9/23/83
-
-WITH REPORT;
-PROCEDURE C74409B IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C74409B", "CHECK THAT A COMPOSITE TYPE WITH A LIMITED " &
- "PRIVATE COMPONENT IS TREATED AS A LIMITED " &
- "TYPE UNTIL ASSIGNMENT AND EQUALITY ARE BOTH " &
- "AVAILABLE FOR THE COMPOSITE TYPE");
-
- DECLARE
-
- PACKAGE P IS
- TYPE LP IS LIMITED PRIVATE;
- PACKAGE Q IS
- TYPE LP_ARRAY IS ARRAY (1 .. 2) OF LP;
- END Q;
- PRIVATE
- TYPE LP IS NEW INTEGER;
- END P;
-
- PACKAGE BODY P IS
- USE Q;
- FUNCTION "=" (L,R : LP_ARRAY) RETURN BOOLEAN IS -- LEGAL
- BEGIN
- RETURN TRUE;
- END;
-
- GENERIC
- TYPE T IS PRIVATE; -- NOTE: NOT LIMITED PRIVATE
- C, D : T;
- PACKAGE A IS
- -- IRRELEVANT DETAILS
- END A;
-
- PACKAGE BODY A IS
- BEGIN
- IF C = D THEN
- FAILED ("USED WRONG EQUALITY OPERATOR");
- END IF;
- END A;
-
- PACKAGE BODY Q IS
- PACKAGE ANOTHER_NEW_A IS
- NEW A (LP_ARRAY, (2,3), (4,5)); -- LEGAL
- END Q;
- END P;
-
- BEGIN
-
- NULL;
-
- END;
-
- RESULT;
-
-END C74409B;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760001.a b/gcc/testsuite/ada/acats/tests/c7/c760001.a
deleted file mode 100644
index be9ff81..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760001.a
+++ /dev/null
@@ -1,390 +0,0 @@
--- C760001.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 Initialize is called for objects and components of
--- a controlled type when the objects and components are not
--- assigned explicit initial values. Check this for "simple" controlled
--- objects, controlled record components and arrays with controlled
--- components.
---
--- Check that if an explicit initial value is assigned to an object
--- or component of a controlled type then Initialize is not called.
---
--- TEST DESCRIPTION:
--- This test derives a type for Ada.Finalization.Controlled, and
--- overrides the Initialize and Adjust operations for the type. The
--- intent of the type is that it should carry incremental values
--- indicating the ordering of events with respect to these (and default
--- initialization) operations. The body of the test uses these values
--- to determine that the implicit calls to these subprograms happen
--- (or don't) at the appropriate times.
---
--- The test further derives types from this "root" type, which are the
--- actual types used in the test. One of the types is "simply" derived
--- from the "root" type, the other contains a component of the first
--- type, thus nesting a controlled object as a record component in
--- controlled objects.
---
--- The main program declares objects of these types and checks the
--- values of the components to ascertain that they have been touched
--- as expected.
---
--- Note that Finalization procedures are provided. This test does not
--- test that the calls to Finalization are made correctly. The
--- Finalization procedures are provided to catch an implementation that
--- calls Finalization at an incorrect time.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
----------------------------------------------------------------- C760001_0
-
-with Ada.Finalization;
-package C760001_0 is
- subtype Unique_ID is Natural;
- function Unique_Value return Unique_ID;
- -- increments each time it's called
-
- function Most_Recent_Unique_Value return Unique_ID;
- -- returns the same value as the most recent call to Unique_Value
-
- type Root_Controlled is new Ada.Finalization.Controlled with record
- My_ID : Unique_ID := Unique_Value;
- My_Init_ID : Unique_ID := Unique_ID'First;
- My_Adj_ID : Unique_ID := Unique_ID'First;
- end record;
-
- procedure Initialize( R: in out Root_Controlled );
- procedure Adjust ( R: in out Root_Controlled );
-
- TC_Initialize_Calls_Is_Failing : Boolean := False;
-
-end C760001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760001_0 is
-
- Global_Unique_Counter : Unique_ID := 0;
-
- function Unique_Value return Unique_ID is
- begin
- Global_Unique_Counter := Global_Unique_Counter +1;
- return Global_Unique_Counter;
- end Unique_Value;
-
- function Most_Recent_Unique_Value return Unique_ID is
- begin
- return Global_Unique_Counter;
- end Most_Recent_Unique_Value;
-
- procedure Initialize( R: in out Root_Controlled ) is
- begin
- if TC_Initialize_Calls_Is_Failing then
- Report.Failed("Initialized incorrectly called");
- end if;
- R.My_Init_ID := Unique_Value;
- end Initialize;
-
- procedure Adjust( R: in out Root_Controlled ) is
- begin
- R.My_Adj_ID := Unique_Value;
- end Adjust;
-
-end C760001_0;
-
----------------------------------------------------------------- C760001_1
-
-with Ada.Finalization;
-with C760001_0;
-package C760001_1 is
-
- type Proc_ID is (None, Init, Adj, Fin);
-
- type Test_Controlled is new C760001_0.Root_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Controlled );
- procedure Adjust ( TC: in out Test_Controlled );
- procedure Finalize ( TC: in out Test_Controlled );
-
- type Nested_Controlled is new C760001_0.Root_Controlled with record
- Nested : C760001_0.Root_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Controlled );
- procedure Adjust ( TC: in out Nested_Controlled );
- procedure Finalize ( TC: in out Nested_Controlled );
-
-end C760001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760001_1 is
-
- procedure Initialize( TC: in out Test_Controlled ) is
- begin
- if TC.Last_Proc_Called /= None then
- Report.Failed("Initialize for Test_Controlled");
- end if;
- TC.Last_Proc_Called := Init;
- C760001_0.Initialize(C760001_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760001_0.Adjust(C760001_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Controlled ) is
- begin
- if TC.Last_Proc_Called /= None then
- Report.Failed("Initialize for Nested_Controlled");
- end if;
- TC.Last_Proc_Called := Init;
- C760001_0.Initialize(C760001_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760001_0.Adjust(C760001_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
-end C760001_1;
-
----------------------------------------------------------------- C760001
-
-with Report;
-with TCTouch;
-with C760001_0;
-with C760001_1;
-with Ada.Finalization;
-procedure C760001 is
-
- use type C760001_1.Proc_ID;
-
- -- in the first test, test the simple case. Check that a controlled object
- -- causes a call to the procedure Initialize.
- -- Also check that assignment causes a call to Adjust.
-
- procedure Check_Simple_Objects is
- S,T : C760001_1.Test_Controlled;
- begin
- TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
- TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
- (T.Last_Proc_Called = C760001_1.Init),
- "Initialize for simple object");
- S := T;
- TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
- "Adjust for simple object");
- TCTouch.Assert((S.My_ID = T.My_ID),
- "Simple object My_ID's don't match");
- TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
- "Simple object My_Init_ID's don't match");
- TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
- "Simple object My_Adj_ID's in wrong order");
- end Check_Simple_Objects;
-
- -- in the second test, test a more complex case, check that a controlled
- -- component of a controlled object gets processed correctly
-
- procedure Check_Nested_Objects is
- NO1 : C760001_1.Nested_Controlled;
- begin
- TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
- "Default value order incorrect");
- TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
- "Initialization call order incorrect");
- end Check_Nested_Objects;
-
- -- check that objects assigned an initial value at declaration are Adjusted
- -- and NOT Initialized
-
- procedure Check_Objects_With_Initial_Values is
-
- TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
-
- A: C760001_1.Test_Controlled :=
- ( Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_1.None);
-
- B: C760001_1.Nested_Controlled :=
- ( Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_0.Root_Controlled(A),
- C760001_1.None);
-
- begin
- -- the implementation may or may not call Adjust for the values
- -- assigned into A and B,
- -- but should NOT call Initialize.
- -- if the value used in the aggregate is overwritten by Initialize,
- -- this indicates failure
- TCTouch.Assert(A.My_Init_Id = TC_Now,
- "Initialize was called for A with initial value");
- TCTouch.Assert(B.My_Init_Id = TC_Now,
- "Initialize was called for B with initial value");
- TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
- "Initialize was called for B.Nested initial value");
- end Check_Objects_With_Initial_Values;
-
- procedure Check_Array_Case is
- type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
-
- Simple_Array_Default : Array_Simple;
-
- Nested_Array_Default : Array_Nested;
-
- TC_A_Bit_Later : C760001_0.Unique_ID;
-
- begin
- TC_A_Bit_Later := C760001_0.Unique_Value;
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
- = C760001_1.Init,
- "Initialize for array initial value");
-
- TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Simple_Array_Default(N).My_Init_ID
- < TC_A_Bit_Later),
- "Initialize timing for simple array");
-
- TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Nested_Array_Default(N).My_Init_ID
- < TC_A_Bit_Later),
- "Initialize timing for container array");
-
- TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
- = C760001_1.Init,
- "Initialize for nested array (outer) initial value");
-
- TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Nested_Array_Default(N).Nested.My_Init_ID
- < Nested_Array_Default(N).My_Init_ID),
- "Initialize timing for array content");
- end loop;
- end Check_Array_Case;
-
- procedure Check_Array_Case_With_Initial_Values is
-
- TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
-
- type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
-
- Simple_Array_Explicit : Array_Simple := ( 1..4 => (
- Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_1.None ) );
-
- A : constant C760001_0.Root_Controlled :=
- ( Ada.Finalization.Controlled
- with others => TC_Now);
-
- Nested_Array_Explicit : Array_Nested := ( 1..4 => (
- Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- A,
- C760001_1.None ) );
-
- begin
- -- the implementation may or may not call Adjust for the values
- -- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
- -- but should NOT call Initialize.
- -- if the value used in the aggregate is overwritten by Initialize,
- -- this indicates failure
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
- = TC_Now,
- "Initialize was called for array with initial value");
- TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
- = TC_Now,
- "Initialize was called for nested array (outer) with initial value");
- TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
- "Initialize was called for nested array (inner) with initial value");
- end loop;
- end Check_Array_Case_With_Initial_Values;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C760001", "Check that Initialize is called for objects " &
- "and components of a controlled type when the " &
- "objects and components are not assigned " &
- "explicit initial values. Check that if an " &
- "explicit initial value is assigned to an " &
- "object or component of a controlled type " &
- "then Initialize is not called" );
-
- Check_Simple_Objects;
-
- Check_Nested_Objects;
-
- Check_Array_Case;
-
- C760001_0.TC_Initialize_Calls_Is_Failing := True;
-
- Check_Objects_With_Initial_Values;
-
- Check_Array_Case_With_Initial_Values;
-
- Report.Result;
-
-end C760001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760002.a b/gcc/testsuite/ada/acats/tests/c7/c760002.a
deleted file mode 100644
index 4601873..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760002.a
+++ /dev/null
@@ -1,489 +0,0 @@
--- C760002.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 assignment to an object of a (non-limited) controlled
--- type causes the Adjust operation of the type to be called.
--- Check that Adjust is called after copying the value of the
--- source expression to the target object.
---
--- Check that Adjust is called for all controlled components when
--- the containing object is assigned. (Test this for the cases
--- where the type of the containing object is controlled and
--- noncontrolled; test this for initialization as well as
--- assignment statements.)
---
--- Check that for an object of a controlled type with controlled
--- components, Adjust for each of the components is called before
--- the containing object is adjusted.
---
--- Check that an Adjust procedure for a Limited_Controlled type is
--- not called by the implementation.
---
--- TEST DESCRIPTION:
--- This test is loosely "derived" from C760001.
---
--- Visit Tags:
--- D - Default value at declaration
--- d - Default value at declaration, limited root
--- I - initialize at root controlled
--- i - initialize at root limited controlled
--- A - adjust at root controlled
--- X,Y,Z,x,y,z - used in test body
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Correct test assertion logic for Sinister case
---
---!
-
----------------------------------------------------------------- C760002_0
-
-with Ada.Finalization;
-package C760002_0 is
- subtype Unique_ID is Natural;
- function Unique_Value return Unique_ID;
- -- increments each time it's called
-
- function Most_Recent_Unique_Value return Unique_ID;
- -- returns the same value as the most recent call to Unique_Value
-
- type Root is tagged record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'D'; -- Default
- end record;
-
- procedure Initialize( R: in out Root );
- procedure Adjust ( R: in out Root );
-
- type Root_Controlled is new Ada.Finalization.Controlled with record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'D'; ---------------------------------------- D
- end record;
-
- procedure Initialize( R: in out Root_Controlled );
- procedure Adjust ( R: in out Root_Controlled );
-
- type Root_Limited_Controlled is
- new Ada.Finalization.Limited_Controlled with record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'd'; ---------------------------------------- d
- end record;
-
- procedure Initialize( R: in out Root_Limited_Controlled );
- procedure Adjust ( R: in out Root_Limited_Controlled );
-
-end C760002_0;
-
-with Report;
-package body C760002_0 is
-
- Global_Unique_Counter : Unique_ID := 0;
-
- function Unique_Value return Unique_ID is
- begin
- Global_Unique_Counter := Global_Unique_Counter +1;
- return Global_Unique_Counter;
- end Unique_Value;
-
- function Most_Recent_Unique_Value return Unique_ID is
- begin
- return Global_Unique_Counter;
- end Most_Recent_Unique_Value;
-
- procedure Initialize( R: in out Root ) is
- begin
- Report.Failed("Initialize called for Non_Controlled type");
- end Initialize;
-
- procedure Adjust ( R: in out Root ) is
- begin
- Report.Failed("Adjust called for Non_Controlled type");
- end Adjust;
-
- procedure Initialize( R: in out Root_Controlled ) is
- begin
- R.Visit_Tag := 'I'; --------------------------------------------------- I
- end Initialize;
-
- procedure Adjust( R: in out Root_Controlled ) is
- begin
- R.Visit_Tag := 'A'; --------------------------------------------------- A
- end Adjust;
-
- procedure Initialize( R: in out Root_Limited_Controlled ) is
- begin
- R.Visit_Tag := 'i'; --------------------------------------------------- i
- end Initialize;
-
- procedure Adjust( R: in out Root_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Limited_Controlled type");
- end Adjust;
-
-end C760002_0;
-
----------------------------------------------------------------- C760002_1
-
-with Ada.Finalization;
-with C760002_0;
-package C760002_1 is
-
- type Proc_ID is (None, Init, Adj, Fin);
-
- type Test_Controlled is new C760002_0.Root_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Controlled );
- procedure Adjust ( TC: in out Test_Controlled );
- procedure Finalize ( TC: in out Test_Controlled );
-
- type Nested_Controlled is new C760002_0.Root_Controlled with record
- Nested : C760002_0.Root_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Controlled );
- procedure Adjust ( TC: in out Nested_Controlled );
- procedure Finalize ( TC: in out Nested_Controlled );
-
- type Test_Limited_Controlled is
- new C760002_0.Root_Limited_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Limited_Controlled );
- procedure Adjust ( TC: in out Test_Limited_Controlled );
- procedure Finalize ( TC: in out Test_Limited_Controlled );
-
- type Nested_Limited_Controlled is
- new C760002_0.Root_Limited_Controlled with record
- Nested : C760002_0.Root_Limited_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Limited_Controlled );
- procedure Adjust ( TC: in out Nested_Limited_Controlled );
- procedure Finalize ( TC: in out Nested_Limited_Controlled );
-
-end C760002_1;
-
-with Report;
-package body C760002_1 is
-
- procedure Initialize( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760002_0.Adjust(C760002_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760002_0.Adjust(C760002_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Test_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Test_Limited_Controlled");
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Nested_Limited_Controlled");
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
-end C760002_1;
-
----------------------------------------------------------------- C760002
-
-with Report;
-with TCTouch;
-with C760002_0;
-with C760002_1;
-with Ada.Finalization;
-procedure C760002 is
-
- use type C760002_1.Proc_ID;
-
- -- in the first test, test the simple cases.
- -- Also check that assignment causes a call to Adjust for a controlled
- -- object. Check that assignment of a non-controlled object does not call
- -- an Adjust procedure.
-
- procedure Check_Simple_Objects is
-
- A,B : C760002_0.Root;
- S,T : C760002_1.Test_Controlled;
- Q : C760002_1.Test_Limited_Controlled; -- Adjust call shouldn't happen
- begin
-
- S := T;
-
- TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj),
- "Adjust for simple object");
- TCTouch.Assert((S.My_ID = T.My_ID),
- "Assignment failed for simple object");
-
- -- Check that adjust was called
- TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect");
-
- -- Check that Adjust has not been called
- TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called");
-
- -- Check that Adjust does not get called
- A.My_ID := A.My_ID +1;
- B := A; -- see: Adjust: Report.Failed
-
- end Check_Simple_Objects;
-
- -- in the second test, test a more complex case, check that a controlled
- -- component of a controlled object gets processed correctly
-
- procedure Check_Nested_Objects is
- NO1 : C760002_1.Nested_Controlled;
- NO2 : C760002_1.Nested_Controlled := NO1;
-
- begin
-
- -- NO2 should be flagged with adjust markers
- TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj),
- "Adjust not called for NO2 enclosure declaration");
- TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'),
- "Adjust not called for NO2 enclosed declaration");
-
- NO2.Visit_Tag := 'x';
- NO2.Nested.Visit_Tag := 'y';
-
- NO1 := NO2;
-
- -- NO1 should be flagged with adjust markers
- TCTouch.Assert((NO1.Visit_Tag = 'A'),
- "Adjust not called for NO1 enclosure declaration");
- TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'),
- "Adjust not called for NO1 enclosed declaration");
-
- end Check_Nested_Objects;
-
- procedure Check_Array_Case is
- type Array_Simple is array(1..4) of C760002_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760002_1.Nested_Controlled;
-
- Left,Right : Array_Simple;
- Overlap : Array_Simple := Left;
-
- Sinister,Dexter : Array_Nested;
- Underlap : Array_Nested := Sinister;
-
- Now : Natural;
-
- begin
-
- -- get a current unique value since initializations
- Now := C760002_0.Unique_Value;
-
- -- check results of declarations
- for N in 1..4 loop
- TCTouch.Assert(Left(N).My_Id < Now,
- "Initialize for array initial value");
- TCTouch.Assert(Overlap(N).My_Id < Now,
- "Adjust for nested array (outer) initial value");
- TCTouch.Assert(Sinister(N).Nested.My_Id < Now,
- "Initialize for nested array (inner) initial value");
- TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id,
- "Initialize for enclosure should be after enclosed");
- TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration");
- TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A',
- "Adjust at declaration, nested object");
- end loop;
-
- -- set visit tags
- for O in 1..4 loop
- Overlap(O).Visit_Tag := 'X';
- Underlap(O).Visit_Tag := 'Y';
- Underlap(O).Nested.Visit_Tag := 'y';
- end loop;
-
- -- check that overlapping assignments don't cause odd grief
- Overlap(1..3) := Overlap(2..4);
- Underlap(2..4) := Underlap(1..3);
-
- for M in 2..3 loop
- TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj,
- "Adjust for overlap");
- TCTouch.Assert(Overlap(M).Visit_Tag = 'A',
- "Adjust for overlap ID");
- TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj,
- "Adjust for Underlap");
- TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A',
- "Adjust for Underlaps nested ID");
- end loop;
-
- end Check_Array_Case;
-
- procedure Check_Access_Case is
- type TC_Ref is access C760002_1.Test_Controlled;
- type NC_Ref is access C760002_1.Nested_Controlled;
- type TL_Ref is access C760002_1.Test_Limited_Controlled;
- type NL_Ref is access C760002_1.Nested_Limited_Controlled;
-
- A,B : TC_Ref;
- C,D : NC_Ref;
- E : TL_Ref;
- F : NL_Ref;
-
- begin
-
- A := new C760002_1.Test_Controlled;
- B := new C760002_1.Test_Controlled'( A.all );
-
- C := new C760002_1.Nested_Controlled;
- D := new C760002_1.Nested_Controlled'( C.all );
-
- E := new C760002_1.Test_Limited_Controlled;
- F := new C760002_1.Nested_Limited_Controlled;
-
- TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation");
- TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value");
-
- TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation");
- TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested");
- TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value");
- TCTouch.Assert(D.Nested.Visit_Tag = 'A',
- "NC Allocation, Nested, with value");
-
- TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation");
- TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation");
-
- A.all := B.all;
- C.all := D.all;
-
- TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment");
- TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment");
- TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested");
-
- end Check_Access_Case;
-
- procedure Check_Access_Limited_Array_Case is
- type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled;
- type AS_Ref is access Array_Simple;
- type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled;
- type AN_Ref is access Array_Nested;
-
- Simple_Array_Limited : AS_Ref;
-
- Nested_Array_Limited : AN_Ref;
-
- begin
-
- Simple_Array_Limited := new Array_Simple;
-
- Nested_Array_Limited := new Array_Nested;
-
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called
- = C760002_1.Init,
- "Initialize for array initial value");
- TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called
- = C760002_1.Init,
- "Initialize for nested array (outer) initial value");
- TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i',
- "Initialize for nested array (inner) initial value");
- end loop;
- end Check_Access_Limited_Array_Case;
-
-begin -- Main test procedure.
-
- Report.Test ("C760002", "Check that assignment causes the Adjust " &
- "operation of the type to be called. Check " &
- "that Adjust is called after copying the " &
- "value of the source expression to the target " &
- "object. Check that Adjust is called for all " &
- "controlled components when the containing " &
- "object is assigned. Check that Adjust is " &
- "called for components before the containing " &
- "object is adjusted. Check that Adjust is not " &
- "called for a Limited_Controlled type by the " &
- "implementation" );
-
- Check_Simple_Objects;
-
- Check_Nested_Objects;
-
- Check_Array_Case;
-
- Check_Access_Case;
-
- Check_Access_Limited_Array_Case;
-
- Report.Result;
-
-end C760002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760007.a b/gcc/testsuite/ada/acats/tests/c7/c760007.a
deleted file mode 100644
index c1ddfcb9..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760007.a
+++ /dev/null
@@ -1,247 +0,0 @@
--- C760007.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 Adjust is called for the execution of a return
--- statement for a function returning a result of a (non-limited)
--- controlled type.
---
--- Check that Adjust is called when evaluating an aggregate
--- component association for a controlled component.
---
--- Check that Adjust is called for the assignment of the ancestor
--- expression of an extension aggregate when the type of the
--- aggregate is controlled.
---
--- TEST DESCRIPTION:
--- A type is derived from Ada.Finalization.Controlled; the dispatching
--- procedure Adjust is defined for the new type. Structures and
--- subprograms to model the test objectives are used to check that
--- Adjust is called at the right time. For the sake of simplicity,
--- globally accessible data is used to check that the calls are made.
---
---
--- CHANGE HISTORY:
--- 06 DEC 94 SAIC ACVC 2.0
--- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1
--- 05 APR 96 SAIC Add RM reference
--- 06 NOV 96 SAIC Reduce adjust requirement
--- 25 NOV 97 EDS Allowed zero calls to adjust at line 144
---!
-
----------------------------------------------------------------- C760007_0
-
-with Ada.Finalization;
-package C760007_0 is
-
- type Controlled is new Ada.Finalization.Controlled with record
- TC_ID : Natural := Natural'Last;
- end record;
- procedure Adjust( Object: in out Controlled );
-
- type Structure is record
- Controlled_Component : Controlled;
- end record;
-
- type Child is new Controlled with record
- TC_XX : Natural := Natural'Last;
- end record;
- procedure Adjust( Object: in out Child );
-
- Adjust_Count : Natural := 0;
- Child_Adjust_Count : Natural := 0;
-
-end C760007_0;
-
-package body C760007_0 is
-
- procedure Adjust( Object: in out Controlled ) is
- begin
- Adjust_Count := Adjust_Count +1;
- end Adjust;
-
- procedure Adjust( Object: in out Child ) is
- begin
- Child_Adjust_Count := Child_Adjust_Count +1;
- end Adjust;
-
-end C760007_0;
-
------------------------------------------------------------------- C760007
-
-with Report;
-with C760007_0;
-procedure C760007 is
-
- procedure Check_Adjust_Count(Message: String;
- Min: Natural := 1;
- Max: Natural := 2) is
- begin
-
- -- in order to allow for the anonymous objects referred to in
- -- the reference manual, the check for calls to Adjust must be
- -- in a range. This number must then be further adjusted
- -- to allow for the optimization that does not call for an adjust
- -- of an aggregate initial value built directly in the object
-
- if C760007_0.Adjust_Count not in Min..Max then
- Report.Failed(Message
- & " = " & Natural'Image(C760007_0.Adjust_Count));
- end if;
- C760007_0.Adjust_Count := 0;
- end Check_Adjust_Count;
-
- procedure Check_Child_Adjust_Count(Message: String;
- Min: Natural := 1;
- Max: Natural := 2) is
- begin
- -- ditto above
-
- if C760007_0.Child_Adjust_Count not in Min..Max then
- Report.Failed(Message
- & " = " & Natural'Image(C760007_0.Child_Adjust_Count));
- end if;
- C760007_0.Child_Adjust_Count := 0;
- end Check_Child_Adjust_Count;
-
- Object : C760007_0.Controlled;
-
--- Check that Adjust is called for the execution of a return
--- statement for a function returning a result of a (non-limited)
--- controlled type or a result of a noncontrolled type with
--- controlled components.
-
- procedure Subtest_1 is
- function Create return C760007_0.Controlled is
- New_Object : C760007_0.Controlled;
- begin
- return New_Object;
- end Create;
-
- procedure Examine( Thing : in C760007_0.Controlled ) is
- begin
- Check_Adjust_Count("Function call passed as parameter",0);
- end Examine;
-
- begin
- -- this assignment must call Adjust:
- -- 1: on the value resulting from the function
- -- ** unless this is optimized out by building the result directly
- -- in the target object.
- -- 2: on Object once it's been assigned
- -- may call adjust
- -- 1: for a anonymous object created in the evaluation of the function
- -- 2: for a anonymous object created in the assignment operation
-
- Object := Create;
-
- Check_Adjust_Count("Function call",1,4);
-
- Examine( Create );
-
- end Subtest_1;
-
--- Check that Adjust is called when evaluating an aggregate
--- component association for a controlled component.
-
- procedure Subtest_2 is
- S : C760007_0.Structure;
-
- procedure Examine( Thing : in C760007_0.Structure ) is
- begin
- Check_Adjust_Count("Aggregate passed as parameter");
- end Examine;
-
- begin
- -- this assignment must call Adjust:
- -- 1: on the value resulting from the aggregate
- -- ** unless this is optimized out by building the result directly
- -- in the target object.
- -- 2: on Object once it's been assigned
- -- may call adjust
- -- 1: for a anonymous object created in the evaluation of the aggregate
- -- 2: for a anonymous object created in the assignment operation
- S := ( Controlled_Component => Object );
- Check_Adjust_Count("Aggregate and Assignment", 1, 4);
-
- Examine( C760007_0.Structure'(Controlled_Component => Object) );
- end Subtest_2;
-
--- Check that Adjust is called for the assignment of the ancestor
--- expression of an extension aggregate when the type of the
--- aggregate is controlled.
-
- procedure Subtest_3 is
- Bambino : C760007_0.Child;
-
- procedure Examine( Thing : in C760007_0.Child ) is
- begin
- Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
- Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
- end Examine;
-
- begin
- -- implementation permissions make all of the following calls to adjust
- -- optional:
- -- these assignments may call Adjust:
- -- 1: on the value resulting from the aggregate
- -- 2: on Object once it's been assigned
- -- 3: for a anonymous object created in the evaluation of the aggregate
- -- 4: for a anonymous object created in the assignment operation
- Bambino := ( Object with TC_XX => 10 );
- Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
- Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
-
- Bambino := ( C760007_0.Controlled with TC_XX => 11 );
- Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
- Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
-
- Examine( ( Object with TC_XX => 21 ) );
-
- Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("C760007", "Check that Adjust is called for the " &
- "execution of a return statement for a " &
- "function returning a result containing a " &
- "controlled type. Check that Adjust is " &
- "called when evaluating an aggregate " &
- "component association for a controlled " &
- "component. " &
- "Check that Adjust is called for the " &
- "assignment of the ancestor expression of an " &
- "extension aggregate when the type of the " &
- "aggregate is controlled" );
-
- Subtest_1;
- Subtest_2;
- Subtest_3;
-
- Report.Result;
-
-end C760007;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760009.a b/gcc/testsuite/ada/acats/tests/c7/c760009.a
deleted file mode 100644
index 8c3b80b..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760009.a
+++ /dev/null
@@ -1,533 +0,0 @@
--- C760009.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 for an extension_aggregate whose ancestor_part is a
--- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
--- Initialize is called on all controlled subcomponents of the
--- ancestor part; if the type of the ancestor part is itself controlled,
--- the Initialize procedure of the ancestor type is called, unless that
--- Initialize procedure is abstract.
---
--- Check that the utilization of a controlled type for a generic actual
--- parameter supports the correct behavior in the instantiated package.
---
--- TEST DESCRIPTION:
--- Declares a generic package instantiated to check that controlled
--- types are not impacted by the "generic boundary."
--- This instance is then used to perform the tests of various
--- aggregate formations of the controlled type. After each operation
--- in the main program that should cause implicit calls, the "state" of
--- the software is checked. The "state" of the software is maintained in
--- several variables which count the calls to the Initialize, Adjust and
--- Finalize procedures in each context. Given the nature of the
--- language rules, the test specifies a minimum number of times that
--- these subprograms should have been called. The test also checks cases
--- where the subprograms should not have been called.
---
--- As per the example in AARM 7.6(11a..d);6.0, the distinctions between
--- the presence/absence of default values is tested.
---
--- DATA STRUCTURES
---
--- C760009_3.Master_Control is derived from
--- C760009_2.Control is derived from
--- Ada.Finalization.Controlled
---
--- C760009_1.Simple_Control is derived from
--- Ada.Finalization.Controlled
---
--- C760009_3.Master_Control contains
--- Standard.Integer
---
--- C760009_2.Control contains
--- C760009_1.Simple_Control (default value)
--- C760009_1.Simple_Control (default initialized)
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 SAIC Initial version
--- 19 FEB 96 SAIC Fixed elaboration Initialize count
--- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations
--- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129
--- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0
--- to avoid possible instantiation error
---!
-
----------------------------------------------------------------- C760009_0
-
-with Ada.Finalization;
-generic
-
- type Private_Formal is private;
-
- with procedure TC_Validate( APF: in out Private_Formal );
-
-package C760009_0 is -- Check_1
-
- pragma Elaborate_Body;
- procedure TC_Check_1( APF: in Private_Formal );
- procedure TC_Check_2( APF: out Private_Formal );
- procedure TC_Check_3( APF: in out Private_Formal );
-
-end C760009_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760009_0 is -- Check_1
-
- procedure TC_Check_1( APF: in Private_Formal ) is
- Local : Private_Formal;
- begin
- Local := APF;
- TC_Validate( Local );
- end TC_Check_1;
-
- procedure TC_Check_2( APF: out Private_Formal ) is
- Local : Private_Formal; -- initialized by virtue of actual being
- -- Controlled
- begin
- APF := Local;
- TC_Validate( APF );
- end TC_Check_2;
-
- procedure TC_Check_3( APF: in out Private_Formal ) is
- Local : Private_Formal;
- begin
- Local := APF;
- TC_Validate( Local );
- end TC_Check_3;
-
-end C760009_0;
-
----------------------------------------------------------------- C760009_1
-
-with Ada.Finalization;
-package C760009_1 is
-
- Initialize_Called : Natural := 0;
- Adjust_Called : Natural := 0;
- Finalize_Called : Natural := 0;
-
- procedure Reset_Counters;
-
- type Simple_Control is new Ada.Finalization.Controlled with private;
-
- procedure Initialize( AV: in out Simple_Control );
- procedure Adjust ( AV: in out Simple_Control );
- procedure Finalize ( AV: in out Simple_Control );
- procedure Validate ( AV: in out Simple_Control );
-
- function Item( AV: Simple_Control'Class ) return String;
-
- Empty : constant Simple_Control;
-
- procedure TC_Trace( Message: String );
-
-private
- type Simple_Control is new Ada.Finalization.Controlled with record
- Item: Natural;
- end record;
-
- Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );
-
-end C760009_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760009_1 is
-
- -- Maintenance_Mode and TC_Trace are for the test writers and compiler
- -- developers to get more information from this test as it executes.
- -- Maintenance_Mode is always False for validation purposes.
-
- Maintenance_Mode : constant Boolean := False;
-
- procedure TC_Trace( Message: String ) is
- begin
- if Maintenance_Mode then
- Report.Comment( Message );
- end if;
- end TC_Trace;
-
- procedure Reset_Counters is
- begin
- Initialize_Called := 0;
- Adjust_Called := 0;
- Finalize_Called := 0;
- end Reset_Counters;
-
- Master_Count : Natural := 100; -- Help distinguish values
-
- procedure Initialize( AV: in out Simple_Control ) is
- begin
- Initialize_Called := Initialize_Called +1;
- AV.Item := Master_Count;
- Master_Count := Master_Count +100;
- TC_Trace( "Initialize _1.Simple_Control" );
- end Initialize;
-
- procedure Adjust ( AV: in out Simple_Control ) is
- begin
- Adjust_Called := Adjust_Called +1;
- AV.Item := AV.Item +1;
- TC_Trace( "Adjust _1.Simple_Control" );
- end Adjust;
-
- procedure Finalize ( AV: in out Simple_Control ) is
- begin
- Finalize_Called := Finalize_Called +1;
- AV.Item := AV.Item +1;
- TC_Trace( "Finalize _1.Simple_Control" );
- end Finalize;
-
- procedure Validate ( AV: in out Simple_Control ) is
- begin
- Report.Failed("Attempt to Validate at Simple_Control level");
- end Validate;
-
- function Item( AV: Simple_Control'Class ) return String is
- begin
- return Natural'Image(AV.Item);
- end Item;
-
-end C760009_1;
-
----------------------------------------------------------------- C760009_2
-
-with C760009_1;
-with Ada.Finalization;
-package C760009_2 is
-
- type Control is new Ada.Finalization.Controlled with record
- Element_1 : C760009_1.Simple_Control;
- Element_2 : C760009_1.Simple_Control := C760009_1.Empty;
- end record;
-
- procedure Initialize( AV: in out Control );
- procedure Finalize ( AV: in out Control );
-
- Initialized : Natural := 0;
- Finalized : Natural := 0;
-
-end C760009_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C760009_2 is
-
- procedure Initialize( AV: in out Control ) is
- begin
- Initialized := Initialized +1;
- C760009_1.TC_Trace( "Initialize _2.Control" );
- end Initialize;
-
- procedure Finalize ( AV: in out Control ) is
- begin
- Finalized := Finalized +1;
- C760009_1.TC_Trace( "Finalize _2.Control" );
- end Finalize;
-
-end C760009_2;
-
----------------------------------------------------------------- C760009_3
-
-with C760009_0;
-with C760009_2;
-package C760009_3 is
-
- type Master_Control is new C760009_2.Control with record
- Data: Integer;
- end record;
-
- procedure Initialize( AC: in out Master_Control );
- -- calls C760009_2.Initialize
- -- embedded data causes 1 call to C760009_1.Initialize
-
- -- Adjusting operation will
- -- make 1 call to C760009_2.Adjust
- -- make 2 call to C760009_1.Adjust
-
- -- Finalize operation will
- -- make 1 call to C760009_2.Finalize
- -- make 2 call to C760009_1.Finalize
-
- procedure Validate( AC: in out Master_Control );
-
- package Check_1 is
- new C760009_0(Master_Control, Validate);
-
-end C760009_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with C760009_1;
-package body C760009_3 is
-
- procedure Initialize( AC: in out Master_Control ) is
- begin
- AC.Data := 42;
- C760009_2.Initialize(C760009_2.Control(AC));
- C760009_1.TC_Trace( "Initialize Master_Control" );
- end Initialize;
-
- procedure Validate( AC: in out Master_Control ) is
- begin
- if AC.Data not in 0..1000 then
- Report.Failed("C760009_3.Control did not Initialize" );
- end if;
- end Validate;
-
-end C760009_3;
-
---------------------------------------------------------------------- C760009
-
-with Report;
-with C760009_1;
-with C760009_2;
-with C760009_3;
-procedure C760009 is
-
- -- Comment following declaration indicates expected calls in the order:
- -- Initialize of a C760009_2 value
- -- Finalize of a C760009_2 value
- -- Initialize of a C760009_1 value
- -- Adjust of a C760009_1 value
- -- Finalize of a C760009_1 value
-
- Global_Control : C760009_3.Master_Control;
- -- 1, 0, 1, 1, 0
-
- Parent_Control : C760009_2.Control;
- -- 1, 0, 1, 1, 0
-
- -- Global_Control is a derived tagged type, the parent type
- -- of Master_Control, Control, is derived from Controlled, and contains
- -- two components of a Controlled type, Simple_Control. One of these
- -- components has a default value, the other does not.
-
- procedure Fail( Which: String; Expect, Got: Natural ) is
- begin
- Report.Failed(Which & " Expected" & Natural'Image(Expect)
- & " got" & Natural'Image(Got) );
- end Fail;
-
- procedure Master_Assertion( Layer_2_Inits : Natural;
- Layer_2_Finals : Natural;
- Layer_1_Inits : Natural;
- Layer_1_Adjs : Natural;
- Layer_1_Finals : Natural;
- Failing_Message : String ) is
-
- begin
-
-
-
- if C760009_2.Initialized /= Layer_2_Inits then
- Fail("C760009_2.Initialize " & Failing_Message,
- Layer_2_Inits, C760009_2.Initialized );
- end if;
-
- if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then
- Fail("C760009_2.Finalize " & Failing_Message,
- Layer_2_Finals, C760009_2.Finalized );
- end if;
-
- if C760009_1.Initialize_Called /= Layer_1_Inits then
- Fail("C760009_1.Initialize " & Failing_Message,
- Layer_1_Inits,
- C760009_1.Initialize_Called );
- end if;
-
- if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then
- Fail("C760009_1.Adjust " & Failing_Message,
- Layer_1_Adjs, C760009_1.Adjust_Called );
- end if;
-
- if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then
- Fail("C760009_1.Finalize " & Failing_Message,
- Layer_1_Finals, C760009_1.Finalize_Called );
- end if;
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- end Master_Assertion;
-
- procedure Lesser_Assertion( Layer_2_Inits : Natural;
- Layer_2_Finals : Natural;
- Layer_1_Inits : Natural;
- Layer_1_Adjs : Natural;
- Layer_1_Finals : Natural;
- Failing_Message : String ) is
- begin
-
-
- if C760009_2.Initialized > Layer_2_Inits then
- Fail("C760009_2.Initialize " & Failing_Message,
- Layer_2_Inits, C760009_2.Initialized );
- end if;
-
- if C760009_2.Finalized < Layer_2_Inits
- or C760009_2.Finalized > Layer_2_Finals*2 then
- Fail("C760009_2.Finalize " & Failing_Message,
- Layer_2_Finals, C760009_2.Finalized );
- end if;
-
- if C760009_1.Initialize_Called > Layer_1_Inits then
- Fail("C760009_1.Initialize " & Failing_Message,
- Layer_1_Inits,
- C760009_1.Initialize_Called );
- end if;
-
- if C760009_1.Adjust_Called > Layer_1_Adjs*2 then
- Fail("C760009_1.Adjust " & Failing_Message,
- Layer_1_Adjs, C760009_1.Adjust_Called );
- end if;
-
- if C760009_1.Finalize_Called < Layer_1_Inits
- or C760009_1.Finalize_Called > Layer_1_Finals*2 then
- Fail("C760009_1.Finalize " & Failing_Message,
- Layer_1_Finals, C760009_1.Finalize_Called );
- end if;
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- end Lesser_Assertion;
-
-begin -- Main test procedure.
-
- Report.Test ("C760009", "Check that for an extension_aggregate whose " &
- "ancestor_part is a subtype_mark, Initialize " &
- "is called on all controlled subcomponents of " &
- "the ancestor part. Also check that the " &
- "utilization of a controlled type for a generic " &
- "actual parameter supports the correct behavior " &
- "in the instantiated software" );
-
- C760009_1.TC_Trace( "=====> Case 0 <=====" );
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- C760009_3.Validate( Global_Control ); -- check that it Initialized correctly
-
- C760009_1.TC_Trace( "=====> Case 1 <=====" );
-
- C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) );
- Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );
- -- | | | | + Finalize 2 embedded in aggregate
- -- | | | | + Finalize 2 at assignment in TC_Check_1
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 caused by assignment in TC_Check_1
- -- | | | + Adjust at declaration in TC_Check_1
- -- | | + Initialize at declaration in TC_Check_1
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- | + Finalize of aggregate object
- -- + Initialize of aggregate object
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 2 <=====" );
-
- C760009_3.Check_1.TC_Check_2( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );
- -- | | | | + Finalize 2 at assignment in TC_Check_2
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 caused by assignment in TC_Check_2
- -- | | | + Adjust at declaration in TC_Check_2
- -- | | + Initialize at declaration in TC_Check_2
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 3 <=====" );
-
- Global_Control := ( C760009_2.Control with Data => 2 );
- Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" );
- -- | | | | + Finalize 2 by assignment
- -- | | | + Adjust 2 caused by assignment
- -- | | | + Adjust in aggregate creation
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- + Initialize of aggregate object
-
-
- C760009_1.TC_Trace( "=====> Case 4 <=====" );
-
- C760009_3.Check_1.TC_Check_3( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );
- -- | | | | + Finalize 2 at assignment in TC_Check_3
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 at assignment in TC_Check_3
- -- | | | + Adjust in local variable creation
- -- | | + Initialize of local variable in TC_Check_3
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 5 <=====" );
-
- Global_Control := ( Parent_Control with Data => 3 );
- Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" );
- -- | | | | + Finalize 2 by assignment
- -- | | | + Adjust 2 caused by assignment
- -- | | | + Adjust in aggregate creation
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- + Initialize of aggregate object
-
-
-
- C760009_1.TC_Trace( "=====> Case 6 <=====" );
-
- -- perform this check a second time to make sure nothing is "remembered"
-
- C760009_3.Check_1.TC_Check_3( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );
- -- | | | | + Finalize 2 at assignment in TC_Check_3
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 at assignment in TC_Check_3
- -- | | | + Adjust in local variable creation
- -- | | + Initialize of local variable in TC_Check_3
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- Report.Result;
-
-end C760009;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760010.a b/gcc/testsuite/ada/acats/tests/c7/c760010.a
deleted file mode 100644
index 08fe62b..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760010.a
+++ /dev/null
@@ -1,418 +0,0 @@
--- C760010.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 explicit calls to Initialize, Adjust and Finalize
--- procedures that raise exceptions propagate the exception raised,
--- not Program_Error. Check this for both a user defined exception
--- and a language defined exception. Check that implicit calls to
--- initialize procedures that raise an exception propagate the
--- exception raised, not Program_Error;
---
--- Check that the utilization of a controlled type as the actual for
--- a generic formal tagged private parameter supports the correct
--- behavior in the instantiated software.
---
--- TEST DESCRIPTION:
--- Declares a generic package instantiated to check that controlled
--- types are not impacted by the "generic boundary."
--- This instance is then used to perform the tests of various calls to
--- the procedures. After each operation in the main program that should
--- cause implicit calls where an exception is raised, the program handles
--- Program_Error. After each explicit call, the program handles the
--- Expected_Error. Handlers for the opposite exception are provided to
--- catch the obvious failure modes. The predefined exception
--- Tasking_Error is used to be certain that some other reason has not
--- raised a predefined exception.
---
---
--- DATA STRUCTURES
---
--- C760010_1.Simple_Control is derived from
--- Ada.Finalization.Controlled
---
--- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
--- by way of generic instantiation
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 SAIC Initial version
--- 23 APR 96 SAIC Fix visibility problem for 2.1
--- 14 NOV 96 SAIC Revisit for 2.1 release
--- 26 JUN 98 EDS Added pragma Elaborate_Body to
--- package C760010_0.Check_Formal_Tagged
--- to avoid possible instantiation error
---!
-
----------------------------------------------------------------- C760010_0
-
-package C760010_0 is
-
- User_Defined_Exception : exception;
-
- type Actions is ( No_Action,
- Init_Raise_User_Defined, Init_Raise_Standard,
- Adj_Raise_User_Defined, Adj_Raise_Standard,
- Fin_Raise_User_Defined, Fin_Raise_Standard );
-
- Action : Actions := No_Action;
-
- function Unique return Natural;
-
-end C760010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C760010_0 is
-
- Value : Natural := 101;
-
- function Unique return Natural is
- begin
- Value := Value +1;
- return Value;
- end Unique;
-
-end C760010_0;
-
----------------------------------------------------------------- C760010_0
------------------------------------------------------- Check_Formal_Tagged
-
-generic
-
- type Formal_Tagged is tagged private;
-
-package C760010_0.Check_Formal_Tagged is
-
- pragma Elaborate_Body;
-
- type Embedded_Derived is new Formal_Tagged with record
- TC_Meaningless_Value : Natural := Unique;
- end record;
-
- procedure Initialize( ED: in out Embedded_Derived );
- procedure Adjust ( ED: in out Embedded_Derived );
- procedure Finalize ( ED: in out Embedded_Derived );
-
-end C760010_0.Check_Formal_Tagged;
-
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760010_0.Check_Formal_Tagged is
-
-
- procedure Initialize( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Init_Raise_User_Defined => raise User_Defined_Exception;
- when Init_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Initialize;
-
- procedure Adjust ( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Adj_Raise_User_Defined => raise User_Defined_Exception;
- when Adj_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Adjust;
-
- procedure Finalize ( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Fin_Raise_User_Defined => raise User_Defined_Exception;
- when Fin_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Finalize;
-
-end C760010_0.Check_Formal_Tagged;
-
----------------------------------------------------------------- C760010_1
-
-with Ada.Finalization;
-package C760010_1 is
-
- procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
- procedure Reset_Counters;
-
- type Simple_Control is new Ada.Finalization.Controlled with record
- Item: Integer;
- end record;
- procedure Initialize( AV: in out Simple_Control );
- procedure Adjust ( AV: in out Simple_Control );
- procedure Finalize ( AV: in out Simple_Control );
-
-end C760010_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760010_1 is
-
- Initialize_Called : Natural;
- Adjust_Called : Natural;
- Finalize_Called : Natural;
-
- procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
- begin
- if Init /= Initialize_Called then
- Report.Failed("Initialize mismatch " & Message);
- end if;
- if Adj /= Adjust_Called then
- Report.Failed("Adjust mismatch " & Message);
- end if;
- if Fin /= Finalize_Called then
- Report.Failed("Finalize mismatch " & Message);
- end if;
- end Check_Counters;
-
- procedure Reset_Counters is
- begin
- Initialize_Called := 0;
- Adjust_Called := 0;
- Finalize_Called := 0;
- end Reset_Counters;
-
- procedure Initialize( AV: in out Simple_Control ) is
- begin
- Initialize_Called := Initialize_Called +1;
- AV.Item := 0;
- end Initialize;
-
- procedure Adjust ( AV: in out Simple_Control ) is
- begin
- Adjust_Called := Adjust_Called +1;
- AV.Item := AV.Item +1;
- end Adjust;
-
- procedure Finalize ( AV: in out Simple_Control ) is
- begin
- Finalize_Called := Finalize_Called +1;
- AV.Item := AV.Item +1;
- end Finalize;
-
-end C760010_1;
-
----------------------------------------------------------------- C760010_2
-
-with C760010_0.Check_Formal_Tagged;
-with C760010_1;
-package C760010_2 is
- new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
-
----------------------------------------------------------------------------
-
-with Report;
-with C760010_0;
-with C760010_1;
-with C760010_2;
-procedure C760010 is
-
- use type C760010_0.Actions;
-
- procedure Case_Failure(Message: String) is
- begin
- Report.Failed(Message & " for case "
- & C760010_0.Actions'Image(C760010_0.Action) );
- end Case_Failure;
-
- procedure Check_Implicit_Initialize is
- Item : C760010_2.Embedded_Derived; -- exception here propagates to
- Gadget : C760010_2.Embedded_Derived; -- caller
- begin
- if C760010_0.Action
- in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
- then
- Case_Failure("Anticipated exception at implicit init");
- end if;
- begin
- Item := Gadget; -- exception here handled locally
- if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
- .. C760010_0.Fin_Raise_Standard then
- Case_Failure ("Anticipated exception at assignment");
- end if;
- exception
- when Program_Error =>
- if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
- .. C760010_0.Fin_Raise_Standard then
- Report.Failed("Program_Error in Check_Implicit_Initialize");
- end if;
- when Tasking_Error =>
- Report.Failed("Tasking_Error in Check_Implicit_Initialize");
- when C760010_0.User_Defined_Exception =>
- Report.Failed("User_Error in Check_Implicit_Initialize");
- when others =>
- Report.Failed("Wrong exception Check_Implicit_Initialize");
- end;
- end Check_Implicit_Initialize;
-
----------------------------------------------------------------------------
-
- Global_Item : C760010_2.Embedded_Derived;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Initialize is
- begin
- begin
- C760010_2.Initialize( Global_Item );
- if C760010_0.Action
- in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit init");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Initialize");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Init_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Initialize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Initialize");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Initialize");
- end;
- end Check_Explicit_Initialize;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Adjust is
- begin
- begin
- C760010_2.Adjust( Global_Item );
- if C760010_0.Action
- in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit Adjust");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Adjust");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Adjust");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Adjust");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Adjust");
- end;
- end Check_Explicit_Adjust;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Finalize is
- begin
- begin
- C760010_2.Finalize( Global_Item );
- if C760010_0.Action
- in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit Finalize");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Finalize");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Finalize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Finalize");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Finalize");
- end;
- end Check_Explicit_Finalize;
-
----------------------------------------------------------------------------
-
-begin -- Main test procedure.
-
- Report.Test ("C760010", "Check that explicit calls to finalization " &
- "procedures that raise exceptions propagate " &
- "the exception raised. Check the utilization " &
- "of a controlled type as the actual for a " &
- "generic formal tagged private parameter" );
-
- for Act in C760010_0.Actions loop
- C760010_1.Reset_Counters;
- C760010_0.Action := Act;
-
- begin
- Check_Implicit_Initialize;
- if Act in
- C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
- Case_Failure("No exception at Check_Implicit_Initialize");
- end if;
- exception
- when Tasking_Error =>
- if Act /= C760010_0.Init_Raise_Standard then
- Case_Failure("Tasking_Error at Check_Implicit_Initialize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if Act /= C760010_0.Init_Raise_User_Defined then
- Case_Failure("User_Error at Check_Implicit_Initialize");
- end if;
- when Program_Error =>
- -- If finalize raises an exception, all other object are finalized
- -- first and Program_Error is raised upon leaving the master scope.
- -- 7.6.1:14
- if Act not in C760010_0.Fin_Raise_User_Defined..
- C760010_0.Fin_Raise_Standard then
- Case_Failure("Program_Error at Check_Implicit_Initialize");
- end if;
- when others =>
- Case_Failure("Wrong exception at Check_Implicit_Initialize");
- end;
-
- Check_Explicit_Initialize;
- Check_Explicit_Adjust;
- Check_Explicit_Finalize;
-
- C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
-
- end loop;
-
- -- Set to No_Action to avoid exception in finalizing Global_Item
- C760010_0.Action := C760010_0.No_Action;
-
- Report.Result;
-
-end C760010;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760011.a b/gcc/testsuite/ada/acats/tests/c7/c760011.a
deleted file mode 100644
index 8df37fa..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760011.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- C760011.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 anonymous objects of a controlled type associated with
--- function results and aggregates are finalized no later than the
--- end of the innermost enclosing declarative_item or statement. Also
--- check this for function calls and aggregates of a noncontrolled type
--- with controlled components.
---
--- TEST DESCRIPTION:
--- This test defines a controlled type with a discriminant, the
--- discriminant is use as an index into a global table to indicate that
--- the object has been finalized. The controlled type is used as the
--- component of a non-controlled type, and the non-controlled type is
--- used for the same set of tests. Following is a table of the tests
--- performed and their associated tag character.
---
--- 7.6(21) allows for the optimizations that remove these temporary
--- objects from ever existing. As such this test checks that in the
--- case the object was initialized (the only access we have to
--- determining if it ever existed) it must subsequently be finalized.
---
--- CASE TABLE:
--- A - aggregate test, controlled
--- B - aggregate test, controlled
--- C - aggregate test, non_controlled
--- D - function test, controlled
--- E - function test, non_controlled
--- F - formal parameter function test, controlled
--- G - formal parameter aggregate test, controlled
--- H - formal parameter function test, non_controlled
--- I - formal parameter aggregate test, non_controlled
---
--- X - scratch object, not consequential to the objective
--- Y - scratch object, not consequential to the objective
--- Z - scratch object, not consequential to the objective
---
---
--- CHANGE HISTORY:
--- 22 MAY 95 SAIC Initial version
--- 24 APR 96 SAIC Minor doc fixes, visibility patch
--- 14 NOV 96 SAIC Revised for release 2.1
---
---!
-
-------------------------------------------------------------------- C760011_0
-
-with Ada.Finalization;
-package C760011_0 is
- type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
-
- Initialized : Tracking_Array := (others => False);
- Finalized : Tracking_Array := (others => False);
-
- type Controlled_Type(Tag : Character) is
- new Ada.Finalization.Controlled with record
- TC_Component : String(1..4) := "ACVC";
- end record;
- procedure Initialize( It: in out Controlled_Type );
- procedure Finalize ( It: in out Controlled_Type );
- function Create(With_Tag: Character) return Controlled_Type;
-
- type Non_Controlled(Tag : Character := 'Y') is record
- Controlled_Component : Controlled_Type(Tag);
- end record;
- procedure Initialize( It: in out Non_Controlled );
- procedure Finalize ( It: in out Non_Controlled );
- function Create(With_Tag: Character) return Non_Controlled;
-
- Under_Debug : constant Boolean := False; -- construction lines
-
-end C760011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760011_0 is
-
- procedure Initialize( It: in out Controlled_Type ) is
- begin
- It.TC_Component := (others => It.Tag);
- if It.Tag in Tracking_Array'Range then
- Initialized(It.Tag) := True;
- end if;
- if Under_Debug then
- Report.Comment("Initializing Tag: " & It.Tag );
- end if;
- end Initialize;
-
- procedure Finalize( It: in out Controlled_Type ) is
- begin
- if Under_Debug then
- Report.Comment("Finalizing for Tag: " & It.Tag );
- end if;
- if It.Tag in Finalized'Range then
- Finalized(It.Tag) := True;
- end if;
- end Finalize;
-
- function Create(With_Tag: Character) return Controlled_Type is
- begin
- return Controlled_Type'(Ada.Finalization.Controlled
- with Tag => With_Tag,
- TC_Component => "*CON" );
- end Create;
-
- procedure Initialize( It: in out Non_Controlled ) is
- begin
- Report.Failed("Called Initialize for Non_Controlled");
- end Initialize;
-
- procedure Finalize( It: in out Non_Controlled ) is
- begin
- Report.Failed("Called Finalize for Non_Controlled");
- end Finalize;
-
- function Create(With_Tag: Character) return Non_Controlled is
- begin
- return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
- Ada.Finalization.Controlled
- with Tag => With_Tag,
- TC_Component => "#NON" ) );
- end Create;
-
-end C760011_0;
-
---------------------------------------------------------------------- C760011
-
-with Report;
-with TCTouch;
-with C760011_0;
-with Ada.Finalization; -- needed to be able to create extension aggregates
-procedure C760011 is
-
- use type C760011_0.Controlled_Type;
- use type C760011_0.Controlled_Type'Class;
- use type C760011_0.Non_Controlled;
-
- subtype AFC is Ada.Finalization.Controlled;
-
- procedure Check_Result( Tag : Character; Message : String ) is
- -- make allowance for 7.6(21) optimizations
- begin
- if C760011_0.Initialized(Tag) then
- TCTouch.Assert(C760011_0.Finalized(Tag),Message);
- elsif C760011_0.Under_Debug then
- Report.Comment("Optimized away: " & Tag );
- end if;
- end Check_Result;
-
- procedure Subtest_1 is
-
-
- procedure Subtest_1_Local_1 is
- An_Object : C760011_0.Controlled_Type'Class
- := C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
- -- initialize An_Object
- begin
- if C760011_0.Controlled_Type(An_Object)
- = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
- Report.Failed("Comparison bad"); -- A = X !!!
- end if;
- end Subtest_1_Local_1;
- -- An_Object must be Finalized by this point.
-
- procedure Subtest_1_Local_2 is
- An_Object : C760011_0.Controlled_Type('B');
- begin
- An_Object := (AFC with 'B', "TWO!" );
- if Report.Ident_Char(An_Object.Tag) /= 'B' then
- Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
- end if;
- exception
- when others => Report.Failed("Bad controlled assignment");
- end Subtest_1_Local_2;
- -- An_Object must be Finalized by this point.
-
- procedure Subtest_1_Local_3 is
- An_Object : C760011_0.Non_Controlled('C');
- begin
- TCTouch.Assert_Not(C760011_0.Finalized('C'),
- "Non_Controlled declaration C");
- An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
- => (AFC with 'C', "TEE!"));
- if Report.Ident_Char(An_Object.Tag) /= 'C' then
- Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
- end if;
- end Subtest_1_Local_3;
- -- Only controlled components of An_Object must be finalized; it is an
- -- error to call Finalize for An_Object
-
- begin
- Subtest_1_Local_1;
- Check_Result( 'A', "Aggregate in subprogram 1" );
-
- Subtest_1_Local_2;
- Check_Result( 'B', "Aggregate in subprogram 2" );
-
- Subtest_1_Local_3;
- Check_Result( 'C', "Embedded aggregate in subprogram 3" );
- end Subtest_1;
-
-
- procedure Subtest_2 is
- -- using 'Z' for both evades order issues
- Con_Object : C760011_0.Controlled_Type('Z');
- Non_Object : C760011_0.Non_Controlled('Z');
- begin
- if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
- Report.Failed("Con_Object catastrophe");
- end if;
- -- Controlled function result should be finalized by now
- Check_Result( 'D', "Function Result" );
-
- if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
- Report.Failed("Non_Object catastrophe");
- end if;
- -- Controlled component of function result should be finalized by now
- Check_Result( 'E', "Function Result" );
- end Subtest_2;
-
-
- procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
- begin
- if Con.Tag not in 'F'..'G' then
- Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
- & Report.Ident_Str(Con.TC_Component));
- end if;
- end Subtest_3;
-
-
- procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
- begin
- if Non.Tag not in 'H'..'I' then
- Report.Failed("Bad value passed to subtest 4 "
- & Non.Tag & ' '
- & Report.Ident_Str(Non.Controlled_Component.TC_Component));
- end if;
- end Subtest_4;
-
-
-begin -- Main test procedure.
-
- Report.Test ("C760011", "Check that anonymous objects of controlled " &
- "types or types containing controlled types " &
- "are finalized no later than the end of the " &
- "innermost enclosing declarative_item or " &
- "statement" );
-
- Subtest_1;
-
- Subtest_2;
-
- Subtest_3(C760011_0.Create('F'));
- Check_Result( 'F', "Function as formal F" );
-
- Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
- Check_Result( 'G', "Aggregate as formal G" );
-
- Subtest_4(C760011_0.Create('H'));
- Check_Result( 'H', "Function as formal H" );
-
- Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
- Check_Result( 'I', "Aggregate as formal I" );
-
- Report.Result;
-
-end C760011;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760012.a b/gcc/testsuite/ada/acats/tests/c7/c760012.a
deleted file mode 100644
index 08986a8..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760012.a
+++ /dev/null
@@ -1,256 +0,0 @@
--- C760012.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 record components that have per-object access discriminant
--- constraints are initialized in the order of their component
--- declarations, and after any components that are not so constrained.
---
--- Check that record components that have per-object access discriminant
--- constraints are finalized in the reverse order of their component
--- declarations, and before any components that are not so constrained.
---
--- TEST DESCRIPTION:
--- The type List_Item is the "container" type. It holds two fields that
--- have per-object access discriminant constraints, and two fields that
--- are not discriminated. These four fields are all controlled types.
--- A fifth field is a pointer used to maintain a linked list of these
--- data objects. Each component is of a unique type which allows for
--- the test to simply track the order of initialization and finalization.
---
--- The types and their purpose are:
--- Constrained_First - a controlled discriminated type
--- Constrained_Second - a controlled discriminated type
--- Simple_First - a controlled type with no discriminant
--- Simple_Second - a controlled type with no discriminant
---
--- The required order of operations:
--- Initialize
--- ( Simple_First | Simple_Second ) -- no "internal order" required
--- Constrained_First
--- Constrained_Second
--- Finalize
--- Constrained_Second
--- Constrained_First
--- ( Simple_First | Simple_Second ) -- must be inverse of init.
---
---
--- CHANGE HISTORY:
--- 23 MAY 95 SAIC Initial version
--- 02 MAY 96 SAIC Reorganized for 2.1
--- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check
--- 31 DEC 97 EDS Remove references to and uses of
--- Initialization_Sequence
---!
-
----------------------------------------------------------------- C760012_0
-
-with Ada.Finalization;
-with Ada.Unchecked_Deallocation;
-package C760012_0 is
-
- type List_Item;
-
- type List is access all List_Item;
-
- package Firsts is -- distinguish first from second
- type Constrained_First(Container : access List_Item) is
- new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize( T : in out Constrained_First );
- procedure Finalize ( T : in out Constrained_First );
-
- type Simple_First is new Ada.Finalization.Controlled with
- record
- My_Init_Seq_Number : Natural;
- end record;
- procedure Initialize( T : in out Simple_First );
- procedure Finalize ( T : in out Simple_First );
-
- end Firsts;
-
- type Constrained_Second(Container : access List_Item) is
- new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize( T : in out Constrained_Second );
- procedure Finalize ( T : in out Constrained_Second );
-
- type Simple_Second is new Ada.Finalization.Controlled with
- record
- My_Init_Seq_Number : Natural;
- end record;
- procedure Initialize( T : in out Simple_Second );
- procedure Finalize ( T : in out Simple_Second );
-
- -- by 3.8(18);6.0 the following type contains components constrained
- -- by per-object expressions
-
-
- type List_Item is new Ada.Finalization.Limited_Controlled
- with record
- ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
- SimpleA : Firsts.Simple_First; -- A T
- SimpleB : Simple_Second; -- A T
- ContentB : Constrained_Second( List_Item'Access ); -- D R
- Next : List; -- | |
- end record; -- | |
- procedure Initialize( L : in out List_Item ); ------------------+ |
- procedure Finalize ( L : in out List_Item ); --------------------+
-
- -- the tags are the same for SimpleA and SimpleB due to the fact that
- -- the language does not specify an ordering with respect to this
- -- component pair. 7.6(12) does specify the rest of the ordering.
-
- procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
-
-end C760012_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C760012_0 is
-
- package body Firsts is
-
- procedure Initialize( T : in out Constrained_First ) is
- begin
- TCTouch.Touch('C'); ----------------------------------------------- C
- end Initialize;
-
- procedure Finalize ( T : in out Constrained_First ) is
- begin
- TCTouch.Touch('S'); ----------------------------------------------- S
- end Finalize;
-
- procedure Initialize( T : in out Simple_First ) is
- begin
- T.My_Init_Seq_Number := 0;
- TCTouch.Touch('A'); ----------------------------------------------- A
- end Initialize;
-
- procedure Finalize ( T : in out Simple_First ) is
- begin
- TCTouch.Touch('T'); ----------------------------------------------- T
- end Finalize;
-
- end Firsts;
-
- procedure Initialize( T : in out Constrained_Second ) is
- begin
- TCTouch.Touch('D'); ------------------------------------------------- D
- end Initialize;
-
- procedure Finalize ( T : in out Constrained_Second ) is
- begin
- TCTouch.Touch('R'); ------------------------------------------------- R
- end Finalize;
-
-
- procedure Initialize( T : in out Simple_Second ) is
- begin
- T.My_Init_Seq_Number := 0;
- TCTouch.Touch('A'); ------------------------------------------------- A
- end Initialize;
-
- procedure Finalize ( T : in out Simple_Second ) is
- begin
- TCTouch.Touch('T'); ------------------------------------------------- T
- end Finalize;
-
- procedure Initialize( L : in out List_Item ) is
- begin
- TCTouch.Touch('F'); ------------------------------------------------- F
- end Initialize;
-
- procedure Finalize ( L : in out List_Item ) is
- begin
- TCTouch.Touch('Q'); ------------------------------------------------- Q
- end Finalize;
-
-end C760012_0;
-
---------------------------------------------------------------------- C760012
-
-with Report;
-with TCTouch;
-with C760012_0;
-procedure C760012 is
-
- use type C760012_0.List;
-
- procedure Subtest_1 is
- -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
- -- 7.6.1(9);6.0 dictates the order of finalization of the components
-
- One_Of_Them : C760012_0.List_Item;
- begin
- if One_Of_Them.Next /= null then -- just to hold the subtest in place
- Report.Failed("No default value for Next");
- end if;
- end Subtest_1;
-
- List : C760012_0.List;
-
- procedure Subtest_2 is
- begin
-
- List := new C760012_0.List_Item;
-
- List.Next := new C760012_0.List_Item;
-
- end Subtest_2;
-
- procedure Subtest_3 is
- begin
-
- C760012_0.Deallocate( List.Next );
-
- C760012_0.Deallocate( List );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("C760012", "Check that record components that have " &
- "per-object access discriminant constraints " &
- "are initialized in the order of their " &
- "component declarations, and after any " &
- "components that are not so constrained. " &
- "Check that record components that have " &
- "per-object access discriminant constraints " &
- "are finalized in the reverse order of their " &
- "component declarations, and before any " &
- "components that are not so constrained" );
-
- Subtest_1;
- TCTouch.Validate("AACDFQRSTT", "One object");
-
- Subtest_2;
- TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
-
- Subtest_3;
- TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
-
- Report.Result;
-
-end C760012;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760013.a b/gcc/testsuite/ada/acats/tests/c7/c760013.a
deleted file mode 100644
index 6921bf0..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760013.a
+++ /dev/null
@@ -1,108 +0,0 @@
--- C760013.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Initialize is not called for default-initialized subcomponents
--- of the ancestor type of an extension aggregate. (Defect Report
--- 8652/0021, Technical Corrigendum 7.6(11/1)).
---
--- CHANGE HISTORY:
--- 25 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C760013_0 is
-
- type Ctrl1 is new Controlled with
- record
- C : Integer := 0;
- end record;
- type Ctrl2 is new Controlled with
- record
- C : Integer := 0;
- end record;
-
- procedure Initialize (Obj1 : in out Ctrl1);
- procedure Initialize (Obj2 : in out Ctrl2);
-
-end C760013_0;
-
-with Report;
-use Report;
-package body C760013_0 is
-
- procedure Initialize (Obj1 : in out Ctrl1) is
- begin
- Obj1.C := Ident_Int (47);
- end Initialize;
-
- procedure Initialize (Obj2 : in out Ctrl2) is
- begin
- Failed ("Initialize called for type Ctrl2");
- end Initialize;
-
-end C760013_0;
-
-with Ada.Finalization;
-with C760013_0;
-use C760013_0;
-with Report;
-use Report;
-procedure C760013 is
-
- type T is tagged
- record
- C1 : Ctrl1;
- C2 : Ctrl2 := (Ada.Finalization.Controlled with
- C => Ident_Int (23));
- end record;
-
- type Nt is new T with
- record
- C3 : Float;
- end record;
-
- X : Nt;
-
-begin
- Test ("C760013",
- "Check that Initialize is not called for " &
- "default-initialized subcomponents of the ancestor type of an " &
- "extension aggregate");
-
- X := (T with C3 => 5.0);
-
- if X.C1.C /= Ident_Int (47) then
- Failed ("Initialize not called for type Ctrl1");
- end if;
- if X.C2.C /= Ident_Int (23) then
- Failed ("Initial value not assigned for type Ctrl2");
- end if;
-
- Result;
-end C760013;
-
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761001.a b/gcc/testsuite/ada/acats/tests/c7/c761001.a
deleted file mode 100644
index 7be1ee0..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761001.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- C761001.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 controlled objects declared immediately within a library
--- package are finalized following the completion of the environment
--- task (and prior to termination of the program).
---
--- TEST DESCRIPTION:
--- This test derives a type from Ada.Finalization.Controlled, and
--- declares an object of that type in the body of a library package.
--- The dispatching procedure Finalize is redefined for the derived
--- type to perform a check that it has been called only once, and in
--- turn calls Report.Result. This test may fail by not calling
--- Report.Result. This test may also fail by calling Report.Result
--- twice, the first call will report a false pass.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-with Ada.Finalization;
-package C761001_0 is
-
- type Global is new Ada.Finalization.Controlled with null record;
- procedure Finalize( It: in out Global );
-
-end C761001_0;
-
-package C761001_1 is
-
- task Library_Task is
- entry Never_Called;
- end Library_Task;
-
-end C761001_1;
-
-with Report;
-with C761001_1;
-package body C761001_0 is
-
- My_Object : Global;
-
- Done : Boolean := False;
-
- procedure Finalize( It: in out Global ) is
- begin
- if not C761001_1.Library_Task'Terminated then
- Report.Failed("Library task not terminated before finalize");
- end if;
- if Done then -- checking included "just in case"
- Report.Comment("Test FAILED, even if previously reporting passed");
- Report.Failed("Unwarranted multiple call to finalize");
- end if;
- Report.Result;
- Done := True;
- end Finalize;
-
-end C761001_0;
-
-with Report;
-package body C761001_1 is
-
- task body Library_Task is
- begin
- if Report.Ident_Int( 1 ) /= 1 then
- Report.Failed( "Baseline failure in Library_Task");
- end if;
- end Library_Task;
-
-end C761001_1;
-
-with Report;
-with C761001_0;
-
-procedure C761001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C761001", "Check that controlled objects declared "
- & "immediately within a library package are "
- & "finalized following the completion of the "
- & "environment task (and prior to termination "
- & "of the program)");
-
- -- note that if the test DOES call report twice, the first will report a
- -- false pass, the second call will correctly fail the test.
-
- -- not calling Report.Result;
- -- Result is called as part of the finalization of C761001_0.My_Object.
-
-end C761001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761002.a b/gcc/testsuite/ada/acats/tests/c7/c761002.a
deleted file mode 100644
index 5b807bb..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761002.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- C761002.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 objects of a controlled type that are created
--- by an allocator are finalized at the appropriate time. In
--- particular, check that such objects are not finalized due to
--- completion of the master in which they were allocated if the
--- corresponding access type is declared outside of that master.
---
--- Check that Unchecked_Deallocation of a controlled
--- object causes finalization of that object.
---
--- TEST DESCRIPTION:
--- This test derives a type from Ada.Finalization.Controlled, and
--- declares access types to that type in various scope scenarios.
--- The dispatching procedure Finalize is redefined for the derived
--- type to perform a check that it has been called at the
--- correct time. This is accomplished using a global variable
--- which indicates what state the software is currently
--- executing. The test utilizes the TCTouch facilities to
--- verify that Finalize is called the correct number of times, at
--- the correct times. Several calls are made to validate passing
--- the null string to check that Finalize has NOT been called at
--- that point.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Finalization;
-package C761002_0 is
- type Global is new Ada.Finalization.Controlled with null record;
- procedure Finalize( It: in out Global );
-
- type Second is new Ada.Finalization.Limited_Controlled with null record;
- procedure Finalize( It: in out Second );
-end C761002_0;
-
-with Report;
-with TCTouch;
-package body C761002_0 is
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch('F'); ------------------------------------------------- F
- end Finalize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch('S'); ------------------------------------------------- S
- end Finalize;
-end C761002_0;
-
-with Report;
-with TCTouch;
-with C761002_0;
-with Unchecked_Deallocation;
-procedure C761002 is
-
- -- check the straightforward case
- procedure Subtest_1 is
- type Access_1 is access C761002_0.Global;
- V1 : Access_1;
- procedure Allocate is
- V2 : Access_1;
- begin
- V2 := new C761002_0.Global;
- V1 := V2; -- "dead" assignment must not be optimized away due to
- -- finalization "side effects", many more of these follow
- end Allocate;
- begin
- Allocate;
- -- no calls to Finalize should have occurred at this point
- TCTouch.Validate("","Allocated nested, retained");
- end Subtest_1;
-
- -- check Unchecked_Deallocation
- procedure Subtest_2 is
- type Access_2 is access C761002_0.Global;
- procedure Free is
- new Unchecked_Deallocation(C761002_0.Global, Access_2);
- V1 : Access_2;
- V2 : Access_2;
-
- procedure Allocate is
- begin
- V1 := new C761002_0.Global;
- V2 := new C761002_0.Global;
- end Allocate;
-
- begin
- Allocate;
- -- no calls to Finalize should have occurred at this point.
- TCTouch.Validate("","Allocated nested, non-local");
-
- Free(V1); -- instance of Unchecked_Deallocation
- -- should cause the finalization of V1.all
- TCTouch.Validate("F","Unchecked Deallocation");
- end Subtest_2; -- leaving this scope should cause the finalization of V2.all
-
- -- check various master-exit scenarios
- -- the "Fake" parameters are used to avoid unwanted optimizations
- procedure Subtest_3 is
- procedure With_Local_Block is
- type Access_3 is access C761002_0.Global;
- V1 : Access_3;
- begin
- declare
- V2 : Access_3 := new C761002_0.Global;
- begin
- V1 := V2;
- end;
- TCTouch.Validate("","Local Block, normal exit");
- -- the allocated object should be finalized on leaving this scope
- end With_Local_Block;
-
- procedure With_Local_Block_Return(Fake: Integer) is
- type Access_4 is access C761002_0.Global;
- V1 : Access_4 := new C761002_0.Global;
- begin
- if Fake = 0 then
- declare
- V2 : Access_4;
- begin
- V2 := new C761002_0.Global;
- return; -- the two allocated objects should be finalized
- end; -- upon leaving this scope
- else
- V1 := null;
- end if;
- end With_Local_Block_Return;
-
- procedure With_Goto(Fake: Integer) is
- type Access_5 is access C761002_0.Global;
- V1 : Access_5 := new C761002_0.Global;
- V2 : Access_5;
- V3 : Access_5;
- begin
- if Fake = 0 then
- declare
- type Access_6 is access C761002_0.Second;
- V6 : Access_6;
- begin
- V6 := new C761002_0.Second;
- goto check;
- end;
- else
- V2 := V1;
- end if;
- V3 := V2;
-<<check>>
- TCTouch.Validate("S","goto past master end");
- end With_Goto;
-
- begin
- With_Local_Block;
- TCTouch.Validate("F","Local Block, normal exit, after master");
-
- With_Local_Block_Return( Report.Ident_Int(0) );
- TCTouch.Validate("FF","Local Block, return from block");
-
- With_Goto( Report.Ident_Int(0) );
- TCTouch.Validate("F","With Goto");
-
- end Subtest_3;
-
- procedure Subtest_4 is
-
- Oops : exception;
-
- procedure Alley( Fake: Integer ) is
- type Access_1 is access C761002_0.Global;
- V1 : Access_1;
- begin
- V1 := new C761002_0.Global;
- if Fake = 1 then
- raise Oops;
- end if;
- V1 := null;
- end Alley;
-
- begin
- Catch: begin
- Alley( Report.Ident_Int(1) );
- exception
- when Oops => TCTouch.Validate("F","leaving via exception");
- when others => Report.Failed("Wrong exception");
- end Catch;
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761002", "Check that objects of a controlled type created "
- & "by an allocator are finalized appropriately. "
- & "Check that Unchecked_Deallocation of a "
- & "controlled object causes finalization "
- & "of that object" );
-
- Subtest_1;
- -- leaving the scope of the access type should finalize the
- -- collection
- TCTouch.Validate("F","Allocated nested, Subtest 1");
-
- Subtest_2;
- -- Unchecked_Deallocation already finalized one of the two
- -- objects allocated, the other should be the only one finalized
- -- at leaving the scope of the access type.
- TCTouch.Validate("F","Allocated non-local");
-
- Subtest_3;
- -- there should be no remaining finalizations from this subtest
- TCTouch.Validate("","Localized objects");
-
- Subtest_4;
- -- there should be no remaining finalizations from this subtest
- TCTouch.Validate("","Exception testing");
-
- Report.Result;
-
-end C761002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761003.a b/gcc/testsuite/ada/acats/tests/c7/c761003.a
deleted file mode 100644
index 77051ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761003.a
+++ /dev/null
@@ -1,447 +0,0 @@
--- C761003.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 object of a controlled type is finalized when the
--- enclosing master is complete.
--- Check this for controlled types where the derived type has a
--- discriminant.
--- Check this for subprograms of abstract types derived from the
--- types in Ada.Finalization.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then type are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC ACVC 2.0.1
---
---!
-
------------------------------------------------------------- C761003_Support
-
-package C761003_Support is
-
- function Pick_Char return Character;
- -- successive calls to Pick_Char return distinct characters which may
- -- be assigned to objects to track an order sequence. These characters
- -- are then used in calls to TCTouch.Touch.
-
- procedure Validate(Initcount : Natural;
- Testnumber : Natural;
- Check_Order : Boolean := True);
- -- does a little extra processing prior to calling TCTouch.Validate,
- -- specifically, it reverses the stored string of characters, and checks
- -- for a correct count.
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761003_Support;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C761003_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- begin
- for SI in reverse S'Range loop
- T(S'Last - SI + 1) := S(SI);
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount : Natural;
- Testnumber : Natural;
- Check_Order : Boolean := True) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected"
- & Natural'Image(Initcount) & ", Subtest " & Number);
- TCTouch.Flush;
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, Order_Meaningful => Check_Order );
- end if;
- Inits_Called := 0; -- reset for the next batch
- end Validate;
-
-end C761003_Support;
-
------------------------------------------------------------------- C761003_0
-
-with Ada.Finalization;
-package C761003_0 is
-
- type Global(Tag: Character) is new Ada.Finalization.Controlled
- with null record;
-
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1');
-
- type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled
- with null record;
-
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761003_0;
-
------------------------------------------------------------------- C761003_1
-
-with Ada.Finalization;
-package C761003_1 is
-
- type Global is abstract new Ada.Finalization.Controlled with record
- Tag: Character;
- end record;
-
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- type Second is abstract new Ada.Finalization.Limited_Controlled with record
- Tag: Character;
- end record;
-
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761003_1;
-
------------------------------------------------------------------- C761003_2
-
-with C761003_1;
-package C761003_2 is
-
- type Global is new C761003_1.Global with null record;
- -- inherits Initialize and Finalize
-
- type Second is new C761003_1.Second with null record;
- -- inherits Initialize and Finalize
-
-end C761003_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0
-
-with TCTouch;
-with C761003_Support;
-package body C761003_0 is
-
- package Sup renames C761003_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
-end C761003_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1
-
-with TCTouch;
-with C761003_Support;
-package body C761003_1 is
-
- package Sup renames C761003_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
-end C761003_1;
-
--------------------------------------------------------------------- C761003
-
-with Report;
-with TCTouch;
-with C761003_0;
-with C761003_2;
-with C761003_Support;
-procedure C761003 is
-
- package Sup renames C761003_Support;
-
----------------------------------------------------------------- Subtest_1
-
- Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous
-
- procedure Subtest_1 is
-
- -- the constant will take its constraint from the value.
- -- must be declared first to be finalized last (and take the
- -- initialize from before calling subtest_1)
- Item_1 : constant C761003_0.Global := C761003_0.Null_Global;
-
- -- Item_2, declared second, should be finalized second to last.
- Item_2 : C761003_0.Global(Sup.Pick_Char);
-
- -- Item_3 and Item_4 will be created in the order of the
- -- list.
- Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char);
-
- -- Item_5 will be finalized first.
- Item_5 : C761003_0.Second(Sup.Pick_Char);
-
- begin
- if Item_3.Tag >= Item_4.Tag then
- Report.Failed("Controlled objects created by list in wrong order");
- end if;
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 1 body");
- end Subtest_1;
-
----------------------------------------------------------------- Subtest_2
-
- -- These declarations should cause calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types. Note that for these objects, the
- -- Initialize and Finalize are visible only by inheritance.
-
- Subtest_2_Inits_Expected : constant := 4;
-
- procedure Subtest_2 is
-
- Item_1 : C761003_2.Global;
- Item_2, Item_3 : C761003_2.Global;
- Item_4 : C761003_2.Second;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 2 body");
- end Subtest_2;
-
----------------------------------------------------------------- Subtest_3
-
- -- Test for controlled objects embedded in arrays. Using structures
- -- that will cause a checkable order.
-
- Subtest_3_Inits_Expected : constant := 8;
-
- procedure Subtest_3 is
-
- type Global_List is array(Natural range <>)
- of C761003_0.Global(Sup.Pick_Char);
-
- Items : Global_List(1..4); -- components have the same tag
-
- type Second_List is array(Natural range <>)
- of C761003_0.Second(Sup.Pick_Char);
-
- Second_Items : Second_List(1..4); -- components have the same tag,
- -- distinct from the tag used in Items
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 3 body");
- end Subtest_3;
-
----------------------------------------------------------------- Subtest_4
-
- -- These declarations should cause dispatching calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
-
- Subtest_4_Inits_Expected : constant := 2;
-
- procedure Subtest_4 is
-
- type Global_Rec is record
- Item1: C761003_0.Global(Sup.Pick_Char);
- end record;
-
- type Second_Rec is record
- Item2: C761003_2.Second;
- end record;
-
- G : Global_Rec;
- S : Second_Rec;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 4 body");
- end Subtest_4;
-
----------------------------------------------------------------- Subtest_5
-
- -- Test for controlled objects embedded in arrays. In these cases, the
- -- order of the finalization of the components is not defined by the
- -- language.
-
- Subtest_5_Inits_Expected : constant := 8;
-
- procedure Subtest_5 is
-
-
- type Another_Global_List is array(Natural range <>)
- of C761003_2.Global;
-
- More_Items : Another_Global_List(1..4);
-
- type Another_Second_List is array(Natural range <>)
- of C761003_2.Second;
-
- Second_More_Items : Another_Second_List(1..4);
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 5 body");
- end Subtest_5;
-
----------------------------------------------------------------- Subtest_6
-
- -- These declarations should cause dispatching calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
-
- Subtest_6_Inits_Expected : constant := 2;
-
- procedure Subtest_6 is
-
- type Global_Rec is record
- Item2: C761003_2.Global;
- end record;
-
- type Second_Rec is record
- Item1: C761003_0.Second(Sup.Pick_Char);
- end record;
-
- G : Global_Rec;
- S : Second_Rec;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 6 body");
- end Subtest_6;
-
-begin -- Main test procedure.
-
- Report.Test ("C761003", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- -- adjust for optional adjusts and initializes for C761003_0.Null_Global
- TCTouch.Flush; -- clear the optional adjust
- if Sup.Inits_Called /= 1 then
- -- C761003_0.Null_Global did not get "initialized"
- C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump
- end if;
-
- Subtest_1;
- Sup.Validate(Subtest_1_Inits_Expected, 1);
-
- Subtest_2;
- Sup.Validate(Subtest_2_Inits_Expected, 2);
-
- Subtest_3;
- Sup.Validate(Subtest_3_Inits_Expected, 3);
-
- Subtest_4;
- Sup.Validate(Subtest_4_Inits_Expected, 4);
-
- Subtest_5;
- Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False);
-
- Subtest_6;
- Sup.Validate(Subtest_6_Inits_Expected, 6);
-
- Report.Result;
-
-end C761003;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761004.a b/gcc/testsuite/ada/acats/tests/c7/c761004.a
deleted file mode 100644
index 9b88382..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761004.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- C761004.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 object of a controlled type is finalized with the
--- enclosing master is complete.
--- Check that finalization occurs in the case where the master is
--- left by a transfer of control.
--- Specifically check for types where the derived types do not have
--- discriminants.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then they are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package C761004_Support is
-
- function Pick_Char return Character;
- -- successive calls to Pick_Char return distinct characters which may
- -- be assigned to objects to track an order sequence. These characters
- -- are then used in calls to TCTouch.Touch.
-
- procedure Validate(Initcount: Natural; Testnumber:Natural);
- -- does a little extra processing prior to calling TCTouch.Validate,
- -- specifically, it reverses the stored string of characters, and checks
- -- for a correct count.
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761004_Support;
-
-with Report;
-with TCTouch;
-package body C761004_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- TI: Positive := 1;
- begin
- for SI in reverse S'Range loop
- T(TI) := S(SI);
- TI := TI +1;
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount: Natural; Testnumber:Natural) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Wrong number of inits, Subtest " & Number);
- TCTouch.Flush;
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, True);
- end if;
- end Validate;
-
-end C761004_Support;
-
------------------------------------------------------------------ C761004_0
-
-with Ada.Finalization;
-package C761004_0 is
- type Global is new Ada.Finalization.Controlled with record
- Tag : Character;
- end record;
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- type Second is new Ada.Finalization.Limited_Controlled with record
- Tag : Character;
- end record;
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761004_0;
-
-with TCTouch;
-with C761004_Support;
-package body C761004_0 is
-
- package Sup renames C761004_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-end C761004_0;
-
-------------------------------------------------------------------- C761004
-
-with Report;
-with TCTouch;
-with C761004_0;
-with C761004_Support;
-with Ada.Finalization; -- needed to be able to create extension aggregates
-procedure C761004 is
-
- Verbose : constant Boolean := False;
-
- package Sup renames C761004_Support;
-
- -- Subtest 1, general case. Check that several objects declared in a
- -- subprogram are created, and finalized in opposite order.
-
- Subtest_1_Expected_Inits : constant := 3;
-
- procedure Subtest_1 is
- Item_1 : C761004_0.Global;
- Item_2, Item_3 : C761004_0.Global;
- begin
- if Item_2.Tag = Item_3.Tag then -- not germane to the test
- Report.Failed("Duplicate tag");-- but helps prevent code elimination
- end if;
- end Subtest_1;
-
- -- Subtest 2, extension of the general case. Check that several objects
- -- created identically on the stack (via a recursive procedure) are
- -- finalized in the opposite order of their creation.
- Subtest_2_Expected_Inits : constant := 12;
- User_Exception : exception;
-
- procedure Subtest_2 is
-
- Item_1 : C761004_0.Global;
-
- -- combine recursion and exit by exception:
-
- procedure Nested(Recurs: Natural) is
- Item_3 : C761004_0.Global;
- begin
- if Verbose then
- Report.Comment("going in: " & Item_3.Tag);
- end if;
- if Recurs = 1 then
- raise User_Exception;
- else
- Nested(Recurs -1);
- end if;
- end Nested;
-
- Item_2 : C761004_0.Global;
-
- begin
- Nested(10);
- end Subtest_2;
-
- -- subtest 3, check the case of objects embedded in structures:
- -- an array
- -- a record
- Subtest_3_Expected_Inits : constant := 3;
- procedure Subtest_3 is
- type G_List is array(Positive range <>) of C761004_0.Global;
- type Pandoras_Box is record
- G : G_List(1..1);
- end record;
-
- procedure Nested(Recursions: Natural) is
- Merlin : Pandoras_Box;
- begin
- if Recursions > 1 then
- Nested(Recursions-1);
- else
- TCTouch.Validate("","Final Nested call");
- end if;
- end Nested;
-
- begin
- Nested(3);
- end Subtest_3;
-
- -- subtest 4, check the case of objects embedded in structures:
- -- an array
- -- a record
- Subtest_4_Expected_Inits : constant := 3;
- procedure Subtest_4 is
- type S_List is array(Positive range <>) of C761004_0.Second;
- type Pandoras_Box is record
- S : S_List(1..1);
- end record;
-
- procedure Nested(Recursions: Natural) is
- Merlin : Pandoras_Box;
- begin
- if Recursions > 1 then
- Nested(Recursions-1);
- else
- TCTouch.Validate("","Final Nested call");
- end if;
- end Nested;
-
- begin
- Nested(3);
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761004", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- Subtest_1;
- Sup.Validate(Subtest_1_Expected_Inits,1);
-
- Subtest_2_Frame: begin
- Sup.Inits_Called := 0;
- Subtest_2;
- exception
- when User_Exception => null;
- when others => Report.Failed("Wrong Exception, Subtest 2");
- end Subtest_2_Frame;
- Sup.Validate(Subtest_2_Expected_Inits,2);
-
- Sup.Inits_Called := 0;
- Subtest_3;
- Sup.Validate(Subtest_3_Expected_Inits,3);
-
- Sup.Inits_Called := 0;
- Subtest_4;
- Sup.Validate(Subtest_4_Expected_Inits,4);
-
- Report.Result;
-
-end C761004;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761005.a b/gcc/testsuite/ada/acats/tests/c7/c761005.a
deleted file mode 100644
index acac59b..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761005.a
+++ /dev/null
@@ -1,288 +0,0 @@
--- C761005.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 deriving abstract types from the types in Ada.Finalization
--- does not negatively impact the implicit operations.
--- Check that an object of a controlled type is finalized when the
--- enclosing master is complete.
--- Check that finalization occurs in the case where the master is
--- left by a transfer of control.
--- Check this for controlled types where the derived type has a
--- discriminant.
--- Check this for cases where the type is defined as private,
--- and the full type is derived from the types in Ada.Finalization.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then type are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package C761005_Support is
-
- function Pick_Char return Character;
- procedure Validate(Initcount: Natural; Testnumber:Natural);
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761005_Support;
-
-with Report;
-with TCTouch;
-package body C761005_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- TI: Positive := 1;
- begin
- for SI in reverse S'Range loop
- T(TI) := S(SI);
- TI := TI +1;
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount: Natural; Testnumber:Natural) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Wrong number of inits, Subtest " & Number);
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, True);
- end if;
- Inits_Called := 0;
- end Validate;
-
-end C761005_Support;
-
------------------------------------------------------------------------------
-with Ada.Finalization;
-package C761005_0 is
- type Final_Root(Tag: Character) is private;
-
- type Ltd_Final_Root(Tag: Character) is limited private;
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-private
- type Final_Root(Tag: Character) is new Ada.Finalization.Controlled
- with null record;
- procedure Initialize( It: in out Final_Root );
- procedure Finalize ( It: in out Final_Root );
-
- type Ltd_Final_Root(Tag: Character) is new
-Ada.Finalization.Limited_Controlled
- with null record;
- procedure Initialize( It: in out Ltd_Final_Root );
- procedure Finalize ( It: in out Ltd_Final_Root );
-end C761005_0;
-
------------------------------------------------------------------------------
-with Ada.Finalization;
-package C761005_1 is
- type Final_Abstract is abstract tagged private;
-
- type Ltd_Final_Abstract_Child is abstract tagged limited private;
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-private
- type Final_Abstract is abstract new Ada.Finalization.Controlled with record
- Tag: Character;
- end record;
- procedure Initialize( It: in out Final_Abstract );
- procedure Finalize ( It: in out Final_Abstract );
-
- type Ltd_Final_Abstract_Child is
- abstract new Ada.Finalization.Limited_Controlled with record
- Tag: Character;
- end record;
- procedure Initialize( It: in out Ltd_Final_Abstract_Child );
- procedure Finalize ( It: in out Ltd_Final_Abstract_Child );
-
-end C761005_1;
-
------------------------------------------------------------------------------
-with C761005_1;
-package C761005_2 is
-
- type Final_Child is new C761005_1.Final_Abstract with null record;
- type Ltd_Final_Child is
- new C761005_1.Ltd_Final_Abstract_Child with null record;
-
-end C761005_2;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_Support;
-package body C761005_0 is
-
- package Sup renames C761005_Support;
-
- procedure Initialize( It: in out Final_Root ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Final_Root ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-
- procedure Initialize( It: in out Ltd_Final_Root ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Ltd_Final_Root ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-end C761005_0;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_Support;
-package body C761005_1 is
-
- package Sup renames C761005_Support;
-
- procedure Initialize( It: in out Final_Abstract ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Final_Abstract ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-
- procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-end C761005_1;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_0;
-with C761005_2;
-with C761005_Support;
-procedure C761005 is
-
- package Sup renames C761005_Support;
-
- Subtest_1_Inits_Expected : constant := 4;
- procedure Subtest_1 is
- Item_1 : C761005_0.Final_Root(Sup.Pick_Char);
- Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char);
- Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char);
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 1 body");
- end Subtest_1;
-
- -- These declarations should cause calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
- Subtest_2_Inits_Expected : constant := 4;
- procedure Subtest_2 is
- Item_1 : C761005_2.Final_Child;
- Item_2, Item_3 : C761005_2.Final_Child;
- Item_4 : C761005_2.Ltd_Final_Child;
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 2 body");
- end Subtest_2;
-
-begin -- Main test procedure.
-
- Report.Test ("C761005", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- Subtest_1;
- Sup.Validate(Subtest_1_Inits_Expected,1);
-
- Subtest_2;
- Sup.Validate(Subtest_2_Inits_Expected,2);
-
- Report.Result;
-
-end C761005;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761006.a b/gcc/testsuite/ada/acats/tests/c7/c761006.a
deleted file mode 100644
index 5cf4d89..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761006.a
+++ /dev/null
@@ -1,446 +0,0 @@
--- C761006.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 Program_Error is raised when:
--- * an exception is raised if Finalize invoked as part of an
--- assignment operation; or
--- * an exception is raised if Adjust invoked as part of an assignment
--- operation, after any other adjustment due to be performed are
--- performed; or
--- * an exception is raised if Finalize invoked as part of a call on
--- Unchecked_Deallocation, after any other finalizations to be
--- performed are performed.
---
--- TEST DESCRIPTION:
--- This test defines these four controlled types:
--- Good
--- Bad_Initialize
--- Bad_Adjust
--- Bad_Finalize
--- The type name conveys the associated failure. The operations in type
--- good will "touch" the boolean array indicating correct path
--- utilization for the purposes of checking "other <operations> are
--- performed", where <operations> ::= initialization, adjusting, and
--- finalization
---
---
---
--- CHANGE HISTORY:
--- 12 APR 94 SAIC Initial version
--- 02 MAY 96 SAIC Visibility fixed for 2.1
--- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286
--- 01 DEC 97 EDS Made correction wrt RM 7.6(21)
--- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with
--- RM 7.6.1(16/1) from Technical Corrigendum 1.
--- 05 JUL 12 RLB Redid Unchecked_Deallocation case to handle
--- the fact that the behavior is unspecified (see
--- AI95-0179-1). Also fixed indentation.
---
---!
-
-------------------------------------------------------------- C761006_Support
-
-package C761006_Support is
-
- type Events is ( Good_Initialize, Good_Adjust, Good_Finalize );
-
- type Event_Array is array(Events) of Boolean;
-
- Events_Occurring : Event_Array := (others => False);
-
- Propagating_Exception : exception;
-
- procedure Raise_Propagating_Exception(Do_It: Boolean);
-
- function Unique_Value return Natural;
-
-end C761006_Support;
-
-------------------------------------------------------------- C761006_Support
-
-with Report;
-package body C761006_Support is
-
- procedure Raise_Propagating_Exception(Do_It: Boolean) is
- begin
- if Report.Ident_Bool(Do_It) then
- raise Propagating_Exception;
- end if;
- end Raise_Propagating_Exception;
-
- Seed : Natural := 0;
-
- function Unique_Value return Natural is
- begin
- Seed := Seed +1;
- return Seed;
- end Unique_Value;
-
-end C761006_Support;
-
-------------------------------------------------------------------- C761006_0
-
-with Ada.Finalization;
-with C761006_Support;
-package C761006_0 is
-
- type Good is new Ada.Finalization.Controlled
- with record
- Initialized : Boolean := False;
- Adjusted : Boolean := False;
- Unique : Natural := C761006_Support.Unique_Value;
- end record;
-
- procedure Initialize( It: in out Good );
- procedure Adjust ( It: in out Good );
- procedure Finalize ( It: in out Good );
-
- type Bad_Initialize is private;
-
- type Bad_Adjust is private;
-
- type Bad_Finalize is private;
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-private
- type Bad_Initialize is new Ada.Finalization.Controlled
- with null record;
- procedure Initialize( It: in out Bad_Initialize );
-
- type Bad_Adjust is new Ada.Finalization.Controlled
- with null record;
- procedure Adjust ( It: in out Bad_Adjust );
-
- type Bad_Finalize is
- new Ada.Finalization.Controlled with null record;
- procedure Finalize ( It: in out Bad_Finalize );
-end C761006_0;
-
-------------------------------------------------------------------- C761006_1
-
-with Ada.Finalization;
-with C761006_0;
-package C761006_1 is
-
- type Init_Check_Root is new Ada.Finalization.Controlled with record
- Good_Component : C761006_0.Good;
- Init_Fails : C761006_0.Bad_Initialize;
- end record;
-
- type Adj_Check_Root is new Ada.Finalization.Controlled with record
- Good_Component : C761006_0.Good;
- Adj_Fails : C761006_0.Bad_Adjust;
- end record;
-
- type Fin_Check_Root is new Ada.Finalization.Controlled with record
- Good_Component : C761006_0.Good;
- Fin_Fails : C761006_0.Bad_Finalize;
- end record;
-
-end C761006_1;
-
-------------------------------------------------------------------- C761006_2
-
-with C761006_1;
-package C761006_2 is
-
- type Init_Check is new C761006_1.Init_Check_Root with null record;
- type Adj_Check is new C761006_1.Adj_Check_Root with null record;
- type Fin_Check is new C761006_1.Fin_Check_Root with null record;
-
-end C761006_2;
-
-------------------------------------------------------------------- C761006_0
-
-with Report;
-with C761006_Support;
-package body C761006_0 is
-
- package Sup renames C761006_Support;
-
- procedure Initialize( It: in out Good ) is
- begin
- Sup.Events_Occurring( Sup.Good_Initialize ) := True;
- It.Initialized := True;
- end Initialize;
-
- procedure Adjust ( It: in out Good ) is
- begin
- Sup.Events_Occurring( Sup.Good_Adjust ) := True;
- It.Adjusted := True;
- It.Unique := C761006_Support.Unique_Value;
- end Adjust;
-
- procedure Finalize ( It: in out Good ) is
- begin
- Sup.Events_Occurring( Sup.Good_Finalize ) := True;
- end Finalize;
-
- procedure Initialize( It: in out Bad_Initialize ) is
- begin
- Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
- end Initialize;
-
- procedure Adjust( It: in out Bad_Adjust ) is
- begin
- Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
- end Adjust;
-
- procedure Finalize( It: in out Bad_Finalize ) is
- begin
- Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
- end Finalize;
-
-end C761006_0;
-
---------------------------------------------------------------------- C761006
-
-with Report;
-with C761006_0;
-with C761006_2;
-with C761006_Support;
-with Ada.Exceptions;
-with Ada.Finalization;
-with Unchecked_Deallocation;
-procedure C761006 is
-
- package Sup renames C761006_Support;
- use type Sup.Event_Array;
-
- type Procedure_Handle is access procedure;
-
- type Test_ID is ( Simple, Initialize, Adjust, Finalize );
-
- Sub_Tests : array(Test_ID) of Procedure_Handle;
-
- procedure Simple_Test is
- A_Good_Object : C761006_0.Good; -- should call Initialize
- begin
- if not A_Good_Object.Initialized then
- Report.Failed("Good object not initialized");
- end if;
-
- -- should call Adjust
- A_Good_Object := ( Ada.Finalization.Controlled
- with Unique => 0, others => False );
- if not A_Good_Object.Adjusted then
- Report.Failed("Good object not adjusted");
- end if;
-
- -- should call Finalize before end of scope
- end Simple_Test;
-
- procedure Initialize_Test is
- begin
- declare
- This_Object_Fails_In_Initialize : C761006_2.Init_Check;
- begin
- Report.Failed("Exception in Initialize did not occur");
- exception
- when others =>
- Report.Failed("Initialize caused exception at wrong lex");
- end;
-
- Report.Failed("Error in execution sequence");
-
- exception
- when Sup.Propagating_Exception => -- this is correct
- if not Sup.Events_Occurring(Sup.Good_Initialize) then
- Report.Failed("Initialization of Good Component did not occur");
- end if;
- end Initialize_Test;
-
- procedure Adjust_Test is
- This_Object_OK : C761006_2.Adj_Check;
- This_Object_Target : C761006_2.Adj_Check;
- begin
-
- Check_Adjust_Due_To_Assignment: begin
- This_Object_Target := This_Object_OK;
- Report.Failed("Adjust did not propagate any exception");
- exception
- when Program_Error => -- expected case
- if not This_Object_Target.Good_Component.Adjusted then
- Report.Failed("other adjustment not performed");
- end if;
- when others =>
- Report.Failed("Adjust propagated wrong exception");
- end Check_Adjust_Due_To_Assignment;
-
- C761006_Support.Events_Occurring := (True, False, False);
-
- Check_Adjust_Due_To_Initial_Assignment: declare
- Another_Target : C761006_2.Adj_Check := This_Object_OK;
- begin
- Report.Failed("Adjust did not propagate any exception");
- exception
- when others => Report.Failed("Adjust caused exception at wrong lex");
- end Check_Adjust_Due_To_Initial_Assignment;
-
- exception
- when Program_Error => -- expected case
- if Sup.Events_Occurring(Sup.Good_Finalize) /=
- Sup.Events_Occurring(Sup.Good_Adjust) then
- -- RM 7.6.1(16/1) says that the good Adjust may or may not
- -- be performed; but if it is, then the Finalize must be
- -- performed; and if it is not, then the Finalize must not
- -- performed.
- if Sup.Events_Occurring(Sup.Good_Finalize) then
- Report.Failed("Good adjust not performed with bad adjust, " &
- "but good finalize was");
- else
- Report.Failed("Good adjust performed with bad adjust, " &
- "but good finalize was not");
- end if;
- end if;
- when others =>
- Report.Failed("Adjust propagated wrong exception");
- end Adjust_Test;
-
- procedure Finalize_Test is
-
- Fin_Not_Perf : constant String := "other finalizations not performed";
-
- procedure Finalize_15 is
- Item : C761006_2.Fin_Check;
- Target : C761006_2.Fin_Check;
- begin
-
- Item := Target;
- -- finalization of Item should cause PE
- -- ARM7.6:21 allows the implementation to omit the assignment of the
- -- value into an anonymous object, which is the point at which Adjust
- -- is normally called. However, this would result in Program_Error's
- -- being raised before the call to Adjust, with the consequence that
- -- Adjust is never called.
-
- exception
- when Program_Error => -- expected case
- if not Sup.Events_Occurring(Sup.Good_Finalize) then
- Report.Failed("Assignment: " & Fin_Not_Perf);
- end if;
- when others =>
- Report.Failed("Other exception in Finalize_15");
-
- -- finalization of Item/Target should cause PE
- end Finalize_15;
-
- -- check failure in finalize due to Unchecked_Deallocation
-
- procedure Finalize_17_Outer is
- -- This procedure exists to make Shark local, so everything allocated
- -- on it will be finalized when this routine exits.
-
- type Shark is access C761006_2.Fin_Check;
-
- procedure Catch is
- new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
-
- procedure Finalize_17_Inner is
- White : Shark := new C761006_2.Fin_Check;
- begin
- Catch (White);
- -- Note: It is unspecified if Catch deallocates the memory
- -- of the allocated object, and if it ceases to exist.
- -- As such, it is possible that it will be finalized when
- -- the scope of the access type is exited. We check for this
- -- case below.
- exception
- when Program_Error =>
- if not Sup.Events_Occurring(Sup.Good_Finalize) then
- Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
- end if;
- end Finalize_17_Inner;
-
- begin
- Finalize_17_Inner;
- exception
- when others =>
- Report.Failed("Unchecked_Deallocation check, unwanted exception in Outer");
- end Finalize_17_Outer;
-
- begin
-
- Exception_In_Finalization: begin
- Finalize_15;
- exception
- when Program_Error => null; -- anticipated
- end Exception_In_Finalization;
-
- Use_Of_Unchecked_Deallocation: begin
- Finalize_17_Outer;
- exception
- when Program_Error =>
- Report.Comment("Unchecked_Deallocation check, double finalization occurred");
- when others =>
- Report.Failed("Unchecked_Deallocation check, unwanted exception in caller");
- end Use_Of_Unchecked_Deallocation;
-
- end Finalize_Test;
-
-begin -- Main test procedure.
-
- Report.Test ("C761006", "Check that exceptions raised in Initialize, " &
- "Adjust and Finalize are processed correctly" );
-
- Sub_Tests := (Simple_Test'Access, Initialize_Test'Access,
- Adjust_Test'Access, Finalize_Test'Access);
-
- for Test in Sub_Tests'Range loop
- begin
-
- Sup.Events_Occurring := (others => False);
-
- Sub_Tests(Test).all;
-
- case Test is
- when Simple | Adjust =>
- if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then
- Report.Failed ( "Other operation missing in " &
- Test_ID'Image ( Test ) );
- end if;
- when Initialize =>
- null;
- when Finalize =>
- -- Note that for Good_Adjust, we may get either True or False
- if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
- Sup.Events_Occurring ( Sup.Good_Finalize ) = False
- then
- Report.Failed ( "Other operation missing in " &
- Test_ID'Image ( Test ) );
- end if;
- end case;
-
- exception
- when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
- & " from " & Test_ID'Image( Test ) );
- end;
- end loop;
-
- Report.Result;
-
-end C761006;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761007.a b/gcc/testsuite/ada/acats/tests/c7/c761007.a
deleted file mode 100644
index 7b3dbfb..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761007.a
+++ /dev/null
@@ -1,419 +0,0 @@
--- C761007.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 finalize procedure invoked by a transfer of control
--- due to selection of a terminate alternative attempts to propagate an
--- exception, the exception is ignored, but any other finalizations due
--- to be performed are performed.
---
---
--- TEST DESCRIPTION:
--- This test declares a nested controlled data type, and embeds an object
--- of that type within a protected type. Objects of the protected type
--- are created and destroyed, and the actions of the embedded controlled
--- object are checked. The container controlled type causes an exception
--- as the last part of it's finalization operation.
---
--- This test utilizes several tasks to accomplish the objective. The
--- tasks contain delays to ensure that the expected order of processing
--- is indeed accomplished.
---
--- Subtest 1:
--- local task object runs to normal completion
---
--- Subtest 2:
--- local task aborts a nested task to cause finalization
---
--- Subtest 3:
--- local task sleeps long enough to allow procedure started
--- asynchronously to go into infinite loop. Procedure is then aborted
--- via ATC, causing finalization of objects.
---
--- Subtest 4:
--- local task object takes terminate alternative, causing finalization
---
---
--- CHANGE HISTORY:
--- 06 JUN 95 SAIC Initial version
--- 05 APR 96 SAIC Documentation changes
--- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test
--- 02 DEC 97 EDS Remove duplicate characters from check string.
---!
-
----------------------------------------------------------------- C761007_0
-
-with Ada.Finalization;
-package C761007_0 is
-
- type Internal is new Ada.Finalization.Controlled
- with record
- Effect : Character;
- end record;
-
- procedure Finalize( I: in out Internal );
-
- Side_Effect : String(1..80); -- way bigger than needed
- Side_Effect_Finger : Natural := 0;
-
-end C761007_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C761007_0 is
-
- procedure Finalize( I : in out Internal ) is
- Previous_Side_Effect : Boolean := False;
- begin
- -- look to see if this character has been finalized yet
- for SEI in 1..Side_Effect_Finger loop
- Previous_Side_Effect := Previous_Side_Effect
- or Side_Effect(Side_Effect_Finger) = I.Effect;
- end loop;
-
- -- if not, then tack it on to the string, and touch the character
- if not Previous_Side_Effect then
- Side_Effect_Finger := Side_Effect_Finger +1;
- Side_Effect(Side_Effect_Finger) := I.Effect;
- TCTouch.Touch(I.Effect);
- end if;
-
- end Finalize;
-
-end C761007_0;
-
----------------------------------------------------------------- C761007_1
-
-with C761007_0;
-with Ada.Finalization;
-package C761007_1 is
-
- type Container is new Ada.Finalization.Controlled
- with record
- Effect : Character;
- Content : C761007_0.Internal;
- end record;
-
- procedure Finalize( C: in out Container );
-
- Side_Effect : String(1..80); -- way bigger than needed
- Side_Effect_Finger : Natural := 0;
-
- This_Exception_Is_Supposed_To_Be_Ignored : exception;
-
-end C761007_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C761007_1 is
-
- procedure Finalize( C: in out Container ) is
- Previous_Side_Effect : Boolean := False;
- begin
- -- look to see if this character has been finalized yet
- for SEI in 1..Side_Effect_Finger loop
- Previous_Side_Effect := Previous_Side_Effect
- or Side_Effect(Side_Effect_Finger) = C.Effect;
- end loop;
-
- -- if not, then tack it on to the string, and touch the character
- if not Previous_Side_Effect then
- Side_Effect_Finger := Side_Effect_Finger +1;
- Side_Effect(Side_Effect_Finger) := C.Effect;
- TCTouch.Touch(C.Effect);
- end if;
-
- raise This_Exception_Is_Supposed_To_Be_Ignored;
-
- end Finalize;
-
-end C761007_1;
-
----------------------------------------------------------------- C761007_2
-with C761007_1;
-package C761007_2 is
-
- protected type Prot_W_Fin_Obj is
- procedure Set_Effects( Container, Filling: Character );
- private
- The_Data_Under_Test : C761007_1.Container;
- -- finalization for this will occur when the Prot_W_Fin_Obj object
- -- "goes out of existence" for whatever reason.
- end Prot_W_Fin_Obj;
-
-end C761007_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C761007_2 is
-
- protected body Prot_W_Fin_Obj is
- procedure Set_Effects( Container, Filling: Character ) is
- begin
- The_Data_Under_Test.Effect := Container; -- A, etc.
- The_Data_Under_Test.Content.Effect := Filling; -- B, etc.
- end Set_Effects;
- end Prot_W_Fin_Obj;
-
-end C761007_2;
-
------------------------------------------------------------------- C761007
-
-with Report;
-with Impdef;
-with TCTouch;
-with C761007_0;
-with C761007_1;
-with C761007_2;
-procedure C761007 is
-
- task type Subtests( Outer, Inner : Character) is
- entry Ready;
- entry Complete;
- end Subtests;
-
- task body Subtests is
- Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj;
- begin
- Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner );
-
- accept Ready;
-
- select
- accept Complete;
- or terminate; -- used in Subtest 4
- end select;
- exception
- -- the exception caused by the finalization of Local_Prot_W_Fin_Obj
- -- should never be visible to this scope.
- when others => Report.Failed("Exception in a Subtest object "
- & Outer & Inner);
- end Subtests;
-
- procedure Subtest_1 is
- -- check the case where "nothing special" happens.
-
- This_Subtest : Subtests( 'A', 'B' );
- begin
-
- This_Subtest.Ready;
- This_Subtest.Complete;
-
- while not This_Subtest'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- -- in the finalization of This_Subtest, the controlled object embedded in
- -- the Prot_W_Fin_Obj will finalize. An exception is raised in the
- -- container object, after "touching" it's tag character.
- -- The finalization of the contained controlled object must be performed.
-
-
- TCTouch.Validate( "AB", "Item embedded in task" );
-
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_1");
-
- end Subtest_1;
-
- procedure Subtest_2 is
- -- check for explicit abort
-
- task Subtest_Task is
- entry Complete;
- end Subtest_Task;
-
- task body Subtest_Task is
-
- task Nesting;
- task body Nesting is
- Deep_Nesting : Subtests( 'E', 'F' );
- begin
- if Report.Ident_Bool( True ) then
- -- controlled objects have been created in the elaboration of
- -- Deep_Nesting. Deep_Nesting must call the Set_Effects operation
- -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete
- -- entry call.
- Deep_Nesting.Ready;
- abort Deep_Nesting;
- else
- Report.Failed("Dead code in Nesting");
- end if;
- exception
- when others => Report.Failed("Exception in Subtest_Task.Nesting");
- end Nesting;
-
- Local_2 : C761007_2.Prot_W_Fin_Obj;
-
- begin
- -- Nesting has activated at this point, which implies the activation
- -- of Deep_Nesting as well.
-
- Local_2.Set_Effects( 'C', 'D' );
-
- -- wait for Nesting to terminate
-
- while not Nesting'Terminated loop
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- accept Complete;
-
- exception
- when others => Report.Failed("Exception in Subtest_Task");
- end Subtest_Task;
-
- begin
-
- -- wait for everything in Subtest_Task to happen
- Subtest_Task.Complete;
-
- while not Subtest_Task'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- TCTouch.Validate( "EFCD", "Aborted nested task" );
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_2");
- end Subtest_2;
-
- procedure Subtest_3 is
- -- check abort caused by asynchronous transfer of control
-
- task Subtest_3_Task is
- entry Complete;
- end Subtest_3_Task;
-
- procedure Check_Atc_Operation is
- Check_Atc : C761007_2.Prot_W_Fin_Obj;
- begin
-
- Check_Atc.Set_Effects( 'G', 'H' );
-
-
- while Report.Ident_Bool( True ) loop -- wait to be aborted
- if Report.Ident_Bool( True ) then
- Impdef.Exceed_Time_Slice;
- delay Impdef.Switch_To_New_Task;
- else
- Report.Failed("Optimization prevention");
- end if;
- end loop;
-
- Report.Failed("Check_Atc_Operation loop completed");
-
- end Check_Atc_Operation;
-
- task body Subtest_3_Task is
- task Nesting is
- entry Complete;
- end Nesting;
-
- task body Nesting is
- Nesting_3 : C761007_2.Prot_W_Fin_Obj;
- begin
- Nesting_3.Set_Effects( 'G', 'H' );
-
- -- give Check_Atc_Operation sufficient time to perform it's
- -- Set_Effects on it's local Prot_W_Fin_Obj object
- delay Impdef.Clear_Ready_Queue;
-
- accept Complete;
- exception
- when others => Report.Failed("Exception in Subtest_3_Task.Nesting");
- end Nesting;
-
- Local_3 : C761007_2.Prot_W_Fin_Obj;
-
- begin -- Subtest_3_Task
-
- Local_3.Set_Effects( 'I', 'J' );
-
- select
- Nesting.Complete;
- then abort ---------------------------------------------------- cause KL
- Check_ATC_Operation;
- end select;
-
- accept Complete;
-
- exception
- when others => Report.Failed("Exception in Subtest_3_Task");
- end Subtest_3_Task;
-
- begin -- Subtest_3
- Subtest_3_Task.Complete;
-
- while not Subtest_3_Task'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" );
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_3");
- end Subtest_3;
-
- procedure Subtest_4 is
- -- check the case where transfer is caused by terminate alternative
- -- highly similar to Subtest_1
-
- This_Subtest : Subtests( 'M', 'N' );
- begin
-
- This_Subtest.Ready;
- -- don't call This_Subtest.Complete;
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_4");
-
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761007", "Check that if a finalize procedure invoked by " &
- "a transfer of control or selection of a " &
- "terminate alternative attempts to propagate " &
- "an exception, the exception is ignored, but " &
- "any other finalizations due to be performed " &
- "are performed" );
-
- Subtest_1; -- checks internal
-
- Subtest_2; -- checks internal
-
- Subtest_3; -- checks internal
-
- Subtest_4;
- TCTouch.Validate( "MN", "transfer due to terminate alternative" );
-
- Report.Result;
-
-end C761007;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761010.a b/gcc/testsuite/ada/acats/tests/c7/c761010.a
deleted file mode 100644
index 7784c6d..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761010.a
+++ /dev/null
@@ -1,447 +0,0 @@
--- C761010.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 WHATSOVER, 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 the requirements of the new 7.6(17.1/1) from Technical
--- Corrigendum 1 (originally discussed as AI95-00083).
--- This new paragraph requires that the initialization of an object with
--- an aggregate does not involve calls to Adjust.
---
--- TEST DESCRIPTION
--- We include several cases of initialization:
--- - Explicit initialization of an object declared by an
--- object declaration.
--- - Explicit initialization of a heap object.
--- - Default initialization of a record component.
--- - Initialization of a formal parameter during a call.
--- - Initialization of a formal parameter during a call with
--- a defaulted parameter.
--- - Lots of nested records, arrays, and pointers.
--- In this test, Initialize should never be called, because we
--- never declare a default-initialized controlled object (although
--- we do declare default-initialized records containing controlled
--- objects, with default expressions for the components).
--- Adjust should never be called, because every initialization
--- is via an aggregate. Finalize is called, because the objects
--- themselves need to be finalized.
--- Thus, Initialize and Adjust call Failed.
--- In some of the cases, these procedures will not yet be elaborated,
--- anyway.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 10 APR 2000 RLB Corrected errors in comments and text, fixed
--- discriminant error. Fixed so that Report.Test
--- is called before any Report.Failed call. Added
--- a marker so that the failed subtest can be
--- determined.
--- 26 APR 2000 RAD Try to defeat optimizations.
--- 04 AUG 2000 RLB Corrected error in Check_Equal.
--- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172).
--- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result.
---
---!
-
-with Ada; use Ada;
-with Report; use Report; pragma Elaborate_All(Report);
-with Ada.Finalization;
-package C761010_1 is
- pragma Elaborate_Body;
- function Square(X: Integer) return Integer;
-private
- type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize (Object : in out TC_Control);
- procedure Finalize (Object : in out TC_Control);
- TC_Finalize_Called : Boolean := False;
-end C761010_1;
-
-package body C761010_1 is
- function Square(X: Integer) return Integer is
- begin
- return X**2;
- end Square;
-
- procedure Initialize (Object : in out TC_Control) is
- begin
- Test("C761010_1",
- "Check that Adjust is not called"
- & " when aggregates are used to initialize objects");
- end Initialize;
-
- procedure Finalize (Object : in out TC_Control) is
- begin
- if not TC_Finalize_Called then
- Failed("Var_Strings Finalize never called");
- end if;
- Result;
- end Finalize;
-
- TC_Test : TC_Control; -- Starts test; finalization ends test.
-end C761010_1;
-
-with Ada.Finalization;
-package C761010_1.Var_Strings is
- type Var_String(<>) is private;
-
- Some_String: constant Var_String;
-
- function "=" (X, Y: Var_String) return Boolean;
-
- procedure Check_Equal(X, Y: Var_String);
- -- Calls to this are used to defeat optimizations
- -- that might otherwise defeat the purpose of the
- -- test. I'm talking about the optimization of removing
- -- unused controlled objects.
-
-private
-
- type String_Ptr is access constant String;
-
- type Var_String(Length: Natural) is new Finalization.Controlled with
- record
- Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
- Comp_2: String_Ptr(1..Length) := null;
- Comp_3: String(Length..Length) := (others => '.');
- TC_Lab: Character := '1';
- end record;
- procedure Initialize(X: in out Var_String);
- procedure Adjust(X: in out Var_String);
- procedure Finalize(X: in out Var_String);
-
- Some_String: constant Var_String
- := (Finalization.Controlled with Length => 1,
- Comp_1 => null,
- Comp_2 => null,
- Comp_3 => "x",
- TC_Lab => 'A');
-
- Another_String: constant Var_String
- := (Finalization.Controlled with Length => 10,
- Comp_1 => Some_String.Comp_2,
- Comp_2 => new String'("1234567890"),
- Comp_3 => "x",
- TC_Lab => 'B');
-
-end C761010_1.Var_Strings;
-
-package C761010_1.Var_Strings.Types is
-
- type Ptr is access all Var_String;
- Ptr_Const: constant Ptr;
-
- type Ptr_Arr is array(Positive range <>) of Ptr;
- Ptr_Arr_Const: constant Ptr_Arr;
-
- type Ptr_Rec(N_Strings: Natural) is
- record
- Ptrs: Ptr_Arr(1..N_Strings);
- end record;
- Ptr_Rec_Const: constant Ptr_Rec;
-
-private
-
- Ptr_Const: constant Ptr := new Var_String'
- (Finalization.Controlled with
- Length => 1,
- Comp_1 => null,
- Comp_2 => null,
- Comp_3 => (others => ' '),
- TC_Lab => 'C');
-
- Ptr_Arr_Const: constant Ptr_Arr :=
- (1 => new Var_String'
- (Finalization.Controlled with
- Length => 1,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'D'));
-
- Ptr_Rec_Var: Ptr_Rec :=
- (3,
- (1..2 => null,
- 3 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'E')));
-
- Ptr_Rec_Const: constant Ptr_Rec :=
- (3,
- (1..2 => null,
- 3 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'F')));
-
- type Arr is array(Positive range <>) of Var_String(Length => 2);
-
- Arr_Var: Arr :=
- (1 => (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'G'));
-
- type Rec(N_Strings: Natural) is
- record
- Ptrs: Ptr_Rec(N_Strings);
- Strings: Arr(1..N_Strings) :=
- (others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'H'));
- end record;
-
- Default_Init_Rec_Var: Rec(N_Strings => 10);
- Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
-
- Rec_Var: Rec(N_Strings => 2) :=
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'J'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'K'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'L')));
-
- procedure Check_Equal(X, Y: Rec);
-
-end C761010_1.Var_Strings.Types;
-
-package body C761010_1.Var_Strings.Types is
-
- -- Check that parameter passing doesn't create new objects,
- -- and therefore doesn't need extra Adjusts or Finalizes.
-
- procedure Check_Equal(X, Y: Rec) is
- -- We assume that the arguments should be equal.
- -- But we cannot assume that pointer values are the same.
- begin
- if X.N_Strings /= Y.N_Strings then
- Failed("Records should be equal (1)");
- else
- for I in 1 .. X.N_Strings loop
- if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
- if X.Ptrs.Ptrs(I) = null or else
- Y.Ptrs.Ptrs(I) = null or else
- X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
- Failed("Records should be equal (2)");
- end if;
- end if;
- if X.Strings(I) /= Y.Strings(I) then
- Failed("Records should be equal (3)");
- end if;
- end loop;
- end if;
- end Check_Equal;
-
- procedure My_Check_Equal
- (X: Rec := Rec_Var;
- Y: Rec :=
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'M'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'N'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'O'))))
- renames Check_Equal;
-begin
-
- My_Check_Equal;
-
- Check_Equal(Rec_Var,
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'P'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'Q'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'R'))));
-
- -- Use the objects to avoid optimizations.
-
- Check_Equal(Ptr_Const.all, Ptr_Const.all);
- Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
- Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
- Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
- Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
- Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
-
- if Report.Equal (3, 2) then
- -- Can't get here.
- Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
- Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
- end if;
-
-end C761010_1.Var_Strings.Types;
-
-with C761010_1.Var_Strings;
-with C761010_1.Var_Strings.Types;
-procedure C761010_1.Main is
-begin
- -- Report.Test is called by the elaboration of C761010_1, and
- -- Report.Result is called by the finalization of C761010_1.
- -- This will happen before any objects are created, and after any
- -- are finalized.
- null;
-end C761010_1.Main;
-
-with C761010_1.Main;
-procedure C761010 is
-begin
- C761010_1.Main;
-end C761010;
-
-package body C761010_1.Var_Strings is
-
- Some_Error: exception;
-
- procedure Initialize(X: in out Var_String) is
- begin
- Failed("Initialize should never be called");
- raise Some_Error;
- end Initialize;
-
- procedure Adjust(X: in out Var_String) is
- begin
- Failed("Adjust should never be called - case " & X.TC_Lab);
- raise Some_Error;
- end Adjust;
-
- procedure Finalize(X: in out Var_String) is
- begin
- Comment("Finalize called - case " & X.TC_Lab);
- C761010_1.TC_Finalize_Called := True;
- end Finalize;
-
- function "=" (X, Y: Var_String) return Boolean is
- -- Don't check the TC_Lab component, but do check the contents of the
- -- access values.
- begin
- if X.Length /= Y.Length then
- return False;
- end if;
- if X.Comp_3 /= Y.Comp_3 then
- return False;
- end if;
- if X.Comp_1 /= Y.Comp_1 then
- -- Still OK if the values are the same.
- if X.Comp_1 = null or else
- Y.Comp_1 = null or else
- X.Comp_1.all /= Y.Comp_1.all then
- return False;
- --else OK.
- end if;
- end if;
- if X.Comp_2 /= Y.Comp_2 then
- -- Still OK if the values are the same.
- if X.Comp_2 = null or else
- Y.Comp_2 = null or else
- X.Comp_2.all /= Y.Comp_2.all then
- return False;
- end if;
- end if;
- return True;
- end "=";
-
- procedure Check_Equal(X, Y: Var_String) is
- begin
- if X /= Y then
- Failed("Check_Equal of Var_String");
- end if;
- end Check_Equal;
-
-begin
- Check_Equal(Another_String, Another_String);
-end C761010_1.Var_Strings;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761011.a b/gcc/testsuite/ada/acats/tests/c7/c761011.a
deleted file mode 100644
index 1d447c7..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761011.a
+++ /dev/null
@@ -1,410 +0,0 @@
--- C761011.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Finalize propagates an exception, other Finalizes due
--- to be performed are performed.
--- Case 1: A Finalize invoked due to the end of execution of
--- a master. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 2: A Finalize invoked due to finalization of an anonymous
--- object. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 3: A Finalize invoked due to the transfer of control
--- due to an exit statement.
--- Case 4: A Finalize invoked due to the transfer of control
--- due to a goto statement.
--- Case 5: A Finalize invoked due to the transfer of control
--- due to a return statement.
--- Case 6: A Finalize invoked due to the transfer of control
--- due to raises an exception.
---
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release; added optimization blockers.
--- Added test cases for paragraphs 18 and 19 of the
--- standard (the previous tests were withdrawn).
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C761011_0 is
-
- type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
- record
- Finalized : Boolean := False;
- case D is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- function Create (Id : Integer) return Ctrl;
- procedure Finalize (Obj : in out Ctrl);
- function Was_Finalized (Id : Integer) return Boolean;
- procedure Use_It (Obj : in Ctrl);
- -- Use Obj to prevent optimization.
-
-end C761011_0;
-
-with Report;
-use Report;
-package body C761011_0 is
-
- User_Error : exception;
-
- Finalize_Called : array (0 .. 50) of Boolean := (others => False);
-
- function Create (Id : Integer) return Ctrl is
- Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
- begin
- case Obj.D is
- when False =>
- Obj.C1 := Ident_Int (Id);
- when True =>
- Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
- end case;
- return Obj;
- end Create;
-
- procedure Finalize (Obj : in out Ctrl) is
- begin
- if not Obj.Finalized then
- Obj.Finalized := True;
- if Obj.D then
- if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
- Ident_Int (3) then
- raise User_Error;
- else
- Finalize_Called (Integer (Obj.C2) / 2) := True;
- end if;
- else
- if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
- raise Tasking_Error;
- else
- Finalize_Called (Obj.C1) := True;
- end if;
- end if;
- end if;
- end Finalize;
-
- function Was_Finalized (Id : Integer) return Boolean is
- begin
- return Finalize_Called (Ident_Int (Id));
- end Was_Finalized;
-
- procedure Use_It (Obj : in Ctrl) is
- -- Use Obj to prevent optimization.
- begin
- case Obj.D is
- when True =>
- if not Equal (Boolean'Pos(Obj.Finalized),
- Boolean'Pos(Obj.Finalized)) then
- Failed ("Identity check - 1");
- end if;
- when False =>
- if not Equal (Obj.C1, Obj.C1) then
- Failed ("Identity check - 2");
- end if;
- end case;
- end Use_It;
-
-end C761011_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Finalization;
-with C761011_0;
-use C761011_0;
-with Report;
-use Report;
-procedure C761011 is
-begin
- Test
- ("C761011",
- " Check that if a finalize propagates an exception, other finalizes " &
- "due to be performed are performed");
-
- Normal: -- Case 1
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (1));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (2));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int
- (3))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (4));
- begin
- Comment ("Finalization of normal object");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of normal object");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (1)) or
- not Was_Finalized (Ident_Int (2)) or
- not Was_Finalized (Ident_Int (4)) then
- Failed ("Missing finalizations - 1");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 1");
- end Normal;
-
- Anon: -- Case 2
- begin
- declare
- Obj1 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (5)));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (6));
- Obj3 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (7)));
- Obj4 : Ctrl := Create (Ident_Int (8));
- begin
- Comment ("Finalization of anonymous object");
-
- -- The finalization of the anonymous object below will raise
- -- Tasking_Error.
- if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
- Failed ("Incorrect construction of an anonymous object");
- end if;
- Failed ("Anonymous object not finalized at the end of the " &
- "enclosing statement");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of an anonymous " &
- "object of a function");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (5)) or
- not Was_Finalized (Ident_Int (6)) or
- not Was_Finalized (Ident_Int (7)) or
- not Was_Finalized (Ident_Int (8)) then
- Failed ("Missing finalizations - 2");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 2");
- end Anon;
-
- An_Exit: -- Case 3
- begin
- for Counter in 1 .. 4 loop
- declare
- Obj1 : Ctrl := Create (Ident_Int (11));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (12));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(13))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (14));
- begin
- Comment ("Finalization because of exit of loop");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- exit when not Ident_Bool (Obj2.D);
-
- Failed ("Exit not taken");
- end;
- end loop;
- Failed ("No exception raised by finalization on exit");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (11)) or
- not Was_Finalized (Ident_Int (12)) or
- not Was_Finalized (Ident_Int (14)) then
- Failed ("Missing finalizations - 3");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 3");
- end An_Exit;
-
- A_Goto: -- Case 4
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (15));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (0));
- -- Finalization: Tasking_Error
- Obj3 : Ctrl := Create (Ident_Int (16));
- Obj4 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (17)));
- begin
- Comment ("Finalization because of goto statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if Ident_Bool (Obj4.D) then
- goto Continue;
- end if;
-
- Failed ("Goto not taken");
- end;
- <<Continue>>
- Failed ("No exception raised by finalization on goto");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (15)) or
- not Was_Finalized (Ident_Int (16)) or
- not Was_Finalized (Ident_Int (17)) then
- Failed ("Missing finalizations - 4");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 4");
- end A_Goto;
-
- A_Return: -- Case 5
- declare
- procedure Do_Something is
- Obj1 : Ctrl := Create (Ident_Int (18));
- Obj2 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (19)));
- Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (20));
- -- Finalization: Tasking_Error
- begin
- Comment ("Finalization because of return statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
-
- if not Ident_Bool (Obj3.D) then
- return;
- end if;
-
- Failed ("Return not taken");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on return statement");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (18)) or
- not Was_Finalized (Ident_Int (19)) then
- Failed ("Missing finalizations - 5");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 5");
- end A_Return;
-
- Except: -- Case 6
- declare
- Funky_Error : exception;
-
- procedure Do_Something is
- Obj1 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(23))); -- Finalization: User_Error
- Obj2 : Ctrl := Create (Ident_Int (24));
- Obj3 : Ctrl := Create (Ident_Int (25));
- Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (26));
- begin
- Comment ("Finalization because of exception propagation");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if not Ident_Bool (Obj4.D) then
- raise Funky_Error;
- end if;
-
- Failed ("Exception not raised");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on exception " &
- "propagation");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (24)) or
- not Was_Finalized (Ident_Int (25)) or
- not Was_Finalized (Ident_Int (26)) then
- Failed ("Missing finalizations - 6");
- end if;
- when Funky_Error =>
- Failed ("Wrong exception propagated");
- -- Should be Program_Error (7.6.1(19)).
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 6");
- end Except;
-
- Result;
-end C761011;
-
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761012.a b/gcc/testsuite/ada/acats/tests/c7/c761012.a
deleted file mode 100644
index 77b9e22..0000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761012.a
+++ /dev/null
@@ -1,151 +0,0 @@
--- C761012.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 anonymous object is finalized with its enclosing master if
--- a transfer of control or exception occurs prior to performing its normal
--- finalization. (Defect Report 8652/0023, as reflected in
--- Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C761012_0 is
-
- type Ctrl (D : Boolean) is new Controlled with
- record
- case D is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- function Create return Ctrl;
- procedure Finalize (Obj : in out Ctrl);
- function Finalize_Was_Called return Boolean;
-
-end C761012_0;
-
-with Report;
-use Report;
-package body C761012_0 is
-
- Finalization_Flag : Boolean := False;
-
- function Create return Ctrl is
- Obj : Ctrl (Ident_Bool (True));
- begin
- Obj.C2 := 3.0;
- return Obj;
- end Create;
-
- procedure Finalize (Obj : in out Ctrl) is
- begin
- Finalization_Flag := True;
- end Finalize;
-
- function Finalize_Was_Called return Boolean is
- begin
- if Finalization_Flag then
- Finalization_Flag := False;
- return True;
- else
- return False;
- end if;
- end Finalize_Was_Called;
-
-end C761012_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with C761012_0;
-use C761012_0;
-with Report;
-use Report;
-procedure C761012 is
-begin
- Test ("C761012",
- "Check that an anonymous object is finalized with its enclosing " &
- "master if a transfer of control or exception occurs prior to " &
- "performing its normal finalization");
-
- Excep:
- begin
-
- declare
- I : Integer := Create.C1; -- Raises Constraint_Error
- begin
- Failed
- ("Improper component selection did not raise Constraint_Error, I =" &
- Integer'Image (I));
- exception
- when Constraint_Error =>
- Failed ("Constraint_Error caught by the wrong handler");
- end;
-
- Failed ("Transfer of control did not happen correctly");
-
- exception
- when Constraint_Error =>
- if not Finalize_Was_Called then
- Failed ("Finalize wasn't called when the master was left " &
- "- Constraint_Error");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E));
- end Excep;
-
- Transfer:
- declare
- Finalize_Was_Called_Before_Leaving_Exit : Boolean;
- begin
-
- begin
- loop
- exit when Create.C2 = 3.0;
- end loop;
- Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
- if Finalize_Was_Called_Before_Leaving_Exit then
- Comment ("Finalize called before the transfer of control");
- end if;
- end;
-
- if not Finalize_Was_Called and then
- not Finalize_Was_Called_Before_Leaving_Exit then
- Failed ("Finalize wasn't called when the master was left " &
- "- transfer of control");
- end if;
- end Transfer;
-
- Result;
-end C761012;
-
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83007a.ada b/gcc/testsuite/ada/acats/tests/c8/c83007a.ada
deleted file mode 100644
index f33d907..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83007a.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- C83007A.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 FORMAL PARAMETER OF A SUBPROGRAM DECLARED BY A
--- RENAMING DECLARATION CAN HAVE THE SAME IDENTIFIER AS A
--- DECLARATION IN THE BODY OF THE RENAMED SUBPROGRAM.
-
--- HISTORY:
--- VCL 02/18/88 CREATED ORIGINAL TEST.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83007A IS
-BEGIN
- TEST ("C83007A", "A FORMAL PARAMETER OF A SUBPROGRAM DECLARED " &
- "BY A RENAMING DECLARATION CAN HAVE THE SAME " &
- "IDENTIFIER AS A DECLARATION IN THE BODY OF " &
- "THE RENAMED SUBPROGRAM");
- DECLARE
- PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING);
-
- PROCEDURE R (D1 : INTEGER;
- D2 : FLOAT;
- D3 : STRING) RENAMES P;
-
- PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING) IS
- TYPE D1 IS RANGE 1..10;
- I : D1 := D1(IDENT_INT (7));
-
- D2 : FLOAT;
-
- FUNCTION D3 RETURN STRING IS
- BEGIN
- RETURN "D3";
- END D3;
-
- FUNCTION IDENT_FLOAT (VAL : FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN VAL;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FLOAT;
-
- BEGIN
- IF ONE /= 5 THEN
- FAILED ("INCORRECT VALUE FOR PARAMETER ONE");
- END IF;
- IF TWO /= 4.5 THEN
- FAILED ("INCORRECT VALUE FOR PARAMETER TWO");
- END IF;
- IF THREE /= "R1" THEN
- FAILED ("INCORRECT VALUE FOR PARAMETER THREE");
- END IF;
-
- IF I /= 7 THEN
- FAILED ("INCORRECT VALUE FOR OBJECT I");
- END IF;
- D2 := IDENT_FLOAT (3.5);
- IF D2 /= 3.5 THEN
- FAILED ("INCORRECT VALUE FOR OBJECT D2");
- END IF;
- IF D3 /= "D3" THEN
- FAILED ("INCORRECT VALUE FOR FUNCTION D3");
- END IF;
- END P;
- BEGIN
- R (D1=>5, D2=>4.5, D3=>"R1");
- END;
-
- RESULT;
-END C83007A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83012d.ada b/gcc/testsuite/ada/acats/tests/c8/c83012d.ada
deleted file mode 100644
index a73639c..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83012d.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- C83012D.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 WITHIN A GENERIC PACKAGE INSTANTIATION, A DECLARATION
--- HAVING THE SAME IDENTIFIER AS THE PACKAGE IS VISIBLE BY
--- SELECTION.
-
--- HISTORY:
--- JET 08/11/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83012D IS
-
- PACKAGE PACK IS
- SUBTYPE PACK1 IS INTEGER;
- PACK2 : INTEGER := 2;
- END PACK;
-
- TYPE REC IS RECORD
- PACK3 : INTEGER;
- PACK4 : INTEGER;
- END RECORD;
-
- R : REC := (PACK3 => 3, PACK4 => 1);
-
- GENERIC
- TYPE T IS RANGE <>;
- PACKAGE GEN1 IS
- J : INTEGER := IDENT_INT(1);
- END GEN1;
-
- GENERIC
- I : INTEGER;
- PACKAGE GEN2 IS
- J : INTEGER := IDENT_INT(I);
- END GEN2;
-
- GENERIC
- R : REC;
- PACKAGE GEN3 IS
- J : INTEGER := IDENT_INT(R.PACK4);
- END GEN3;
-
- GENERIC
- PACK6 : INTEGER;
- PACKAGE GEN4 IS
- J : INTEGER := IDENT_INT(PACK6);
- END GEN4;
-
- FUNCTION FUNC (PACK5: INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(PACK5);
- END FUNC;
-
- PACKAGE PACK1 IS NEW GEN1(PACK.PACK1);
- PACKAGE PACK2 IS NEW GEN2(PACK.PACK2);
- PACKAGE PACK3 IS NEW GEN2(R.PACK3);
- PACKAGE PACK4 IS NEW GEN3((1, PACK4 => 4));
- PACKAGE PACK5 IS NEW GEN2(FUNC(PACK5 => 5));
- PACKAGE PACK6 IS NEW GEN4(PACK6 => 6);
-
-BEGIN
- TEST ("C83012D", "CHECK THAT WITHIN A GENERIC PACKAGE " &
- "INSTANTIATION, A DECLARATION HAVING THE SAME " &
- "IDENTIFIER AS THE PACKAGE IS VISIBLE BY " &
- "SELECTION");
-
- IF PACK1.J /= 1 THEN
- FAILED ("INCORRECT VALUE OF PACK1.J");
- END IF;
-
- IF PACK2.J /= 2 THEN
- FAILED ("INCORRECT VALUE OF PACK2.J");
- END IF;
-
- IF PACK3.J /= 3 THEN
- FAILED ("INCORRECT VALUE OF PACK3.J");
- END IF;
-
- IF PACK4.J /= 4 THEN
- FAILED ("INCORRECT VALUE OF PACK4.J");
- END IF;
-
- IF PACK5.J /= 5 THEN
- FAILED ("INCORRECT VALUE OF PACK5.J");
- END IF;
-
- IF PACK6.J /= 6 THEN
- FAILED ("INCORRECT VALUE OF PACK6.J");
- END IF;
-
- RESULT;
-
-END C83012D;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022a.ada b/gcc/testsuite/ada/acats/tests/c8/c83022a.ada
deleted file mode 100644
index 391c9dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83022a.ada
+++ /dev/null
@@ -1,338 +0,0 @@
--- C83022A.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 DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY
--- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE
--- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE
--- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE
--- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAH DECLARATION.
-
--- HISTORY:
--- TBN 08/01/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83022A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83022A", "CHECK THAT A DECLARATION IN A SUBPROGRAM " &
- "FORMAL PART OR BODY HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE -- SUBPROGRAM DECLARATIVE REGION.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := ONE.A;
- END IF;
- END INNER;
-
- BEGIN -- ONE
- INNER (A);
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE -- FORMAL PARAMETER OF SUBPROGRAM.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- PROCEDURE INNER (X : IN INTEGER := A;
- A : IN OUT INTEGER) IS
- C : INTEGER := A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10");
- END IF;
- IF TWO.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
- IF TWO.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
- END INNER;
-
- BEGIN -- TWO
- INNER (A => OBJ);
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END TWO;
-
- THREE:
- DECLARE -- AFTER THE SPECIFICATION OF SUBPROGRAM.
- A : INTEGER := IDENT_INT(2);
-
- FUNCTION INNER (X : INTEGER) RETURN INTEGER;
-
- B : INTEGER := A;
-
- FUNCTION INNER (X : INTEGER) RETURN INTEGER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
- IF THREE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
- IF THREE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
- IF EQUAL(1,1) THEN
- RETURN A;
- ELSE
- RETURN X;
- END IF;
- END INNER;
-
- BEGIN -- THREE
- IF INNER(A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 25");
- END IF;
- END THREE;
-
- FOUR:
- DECLARE -- RENAMING DECLARATION.
- A : INTEGER := IDENT_INT(2);
-
- PROCEDURE TEMPLATE (X : IN INTEGER := A;
- Y : IN OUT INTEGER);
-
- PROCEDURE INNER (Z : IN INTEGER := A;
- A : IN OUT INTEGER) RENAMES TEMPLATE;
-
- B : INTEGER := A;
- OBJ : INTEGER := 5;
-
- PROCEDURE TEMPLATE (X : IN INTEGER := A;
- Y : IN OUT INTEGER) IS
- BEGIN -- TEMPLATE
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FOR VARIABLE - 30");
- END IF;
- IF Y /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RESULTS FOR VARIABLE - 31");
- END IF;
- Y := IDENT_INT(2 * X);
- IF FOUR.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " &
- "32");
- END IF;
- END TEMPLATE;
-
- BEGIN -- FOUR
- IF B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32");
- END IF;
- INNER (A => OBJ);
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 33");
- END IF;
- END FOUR;
-
- FIVE:
- DECLARE -- GENERIC FORMAL SUBPROGRAM.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- PROCEDURE INNER (X : IN OUT INTEGER);
-
- GENERIC
- WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>;
- PACKAGE P IS
- PAC_VAR : INTEGER := 1;
- END P;
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41");
- END IF;
- IF FIVE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42");
- END IF;
- IF FIVE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43");
- END IF;
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44");
- END IF;
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 45");
- END IF;
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := FIVE.A;
- END IF;
- END INNER;
-
- PACKAGE BODY P IS
- BEGIN
- SUBPR (A);
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 46");
- END IF;
- IF PAC_VAR /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE FOR PAC_VAR - 47");
- END IF;
- END P;
-
- PACKAGE NEW_P IS NEW P (INNER);
-
- BEGIN -- FIVE
- NULL;
- END FIVE;
-
- SIX:
- DECLARE -- GENERIC INSTANTIATION.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- GENERIC
- PROCEDURE INNER (X : IN INTEGER := A;
- A : IN OUT INTEGER);
-
- PROCEDURE INNER (X : IN INTEGER := SIX.A;
- A : IN OUT INTEGER) IS
- C : INTEGER := A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -50");
- END IF;
- IF SIX.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 51");
- END IF;
- IF SIX.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 52");
- END IF;
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 53");
- END IF;
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 54");
- END IF;
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
- END INNER;
-
- PROCEDURE SUBPR IS NEW INNER;
-
- BEGIN -- SIX
- SUBPR (A => OBJ);
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 55");
- END IF;
- END SIX;
-
- SEVEN:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 5.0;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS
- BEGIN
- X := INTEGER(F);
- END INNER;
-
- BEGIN
- FLO := 6.25;
- INNER (OBJ, FLO);
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60");
- END IF;
- END SEVEN;
-
-
- RESULT;
-END C83022A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada b/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada
deleted file mode 100644
index 36f3f90..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada
+++ /dev/null
@@ -1,165 +0,0 @@
--- C83022G0M.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 DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY
--- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE
--- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE
--- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE
--- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED
--- SEPARATELY AS A SUBUNIT.
-
--- SEPARATE FILES ARE:
--- C83022G0M.ADA - (THIS FILE) MAIN PROGRAM.
--- C83022G1.ADA -- SUBPROGRAM BODIES.
-
--- HISTORY:
--- BCB 08/26/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C83022G0M IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- OBJ : INTEGER := IDENT_INT(3);
-
- FLO : FLOAT := 5.0;
-
- PROCEDURE TEMPLATE (X : IN INTEGER := A;
- Y : IN OUT INTEGER);
-
- PROCEDURE INNER4 (Z : IN INTEGER := A;
- A : IN OUT INTEGER) RENAMES TEMPLATE;
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE;
-
- PROCEDURE INNER2 (X : IN INTEGER := A;
- A : IN OUT INTEGER) IS SEPARATE;
-
- FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS SEPARATE;
-
- PROCEDURE TEMPLATE (X : IN INTEGER := A;
- Y : IN OUT INTEGER) IS SEPARATE;
-
- PROCEDURE INNER5 (X : IN OUT INTEGER) IS SEPARATE;
-
- GENERIC
- WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>;
- PACKAGE P IS
- PAC_VAR : INTEGER := 1;
- END P;
-
- PACKAGE BODY P IS
- BEGIN
- SUBPR (A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 1");
- END IF;
-
- IF PAC_VAR /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE FOR PAC_VAR - 2");
- END IF;
- END P;
-
- PACKAGE NEW_P IS NEW P (INNER5);
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS SEPARATE;
-
-BEGIN
- TEST ("C83022G", "CHECK THAT A DECLARATION IN A SUBPROGRAM " &
- "FORMAL PART OR BODY HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- A := IDENT_INT(2);
- B := A;
-
- INNER (A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 3");
- END IF;
-
- A := IDENT_INT(2);
-
- INNER2 (A => OBJ);
-
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 4");
- END IF;
-
- A := IDENT_INT(2);
-
- B := A;
-
- IF INNER3(A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 5");
- END IF;
-
- A := IDENT_INT(2);
-
- B := A;
- OBJ := 5;
-
- IF B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 6");
- END IF;
-
- INNER4 (A => OBJ);
-
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 7");
- END IF;
-
- OBJ := 1;
-
- FLO := 6.25;
-
- INNER6 (OBJ, FLO);
-
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 8");
- END IF;
-
- RESULT;
-END C83022G0M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada b/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada
deleted file mode 100644
index e25bdc9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada
+++ /dev/null
@@ -1,189 +0,0 @@
--- C83022G1.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 DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY
--- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE
--- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE
--- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE
--- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED
--- SEPARATELY AS A SUBUNIT.
-
--- HISTORY:
--- BCB 08/26/88 CREATED ORIGINAL TEST.
-
-SEPARATE (C83022G0M)
-PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF C83022G0M.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF C83022G0M.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := C83022G0M.A;
- END IF;
-END INNER;
-
-SEPARATE (C83022G0M)
-PROCEDURE INNER2 (X : IN INTEGER := C83022G0M.A;
- A : IN OUT INTEGER) IS
- C : INTEGER := A;
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10");
- END IF;
-
- IF C83022G0M.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF C83022G0M.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
-END INNER2;
-
-SEPARATE (C83022G0M)
-FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
-
- IF C83022G0M.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
-
- IF C83022G0M.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
-
- IF EQUAL(1,1) THEN
- RETURN A;
- ELSE
- RETURN X;
- END IF;
-END INNER3;
-
-SEPARATE (C83022G0M)
-PROCEDURE TEMPLATE (X : IN INTEGER := A;
- Y : IN OUT INTEGER) IS
-BEGIN -- TEMPLATE
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FOR VARIABLE - 30");
- END IF;
-
- IF Y /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RESULTS FOR VARIABLE - 31");
- END IF;
-
- Y := IDENT_INT(2 * X);
-
- IF C83022G0M.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " &
- "32");
- END IF;
-END TEMPLATE;
-
-SEPARATE (C83022G0M)
-PROCEDURE INNER5 (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41");
- END IF;
-
- IF C83022G0M.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42");
- END IF;
-
- IF C83022G0M.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 45");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := C83022G0M.A;
- END IF;
-END INNER5;
-
-SEPARATE (C83022G0M)
-PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS
-BEGIN
- X := INTEGER(F);
-END INNER6;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83023a.ada b/gcc/testsuite/ada/acats/tests/c8/c83023a.ada
deleted file mode 100644
index 18f80c3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83023a.ada
+++ /dev/null
@@ -1,194 +0,0 @@
--- C83023A.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 DECLARATION IN A DECLARATIVE REGION OF A TASK
--- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE
--- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE
--- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE
--- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 08/29/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83023A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83023A", "CHECK THAT A DECLARATION IN A DECLARATIVE " &
- "REGION OF A TASK HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE -- DECLARATIVE REGION.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- TASK INNER IS
- ENTRY HERE (X : IN OUT INTEGER);
- END INNER;
-
- TASK BODY INNER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- ACCEPT HERE (X : IN OUT INTEGER) DO
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" &
- " - 1");
- END IF;
-
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" &
- " - 2");
- END IF;
-
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " &
- "- 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE " &
- "- 4");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := ONE.A;
- END IF;
- END HERE;
- END INNER;
-
- BEGIN -- ONE
- INNER.HERE(A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE -- AFTER THE SPECIFICATION OF TASK.
- TASK INNER IS
- ENTRY HERE (X : IN OUT INTEGER);
- END INNER;
-
- A : INTEGER := IDENT_INT(2);
-
- B : INTEGER := A;
-
- TASK BODY INNER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- ACCEPT HERE (X : IN OUT INTEGER) DO
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" &
- " - 10");
- END IF;
-
- IF TWO.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" &
- " - 11");
- END IF;
-
- IF TWO.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " &
- "- 12");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE " &
- "- 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- NULL;
- END IF;
- END HERE;
- END INNER;
-
- BEGIN -- TWO
- INNER.HERE(A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END TWO;
-
- THREE:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 5.0;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- TASK INNER IS
- ENTRY HERE (X : IN OUT INTEGER);
- END INNER;
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- TASK BODY INNER IS
- F : FLOAT := 6.25;
- BEGIN
- ACCEPT HERE (X : IN OUT INTEGER) DO
- X := INTEGER(F);
- END HERE;
- END INNER;
-
- BEGIN
- INNER.HERE (OBJ);
-
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20");
- END IF;
- END THREE;
-
- RESULT;
-END C83023A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024a.ada b/gcc/testsuite/ada/acats/tests/c8/c83024a.ada
deleted file mode 100644
index 0ad06b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83024a.ada
+++ /dev/null
@@ -1,185 +0,0 @@
--- C83024A.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 DECLARATION IN A DECLARATIVE REGION FOR A GENERIC
--- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK
--- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH
--- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH
--- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAH DECLARATION.
-
--- HISTORY:
--- BCB 08/30/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C83024A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83024A", "CHECK THAT A DECLARATION IN A DECLARATIVE " &
- "REGION FOR A GENERIC PACKAGE HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- GENERIC
- X : IN INTEGER := A;
- A : IN OUT INTEGER;
- PACKAGE INNER IS
- C : INTEGER := A;
- END INNER;
-
- PACKAGE BODY INNER IS
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10");
- END IF;
-
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
- END INNER;
-
- PACKAGE NEW_INNER IS NEW INNER (A => OBJ);
-
- BEGIN -- ONE
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END ONE;
-
- TWO:
- DECLARE -- AFTER THE SPECIFICATION OF PACKAGE.
- A : INTEGER := IDENT_INT(2);
-
- GENERIC
- X : IN OUT INTEGER;
- PACKAGE INNER IS
- A : INTEGER := IDENT_INT(3);
- END INNER;
-
- B : INTEGER := A;
-
- PACKAGE BODY INNER IS
- C : INTEGER := TWO.A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
-
- IF TWO.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
-
- IF TWO.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- NULL;
- END IF;
- END INNER;
-
- PACKAGE NEW_INNER IS NEW INNER (A);
-
- BEGIN -- TWO
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 25");
- END IF;
- END TWO;
-
- THREE:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 6.25;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- GENERIC
- X : IN OUT INTEGER;
- F : IN FLOAT;
- PACKAGE INNER IS
- END INNER;
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- PACKAGE BODY INNER IS
- BEGIN
- X := INTEGER(F);
- END INNER;
-
- PACKAGE NEW_INNER IS NEW INNER (OBJ, FLO);
-
- BEGIN
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60");
- END IF;
- END THREE;
-
- RESULT;
-END C83024A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada b/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada
deleted file mode 100644
index e92cffb..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C83024E0.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 DECLARATION IN THE DECLARATIVE REGION OF A GENERIC
--- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK
--- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH
--- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH
--- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY
--- COMPILED, BUT NOT AS A SUBUNIT.
-
--- HISTORY:
--- BCB 08/30/88 CREATED ORIGINAL TEST.
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-GENERIC
- TYPE T IS PRIVATE;
- X : T;
-FUNCTION C83024E_GEN_FUN RETURN T;
-
-FUNCTION C83024E_GEN_FUN RETURN T IS
-BEGIN
- RETURN X;
-END C83024E_GEN_FUN;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE(REPORT);
-PACKAGE C83024E_P1 IS
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- PROCEDURE REQUIRE_BODY;
-
- GENERIC
- X : IN OUT INTEGER;
- PACKAGE C83024E_PACK1 IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- END C83024E_PACK1;
-END C83024E_P1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE(REPORT);
-PACKAGE C83024E_P2 IS
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- PROCEDURE REQUIRE_BODY;
-
- GENERIC
- X : IN INTEGER := A;
- A : IN OUT INTEGER;
- PACKAGE C83024E_PACK2 IS
- C : INTEGER := A;
- END C83024E_PACK2;
-END C83024E_P2;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE(REPORT);
-PACKAGE C83024E_P3 IS
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- PROCEDURE REQUIRE_BODY;
-
- GENERIC
- X : IN OUT INTEGER;
- PACKAGE C83024E_PACK3 IS
- END C83024E_PACK3;
-END C83024E_P3;
-
-WITH REPORT; USE REPORT;
-WITH C83024E_GEN_FUN;
-PRAGMA ELABORATE(REPORT,C83024E_GEN_FUN);
-PACKAGE C83024E_P4 IS
- OBJ : INTEGER := IDENT_INT(1);
- FLO : FLOAT := 6.25;
-
- PROCEDURE REQUIRE_BODY;
-
- FUNCTION F IS NEW C83024E_GEN_FUN (INTEGER, OBJ);
- FUNCTION F IS NEW C83024E_GEN_FUN (FLOAT, FLO);
-
- GENERIC
- X : IN OUT INTEGER;
- F : IN FLOAT;
- PACKAGE C83024E_PACK4 IS
- END C83024E_PACK4;
-END C83024E_P4;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada b/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada
deleted file mode 100644
index d7c1c5b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada
+++ /dev/null
@@ -1,220 +0,0 @@
--- C83024E1M.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 DECLARATION IN THE DECLARATIVE REGION OF A GENERIC
--- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK
--- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH
--- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH
--- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY
--- COMPILED, BUT NOT AS A SUBUNIT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT SEPARATE
--- COMPILATIONS OF GENERIC SPECIFICATIONS AND BODIES.
-
--- SEPARATE FILES ARE:
--- C83024E0.ADA -- GENERIC PACKAGE SPECIFICATIONS.
--- C83024E1M.ADA - (THIS FILE) GENERIC PACKAGE BODIES AND
--- MAIN PROGRAM.
-
--- HISTORY:
--- BCB 08/30/88 CREATED ORIGINAL TEST.
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-PACKAGE BODY C83024E_P1 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY C83024E_PACK1 IS
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF C83024E_P1.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF C83024E_P1.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := C83024E_P1.A;
- END IF;
- END C83024E_PACK1;
-END C83024E_P1;
-
-PACKAGE BODY C83024E_P2 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY C83024E_PACK2 IS
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10");
- END IF;
-
- IF C83024E_P2.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF C83024E_P2.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
- END C83024E_PACK2;
-END C83024E_P2;
-
-PACKAGE BODY C83024E_P3 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY C83024E_PACK3 IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
-
- IF C83024E_P3.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
-
- IF C83024E_P3.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- NULL;
- END IF;
- END C83024E_PACK3;
-END C83024E_P3;
-
-PACKAGE BODY C83024E_P4 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY C83024E_PACK4 IS
- BEGIN
- X := INTEGER(F);
- END C83024E_PACK4;
-END C83024E_P4;
-
-WITH REPORT; USE REPORT;
-WITH C83024E_P1; WITH C83024E_P2;
-WITH C83024E_P3; WITH C83024E_P4;
-USE C83024E_P1; USE C83024E_P2;
-USE C83024E_P3; USE C83024E_P4;
-PROCEDURE C83024E1M IS
-
-BEGIN
- TEST ("C83024E", "CHECK THAT A DECLARATION IN THE DECLARATIVE " &
- "REGION OF A GENERIC PACKAGE HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- DECLARE
- PACKAGE NEW_C83024E_PACK1 IS NEW C83024E_PACK1 (C83024E_P1.A);
- BEGIN
- IF C83024E_P1.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END;
-
- DECLARE
- PACKAGE NEW_C83024E_PACK2 IS
- NEW C83024E_PACK2 (A => C83024E_P2.OBJ);
- BEGIN
- IF C83024E_P2.OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END;
-
- DECLARE
- PACKAGE NEW_C83024E_PACK3 IS NEW C83024E_PACK3 (C83024E_P3.A);
- BEGIN
- IF C83024E_P3.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 25");
- END IF;
- END;
-
- DECLARE
- PACKAGE NEW_C83024E_PACK4 IS
- NEW C83024E_PACK4 (C83024E_P4.OBJ, FLO);
- BEGIN
- IF C83024E_P4.OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60");
- END IF;
- END;
-
- RESULT;
-END C83024E1M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83025a.ada b/gcc/testsuite/ada/acats/tests/c8/c83025a.ada
deleted file mode 100644
index aff1914..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83025a.ada
+++ /dev/null
@@ -1,283 +0,0 @@
--- C83025A.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 DECLARATION IN THE DECLARATIVE REGION OF A GENERIC
--- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK
--- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH
--- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH
--- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 08/31/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C83025A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83025A", "CHECK THAT A DECLARATION IN THE DECLARATIVE " &
- "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE -- SUBPROGRAM DECLARATIVE REGION.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- GENERIC
- PROCEDURE INNER (X : IN OUT INTEGER);
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := ONE.A;
- END IF;
- END INNER;
-
- PROCEDURE NEW_INNER IS NEW INNER;
-
- BEGIN -- ONE
- NEW_INNER (A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE -- FORMAL PARAMETER OF GENERIC SUBPROGRAM.
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- GENERIC
- PROCEDURE INNER (X : IN INTEGER := A;
- A : IN OUT INTEGER);
-
- PROCEDURE INNER (X : IN INTEGER := TWO.A;
- A : IN OUT INTEGER) IS
- C : INTEGER := A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10");
- END IF;
-
- IF TWO.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF TWO.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
- END INNER;
-
- PROCEDURE NEW_INNER IS NEW INNER;
-
- BEGIN -- TWO
- NEW_INNER (A => OBJ);
-
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END TWO;
-
- THREE:
- DECLARE -- AFTER THE SPECIFICATION OF GENERIC SUBPROGRAM.
- GENERIC
- A : INTEGER := IDENT_INT(3);
- FUNCTION INNER (X : INTEGER) RETURN INTEGER;
-
- A : INTEGER := IDENT_INT(2);
-
- B : INTEGER := A;
-
- FUNCTION INNER (X : INTEGER) RETURN INTEGER IS
- C : INTEGER := THREE.A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
-
- IF THREE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
-
- IF THREE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
-
- IF EQUAL(1,1) THEN
- RETURN A;
- ELSE
- RETURN X;
- END IF;
- END INNER;
-
- FUNCTION NEW_INNER IS NEW INNER;
-
- BEGIN -- THREE
- IF NEW_INNER(A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 25");
- END IF;
- END THREE;
-
- FOUR:
- DECLARE
- A : INTEGER := IDENT_INT(2);
-
- GENERIC
- A : INTEGER;
- B : INTEGER := A;
- PROCEDURE INNER (X : IN OUT INTEGER);
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := FOUR.A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30");
- END IF;
-
- IF B /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 31");
- END IF;
-
- IF FOUR.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 32");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 34");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := FOUR.A;
- END IF;
- END INNER;
-
- PROCEDURE NEW_INNER IS NEW INNER (A => IDENT_INT(3));
-
- BEGIN
- NEW_INNER (A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 35");
- END IF;
- END FOUR;
-
- FIVE:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 5.0;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- GENERIC
- PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS
- BEGIN
- X := INTEGER(F);
- END INNER;
-
- PROCEDURE NEW_INNER IS NEW INNER;
-
- BEGIN -- FIVE
- FLO := 6.25;
-
- NEW_INNER (OBJ, FLO);
-
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 40");
- END IF;
- END FIVE;
-
- RESULT;
-END C83025A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83025c.ada b/gcc/testsuite/ada/acats/tests/c8/c83025c.ada
deleted file mode 100644
index b21d268..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83025c.ada
+++ /dev/null
@@ -1,345 +0,0 @@
--- C83025C.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 DECLARATION IN A DECLARATIVE REGION OF A GENERIC
--- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK
--- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH
--- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH
--- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER
--- HOMOGRAPH DECLARATION, IF THE GENERIC SUBPROGRAM BODY IS COMPILED
--- AS A SUBUNIT IN THE SAME COMPILATION.
-
--- HISTORY:
--- BCB 09/01/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE(REPORT);
-PACKAGE C83025C_PACK IS
- Y : INTEGER := IDENT_INT(5);
- Z : INTEGER := Y;
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- OBJ : INTEGER := IDENT_INT(3);
-
- FLO : FLOAT := 5.0;
-
- TYPE ENUM IS (ONE, TWO, THREE, FOUR);
-
- EOBJ : ENUM := ONE;
-
- GENERIC
- Y : FLOAT := 2.0;
- PROCEDURE INNER (X : IN OUT INTEGER);
-
- GENERIC
- Y : BOOLEAN := TRUE;
- PROCEDURE INNER2 (X : IN INTEGER := A;
- A : IN OUT INTEGER);
-
- GENERIC
- Y : ENUM := ONE;
- FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER;
-
- GENERIC
- Y : ENUM;
- FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER;
-
- GENERIC
- Y : CHARACTER := 'A';
- PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT;
- Z : CHARACTER := Y);
-END C83025C_PACK;
-
-PACKAGE BODY C83025C_PACK IS
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE;
-
- PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A;
- A : IN OUT INTEGER) IS SEPARATE;
-
- FUNCTION INNER3 (X : INTEGER;
- Z : ENUM := Y) RETURN INTEGER IS SEPARATE;
-
- FUNCTION INNER4 (X : INTEGER;
- Z : ENUM := Y) RETURN INTEGER IS SEPARATE;
-
- PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT;
- Z : CHARACTER := Y) IS SEPARATE;
-END C83025C_PACK;
-
-SEPARATE (C83025C_PACK)
-PROCEDURE INNER (X : IN OUT INTEGER) IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF C83025C_PACK.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF C83025C_PACK.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 5");
- END IF;
-
- IF Y /= 2.0 THEN
- FAILED ("INCORRECT VALUE INNER HOMOGRAPH - 6");
- END IF;
-
- IF EQUAL(1,1) THEN
- X := A;
- ELSE
- X := C83025C_PACK.A;
- END IF;
-END INNER;
-
-SEPARATE (C83025C_PACK)
-PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A;
- A : IN OUT INTEGER) IS
- C : INTEGER := A;
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10");
- END IF;
-
- IF C83025C_PACK.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF C83025C_PACK.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF Y /= TRUE THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 15");
- END IF;
-
- IF EQUAL(1,1) THEN
- A := IDENT_INT(4);
- ELSE
- A := 1;
- END IF;
-END INNER2;
-
-SEPARATE (C83025C_PACK)
-FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20");
- END IF;
-
- IF C83025C_PACK.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21");
- END IF;
-
- IF C83025C_PACK.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 24");
- END IF;
-
- IF Y /= ONE THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 25");
- END IF;
-
- IF Z /= ONE THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 26");
- END IF;
-
- IF EQUAL(1,1) THEN
- RETURN A;
- ELSE
- RETURN X;
- END IF;
-END INNER3;
-
-SEPARATE (C83025C_PACK)
-FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
-BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30");
- END IF;
-
- IF C83025C_PACK.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 31");
- END IF;
-
- IF C83025C_PACK.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 34");
- END IF;
-
- IF Y /= ONE THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 35");
- END IF;
-
- IF Z /= ONE THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 36");
- END IF;
-
- IF EQUAL(1,1) THEN
- RETURN A;
- ELSE
- RETURN X;
- END IF;
-END INNER4;
-
-SEPARATE (C83025C_PACK)
-PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT;
- Z : CHARACTER := Y) IS
-BEGIN
- X := INTEGER(F);
-
- IF Y /= 'A' THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 40");
- END IF;
-
- IF Z /= 'A' THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 41");
- END IF;
-END INNER5;
-
-WITH REPORT; USE REPORT;
-WITH C83025C_PACK; USE C83025C_PACK;
-PROCEDURE C83025C IS
-
- PROCEDURE NEW_INNER IS NEW INNER;
-
- PROCEDURE NEW_INNER2 IS NEW INNER2;
-
- FUNCTION NEW_INNER3 IS NEW INNER3;
-
- FUNCTION NEW_INNER4 IS NEW INNER4 (Y => EOBJ);
-
- PROCEDURE NEW_INNER5 IS NEW INNER5;
-
-BEGIN
- TEST ("C83025C", "CHECK THAT A DECLARATION IN A DECLARATIVE " &
- "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- A := IDENT_INT(2);
- B := A;
-
- NEW_INNER (A);
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 7");
- END IF;
-
- A := IDENT_INT(2);
-
- NEW_INNER2 (A => OBJ);
-
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 16");
- END IF;
-
- A := IDENT_INT(2);
-
- B := A;
-
- IF NEW_INNER3(A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 27");
- END IF;
-
- A := IDENT_INT(2);
-
- B := A;
-
- IF NEW_INNER4(A) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 37");
- END IF;
-
- OBJ := 1;
-
- FLO := 6.25;
-
- NEW_INNER5 (OBJ, FLO);
-
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 42");
- END IF;
-
- IF Y /= 5 THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 50");
- END IF;
-
- IF Z /= 5 THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 51");
- END IF;
-
- RESULT;
-END C83025C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83027a.ada b/gcc/testsuite/ada/acats/tests/c8/c83027a.ada
deleted file mode 100644
index ba7c123..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83027a.ada
+++ /dev/null
@@ -1,188 +0,0 @@
--- C83027A.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 DECLARATION IN A RECORD DECLARATION HIDES AN OUTER
--- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION
--- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE
--- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS
--- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 09/02/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83027A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83027A", "CHECK THAT A DECLARATION IN A RECORD " &
- "DECLARATION HIDES AN OUTER DECLARATION OF " &
- "A HOMOGRAPH");
-
- ONE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- OBJ : INTEGER := IDENT_INT(3);
-
- TYPE INNER2 (A : INTEGER := IDENT_INT(3)) IS RECORD
- C : INTEGER := ONE.A;
- D : INTEGER := A;
- END RECORD;
-
- E : INTEGER := A;
-
- RECVAR : INNER2;
-
- BEGIN -- ONE
- IF A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 1");
- END IF;
-
- IF RECVAR.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 2");
- END IF;
-
- IF E /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF RECVAR.C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF RECVAR.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5");
- END IF;
-
- IF EQUAL(1,1) THEN
- OBJ := RECVAR.A;
- ELSE
- OBJ := 1;
- END IF;
-
- IF OBJ /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE
-
- GENERIC
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- PACKAGE P IS
- TYPE INNER (C : INTEGER := A;
- A : INTEGER := IDENT_INT(3)) IS RECORD
- D : INTEGER := A;
- END RECORD;
- END P;
-
- PACKAGE BODY P IS
- RECVAR : INNER;
- BEGIN
- IF RECVAR.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10");
- END IF;
-
- IF A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF RECVAR.C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF RECVAR.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 14");
- END IF;
- END P;
-
- PACKAGE PACK IS NEW P;
-
- BEGIN -- TWO
- NULL;
- END TWO;
-
- THREE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- OBJ : INTEGER := IDENT_INT(3);
-
- TYPE INNER4 (C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- X : INTEGER := THREE.A) IS RECORD
- D : INTEGER := A;
- END RECORD;
-
- RECVAR : INNER4;
-
- BEGIN -- THREE
- IF A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 20");
- END IF;
-
- IF RECVAR.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 21");
- END IF;
-
- IF RECVAR.C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 22");
- END IF;
-
- IF RECVAR.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23");
- END IF;
-
- IF RECVAR.X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 24");
- END IF;
-
- IF EQUAL(1,1) THEN
- OBJ := RECVAR.A;
- ELSE
- OBJ := 1;
- END IF;
-
- IF OBJ /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 25");
- END IF;
- END THREE;
-
- RESULT;
-END C83027A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83027c.ada b/gcc/testsuite/ada/acats/tests/c8/c83027c.ada
deleted file mode 100644
index 2950135..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83027c.ada
+++ /dev/null
@@ -1,157 +0,0 @@
--- C83027C.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 DECLARATION WITHIN THE DISCRIMINANT PART OF A
--- PRIVATE TYPE DECLARATION, AN INCOMPLETE TYPE DECLARATION, AND A
--- GENERIC FORMAL TYPE DECLARATION HIDES AN OUTER DECLARATION OF A
--- HOMOGRAPH. ALSO, CHECK THAT THE OUTER DECLARATION IS DIRECTLY
--- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE
--- INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY SELECTION
--- AFTER THE INNER HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 09/06/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83027C IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83027C", "CHECK THAT A DECLARATION IN THE DISCRIMINANT " &
- "PART OF A PRIVATE TYPE DECLARATION, AN " &
- "INCOMPLETE TYPE DECLARATION, AND A GENERIC " &
- "FORMAL TYPE DECLARATION HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
-
- D : INTEGER := IDENT_INT(2);
-
- G : INTEGER := IDENT_INT(2);
- H : INTEGER := G;
-
- TYPE REC (Z : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- GENERIC
- TYPE INNER3 (G : INTEGER) IS PRIVATE;
- PACKAGE P_ONE IS
- TYPE INNER (X : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- C : INTEGER := ONE.A) IS PRIVATE;
- TYPE INNER2 (Y : INTEGER := D;
- D : INTEGER := IDENT_INT(3);
- F : INTEGER := ONE.D);
- TYPE INNER2 (Y : INTEGER := D;
- D : INTEGER := IDENT_INT(3);
- F : INTEGER := ONE.D) IS RECORD
- E : INTEGER := D;
- END RECORD;
- PRIVATE
- TYPE INNER (X : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- C : INTEGER := ONE.A) IS RECORD
- B : INTEGER := A;
- END RECORD;
- END P_ONE;
-
- PACKAGE BODY P_ONE IS
- RECVAR : INNER;
- RECVAR2 : INNER2;
- RECVAR3 : INNER3(3);
- BEGIN
- IF RECVAR.A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF RECVAR.B /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 3");
- END IF;
-
- IF RECVAR.C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF RECVAR.X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5");
- END IF;
-
- IF RECVAR2.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 6");
- END IF;
-
- IF D /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 7");
- END IF;
-
- IF RECVAR2.E /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 8");
- END IF;
-
- IF RECVAR2.F /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 9");
- END IF;
-
- IF RECVAR2.Y /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 10");
- END IF;
-
- IF RECVAR3.G /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 11");
- END IF;
-
- IF G /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 12");
- END IF;
-
- IF H /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 13");
- END IF;
- END P_ONE;
-
- PACKAGE NEW_P_ONE IS NEW P_ONE (REC);
-
- BEGIN -- ONE
- NULL;
- END ONE;
-
- RESULT;
-END C83027C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83028a.ada b/gcc/testsuite/ada/acats/tests/c8/c83028a.ada
deleted file mode 100644
index 7aa7af0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83028a.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- C83028A.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 DECLARATION IN A BLOCK STATEMENT HIDES AN OUTER
--- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION
--- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE
--- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS
--- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 09/06/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83028A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83028A", "CHECK THAT A DECLARATION IN A BLOCK " &
- "STATEMENT HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
-
- BEGIN -- ONE
- DECLARE
- C : INTEGER := A;
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF EQUAL(1,1) THEN
- ONE.A := A;
- END IF;
- END;
-
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- OBJ : INTEGER := IDENT_INT(3);
-
- BEGIN -- TWO
- DECLARE
- X : INTEGER := A;
- A : INTEGER := OBJ;
- C : INTEGER := A;
- BEGIN
- IF A /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10");
- END IF;
-
- IF TWO.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11");
- END IF;
-
- IF TWO.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12");
- END IF;
-
- IF C /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13");
- END IF;
-
- IF X /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE PASSED IN - 14");
- END IF;
-
- IF EQUAL(1,1) THEN
- TWO.OBJ := IDENT_INT(4);
- ELSE
- TWO.OBJ := 1;
- END IF;
- END;
-
- IF OBJ /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 15");
- END IF;
- END TWO;
-
- THREE:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 5.0;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- BEGIN
- DECLARE
- F : FLOAT := 6.25;
- BEGIN
- THREE.OBJ := INTEGER(F);
- END;
-
- IF OBJ /= IDENT_INT(6) THEN
- FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20");
- END IF;
- END THREE;
-
- RESULT;
-END C83028A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83029a.ada b/gcc/testsuite/ada/acats/tests/c8/c83029a.ada
deleted file mode 100644
index 1460a53..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83029a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C83029A.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 LOOP PARAMETER HIDES AN OUTER DECLARATION OF A
--- HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION IS DIRECTLY
--- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF
--- THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY
--- SELECTION AFTER THE INNER HOMOGRAPH DECLARATION.
-
--- HISTORY:
--- BCB 09/06/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83029A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- X : T;
- FUNCTION GEN_FUN RETURN T;
-
- FUNCTION GEN_FUN RETURN T IS
- BEGIN
- RETURN X;
- END GEN_FUN;
-
-BEGIN
- TEST ("C83029A", "CHECK THAT A LOOP PARAMETER HIDES AN OUTER " &
- "DECLARATION OF A HOMOGRAPH");
-
- ONE:
- DECLARE
- A : INTEGER := IDENT_INT(2);
- B : INTEGER := A;
- C : INTEGER;
-
- BEGIN -- ONE
-
- FOR A IN 1 .. 1 LOOP
- C := A;
-
- IF A /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1");
- END IF;
-
- IF ONE.A /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2");
- END IF;
-
- IF ONE.B /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3");
- END IF;
-
- IF C /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4");
- END IF;
-
- IF EQUAL(1,1) THEN
- ONE.A := A;
- END IF;
- END LOOP;
-
- IF A /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE PASSED OUT - 6");
- END IF;
- END ONE;
-
- TWO:
- DECLARE -- OVERLOADING OF FUNCTIONS.
-
- OBJ : INTEGER := 1;
- FLO : FLOAT := 5.0;
-
- FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ);
-
- FUNCTION F IS NEW GEN_FUN (FLOAT, FLO);
-
- BEGIN
- FOR F IN 1 .. 1 LOOP
- OBJ := INTEGER(F);
- END LOOP;
-
- IF OBJ /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE RETURNED - 10");
- END IF;
- END TWO;
-
- RESULT;
-END C83029A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83030a.ada b/gcc/testsuite/ada/acats/tests/c8/c83030a.ada
deleted file mode 100644
index d992f7b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83030a.ada
+++ /dev/null
@@ -1,234 +0,0 @@
--- C83030A.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 WITHIN A GENERIC SUBPROGRAM BODY, NO SUBPROGRAM
--- DECLARED IN AN OUTER DECLARATIVE REGION IS HIDDEN (UNLESS THE
--- SUBPROGRAM IS A HOMOGRAPH OF THE GENERIC SUBPROGRAM).
-
--- HISTORY:
--- TBN 08/03/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83030A IS
-
- GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST);
- SWITCH1 : BOOLEAN := TRUE;
-
- PROCEDURE P IS
- BEGIN
- GLOBAL := IDENT_INT(1);
- END P;
-
- PROCEDURE P (X : INTEGER) IS
- BEGIN
- GLOBAL := IDENT_INT(X);
- END P;
-
-BEGIN
- TEST ("C83030A", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY, " &
- "NO SUBPROGRAM DECLARED IN AN OUTER " &
- "DECLARATIVE REGION IS HIDDEN " &
- "(UNLESS THE SUBPROGRAM IS A HOMOGRAPH OF THE " &
- "GENERIC SUBPROGRAM)");
-
- ONE:
- DECLARE
- GENERIC
- PROCEDURE P;
-
- PROCEDURE P IS
- A : INTEGER := IDENT_INT(2);
- BEGIN
- IF SWITCH1 THEN
- SWITCH1 := FALSE;
- P;
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " &
- "- 1");
- END IF;
- END IF;
- P(A);
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2");
- END IF;
- GLOBAL := IDENT_INT(3);
- END P;
-
- PROCEDURE NEW_P IS NEW P;
-
- BEGIN
- IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR START OF TEST ONE");
- END IF;
- NEW_P;
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST ONE");
- END IF;
- END ONE;
-
-
- TWO:
- DECLARE
- GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST);
- SWITCH : BOOLEAN := TRUE;
-
- GENERIC
- TYPE T IS (<>);
- PROCEDURE P (X : T);
-
- PROCEDURE P (X : T) IS
- A : T := T'FIRST;
- BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- P (X);
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " &
- "- 20");
- END IF;
- GLOBAL := IDENT_INT(3);
- ELSE
- GLOBAL := IDENT_INT(2);
- END IF;
- END P;
-
- PROCEDURE NEW_P IS NEW P (INTEGER);
-
- BEGIN
- IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR START OF TEST TWO");
- END IF;
- NEW_P (1);
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST TWO");
- END IF;
- END TWO;
-
-
- THREE:
- DECLARE
- SWITCH : BOOLEAN := TRUE;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END F;
-
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL(FALSE);
- END F;
-
- FUNCTION F (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(X);
- END F;
-
- BEGIN
- DECLARE
- GENERIC
- FUNCTION F RETURN INTEGER;
-
- FUNCTION F RETURN INTEGER IS
- A : INTEGER := INTEGER'LAST;
- BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- IF F /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION " &
- "CALL - 30");
- END IF;
- END IF;
- IF F(A) /= IDENT_INT(INTEGER'LAST) THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL " &
- "- 31");
- END IF;
- IF F THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL " &
- "- 32");
- END IF;
- RETURN IDENT_INT(3);
- END F;
-
- FUNCTION NEW_F IS NEW F;
-
- BEGIN
- IF NEW_F /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST THREE");
- END IF;
- END;
- END THREE;
-
-
- FOUR:
- DECLARE
- SWITCH : BOOLEAN := TRUE;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END F;
-
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL(FALSE);
- END F;
-
- BEGIN
- DECLARE
- GENERIC
- TYPE T IS (<>);
- FUNCTION F RETURN T;
-
- FUNCTION F RETURN T IS
- A : T := T'LAST;
- BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- IF F /= T'LAST THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION " &
- "CALL - 40");
- END IF;
- RETURN T'FIRST;
- ELSE
- IF F THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION " &
- "CALL - 41");
- END IF;
- RETURN T'LAST;
- END IF;
- END F;
-
- FUNCTION NEW_F IS NEW F (INTEGER);
-
- BEGIN
- IF NEW_F /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST FOUR");
- END IF;
- END;
- END FOUR;
-
- RESULT;
-END C83030A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83030c.ada b/gcc/testsuite/ada/acats/tests/c8/c83030c.ada
deleted file mode 100644
index 914bd64..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83030c.ada
+++ /dev/null
@@ -1,263 +0,0 @@
--- C83030C.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 WITHIN A GENERIC SUBPROGRAM BODY COMPILED AS A SUBUNIT
--- IN THE SAME COMPILATION, NON-HOMOGRAPH SUBPROGRAMS DECLARED
--- OUTSIDE THE GENERIC UNIT, AND HAVING THE SAME IDENTIFIER, ARE NOT
--- HIDDEN.
-
--- HISTORY:
--- JET 10/17/88 CREATED ORIGINAL TEST.
--- BCB 10/03/90 ADDED "PRAGMA ELABORATE (REPORT);".
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE C83030C_DECL1 IS
- GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST);
- SWITCH : BOOLEAN := TRUE;
-
- PROCEDURE C83030C_PROC1;
- PROCEDURE C83030C_PROC1 (X : INTEGER);
- PROCEDURE C83030C_PROC2;
- PROCEDURE C83030C_PROC2 (X : INTEGER);
- FUNCTION C83030C_FUNC3 RETURN INTEGER;
- FUNCTION C83030C_FUNC3 RETURN BOOLEAN;
- FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER;
- FUNCTION C83030C_FUNC4 RETURN INTEGER;
- FUNCTION C83030C_FUNC4 RETURN BOOLEAN;
-END C83030C_DECL1;
-
-WITH REPORT; USE REPORT;
-WITH C83030C_DECL1; USE C83030C_DECL1;
-PACKAGE C83030C_DECL2 IS
- GENERIC
- PROCEDURE C83030C_PROC1;
-
- GENERIC
- TYPE T IS (<>);
- PROCEDURE C83030C_PROC2 (X : T);
-
- GENERIC
- FUNCTION C83030C_FUNC3 RETURN INTEGER;
-
- GENERIC
- TYPE T IS (<>);
- FUNCTION C83030C_FUNC4 RETURN T;
-END C83030C_DECL2;
-
-WITH REPORT; USE REPORT;
-PACKAGE BODY C83030C_DECL1 IS
- PROCEDURE C83030C_PROC1 IS
- BEGIN
- GLOBAL := IDENT_INT(1);
- END C83030C_PROC1;
-
- PROCEDURE C83030C_PROC1 (X : INTEGER) IS
- BEGIN
- GLOBAL := IDENT_INT(X);
- END C83030C_PROC1;
-
- PROCEDURE C83030C_PROC2 IS
- BEGIN
- GLOBAL := IDENT_INT(1);
- END C83030C_PROC2;
-
- PROCEDURE C83030C_PROC2 (X : INTEGER) IS
- BEGIN
- GLOBAL := IDENT_INT(X);
- END C83030C_PROC2;
-
- FUNCTION C83030C_FUNC3 RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END C83030C_FUNC3;
-
- FUNCTION C83030C_FUNC3 RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL(FALSE);
- END C83030C_FUNC3;
-
- FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(X);
- END C83030C_FUNC3;
-
- FUNCTION C83030C_FUNC4 RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END C83030C_FUNC4;
-
- FUNCTION C83030C_FUNC4 RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL(FALSE);
- END C83030C_FUNC4;
-END C83030C_DECL1;
-
-WITH REPORT; USE REPORT;
-WITH C83030C_DECL1; USE C83030C_DECL1;
-PACKAGE BODY C83030C_DECL2 IS
- PROCEDURE C83030C_PROC1 IS SEPARATE;
- PROCEDURE C83030C_PROC2 (X : T) IS SEPARATE;
- FUNCTION C83030C_FUNC3 RETURN INTEGER IS SEPARATE;
- FUNCTION C83030C_FUNC4 RETURN T IS SEPARATE;
-END C83030C_DECL2;
-
-SEPARATE (C83030C_DECL2)
-PROCEDURE C83030C_PROC1 IS
- A : INTEGER := IDENT_INT(2);
-BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- C83030C_PROC1;
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 1");
- END IF;
- END IF;
- C83030C_PROC1(A);
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2");
- END IF;
- GLOBAL := IDENT_INT(3);
-END C83030C_PROC1;
-
-SEPARATE (C83030C_DECL2)
-PROCEDURE C83030C_PROC2 (X : T) IS
- A : T := T'FIRST;
-BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- C83030C_PROC2 (X);
- IF GLOBAL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 20");
- END IF;
- GLOBAL := IDENT_INT(3);
- ELSE
- GLOBAL := IDENT_INT(2);
- END IF;
-END C83030C_PROC2;
-
-SEPARATE (C83030C_DECL2)
-FUNCTION C83030C_FUNC3 RETURN INTEGER IS
- A : INTEGER := INTEGER'LAST;
-BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- IF C83030C_FUNC3 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 30");
- END IF;
- END IF;
- IF C83030C_FUNC3(A) /= IDENT_INT(INTEGER'LAST) THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 31");
- END IF;
- IF C83030C_FUNC3 THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 32");
- END IF;
- RETURN IDENT_INT(3);
-END C83030C_FUNC3;
-
-SEPARATE (C83030C_DECL2)
-FUNCTION C83030C_FUNC4 RETURN T IS
- A : T := T'LAST;
-BEGIN
- IF SWITCH THEN
- SWITCH := FALSE;
- IF C83030C_FUNC4 /= T'LAST THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 40");
- END IF;
- RETURN T'FIRST;
- ELSE
- IF C83030C_FUNC4 THEN
- FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 41");
- END IF;
- RETURN T'LAST;
- END IF;
-END C83030C_FUNC4;
-
-WITH REPORT; USE REPORT;
-WITH C83030C_DECL1, C83030C_DECL2; USE C83030C_DECL1, C83030C_DECL2;
-PROCEDURE C83030C IS
-BEGIN
- TEST ("C83030C", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY " &
- "COMPILED AS A SUBUNIT IN THE SAME COMPILATION," &
- " NON-HOMOGRAPH SUBPROGRAMS DECLARED OUTSIDE " &
- "THE GENERIC UNIT, AND HAVING THE SAME " &
- "IDENTIFIER, ARE NOT HIDDEN");
-
- ONE:
- DECLARE
- PROCEDURE PROC1 IS NEW C83030C_DECL2.C83030C_PROC1;
- BEGIN
- IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR START OF TEST ONE");
- END IF;
- PROC1;
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST ONE");
- END IF;
-
- GLOBAL := IDENT_INT(INTEGER'FIRST);
- SWITCH := TRUE;
- END ONE;
-
- TWO:
- DECLARE
- PROCEDURE PROC2 IS NEW C83030C_DECL2.C83030C_PROC2(INTEGER);
- BEGIN
- IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR START OF TEST TWO");
- END IF;
- PROC2 (1);
- IF GLOBAL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST TWO");
- END IF;
-
- SWITCH := TRUE;
- END TWO;
-
- THREE:
- DECLARE
- FUNCTION FUNC3 IS NEW C83030C_DECL2.C83030C_FUNC3;
- BEGIN
- IF FUNC3 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST THREE");
- END IF;
-
- SWITCH := TRUE;
- END THREE;
-
- FOUR:
- DECLARE
- FUNCTION FUNC4 IS NEW C83030C_DECL2.C83030C_FUNC4 (INTEGER);
- BEGIN
- IF FUNC4 /= IDENT_INT(INTEGER'FIRST) THEN
- FAILED ("INCORRECT VALUE FOR END OF TEST FOUR");
- END IF;
-
- GLOBAL := INTEGER'FIRST;
- SWITCH := TRUE;
- END FOUR;
-
- RESULT;
-END C83030C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031a.ada b/gcc/testsuite/ada/acats/tests/c8/c83031a.ada
deleted file mode 100644
index 13b90bb..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83031a.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- C83031A.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 IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR
--- AN ENUMERATION LITERAL IS HIDDEN BY A SUBPROGRAM DECLARATION OR
--- A RENAMING DECLARATION WHICH DECLARES A HOMOGRAPH OF THE
--- OPERATOR OR LITERAL.
-
--- HISTORY:
--- VCL 08/10/88 CREATED ORIGINAL TEST.
--- JRL 03/20/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83031A IS
-BEGIN
- TEST ("C83031A", "AN IMPLICIT DECLARATION OF A PREDEFINED " &
- "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " &
- "BY A SUBPROGRAM DECLARATION OR A RENAMING " &
- "DECLARATION WHICH DECLARES A HOMOGRAPH OF THE " &
- "OPERATOR OR LITERAL");
-
- DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS
- PACKAGE P IS
- TYPE INT IS RANGE -20 .. 20;
-
- M : INT := 3 * INT(IDENT_INT(3));
- N : INT := 4 + INT(IDENT_INT(4));
-
- FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT;
- TYPE INT2 IS PRIVATE;
- FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2;
- PRIVATE
- FUNCTION "+" (LEFT, RIGHT : INT) RETURN INT
- RENAMES "/" ;
-
- TYPE INT2 IS RANGE -20 .. 20;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT IS
- BEGIN
- RETURN LEFT / RIGHT;
- END "*";
-
- FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2 IS
- BEGIN
- RETURN LEFT - RIGHT;
- END "+";
-
- BEGIN
- IF 2 * INT(IDENT_INT(2)) /= 1 THEN
- FAILED ("INCORRECT VALUE RETURNED IN CALL TO " &
- "EXPLICIT '*' OPERATOR - 1");
- END IF;
-
- IF N /= 8 THEN
- FAILED ("INCORRECT INITIAL VALUE FOR N - 1");
- END IF;
- N := 2 + 2;
- IF N /= INT(IDENT_INT (1)) THEN
- FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " &
- "EXPLICIT '+' OPERATOR - 1");
- END IF;
-
- DECLARE
- Q : INT2 := 8 + 9;
- BEGIN
- IF Q /= -1 THEN
- FAILED ("INCORRECT VALUE FOR Q");
- END IF;
- END;
- END P;
- BEGIN
- IF M /= 9 THEN
- FAILED ("INCORRECT INITIAL VALUE FOR M - 2");
- END IF;
- IF 2 * INT(IDENT_INT(2)) /= 1 THEN
- FAILED ("INCORRECT VALUE RETURNED IN CALL TO " &
- "EXPLICIT '*' OPERATOR - 2");
- END IF;
-
- N := 2 + 2;
- IF N /= INT(IDENT_INT (4)) THEN
- FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " &
- "IMPLICIT '+' OPERATOR - 2");
- END IF;
-
- END;
-
- DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS.
-
- PACKAGE P1 IS
- TYPE ENUM1 IS (E11, E12, E13);
- TYPE PRIV1 IS PRIVATE;
- FUNCTION E11 RETURN PRIV1;
- PRIVATE
- TYPE PRIV1 IS NEW ENUM1;
- FUNCTION E12 RETURN PRIV1 RENAMES E13;
- END P1;
- USE P1;
-
- E13 : INTEGER := IDENT_INT (5);
-
- FUNCTION E12 RETURN ENUM1 RENAMES E11 ;
-
- FUNCTION CHECK (E: ENUM1) RETURN INTEGER IS
- BEGIN
- RETURN ENUM1'POS (E);
- END CHECK;
-
- FUNCTION CHECK (E: INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER'POS (E);
- END CHECK;
-
- PACKAGE BODY P1 IS
- FUNCTION E11 RETURN PRIV1 IS
- BEGIN
- RETURN E13;
- END E11;
- BEGIN
- IF PRIV1'(E11) /= E13 THEN
- FAILED ("INCORRECT VALUE FOR E11");
- END IF;
-
- IF E12 /= PRIV1'LAST THEN
- FAILED ("INCORRECT VALUE FOR E12 - 1");
- END IF;
- END P1;
- BEGIN
- IF E12 /= ENUM1'FIRST THEN
- FAILED ("INCORRECT VALUE FOR E12 - 2");
- END IF;
-
- IF CHECK (E13) /= 5 THEN
- FAILED ("INCORRECT VALUE FOR E13");
- END IF;
- END;
- RESULT;
-END C83031A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031c.ada b/gcc/testsuite/ada/acats/tests/c8/c83031c.ada
deleted file mode 100644
index 1327a25..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83031c.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C83031C.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 IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR
--- ENUMERATION LITERAL IS HIDDEN BY A GENERIC INSTANTIATION WHICH
--- DECLARES A HOMOGRAPH OF THE OPERATOR OR LITERAL.
-
--- HISTORY:
--- BCB 09/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83031C IS
-
-BEGIN
- TEST ("C83031C", "CHECK THAT AN IMPLICIT DECLARATION OF A " &
- "PREDEFINED OPERATOR OR ENUMERATION LITERAL IS " &
- "HIDDEN BY A GENERIC INSTANTIATION WHICH " &
- "DECLARES A HOMOGRAPH OF THE OPERATOR OR " &
- "LITERAL");
-
- DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS
- PACKAGE P IS
- TYPE INT IS RANGE -20 .. 20;
-
- GENERIC
- TYPE X IS RANGE <>;
- FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X;
- END P;
- USE P;
-
- PACKAGE BODY P IS
- FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X IS
- BEGIN
- RETURN LEFT / RIGHT;
- END GEN_FUN;
-
- FUNCTION "*" IS NEW GEN_FUN (INT);
- BEGIN
- IF 2 * INT(IDENT_INT(2)) /= 1 THEN
- FAILED ("INCORRECT VALUE RETURNED IN CALL TO " &
- "EXPLICIT '*' OPERATOR - 1");
- END IF;
- END P;
- BEGIN
- NULL;
- END;
-
- DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS.
-
- PACKAGE P1 IS
- TYPE ENUM1 IS (E11, E12, E13);
- TYPE PRIV1 IS PRIVATE;
-
- GENERIC
- TYPE X IS (<>);
- FUNCTION GEN_FUN RETURN X;
- PRIVATE
- TYPE PRIV1 IS NEW ENUM1;
- END P1;
- USE P1;
-
- PACKAGE BODY P1 IS
- FUNCTION GEN_FUN RETURN X IS
- BEGIN
- RETURN X'LAST;
- END GEN_FUN;
-
- FUNCTION E11 IS NEW GEN_FUN (PRIV1);
- BEGIN
- IF PRIV1'(E11) /= E13 THEN
- FAILED ("INCORRECT VALUE FOR E11");
- END IF;
- END P1;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C83031C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83031e.ada b/gcc/testsuite/ada/acats/tests/c8/c83031e.ada
deleted file mode 100644
index 7742678..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83031e.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C83031E.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 IMPLICIT DECLARATION OF A PREDEFINED OPERATOR IS
--- HIDDEN BY A GENERIC FORMAL SUBPROGRAM DECLARATION WHICH DECLARES
--- A HOMOGRAPH OF THE OPERATOR.
-
--- HISTORY:
--- BCB 09/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C83031E IS
-
-BEGIN
- TEST ("C83031E", "CHECK THAT AN IMPLICIT DECLARATION OF A " &
- "PREDEFINED OPERATOR IS HIDDEN BY A GENERIC " &
- "FORMAL SUBPROGRAM DECLARATION WHICH DECLARES " &
- "A HOMOGRAPH OF THE OPERATOR");
-
- DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS
- TYPE INT IS RANGE -20 .. 20;
-
- GENERIC
- WITH FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT;
- PACKAGE P IS
- END P;
-
- PACKAGE BODY P IS
- BEGIN
- IF 2 * INT(IDENT_INT(2)) /= 1 THEN
- FAILED ("INCORRECT VALUE RETURNED IN CALL TO " &
- "EXPLICIT '*' OPERATOR - 1");
- END IF;
- END P;
-
- FUNCTION MULT (X, Y : INT) RETURN INT IS
- BEGIN
- RETURN X / Y;
- END MULT;
-
- PACKAGE NEW_P IS NEW P (MULT);
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C83031E;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83032a.ada b/gcc/testsuite/ada/acats/tests/c8/c83032a.ada
deleted file mode 100644
index b1920ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83032a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- C83032A.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 IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR
--- AN ENUMERATION LITERAL IS HIDDEN BY A DERIVED SUBPROGRAM
--- HOMOGRAPH.
-
--- HISTORY:
--- VCL 08/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83032A IS
-BEGIN
- TEST ("C83032A", "AN IMPLICIT DECLARATION OF A PREDEFINED " &
- "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " &
- "BY A DERIVED SUBPROGRAM HOMOGRAPH");
-
- DECLARE -- CHECK PREDEFINED OPERATOR.
- PACKAGE P IS
- TYPE INT IS RANGE -20 .. 20;
- FUNCTION "ABS" (X : INT) RETURN INT;
- END P;
- USE P;
-
- TYPE NINT IS NEW INT;
-
- I2 : NINT := -5;
-
- PACKAGE BODY P IS
- I1 : NINT := 5;
-
- FUNCTION "ABS" (X : INT) RETURN INT IS
- BEGIN
- RETURN INT (- (ABS (INTEGER (X))));
- END "ABS";
-
- BEGIN
- IF "ABS"(I1) /= -5 THEN
- FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " &
- "TO DERIVED ""ABS"" - 1");
- END IF;
-
- I1 := ABS (-10);
- IF ABS I1 /= NINT(IDENT_INT (-10)) THEN
- FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " &
- "TO DERIVED ""ABS"" - 2");
- END IF;
- END P;
- BEGIN
- IF "ABS"(I2) /= -5 THEN
- FAILED ("INCORRECT VALUE FOR 'I2' AFTER CALL " &
- "TO DERIVED ""ABS"" - 1");
- END IF;
-
- I2 := ABS (10);
- IF ABS I2 /= NINT (IDENT_INT (-10)) THEN
- FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " &
- "TO DERIVED ""ABS"" - 2");
- END IF;
- END;
-
- DECLARE -- CHECK ENUMERATION LITERALS.
-
- PACKAGE P1 IS
- TYPE ENUM1 IS (E11, E12, E13);
- TYPE PRIV1 IS PRIVATE;
- FUNCTION E11 RETURN PRIV1;
- PRIVATE
- TYPE PRIV1 IS NEW ENUM1;
- TYPE NPRIV1 IS NEW PRIV1;
- END P1;
- USE P1;
-
- PACKAGE BODY P1 IS
- FUNCTION E11 RETURN PRIV1 IS
- BEGIN
- RETURN E13;
- END E11;
- BEGIN
- IF NPRIV1'(E11) /= E13 THEN
- FAILED ("INCORRECT VALUE FOR E11");
- END IF;
- END P1;
-
- BEGIN
- NULL;
- END;
- RESULT;
-END C83032A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83033a.ada b/gcc/testsuite/ada/acats/tests/c8/c83033a.ada
deleted file mode 100644
index 6cfca93..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83033a.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- C83033A.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 IMPLICIT DECLARATION OF A BLOCK NAME, A LOOP NAME,
--- OR A STATEMENT LABEL HIDES THE DECLARATION OF AN ENUMERATION
--- LITERAL OR OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED TYPE
--- DEFINITION.
-
--- HISTORY:
--- DHH 09/21/88 CREATED ORIGINAL TEST.
--- WMC 03/25/92 REMOVED TEST REDUNDANCIES.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE C83033A IS
-
- PACKAGE BASE_P IS
- TYPE A IS (RED, BLUE, YELO);
- FUNCTION RED(T : INTEGER; X : A) RETURN A;
- FUNCTION BLUE(T : INTEGER; X : A) RETURN A;
- END BASE_P;
-
- PACKAGE BODY BASE_P IS
- FUNCTION RED(T : INTEGER; X : A) RETURN A IS
- BEGIN
- IF EQUAL(T, T) THEN
- RETURN X;
- ELSE
- RETURN YELO;
- END IF;
- END RED;
-
- FUNCTION BLUE(T : INTEGER; X : A) RETURN A IS
- BEGIN
- IF EQUAL(T, T) THEN
- RETURN X;
- ELSE
- RETURN YELO;
- END IF;
- END BLUE;
-
- END BASE_P;
-BEGIN
- TEST ("C83033A", "CHECK THAT AN IMPLICIT DECLARATION OF A BLOCK " &
- "NAME, A LOOP NAME, OR A STATEMENT LABEL HIDES " &
- "THE DECLARATION OF AN ENUMERATION LITERAL OR " &
- "OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED " &
- "TYPE DEFINITION");
-
- B1:
- DECLARE
- TYPE STMT2 IS NEW BASE_P.A;
- BEGIN
-
- DECLARE
- C, D : STMT2;
- BEGIN
- C := C83033A.B1.RED(3, C83033A.B1.RED);
- D := C83033A.B1.RED;
-
- GOTO RED; -- DEMONSTRATES USE OF STATEMENT LABEL.
- FAILED("STATEMENT LABEL - 1");
-
- <<RED>> IF C /= D THEN
- FAILED("STATEMENT LABEL - 2");
- END IF;
- END;
- END B1;
-
- B2:
- DECLARE
- TYPE STMT2 IS NEW BASE_P.A;
- BEGIN
-
- DECLARE
- A : STMT2 := BLUE;
- B : STMT2 := BLUE(3, BLUE);
- BEGIN
-
- BLUE:
- FOR I IN 1 .. 1 LOOP
- IF A /= B THEN
- FAILED("LOOP NAME - 1");
- END IF;
- EXIT BLUE; -- DEMONSTRATES USE OF LOOP LABEL.
- FAILED("LOOP NAME - 2");
- END LOOP BLUE;
- END;
- END B2;
-
- B4:
- DECLARE
- PACKAGE P IS
- GLOBAL : INTEGER := 1;
- TYPE ENUM IS (GREEN, BLUE);
- TYPE PRIV IS PRIVATE;
- FUNCTION GREEN RETURN PRIV;
- PRIVATE
- TYPE PRIV IS NEW ENUM;
- END P;
-
- PACKAGE BODY P IS
- FUNCTION GREEN RETURN PRIV IS
- BEGIN
- GLOBAL := GLOBAL + 1;
- RETURN BLUE;
- END GREEN;
- BEGIN
- NULL;
- END P;
- USE P;
- BEGIN
- GREEN:
- DECLARE
- COLOR : PRIV := C83033A.B4.P.GREEN;
- BEGIN
- IF GREEN.COLOR /= C83033A.B4.P.GREEN OR ELSE GLOBAL /= 3 THEN
- FAILED("BLOCK NAME");
- END IF;
- END GREEN;
- END B4;
-
- RESULT;
-END C83033A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83051a.ada b/gcc/testsuite/ada/acats/tests/c8/c83051a.ada
deleted file mode 100644
index 0dc2152..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83051a.ada
+++ /dev/null
@@ -1,397 +0,0 @@
--- C83051A.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 DECLARATIONS IN THE VISIBLE PART OF A PACKAGE NESTED
--- WITHIN THE VISIBLE PART OF A PACKAGE ARE VISIBLE BY SELECTION
--- FROM OUTSIDE THE OUTERMOST PACKAGE.
-
--- HISTORY:
--- GMT 09/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C83051A IS
-
-BEGIN
- TEST ("C83051A", "CHECK THAT DECLARATIONS IN THE VISIBLE " &
- "PART OF A PACKAGE NESTED WITHIN THE VISIBLE " &
- "PART OF A PACKAGE ARE VISIBLE BY SELECTION " &
- "FROM OUTSIDE THE OUTERMOST PACKAGE");
- A_BLOCK:
- DECLARE
- PACKAGE APACK IS
- PACKAGE BPACK IS
- TYPE T1 IS (RED,GREEN);
- TYPE T2A IS ('A', 'B', 'C', 'D');
- TYPE T3 IS NEW BOOLEAN;
- TYPE T4 IS NEW INTEGER RANGE -3 .. 8;
- TYPE T5 IS DIGITS 5;
- TYPE T67 IS DELTA 0.5 RANGE -2.0 .. 10.0;
- TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3;
- SUBTYPE T9B IS T9A (1..10);
- TYPE T9C IS ACCESS T9B;
- TYPE T10 IS PRIVATE;
- V1 : T3 := FALSE;
- ZERO : CONSTANT T4 := 0;
- A_FLT : T5 := 3.0;
- A_FIX : T67 := -1.0;
- ARY : T9A(1..4) := (TRUE,TRUE,TRUE,FALSE);
- P1 : T9C := NEW T9B'( 1..5 => T3'(TRUE),
- 6..10 => T3'(FALSE) );
- C1 : CONSTANT T10;
-
- FUNCTION RET_T1 (X : T1) RETURN T1;
-
- FUNCTION RET_CHAR (X : CHARACTER) RETURN T10;
-
- GENERIC
- PROCEDURE DO_NOTHING (X : IN OUT T3);
- PRIVATE
- TYPE T10 IS NEW CHARACTER;
- C1 : CONSTANT T10 := 'J';
- END BPACK;
- END APACK;
-
- PACKAGE BODY APACK IS
- PACKAGE BODY BPACK IS
- FUNCTION RET_T1 (X : T1) RETURN T1 IS
- BEGIN
- IF X = RED THEN
- RETURN GREEN;
- ELSE
- RETURN RED;
- END IF;
- END RET_T1;
-
- FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS
- BEGIN
- RETURN T10(X);
- END RET_CHAR;
-
- PROCEDURE DO_NOTHING (X : IN OUT T3) IS
- BEGIN
- IF X = TRUE THEN
- X := FALSE;
- ELSE
- X := TRUE;
- END IF;
- END DO_NOTHING;
- END BPACK;
- END APACK;
-
- PROCEDURE NEW_DO_NOTHING IS NEW APACK.BPACK.DO_NOTHING;
-
- BEGIN
-
- -- A1: VISIBILITY FOR UNOVERLOADED ENUMERATION LITERALS
-
- IF APACK.BPACK.">"(APACK.BPACK.RED, APACK.BPACK.GREEN) THEN
- FAILED ("VISIBILITY FOR UNOVERLOADED ENUMERATION " &
- "LITERAL BAD - A1");
- END IF;
-
-
- -- A2: VISIBILITY FOR OVERLOADED
- -- ENUMERATION CHARACTER LITERALS
-
- IF APACK.BPACK."<"(APACK.BPACK.T2A'(APACK.BPACK.'C'),
- APACK.BPACK.T2A'(APACK.BPACK.'B')) THEN
- FAILED ("VISIBILITY FOR OVERLOADED ENUMERATION " &
- "LITERAL BAD - A2");
- END IF;
-
-
- -- A3: VISIBILITY FOR A DERIVED BOOLEAN TYPE
-
- IF APACK.BPACK."<"(APACK.BPACK.T3'(APACK.BPACK.TRUE),
- APACK.BPACK.FALSE) THEN
- FAILED ("VISIBILITY FOR DERIVED BOOLEAN BAD - A3");
- END IF;
-
-
- -- A4: VISIBILITY FOR AN INTEGER TYPE
-
- IF APACK.BPACK."/="(APACK.BPACK."MOD"(6,2),APACK.BPACK.ZERO)
- THEN FAILED ("VISIBILITY FOR INTEGER TYPE BAD - A4");
- END IF;
-
-
- -- A5: VISIBILITY FOR A FLOATING POINT TYPE
-
- IF APACK.BPACK.">"(APACK.BPACK.T5'(2.7),APACK.BPACK.A_FLT)
- THEN FAILED ("VISIBILITY FOR FLOATING POINT BAD - A5");
- END IF;
-
-
- -- A6: VISIBILITY FOR A FIXED POINT INVOLVING UNARY MINUS
-
- IF APACK.BPACK."<"(APACK.BPACK.A_FIX,APACK.BPACK.T67'
- (APACK.BPACK."-"(1.5))) THEN
- FAILED ("VISIBILITY FOR FIXED POINT WITH UNARY MINUS " &
- "BAD - A6");
- END IF;
-
-
- -- A7: VISIBILITY FOR A FIXED POINT DIVIDED BY INTEGER
-
- IF APACK.BPACK."/="(APACK.BPACK.T67(-0.5),APACK.BPACK."/"
- (APACK.BPACK.A_FIX,2)) THEN
- FAILED ("VISIBILITY FOR FIXED POINT DIVIDED BY " &
- "INTEGER BAD - A7");
- END IF;
-
-
- -- A8: VISIBILITY FOR ARRAY EQUALITY
-
- IF APACK.BPACK."/="(APACK.BPACK.ARY,(APACK.BPACK.T3(TRUE),
- APACK.BPACK.T3(TRUE),APACK.BPACK.T3(TRUE),
- APACK.BPACK.T3(FALSE))) THEN
- FAILED ("VISIBILITY FOR ARRAY EQUALITY BAD - A8");
- END IF;
-
-
- -- A9: VISIBILITY FOR ACCESS EQUALITY
-
- IF APACK.BPACK."/="(APACK.BPACK.P1(3),
- APACK.BPACK.T3(IDENT_BOOL(TRUE)))
- THEN FAILED ("VISIBILITY FOR ACCESS EQUALITY BAD - A9");
- END IF;
-
-
- -- A10: VISIBILITY FOR PRIVATE TYPE
-
- IF APACK.BPACK."/="(APACK.BPACK.C1,
- APACK.BPACK.RET_CHAR('J')) THEN
- FAILED ("VISIBILITY FOR PRIVATE TYPE BAD - A10");
- END IF;
-
-
- -- A11: VISIBILITY FOR DERIVED SUBPROGRAM
-
- IF APACK.BPACK."/="(APACK.BPACK.RET_T1(APACK.BPACK.RED),
- APACK.BPACK.GREEN) THEN
- FAILED ("VISIBILITY FOR DERIVED SUBPROGRAM BAD - A11");
- END IF;
-
- -- A12: VISIBILITY FOR GENERIC SUBPROGRAM
-
- NEW_DO_NOTHING (APACK.BPACK.V1);
-
- IF APACK.BPACK."/="(APACK.BPACK.V1,APACK.BPACK.T3(TRUE)) THEN
- FAILED ("VISIBILITY FOR GENERIC SUBPROGRAM BAD - A12");
- END IF;
-
- END A_BLOCK;
-
- B_BLOCK:
- DECLARE
- GENERIC
- TYPE T1 IS (<>);
- PACKAGE GENPACK IS
- PACKAGE APACK IS
- PACKAGE BPACK IS
- TYPE T1 IS (ORANGE,GREEN);
- TYPE T2A IS ('E', 'F', 'G');
- TYPE T3 IS NEW BOOLEAN;
- TYPE T4 IS NEW INTEGER RANGE -3 .. 8;
- TYPE T5 IS DIGITS 5;
- TYPE T67 IS DELTA 0.5 RANGE -3.0 .. 25.0;
- TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3;
- SUBTYPE T9B IS T9A (2 .. 8);
- TYPE T9C IS ACCESS T9B;
- TYPE T10 IS PRIVATE;
- V1 : T3 := TRUE;
- SIX : T4 := 6;
- B_FLT : T5 := 4.0;
- ARY : T9A(1..4) := (TRUE,FALSE,TRUE,FALSE);
- P1 : T9C := NEW T9B'( 2..4 => T3'(FALSE),
- 5..8 => T3'(TRUE));
- K1 : CONSTANT T10;
-
- FUNCTION RET_T1 (X : T1) RETURN T1;
-
- FUNCTION RET_CHAR (X : CHARACTER) RETURN T10;
-
- GENERIC
- PROCEDURE DO_NOTHING (X : IN OUT T3);
- PRIVATE
- TYPE T10 IS NEW CHARACTER;
- K1 : CONSTANT T10 := 'V';
- END BPACK;
- END APACK;
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
- PACKAGE BODY APACK IS
- PACKAGE BODY BPACK IS
- FUNCTION RET_T1 (X : T1) RETURN T1 IS
- BEGIN
- IF X = ORANGE THEN
- RETURN GREEN;
- ELSE
- RETURN ORANGE;
- END IF;
- END RET_T1;
-
- FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS
- BEGIN
- RETURN T10(X);
- END RET_CHAR;
-
- PROCEDURE DO_NOTHING (X : IN OUT T3) IS
- BEGIN
- IF X = TRUE THEN
- X := FALSE;
- ELSE
- X := TRUE;
- END IF;
- END DO_NOTHING;
- END BPACK;
- END APACK;
- END GENPACK;
-
- PACKAGE MYPACK IS NEW GENPACK (T1 => INTEGER);
-
- PROCEDURE MY_DO_NOTHING IS NEW MYPACK.APACK.BPACK.DO_NOTHING;
-
- BEGIN
-
- -- B1: GENERIC INSTANCE OF UNOVERLOADED ENUMERATION LITERAL
-
- IF MYPACK.APACK.BPACK."<"(MYPACK.APACK.BPACK.GREEN,
- MYPACK.APACK.BPACK.ORANGE) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " &
- "UNOVERLOADED ENUMERATION LITERAL BAD - B1");
- END IF;
-
-
- -- B2: GENERIC INSTANCE OF OVERLOADED ENUMERATION LITERAL
-
- IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T2A'(MYPACK.
- APACK.BPACK.'F'),MYPACK.APACK.BPACK.T2A'(MYPACK.APACK.
- BPACK.'G')) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " &
- "OVERLOADED ENUMERATION LITERAL BAD - B2");
- END IF;
-
-
- -- B3: VISIBILITY FOR GENERIC INSTANCE OF DERIVED BOOLEAN
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."NOT"(MYPACK.
- APACK.BPACK.T3'(MYPACK.APACK.BPACK.TRUE)),MYPACK.APACK.
- BPACK.FALSE) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " &
- "BOOLEAN BAD - B3");
- END IF;
-
-
- -- B4: VISIBILITY FOR GENERIC INSTANCE OF DERIVED INTEGER
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."MOD"(MYPACK.
- APACK.BPACK.SIX,2),0) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF INTEGER " &
- "BAD - B4");
- END IF;
-
-
- -- B5: VISIBILITY FOR GENERIC INSTANCE OF FLOATING POINT
-
- IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T5'(1.9),MYPACK.
- APACK.BPACK.B_FLT) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FLOATING " &
- "POINT BAD - B5");
- END IF;
-
-
- -- B6: VISIBILITY FOR GENERIC INSTANCE OF
- -- FIXED POINT UNARY PLUS
-
- IF MYPACK.APACK.BPACK."<"(2.5,MYPACK.APACK.BPACK.T67'(MYPACK.
- APACK.BPACK."+"(1.75))) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " &
- "POINT UNARY PLUS BAD - B6");
- END IF;
-
-
- -- B7: VISIBILITY FOR GENERIC INSTANCE OF
- -- FIXED POINT DIVIDED BY INTEGER
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."/"(2.5,4),
- 0.625) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " &
- "POINT DIVIDED BY INTEGER BAD - B7");
- END IF;
-
-
- -- B8: VISIBILITY FOR GENERIC INSTANCE OF ARRAY EQUALITY
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.ARY,(MYPACK.
- APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE),MYPACK.
- APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE))) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ARRAY " &
- "EQUALITY BAD - B8");
- END IF;
-
-
- -- B9: VISIBILITY FOR GENERIC INSTANCE OF ACCESS EQUALITY
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.P1(3),MYPACK.
- APACK.BPACK.T3(IDENT_BOOL(FALSE))) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ACCESS " &
- "EQUALITY BAD - B9");
- END IF;
-
-
- -- B10: VISIBILITY FOR GENERIC INSTANCE OF PRIVATE EQUALITY
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.K1,MYPACK.APACK.
- BPACK.RET_CHAR('V')) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF PRIVATE " &
- "EQUALITY BAD - B10");
- END IF;
-
-
- -- B11: VISIBILITY FOR GENERIC INSTANCE OF DERIVED SUBPROGRAM
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.RET_T1(MYPACK.
- APACK.BPACK.ORANGE),MYPACK.APACK.BPACK.GREEN) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " &
- "SUBPROGRAM BAD - B11");
- END IF;
-
- -- B12: VISIBILITY FOR GENERIC INSTANCE OF GENERIC SUBPROGRAM
-
- MY_DO_NOTHING (MYPACK.APACK.BPACK.V1);
-
- IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.V1,
- MYPACK.APACK.BPACK.T3(FALSE)) THEN
- FAILED ("VISIBILITY FOR GENERIC INSTANCE OF GENERIC " &
- "SUBPROGRAM BAD - B12");
- END IF;
-
- END B_BLOCK;
-
- RESULT;
-END C83051A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada b/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada
deleted file mode 100644
index c982d3f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C83B02A.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 NESTED LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS,
--- AND REFERENCES IN THE INNERMOST LOOP ARE ASSOCIATED WITH THE
--- INNERMOST PARAMETER, ETC.
-
-
--- RM 4 JUNE 1980
-
-
-WITH REPORT;
-PROCEDURE C83B02A IS
-
- USE REPORT;
-
- I , J , K : INTEGER := 1 ;
-
-BEGIN
-
- TEST ( "C83B02A" ,
- "CHECK THAT NESTED LOOPS CAN HAVE IDENTICALLY NAMED" &
- " PARAMETERS" );
-
- -- I J K
- FOR LOOP_PAR IN 2..2 LOOP
- I := I * LOOP_PAR ; -- 2 1 1
- FOR LOOP_PAR IN 3..3 LOOP
- I := I * LOOP_PAR ; -- 6 1 1
- FOR LOOP_PAR IN 5..5 LOOP
- I := I * LOOP_PAR ; -- 30 1 1
- FOR SECOND_LOOP_PAR IN 7..7 LOOP
- J := J * SECOND_LOOP_PAR ; -- 30 7 1
- FOR SECOND_LOOP_PAR IN 11..11 LOOP
- J := J * SECOND_LOOP_PAR ;-- 30 77 1
- FOR SECOND_LOOP_PAR IN 13..13 LOOP
- J := J *
- SECOND_LOOP_PAR;-- 30 1001 1
- END LOOP;
- K := K * LOOP_PAR ; -- 30 1001 5
- END LOOP;
- K := K * LOOP_PAR ; -- 30 1001 25
- END LOOP;
- K := K * LOOP_PAR ; -- 30 1001 125
- END LOOP;
- K := K * LOOP_PAR ; -- 30 1001 375
- END LOOP;
- K := K * LOOP_PAR ; -- 30 1001 750
- END LOOP;
-
- IF I /= 30 OR J /= 1001 OR K /= 750 THEN
- FAILED ( "DID NOT ACCESS INNERMOST ENCLOSING IDENTICALLY " &
- "NAMED LOOP PARAMETER IN NESTED LOOPS" );
- END IF;
-
- RESULT;
-
-END C83B02A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada b/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada
deleted file mode 100644
index 817647a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C83B02B.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 NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS,
--- AND REFERENCES IN EACH LOOP ARE ASSOCIATED WITH THAT LOOP'S
--- LOOP PARAMETER. (THIS IS PART B OF THE OBJECTIVE.)
--- CHECK ALSO THAT A LOOP PARAMETER CAN HAVE THE SAME IDENTIFIER
--- AS A VARIABLE DECLARED IN THE SCOPE IMMEDIATELY CONTAINING
--- THE LOOP. (THIS IS PART C OF THE OBJECTIVE.)
-
-
-
--- RM 6 JUNE 1980
-
-
-WITH REPORT;
-PROCEDURE C83B02B IS
-
- USE REPORT;
-
- I , J : INTEGER := 1 ;
-
-BEGIN
-
- TEST ( "C83B02B" ,
- "CHECK THAT NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED" &
- " PARAMETERS" );
-
- COMMENT ( "THE NAME MAY BE THE SAME AS THAT OF A VARIABLE" &
- " KNOWN OUTSIDE THE LOOP" );
-
- -- CHECK PART B OF THE OBJECTIVE
- DECLARE
- TYPE WEEKDAY IS ( MON , TUE , WED , THU , FRI );
- BEGIN
-
- FOR LOOP_PAR IN 3..3 LOOP
- I := I * LOOP_PAR ; -- 3
- END LOOP;
-
- FOR LOOP_PAR IN FRI..FRI LOOP
- I := I * WEEKDAY'POS(LOOP_PAR) ; -- 12
- END LOOP;
-
- FOR LOOP_PAR IN 7..7 LOOP
- I := I * LOOP_PAR ; -- 84
- END LOOP;
-
- END;
-
- IF I /= 84 THEN
- FAILED ("DID NOT ACCESS ENCLOSING IDENTICALLY NAMED " &
- "LOOP PARAMETER IN NON-NESTED LOOPS");
- END IF;
-
- -- CHECK PART C OF THE OBJECTIVE
- DECLARE
- LOOP_PAR : INTEGER := 2 ;
- BEGIN
-
- J := J * LOOP_PAR ; -- 2
-
- FOR LOOP_PAR IN 3..3 LOOP
- J := J * LOOP_PAR ; -- 6
- END LOOP;
-
- J := J * LOOP_PAR ; -- 12
-
- FOR LOOP_PAR IN 5..5 LOOP
- J := J * LOOP_PAR ; -- 60
- END LOOP;
-
- J := J * LOOP_PAR ; -- 120
-
- FOR LOOP_PAR IN 7..7 LOOP
- J := J * LOOP_PAR ; -- 840
- END LOOP;
-
- J := J * LOOP_PAR ; -- 1680
-
- END;
-
- IF J /= 1680 THEN
- FAILED ("DID NOT ACCESS IDENTICALLY NAMED LOOP PARAMETER " &
- "INSIDE NON-NESTED LOOPS OR IDENTICALLY NAMED " &
- "VARIABLE OUTSIDE LOOPS");
- END IF;
-
- RESULT;
-
-END C83B02B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada b/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada
deleted file mode 100644
index a99c70b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C83E02A.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 WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE
--- USED DIRECTLY IN A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT,
--- AND AN INDEX CONSTRAINT.
-
--- RM 8 JULY 1980
-
-
-WITH REPORT;
-PROCEDURE C83E02A IS
-
- USE REPORT;
-
- Z : INTEGER := 0 ;
-
- PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS
- X : INTEGER RANGE A+1..1+B ;
- BEGIN
- X := A + 1 ;
- C := X * B + B * X * A ; -- 4*3+3*4*3=48
- END ;
-
- PROCEDURE P2 ( A , B : INTEGER; C : IN OUT INTEGER ) IS
- TYPE T (MAX : INTEGER) IS
- RECORD
- VALUE : INTEGER RANGE 1..3 ;
- END RECORD ;
- X : T(A);
- BEGIN
- X := ( MAX => 4 , VALUE => B ) ; -- ( 4 , 3 )
- C := 10*C + X.VALUE + 2 ; -- 10*48+3+2=485
- END ;
-
- FUNCTION F3 ( A , B : INTEGER ) RETURN INTEGER IS
- TYPE TABLE IS ARRAY( A..B ) OF INTEGER ;
- X : TABLE ;
- Y : ARRAY( A..B ) OF INTEGER ;
- BEGIN
- X(A) := A ; -- 5
- Y(B) := B ; -- 6
- RETURN X(A)-Y(B)+4 ; -- 3
- END ;
-
-
-BEGIN
-
- TEST( "C83E02A" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " &
- " A FORMAL PARAMETER CAN BE USED DIRECTLY IN" &
- " A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT"&
- ", AND AN INDEX CONSTRAINT" ) ;
-
- P1 ( 3 , 3 , Z ); -- Z BECOMES 48
- P2 ( 4 , F3( 5 , 6 ) , Z ); -- Z BECOMES 485
-
- IF Z /= 485 THEN
- FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" );
- END IF;
-
- RESULT;
-
-END C83E02A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada b/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada
deleted file mode 100644
index ba15767..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- C83E02B.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 WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE
--- USED IN AN EXCEPTION HANDLER.
-
--- RM 10 JULY 1980
-
-
-WITH REPORT;
-PROCEDURE C83E02B IS
-
- USE REPORT;
-
- Z : INTEGER := 0 ;
-
- PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS
- E : EXCEPTION ;
- BEGIN
- RAISE E ;
- FAILED( "FAILURE TO RAISE E " );
- EXCEPTION
- WHEN E =>
- C := A + B ;
- WHEN OTHERS =>
- FAILED( "WRONG EXCEPTION RAISED" );
- END ;
-
-
-BEGIN
-
- TEST( "C83E02B" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " &
- " A FORMAL PARAMETER CAN BE USED IN AN EXCEP" &
- "TION HANDLER" ) ;
-
- P1 ( 3 , 14 , Z );
-
- IF Z /= 17 THEN
- FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" );
- END IF;
-
- RESULT;
-
-END C83E02B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada b/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada
deleted file mode 100644
index 0a46f34..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C83E03A.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 IN A NAMED PARAMETER ASSOCIATION
--- IS NOT CONFUSED WITH AN ACTUAL PARAMETER IDENTIFIER HAVING THE
--- SAME SPELLING.
-
-
--- RM 23 JULY 1980
-
-
-WITH REPORT;
-PROCEDURE C83E03A IS
-
- USE REPORT;
-
- P : INTEGER RANGE 1..23 := 17 ;
- FLOW_INDEX : INTEGER := 0 ;
-
-BEGIN
-
- TEST( "C83E03A" , "CHECK THAT A FORMAL PARAMETER IN A NAMED" &
- " PARAMETER ASSOCIATION IS NOT CONFUSED" &
- " WITH AN ACTUAL PARAMETER HAVING THE" &
- " SAME SPELLING" );
-
- DECLARE
-
- PROCEDURE BUMP IS
- BEGIN
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END BUMP ;
-
- PROCEDURE P1 ( P : INTEGER ) IS
- BEGIN
- IF P = 17 THEN BUMP ; END IF ;
- END ;
-
- FUNCTION F1 ( P : INTEGER ) RETURN INTEGER IS
- BEGIN
- RETURN P ;
- END ;
-
- BEGIN
-
- P1 ( P );
- P1 ( P => P );
-
- IF F1 ( P + 1 ) = 17 + 1 THEN BUMP ; END IF;
- IF F1 ( P => P + 1 ) = 17 + 1 THEN BUMP ; END IF;
-
- END ;
-
- IF FLOW_INDEX /= 4 THEN
- FAILED( "INCORRECT ACCESSING OR INCORRECT FLOW" );
- END IF;
-
- RESULT;
-
-END C83E03A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada
deleted file mode 100644
index abf1d74..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C83F01A.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 INSIDE A PACKAGE BODY, AN ATTEMPT TO REFERENCE AN IDENTI-
--- FIER DECLARED IN THE CORRESPONDING PACKAGE SPECIFICATION
--- IS SUCCESSFUL, EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE
--- ENVIRONMENT SURROUNDING THE PACKAGE BODY.
-
--- NESTED PACKAGE BODIES ARE TESTED IN C83F01B , C83F01C , C83F01D
-
-
--- RM 05 AUGUST 1980
--- JRK 13 NOV 1980
-
-
-WITH REPORT;
-PROCEDURE C83F01A IS
-
- USE REPORT;
-
- X1 , X2 : INTEGER RANGE 1..23 := 17 ;
-
- TYPE T1 IS ( A , B , C) ;
-
- Z : T1 := A ;
-
-
-BEGIN
-
- TEST( "C83F01A" , "CHECK THAT INSIDE A PACKAGE BODY, " &
- "AN ATTEMPT TO REFERENCE AN IDENTIFIER " &
- "DECLARED IN THE CORRESPONDING PACKAGE SPECI" &
- "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" &
- "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"&
- "ING THE PACKAGE BODY" ) ;
-
- COMMENT( "NESTED PACKAGE BODIES ARE TESTED IN C83F01B , -C , -D");
-
-
- DECLARE
-
-
- PACKAGE P IS
-
- X1 : BOOLEAN := FALSE ;
- X2 : INTEGER RANGE 1..23 := 11 ;
- Y1 : BOOLEAN := TRUE ;
- Y2 : INTEGER := 5 ;
- T1 : INTEGER := 6 ;
- Z : INTEGER := 7 ;
-
- END P ;
-
-
- Y1 , Y2 : INTEGER := 13 ;
-
-
- PACKAGE BODY P IS
- BEGIN
-
- X1 := X1 OR Y1 ;
- Z := Z + T1 ;
- Y2 := X2 * Y2 ;
-
- -- INCORRECT INTERPRETATIONS IN THE FIRST TWO
- -- ASSIGNMENTS MANIFEST THEMSELVES AT
- -- COMPILE TIME AS TYPE ERRORS.
-
- END P ;
-
-
- BEGIN
-
- IF X1 /= 17 OR
- Z /= A OR
- Y2 /= 13 OR
- NOT P.X1 OR
- P.Z /= 13 OR
- P.Y2 /= 55
- THEN FAILED( "INCORRECT ACCESSING" );
- END IF;
-
- END ;
-
-
- RESULT; -- POSS. ERROR DURING ELABORATION OF P
-
-END C83F01A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada
deleted file mode 100644
index 3dca9fc..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C83F01B.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 INSIDE A PACKAGE BODY NESTED WITHIN ANOTHER PACKAGE BODY
--- AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE
--- CORRESPONDING PACKAGE SPECIFICATION
--- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE
--- OUTER PACKAGE (SPECIFICATION OR BODY) OR IN THE
--- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY.
-
--- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F01C ,
--- C83F01D .
-
-
--- RM 08 AUGUST 1980
--- JRK 13 NOV 1980
-
-
-WITH REPORT;
-PROCEDURE C83F01B IS
-
- USE REPORT;
-
- X1 , X2 : INTEGER RANGE 1..23 := 17 ;
-
- TYPE T1 IS ( A , B , C) ;
-
- Z : T1 := A ;
-
-
-BEGIN
-
- TEST( "C83F01B" , "CHECK THAT INSIDE A NESTED PACKAGE BODY" &
- " AN ATTEMPT TO REFERENCE AN IDENTIFIER" &
- " DECLARED IN THE CORRESPONDING PACKAGE SPECI" &
- "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" &
- "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"&
- "ING THE PACKAGE BODY" ) ;
-
- COMMENT("SEPARATELY COMPILED PACKAGES ARE TESTED IN C83F01C, -D");
-
-
- DECLARE
-
-
- Y1 , Y2 : INTEGER := 100 ;
-
-
- PACKAGE OUTER IS
-
- Y3 : INTEGER := 100 ;
-
- PACKAGE P IS
-
- X1 : BOOLEAN := FALSE ;
- X2 : INTEGER RANGE 1..23 := 11 ;
- Y1 , Y3 : BOOLEAN := TRUE ;
- Y2 , Y4 : INTEGER := 5 ;
- T1 : INTEGER := 6 ;
- Z : INTEGER := 7 ;
-
- END P ;
-
- END OUTER ;
-
-
- X2 : INTEGER := 100 ;
-
-
- PACKAGE BODY OUTER IS
-
- Y4 : INTEGER := 200 ;
-
- PACKAGE BODY P IS
- BEGIN
-
- X1 := NOT X1 AND Y1 AND Y3 ;
- Z := Z + T1 ;
- Y2 := X2 * Y2 ;
- Y4 := X2 * Y4 ;
-
- -- INCORRECT INTERPRETATIONS IN THE FIRST TWO
- -- ASSIGNMENTS MANIFEST THEMSELVES AT
- -- COMPILE TIME AS TYPE ERRORS
-
- END P ;
-
- END OUTER ;
-
-
- BEGIN
-
- IF X1 /= 17 OR
- Z /= A OR
- Y2 /= 100 OR
- NOT OUTER.P.X1 OR
- OUTER.P.Z /= 13 OR
- OUTER.P.Y2 /= 55 OR
- OUTER.P.Y4 /= 55
- THEN FAILED( "INCORRECT ACCESSING" );
- END IF;
-
- END ;
-
-
- RESULT; -- POSSIBLE ERROR DURING ELABORATION OF P
-
-END C83F01B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada
deleted file mode 100644
index 9b8c2da..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- C83F01C0.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.
---*
--- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M
-
--- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO
--- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M ,
--- C83F01D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION
--- OF THE PACKAGE. THE BODY IS IN FILE C83F01C1.
-
-
--- RM 13 AUGUST 1980
--- RM 22 AUGUST 1980
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-
-PACKAGE C83F01C0 IS
-
- Y3 : INTEGER := 100 ;
-
- PACKAGE P IS
-
- X1 : BOOLEAN := FALSE ;
- X2 : INTEGER RANGE 1..23 := 11 ;
- Y1 , Y3 : BOOLEAN := TRUE ;
- Y2 , Y4 : INTEGER := 5 ;
- T1 : INTEGER := 6 ;
- Z : INTEGER := 7 ;
-
- END P ;
-
- PROCEDURE REQUIRE_BODY;
-
-END C83F01C0 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada
deleted file mode 100644
index bd27d16..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C83F01C1.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.
---*
--- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M
-
--- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO
--- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M ,
--- C83F01D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE.
-
--- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME.
-
-
--- RM 13 AUGUST 1980
--- RM 22 AUGUST 1980
--- RM 28 AUGUST 1980 ('FAILED(.)' MOVED TO MAIN)
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-
-PACKAGE BODY C83F01C0 IS
-
- Y4 : INTEGER := 200 ;
-
- PACKAGE BODY P IS
- BEGIN
-
- X1 := NOT X1 AND Y1 AND Y3 ;
- Z := Z + T1 ;
- Y2 := X2 * Y2 ;
- Y4 := X2 * Y4 ;
-
- -- INCORRECT INTERPRETATIONS IN THE FIRST TWO
- -- ASSIGNMENTS MANIFEST THEMSELVES AT
- -- COMPILE TIME AS TYPE ERRORS.
-
- -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER
- -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK
- -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE
- -- PACKAGE WAS NOT ELABORATED).
-
-
- END P ;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
-END C83F01C0 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada
deleted file mode 100644
index dbce105..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C83F01C2M.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.
---*
--- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE
--- ( C83F01C0 ; SPECIFICATION IN C83F01C0.ADA ,
--- BODY IN C83F01C1.ADA )
-
--- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED
--- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE
--- CORRESPONDING PACKAGE SPECIFICATION
--- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE
--- OUTER PACKAGE (SPECIFICATION OR BODY).
-
--- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT
-
-
--- RM 11 AUGUST 1980
--- RM 22 AUGUST 1980
--- RM 29 AUGUST 1980 (MOVED 'FAILED(.)' FROM C83F01C1.ADA TO HERE)
-
-
-WITH REPORT , C83F01C0 ;
-PROCEDURE C83F01C2M IS
-
- USE REPORT , C83F01C0 ;
-
-BEGIN
-
- TEST( "C83F01C" , "CHECK THAT INSIDE A PACKAGE BODY" &
- " NESTED WITHIN A SEPARATELY" &
- " COMPILED PACKAGE BODY LIBRARY UNIT," &
- " AN ATTEMPT TO REFERENCE AN IDENTIFIER" &
- " DECLARED IN THE CORRESPONDING PACKAGE SPECI" &
- "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" &
- "TIFIER IS DECLARED IN THE OUTER PACKAGE" &
- " (SPECIFICATION OR BODY)" ) ;
-
- IF NOT P.X1 OR
- P.Z /= 13 OR
- P.Y2 /= 55 OR
- P.Y4 /= 55
- THEN FAILED( "INCORRECT ACCESSING" );
- END IF;
-
- RESULT ;
-
-
-END C83F01C2M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada
deleted file mode 100644
index c73f0bc..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- C83F01D0M.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.
---*
--- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT
--- ( C83F01D1.ADA )
-
--- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED
--- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE
--- CORRESPONDING PACKAGE SPECIFICATION
--- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE
--- OUTER PACKAGE (SPECIFICATION OR BODY).
-
--- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT
-
-
--- RM 13 AUGUST 1980
--- RM 29 AUGUST 1980
--- JRK 13 NOV 1980
-
-
-WITH REPORT;
-PROCEDURE C83F01D0M IS
-
- USE REPORT ;
-
- X1 , X2 : INTEGER RANGE 1..23 := 17 ;
- Y1 : INTEGER := 157 ;
-
- TYPE T1 IS ( A , B , C) ;
-
- Z : T1 := A ;
-
-
- PACKAGE C83F01D1 IS
-
- Y3 : INTEGER := 100 ;
-
- PACKAGE P IS
-
- X1 : BOOLEAN := FALSE ;
- X2 : INTEGER RANGE 1..23 := 11 ;
- Y1 , Y3 : BOOLEAN := TRUE ;
- Y2 , Y4 : INTEGER := 5 ;
- T1 : INTEGER := 23 ;
- Z : INTEGER := 0 ;
-
- END P ;
-
- END C83F01D1 ;
-
-
- Y2 : INTEGER := 200 ;
-
-
- PACKAGE BODY C83F01D1 IS SEPARATE ;
-
-
-BEGIN
-
- TEST( "C83F01D" , "CHECK THAT INSIDE A PACKAGE BODY" &
- " NESTED WITHIN A SEPARATELY" &
- " COMPILED PACKAGE BODY SUBUNIT," &
- " AN ATTEMPT TO REFERENCE AN IDENTIFIER" &
- " DECLARED IN THE CORRESPONDING PACKAGE SPECI" &
- "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" &
- "TIFIER IS DECLARED IN THE OUTER PACKAGE" &
- " (SPECIFICATION OR BODY)" ) ;
-
- IF X1 /= 17 OR
- Z /= A OR
- Y2 /= 200 OR
- NOT C83F01D1.P.X1 OR
- C83F01D1.P.Z /= 23 OR
- C83F01D1.P.Y2 /= 55 OR
- C83F01D1.P.Y4 /= 55
- THEN FAILED( "INCORRECT ACCESSING" );
- END IF;
-
- RESULT ;
-
-
-END C83F01D0M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada
deleted file mode 100644
index fb0d9f5..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada
+++ /dev/null
@@ -1,57 +0,0 @@
--- C83F01D1.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.
---*
--- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F01D0M
-
-
--- RM 13 AUGUST 1980
--- RM 29 AUGUST 1980
-
-
-
-SEPARATE (C83F01D0M)
-PACKAGE BODY C83F01D1 IS
-
- Y4 : INTEGER := 200 ;
-
- PACKAGE BODY P IS
- BEGIN
-
- X1 := NOT X1 AND Y1 AND Y3 ;
- Z := Z + T1 ;
- Y2 := X2 * Y2 ;
- Y4 := X2 * Y4 ;
-
- -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER
- -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK
- -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE
- -- PACKAGE WAS NOT ELABORATED).
-
- -- INCORRECT INTERPRETATIONS IN THE FIRST TWO
- -- ASSIGNMENTS MANIFEST THEMSELVES AT
- -- COMPILE TIME AS TYPE ERRORS.
-
- END P ;
-
-END C83F01D1 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada
deleted file mode 100644
index a24f038..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- C83F03A.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 INSIDE A PACKAGE BODY AN ATTEMPT TO PLACE AND REFERENCE
--- A LABEL IS SUCCESSFUL EVEN IF ITS IDENTIFIER IS DECLARED IN THE
--- ENVIRONMENT SURROUNDING THE PACKAGE BODY.
-
--- NESTED PACKAGE BODIES ARE TESTED IN C83F03B , C83F03C , C83F03D
-
-
--- RM 03 SEPTEMBER 1980
-
-
-WITH REPORT;
-PROCEDURE C83F03A IS
-
- USE REPORT;
-
- X1 , X2 : INTEGER RANGE 1..23 := 17 ;
-
- TYPE T1 IS ( A , B , C) ;
-
- Z : T1 := A ;
-
- FLOW_INDEX : INTEGER := 0 ;
-
-BEGIN
-
- TEST( "C83F03A" , "CHECK THAT INSIDE A PACKAGE BODY " &
- " AN ATTEMPT TO PLACE AND REFERENCE A LABEL" &
- " IS SUCCESSFUL EVEN IF ITS IDEN" &
- "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"&
- "ING THE PACKAGE BODY" ) ;
-
-
- DECLARE
-
-
- Y1 , Y2 : INTEGER := 13 ;
-
-
- PROCEDURE BUMP IS
- BEGIN
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END BUMP ;
-
-
- PACKAGE P IS
-
- AA : BOOLEAN := FALSE ;
-
- END P ;
-
-
- PACKAGE BODY P IS
- BEGIN
-
- GOTO X1 ;
-
- BUMP ;
- BUMP ;
-
- <<X1>> BUMP ; GOTO X2 ;
- BUMP ;
- <<T1>> BUMP ; GOTO Z ;
- BUMP ;
- <<Y1>> BUMP ; GOTO Y2 ;
- BUMP ;
- <<Y2>> BUMP ; GOTO T1 ;
- BUMP ;
- <<X2>> BUMP ; GOTO Y1 ;
- BUMP ;
- <<Z >> BUMP ; GOTO ENDING ;
- BUMP ;
-
- << ENDING >> NULL;
-
- END P ;
-
-
- BEGIN
-
- IF FLOW_INDEX /= 6
- THEN FAILED( "INCORRECT FLOW OF CONTROL" );
- END IF;
-
- END ;
-
-
- RESULT; -- POSS. ERROR DURING ELABORATION OF P
-
-END C83F03A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada
deleted file mode 100644
index 4b5afea..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada
+++ /dev/null
@@ -1,157 +0,0 @@
--- C83F03B.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 PACKAGE BODY IS NESTED INSIDE ANOTHER PACKAGE BODY
--- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL
--- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY, TO AN IDENTI-
--- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION,
--- OR TO A LABEL IDENTIFIER OR OTHER IDENTIFIER IN THE
--- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY.
-
-
--- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F03C ,
--- C83F03D .
-
-
--- RM 04 SEPTEMBER 1980
-
-
-WITH REPORT;
-PROCEDURE C83F03B IS
-
- USE REPORT;
-
- X1 , X2 : INTEGER RANGE 1..23 := 17 ;
-
- TYPE T1 IS ( A , B , C) ;
-
- Z : T1 := A ;
-
- FLOW_INDEX : INTEGER := 0 ;
-
-BEGIN
-
- TEST( "C83F03B" , "CHECK THAT IF A PACKAGE BODY IS NESTED" &
- " INSIDE ANOTHER PACKAGE BODY, THE INNER" &
- " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" &
- " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" &
- " PACKAGE BODY, TO AN IDENTIFIER DECLARED IN" &
- " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" &
- "TION, OR TO A LABEL IDENTIFIER OR OTHER" &
- " IDENTIFIER IN THE ENVIRONMENT SURROUNDING" &
- " THE OUTER PACKAGE BODY" ) ;
-
-
- DECLARE
-
-
- Y1 , Y2 : INTEGER := 100 ;
-
- X2 : INTEGER := 100 ;
-
-
- PROCEDURE BUMP IS
- BEGIN
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END BUMP ;
-
-
- PACKAGE OUTER IS
-
- Y3 : INTEGER := 100 ;
-
- TYPE T3 IS ( D , E , F ) ;
-
- PACKAGE P IS
- AA : BOOLEAN := FALSE ;
- END P ;
-
- END OUTER ;
-
-
- PACKAGE BODY OUTER IS
-
- Y4 : INTEGER := 200 ;
-
- TYPE T4 IS ( G , H , I ) ;
-
- PACKAGE BODY P IS
- BEGIN
-
-
- GOTO X1 ;
-
- BUMP ;
- BUMP ;
-
- <<X1>> BUMP ; GOTO X2 ;
- BUMP ;
- <<T1>> BUMP ; GOTO Z ;
- BUMP ;
- <<Y1>> BUMP ; GOTO Y2 ;
- BUMP ;
- <<Y2>> BUMP ; GOTO T1 ;
- BUMP ;
- <<X2>> BUMP ; GOTO Y1 ;
- BUMP ;
- <<Z >> BUMP ; GOTO T3 ;
- BUMP ;
- <<T3>> BUMP ; GOTO T4 ;
- BUMP ;
- <<LABEL_IN_OUTER>> BUMP ; GOTO LABEL_IN_MAIN ;
- BUMP ;
- <<Y3>> BUMP ; GOTO Y4 ;
- BUMP ;
- <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ;
- BUMP ;
- <<T4>> BUMP ; GOTO Y3 ;
- BUMP ;
- <<LABEL_IN_MAIN >> BUMP ; GOTO ENDING ;
- BUMP ;
-
- << ENDING >> NULL;
-
- END P ;
-
- BEGIN
-
- << LABEL_IN_OUTER >> NULL ;
-
- END OUTER ;
-
-
- BEGIN
-
- << LABEL_IN_MAIN >>
-
- IF FLOW_INDEX /= 12
- THEN FAILED( "INCORRECT FLOW OF CONTROL" );
- END IF;
-
- END ;
-
-
- RESULT; -- POSS. ERROR DURING ELABORATION OF P
-
-END C83F03B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada
deleted file mode 100644
index 15962eb..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- C83F03C0.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.
---*
--- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M
-
--- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO
--- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M ,
--- C83F03D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION
--- OF THE PACKAGE. THE PACKAGE BODY IS IN C83F03C1.ADA .
-
-
--- RM 04 SEPTEMBER 1980
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-
-PACKAGE C83F03C0 IS
-
- Y3 : INTEGER := 100 ;
-
- TYPE T3 IS ( D , E , F ) ;
-
- FLOW_INDEX : INTEGER := 0 ;
-
- PROCEDURE REQUIRE_BODY;
-
- PACKAGE P IS
-
- AA : BOOLEAN := FALSE ;
-
- END P ;
-
-END C83F03C0 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada
deleted file mode 100644
index fa4dbf0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- C83F03C1.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.
---*
--- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M
-
--- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO
--- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M ,
--- C83F03D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE.
-
--- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME.
-
-
--- RM 05 SEPTEMBER 1980
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-
-PACKAGE BODY C83F03C0 IS
-
- Y4 : INTEGER := 200 ;
-
- TYPE T4 IS ( G , H , I ) ;
-
- PROCEDURE BUMP IS
- BEGIN
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END BUMP ;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY P IS
- BEGIN
-
- GOTO T3 ;
-
- BUMP ;
- BUMP ;
-
- <<T3>> BUMP ; GOTO T4 ;
- BUMP ;
- <<LABEL_IN_OUTER>> BUMP ; GOTO ENDING ;
- BUMP ;
- <<Y3>> BUMP ; GOTO Y4 ;
- BUMP ;
- <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ;
- BUMP ;
- <<T4>> BUMP ; GOTO Y3 ;
- BUMP ;
-
- << ENDING >> NULL;
-
- END P ;
-
-BEGIN
-
- << LABEL_IN_OUTER >> NULL ;
-
-END C83F03C0 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada
deleted file mode 100644
index 978f834..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C83F03C2M.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.
---*
--- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE
--- ( C83F03C0 ; SPECIFICATION IN C83F03C0.ADA ,
--- BODY IN C83F03C1.ADA )
-
--- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED
--- PACKAGE BODY
--- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL
--- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI-
--- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION.
-
--- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT
-
-
--- RM 05 SEPTEMBER 1980
-
-
-WITH REPORT , C83F03C0 ;
-PROCEDURE C83F03C2M IS
-
- USE REPORT , C83F03C0 ;
-
-BEGIN
-
- TEST( "C83F03C" , "CHECK THAT IF A PACKAGE BODY IS NESTED" &
- " INSIDE A SEPARATELY COMPILED PACKAGE BODY" &
- " LIBRARY UNIT, THE INNER" &
- " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" &
- " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" &
- " PACKAGE BODY OR TO AN IDENTIFIER DECLARED IN" &
- " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" &
- "TION" ) ;
-
- IF FLOW_INDEX /= 5
- THEN FAILED( "INCORRECT FLOW OF CONTROL" );
- END IF;
-
- RESULT; -- POSS. ERROR DURING ELABORATION OF P
-
-
-END C83F03C2M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada
deleted file mode 100644
index e2ecd76..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- C83F03D0M.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.
---*
--- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT
--- ( C83F03D1.ADA )
-
--- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED
--- PACKAGE BODY
--- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL
--- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI-
--- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION
--- OR IN ITS ENVIRONMENT.
-
--- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT
-
-
--- RM 08 SEPTEMBER 1980
--- JRK 14 NOVEMBER 1980
-
-
-WITH REPORT;
-PROCEDURE C83F03D0M IS
-
- USE REPORT ;
-
- X1 : INTEGER := 17 ;
-
- TYPE T1 IS ( A, B, C ) ;
-
- Z : T1 := A ;
-
- FLOW_INDEX : INTEGER := 0 ;
-
-
- PACKAGE C83F03D1 IS
-
- Y3 : INTEGER := 100 ;
-
- TYPE T3 IS ( D , E , F ) ;
-
- PACKAGE P IS
- AA : BOOLEAN := FALSE ;
- END P ;
-
- END C83F03D1 ;
-
-
- Y1 : INTEGER := 100 ;
-
-
- PACKAGE BODY C83F03D1 IS SEPARATE ;
-
-
-BEGIN
-
- TEST( "C83F03D" , "CHECK THE RECOGNITION OF LABELS IN NESTED" &
- " PACKAGES SEPARATELY COMPILED AS SUBUNITS" );
-
- << LABEL_IN_MAIN >>
-
- IF FLOW_INDEX /= 10
- THEN FAILED( "INCORRECT FLOW OF CONTROL" );
- END IF;
-
- RESULT; -- POSS. ERROR DURING ELABORATION OF P
-
-
-END C83F03D0M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada b/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada
deleted file mode 100644
index aac2cf9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C83F03D1.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.
---*
--- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F03D0M
-
-
--- RM 08 SEPTEMBER 1980
--- JRK 14 NOVEMBER 1980
-
-
-
-SEPARATE (C83F03D0M)
-PACKAGE BODY C83F03D1 IS
-
- Y4 : INTEGER := 200 ;
-
- TYPE T4 IS ( G , H , I ) ;
-
- PROCEDURE BUMP IS
- BEGIN
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END BUMP ;
-
- PACKAGE BODY P IS
- BEGIN
-
- GOTO X1 ;
-
- BUMP ;
- BUMP ;
-
- <<LABEL_IN_MAIN>> BUMP ; GOTO T3 ;
- BUMP ;
- <<T1>> BUMP ; GOTO Z ;
- BUMP ;
- <<Y1>> BUMP ; GOTO LABEL_IN_MAIN ;
- BUMP ;
- <<X1>> BUMP ; GOTO T1 ;
- BUMP ;
- <<Z>> BUMP ; GOTO Y1 ;
- BUMP ;
- <<T3>> BUMP ; GOTO T4 ;
- BUMP ;
- <<LABEL_IN_OUTER>> BUMP ; GOTO ENDING ;
- BUMP ;
- <<Y3>> BUMP ; GOTO Y4 ;
- BUMP ;
- <<Y4>> BUMP ; GOTO LABEL_IN_OUTER ;
- BUMP ;
- <<T4>> BUMP ; GOTO Y3 ;
- BUMP ;
-
- << ENDING >> NULL;
-
- END P ;
-
-BEGIN
-
- << LABEL_IN_OUTER >> NULL ;
-
-END C83F03D1 ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c840001.a b/gcc/testsuite/ada/acats/tests/c8/c840001.a
deleted file mode 100644
index 2a1df16..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c840001.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- C840001.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, for the type determined by the subtype mark of a use type
--- clause, the declaration of each primitive operator is use-visible
--- within the scope of the clause, even if explicit operators with the
--- same names as the type's operators are declared for the subtype. Check
--- that a call to such an operator executes the body of the type's
--- operation.
---
--- TEST DESCRIPTION:
--- A type may declare a primitive operator, and a subtype of that type
--- may overload the operator. If a use type clause names the subtype,
--- it is the primitive operator of the type (not the subtype) which
--- is made directly visible, and the primitive operator may be called
--- unambiguously. Such a call executes the body of the type's operation.
---
--- In a package, declare a type for which a predefined operator is
--- overridden. In another package, declare a subtype of the type in the
--- previous package. Declare another version of the predefined operator
--- for the subtype.
---
--- The main program declares objects of both the type and the explicit
--- subtype, and uses the "**" operator for both. In all cases, the
--- operator declared for the 1st subtype should be the one executed,
--- since it is the primitive operators of the *type* that are made
--- visible; the operators which were declared for the explicit subtype
--- are not primitive operators of the type, since they were declared in
--- a separate package from the original type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 23 Sep 99 RLB Added test case where operator made visible is
--- not visible by selection (as in AI-00122).
---
---!
-
-package C840001_0 is
--- Usage scenario: the predefined operators for a floating point type
--- are overridden in order to take advantage of improved algorithms.
-
- type Precision_Float is new Float range -100.0 .. 100.0;
- -- Implicit: function "**" (Left: Precision_Float; Right: Integer'Base)
- -- return Precision_Float;
-
- function "**" (Left: Precision_Float; Right: Integer'Base)
- return Precision_Float;
- -- Overrides predefined operator.
-
- function "+" (Right: Precision_Float)
- return Precision_Float;
- -- Overrides predefined operator.
-
- -- ... Other overridden operations.
-
- TC_Expected : constant Precision_Float := 68.0;
-
-end C840001_0;
-
-
- --==================================================================--
-
-package body C840001_0 is
-
- function "**" (Left: Precision_Float; Right: Integer'Base)
- return Precision_Float is
- begin
- -- ... Utilize desired algorithm.
- return (TC_Expected); -- Artificial for testing purposes.
- end "**";
-
- function "+" (Right: Precision_Float)
- return Precision_Float is
- -- Overrides predefined operator.
- begin
- return Right*2.0;
- end "+";
-
-end C840001_0;
-
-
- --==================================================================--
-
--- Take advantage of some even better algorithms designed for positive
--- floating point values.
-
-with C840001_0;
-package C840001_1 is
-
- subtype Precision_Pos_Float is C840001_0.Precision_Float
- range 0.0 .. 100.0;
-
--- This is not a new type, so it has no primitives of it own. However, it
--- can declare another version of the operator and call it as long as both it
--- and the corresponding operator of the 1st subtype are not directly visible
--- in the same place.
-
- function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
- return Precision_Pos_Float; -- Accepts only positive exponent.
-
-end C840001_1;
-
-
- --==================================================================--
-
-package body C840001_1 is
-
- function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
- return Precision_Pos_Float is
- begin
- -- ... Utilize some other algorithms.
- return 57.0; -- Artificial for testing purposes.
- end "**";
-
-end C840001_1;
-
-
- --==================================================================--
-
-with Report;
-with C840001_1;
-procedure C840001_2 is
-
- -- Note that C840001_0 and it's contents is not visible in any form here.
-
- TC_Operand : C840001_1.Precision_Pos_Float := 41.0;
-
- TC_Operand2 : C840001_1.Precision_Pos_Float;
-
- use type C840001_1.Precision_Pos_Float;
- -- Makes the operators of its parent type directly visible, even though
- -- the parent type and operators are not otherwise visible at all.
-
-begin
-
- TC_Operand2 := +TC_Operand; -- Overridden operator is visible and called.
-
- if TC_Operand2 /= 82.0 then -- Predefined equality.
- Report.Failed ("3rd test: type's overridden operation not called for " &
- "operand of 1st subtype");
- end if;
- if TC_Operand + 3.0 >= TC_Operand2 - 13.0 then -- Various predefined operators.
- Report.Failed ("3rd test: wrong result from predefined operators");
- end if;
-
-end C840001_2;
-
- --==================================================================--
-
-
-with C840001_0;
-with C840001_1;
-with C840001_2;
-
-with Report;
-
-procedure C840001 is
-
-begin
- Report.Test ("C840001", "Check that, for the type determined by the " &
- "subtype mark of a use type clause, the declaration of " &
- "each primitive operator is use-visible within the scope " &
- "of the clause, even if explicit operators with the same " &
- "names as the type's operators are declared for the subtype");
-
-
- Use_Type_Precision_Pos_Float:
- declare
- TC_Operand : C840001_0.Precision_Float
- := C840001_0.Precision_Float(-2.0);
- TC_Positive_Operand : C840001_1.Precision_Pos_Float := 6.0;
-
- TC_Actual_Type : C840001_0.Precision_Float;
- TC_Actual_Subtype : C840001_1.Precision_Pos_Float;
-
- use type C840001_1.Precision_Pos_Float;
- -- Both calls to "**" should return 68.0 (that is, Precision_Float's
- -- operation should be called).
-
- begin
-
- TC_Actual_Type := TC_Operand**2;
-
- if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
- Report.Failed ("1st block: type's operation not called for " &
- "operand of 1st subtype");
- end if;
-
- TC_Actual_Subtype := TC_Positive_Operand**2;
-
- if not (C840001_0."="
- (TC_Actual_Subtype, C840001_0.TC_Expected)) then
- Report.Failed ("1st block: type's operation not called for " &
- "operand of explicit subtype");
- end if;
-
- end Use_Type_Precision_Pos_Float;
-
- Use_Type_Precision_Float:
- declare
- TC_Operand : C840001_0.Precision_Float
- := C840001_0.Precision_Float(4.0);
- TC_Positive_Operand : C840001_1.Precision_Pos_Float := 7.0;
-
- TC_Actual_Type : C840001_0.Precision_Float;
- TC_Actual_Subtype : C840001_1.Precision_Pos_Float;
-
- use type C840001_0.Precision_Float;
- -- Again, both calls to "**" should return 68.0.
-
- begin
-
- TC_Actual_Type := TC_Operand**2;
-
- if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
- Report.Failed ("2nd block: type's operation not called for " &
- "operand of 1st subtype");
- end if;
-
- TC_Actual_Subtype := TC_Positive_Operand**2;
-
- if not C840001_0."=" (TC_Actual_Subtype, C840001_0.TC_Expected) then
- Report.Failed ("2nd block: type's operation not called for " &
- "operand of explicit subtype");
- end if;
-
- end Use_Type_Precision_Float;
-
- C840001_2; -- 3rd test.
-
- Report.Result;
-
-end C840001;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c84002a.ada b/gcc/testsuite/ada/acats/tests/c8/c84002a.ada
deleted file mode 100644
index ed421e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c84002a.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- C84002A.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) IF A USE CLAUSE NAMES AN ENCLOSING PACKAGE, THE USE CLAUSE
--- HAS NO EFFECT.
-
--- B) IF A DECLARATION IS DIRECTLY VISIBLE PRIOR TO THE OCCURRENCE
--- OF A USE CLAUSE, AND IS NOT IN THE SET OF POTENTIALLY
--- VISIBLE DECLARATIONS, IT REMAINS DIRECTLY VISIBLE AFTER THE
--- USE CLAUSE.
-
--- C) IF A HOMOGRAPH FOR A POTENTIALLY VISIBLE SUBPROGRAM OR
--- OBJECT IS DECLARED AFTER A USE CLAUSE, THE POTENTIALLY
--- VISIBLE ENTITY IS NO LONGER VISIBLE.
-
--- EG 02/16/84
-
-WITH REPORT;
-
-PROCEDURE C84002A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C84002A","CHECK THAT DECLARATIONS DIRECTLY VISIBLE PRIOR " &
- "TO THE USE CLAUSE REMAIN VISIBLE AFTERWARDS");
-
- BEGIN
-
- COMMENT ("CASE A : CHECK THAT IF A USE CLAUSE NAMES AN " &
- "ENCLOSING PACKAGE, THE USE CLAUSE HAS NO EFFECT");
-
-CASE_A : DECLARE
-
- PACKAGE P1 IS
- X : FLOAT := 1.5;
- END P1;
- PACKAGE P2 IS
- X : INTEGER := 15;
-
- USE P1;
- USE P2;
-
- A : INTEGER := X;
- END P2;
- PACKAGE BODY P1 IS
- BEGIN
- NULL;
- END P1;
- PACKAGE BODY P2 IS
- BEGIN
- IF X /= IDENT_INT(15) OR X /= P2.X OR
- A /= P2.X THEN
- FAILED ("CASE A : USE CLAUSE HAS AN EFFECT");
- END IF;
- END P2;
-
- BEGIN
-
- NULL;
-
- END CASE_A;
-
- COMMENT ("CASE B : CHECK THAT IF A DECLARATION IS DIRECTLY " &
- "VISIBLE PRIOR TO THE OCCURRENCE OF A USE CLAUSE, " &
- "AND IS NOT IN THE SET OF POTENTIALLY VISIBLE " &
- "DECLARATIONS, IT REMAINS DIRECTLY VISIBLE");
-
-CASE_B : BEGIN
-
- CASE_B1 : DECLARE
-
- PACKAGE P1 IS
- Y : FLOAT := 1.5;
- END P1;
- PACKAGE P2 IS
- X : INTEGER := 15;
-
- USE P1;
-
- A : INTEGER := X;
- END P2;
-
- PACKAGE BODY P1 IS
- BEGIN
- NULL;
- END P1;
- PACKAGE BODY P2 IS
- BEGIN
- IF X /= IDENT_INT(15) OR X /= P2.X OR
- A /= P2.X THEN
- FAILED ("CASE B1 : DECLARATION NO " &
- "LONGER DIRECTLY VISIBLE");
- END IF;
- END P2;
-
- BEGIN
-
- NULL;
-
- END CASE_B1;
-
- CASE_B2 : DECLARE
-
- PROCEDURE PROC1 (X : STRING) IS
- BEGIN
- NULL;
- END PROC1;
-
- PACKAGE P1 IS
- PROCEDURE PROC1 (X : STRING);
- END P1;
- PACKAGE BODY P1 IS
- PROCEDURE PROC1 (X : STRING) IS
- BEGIN
- FAILED ("CASE B2 : WRONG PROCEDURE " &
- "DIRECTLY VISIBLE");
- END PROC1;
- END P1;
-
- USE P1;
-
- BEGIN
-
- PROC1 ("ABC");
-
- END CASE_B2;
-
- CASE_B3 : DECLARE
-
- PROCEDURE PROC1 (X : STRING) IS
- BEGIN
- NULL;
- END PROC1;
-
- PACKAGE P1 IS
- PROCEDURE PROC1 (Y : STRING);
- END P1;
- PACKAGE BODY P1 IS
- PROCEDURE PROC1 (Y : STRING) IS
- BEGIN
- FAILED ("CASE B3 : WRONG PROCEDURE " &
- "DIRECTLY VISIBLE");
- END PROC1;
- END P1;
-
- USE P1;
-
- BEGIN
-
- PROC1 ("ABC");
-
- END CASE_B3;
-
- END CASE_B;
-
- COMMENT ("CASE C : IF A HOMOGRAPH FOR A POTENTIALLY " &
- "VISIBLE SUBPROGRAM OR OBJECT IS DECLARED AFTER " &
- "A USE CLAUSE, THE POTENTIALLY VISIBLE ENTITY " &
- "IS NO LONGER VISIBLE");
-
-CASE_C : BEGIN
-
- CASE_C1 : DECLARE
-
- PACKAGE P1 IS
- PROCEDURE PROC1 (X : FLOAT);
- END P1;
-
- USE P1;
-
- PACKAGE BODY P1 IS
- PROCEDURE PROC1 (X : FLOAT) IS
- BEGIN
- IF X = -1.5 THEN
- FAILED ("CASE C1 : WRONG PROCEDURE" &
- " CALLED (A)");
- ELSIF X /= 1.5 THEN
- FAILED ("CASE C1 : WRONG VALUE " &
- "PASSED (A)");
- END IF;
- END PROC1;
- BEGIN
- NULL;
- END P1;
-
- PROCEDURE PROC2 IS
- BEGIN
- PROC1 (1.5);
- END PROC2;
-
- PROCEDURE PROC1 (X : FLOAT) IS
- BEGIN
- IF X = 1.5 THEN
- FAILED ("CASE C1 : WRONG PROCEDURE" &
- " CALLED (B)");
- ELSIF X /= -1.5 THEN
- FAILED ("CASE C1 : WRONG VALUE " &
- "PASSED (B)");
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC2;
- PROC1 (-1.5);
-
- END CASE_C1;
-
- CASE_C2 : DECLARE
-
- PACKAGE P1 IS
- X : INTEGER := 15;
- END P1;
-
- USE P1;
-
- A : INTEGER := X;
-
- X : BOOLEAN := TRUE;
-
- B : BOOLEAN := X;
-
- BEGIN
-
- IF A /= IDENT_INT(15) THEN
- FAILED ("CASE C2 : VARIABLE A DOES NOT " &
- "CONTAIN THE CORRECT VALUE");
- END IF;
- IF B /= IDENT_BOOL(TRUE) THEN
- FAILED ("CASE C2 : VARIABLE B DOES NOT " &
- "CONTAIN THE CORRECT VALUE");
- END IF;
-
- END CASE_C2;
-
- END CASE_C;
-
- END;
-
- RESULT;
-
-END C84002A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c84005a.ada b/gcc/testsuite/ada/acats/tests/c8/c84005a.ada
deleted file mode 100644
index 53bd64a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c84005a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C84005A.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 TWO POTENTIALLY VISIBLE HOMOGRAPHS OF A SUBPROGRAM
--- IDENTIFIER CAN BE MADE DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT
--- WHEN DIFFERENT FORMAL PARAMETER NAMES ARE USED THE SUBPROGRAMS
--- ARE REFERENCED CORRECTLY.
-
--- HISTORY:
--- JET 03/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C84005A IS
-
- PACKAGE PACK1 IS
- FUNCTION FUNK(A : INTEGER) RETURN INTEGER;
- PROCEDURE PROK(A : INTEGER; B : OUT INTEGER);
- END PACK1;
-
- PACKAGE PACK2 IS
- FUNCTION FUNK(X : INTEGER) RETURN INTEGER;
- PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER);
- END PACK2;
-
- USE PACK1, PACK2;
- VAR1, VAR2 : INTEGER;
-
- PACKAGE BODY PACK1 IS
- FUNCTION FUNK(A : INTEGER) RETURN INTEGER IS
- BEGIN
- IF EQUAL (A,A) THEN
- RETURN (1);
- ELSE
- RETURN (0);
- END IF;
- END FUNK;
-
- PROCEDURE PROK(A : INTEGER; B : OUT INTEGER) IS
- BEGIN
- IF EQUAL (A,A) THEN
- B := 1;
- ELSE
- B := 0;
- END IF;
- END PROK;
- END PACK1;
-
- PACKAGE BODY PACK2 IS
- FUNCTION FUNK(X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF EQUAL (X,X) THEN
- RETURN (2);
- ELSE
- RETURN (0);
- END IF;
- END FUNK;
-
- PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER) IS
- BEGIN
- IF EQUAL (X,X) THEN
- Y := 2;
- ELSE
- Y := 0;
- END IF;
- END PROK;
- END PACK2;
-
-BEGIN
- TEST ("C84005A", "CHECK THAT TWO POTENTIALLY VISIBLE HOMOGRAPHS " &
- "OF A SUBPROGRAM IDENTIFIER CAN BE MADE " &
- "DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT " &
- "WHEN DIFFERENT FORMAL PARAMETER NAMES ARE " &
- "USED, THE SUBPROGRAMS ARE REFERENCED CORRECTLY");
-
- IF FUNK(A => 3) /= IDENT_INT(1) THEN
- FAILED("PACK1.FUNK RETURNS INCORRECT RESULT");
- END IF;
-
- IF FUNK(X => 3) /= IDENT_INT(2) THEN
- FAILED("PACK2.FUNK RETURNS INCORRECT RESULT");
- END IF;
-
- PROK(A => 3, B => VAR1);
- PROK(X => 3, Y => VAR2);
-
- IF VAR1 /= IDENT_INT(1) THEN
- FAILED("PACK1.PROK RETURNS INCORRECT RESULT");
- END IF;
-
- IF VAR2 /= IDENT_INT(2) THEN
- FAILED("PACK2.PROK RETURNS INCORRECT RESULT");
- END IF;
-
- RESULT;
-END C84005A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c84008a.ada b/gcc/testsuite/ada/acats/tests/c8/c84008a.ada
deleted file mode 100644
index fb760ed..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c84008a.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C84008A.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 NAMES MADE VISIBLE BY A USE CLAUSE IN THE VISIBLE
--- PART OF A PACKAGE ARE VISIBLE IN THE PRIVATE PART AND BODY OF
--- THE PACKAGE.
-
--- HISTORY:
--- JET 03/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C84008A IS
-
- PACKAGE PACK1 IS
- TYPE A IS RANGE 0..100;
- TYPE B IS RANGE -100..0;
- END PACK1;
-
- PACKAGE PACK2 IS
- USE PACK1;
- TYPE C IS PRIVATE;
- PROCEDURE PROC (X : OUT A; Y : OUT B);
- PRIVATE
- TYPE C IS NEW A RANGE 0..9;
- END PACK2;
-
- VAR1 : PACK1.A;
- VAR2 : PACK1.B;
-
- PACKAGE BODY PACK2 IS
- PROCEDURE PROC (X : OUT A; Y : OUT B) IS
- SUBTYPE D IS B RANGE -9..0;
- BEGIN
- IF EQUAL(3,3) THEN
- X := A'(2);
- Y := D'(-2);
- ELSE
- X := A'(0);
- Y := D'(0);
- END IF;
- END PROC;
- END PACK2;
-
-BEGIN
- TEST ("C84008A", "CHECK THAT THE NAMES MADE VISIBLE BY A USE " &
- "CLAUSE IN THE VISIBLE PART OF A PACKAGE ARE " &
- "VISIBLE IN THE PRIVATE PART AND BODY OF " &
- "THE PACKAGE");
-
- PACK2.PROC (VAR1,VAR2);
-
- IF PACK1."/=" (VAR1, 2) THEN
- FAILED("INCORRECT RETURN VALUE FOR VAR1");
- END IF;
-
- IF PACK1."/=" (VAR2, PACK1."-"(2)) THEN
- FAILED("INCORRECT RETURN VALUE FOR VAR2");
- END IF;
-
- RESULT;
-END C84008A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c84009a.ada b/gcc/testsuite/ada/acats/tests/c8/c84009a.ada
deleted file mode 100644
index afc5fe0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c84009a.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C84009A.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 USE CLAUSE MAKES AN IMPLICITLY OR EXPLICITLY
--- DECLARED OPERATOR DIRECTLY VISIBLE IF NO HOMOGRAPH OF THE
--- OPERATOR IS ALREADY DIRECTLY VISIBLE.
-
--- HISTORY:
--- JET 03/10/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C84009A IS
-
- TYPE INT IS NEW INTEGER RANGE -100 .. 100;
-
- PACKAGE PACK IS
- FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER;
- FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT;
- FUNCTION "-" (RIGHT : INT) RETURN INTEGER;
- FUNCTION "+" (RIGHT : INT) RETURN INTEGER;
- END PACK;
-
- FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER'(1) + INTEGER(RIGHT);
- END "+";
-
- PACKAGE BODY PACK IS
- FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER IS
- BEGIN
- RETURN LEFT + INTEGER(RIGHT);
- END "+";
-
- FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT IS
- BEGIN
- FAILED ("BINARY ""-"" ALREADY VISIBLE FOR TYPE INT");
- RETURN LEFT + (-RIGHT);
- END "-";
-
- FUNCTION "-" (RIGHT : INT) RETURN INTEGER IS
- BEGIN
- RETURN INTEGER'(0) - INTEGER(RIGHT);
- END "-";
-
- FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS
- BEGIN
- FAILED ("UNARY ""+"" ALREADY VISIBLE FOR TYPE INT");
- RETURN INTEGER'(0) + INTEGER(RIGHT);
- END "+";
- END PACK;
-
- USE PACK;
-
-BEGIN
- TEST ("C84009A", "CHECK THAT A USE CLAUSE MAKES AN IMPLICITLY " &
- "OR EXPLICITLY DECLARED OPERATOR DIRECTLY " &
- "VISIBLE IF NO HOMOGRAPH OF THE OPERATOR IS " &
- "ALREADY DIRECTLY VISIBLE");
-
- IF INTEGER'(10) + INT'(10) /= IDENT_INT(20) THEN
- FAILED ("INCORRECT RESULT FROM BINARY ""+""");
- END IF;
-
- IF INT'(5) - INT'(3) /= INT'(2) THEN
- FAILED ("INCORRECT RESULT FROM BINARY ""-""");
- END IF;
-
- IF -INT'(20) /= IDENT_INT(-INTEGER'(20)) THEN
- FAILED ("INCORRECT RESULT FROM UNARY ""-""");
- END IF;
-
- IF +INT'(20) /= IDENT_INT(+INTEGER'(21)) THEN
- FAILED ("INCORRECT RESULT FROM UNARY ""+""");
- END IF;
-
- RESULT;
-END C84009A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85004b.ada b/gcc/testsuite/ada/acats/tests/c8/c85004b.ada
deleted file mode 100644
index 515936f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85004b.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- C85004B.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 RENAMED CONSTANT OBJECT, "IN" PARAMETER OF A
--- SUBPROGRAM OR ENTRY, "IN" FORMAL GENERIC, RECORD DISCRIMINANT,
--- LOOP PARAMETER, DEFERRED CONSTANT, OR RENAMED CONSTANT HAS THE
--- CORRECT VALUE.
-
--- HISTORY:
--- JET 07/25/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85004B IS
-
- TYPE A IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- SUBTYPE P IS POSITIVE RANGE 1 .. 10;
-
- C1 : CONSTANT INTEGER := 1;
- X1 : INTEGER RENAMES C1;
- X2 : INTEGER RENAMES X1;
-
- TYPE REC (D : P := 1) IS
- RECORD
- I : A(1..D);
- END RECORD;
- TYPE ACCREC1 IS ACCESS REC;
- TYPE ACCREC2 IS ACCESS REC(10);
-
- R1 : REC;
- R2 : REC(10);
- AR1 : ACCREC1 := NEW REC;
- AR2 : ACCREC2 := NEW REC(10);
-
- X3 : P RENAMES R1.D;
- X4 : P RENAMES R2.D;
- X5 : P RENAMES AR1.D;
- X6 : P RENAMES AR2.D;
-
- C2 : CONSTANT A(1..3) := (1, 2, 3);
- X7 : INTEGER RENAMES C2(1);
-
- GENERIC
- K1 : IN INTEGER;
- PACKAGE GENPKG IS
- TYPE K IS PRIVATE;
- K2 : CONSTANT K;
- PRIVATE
- TYPE K IS RANGE 1..100;
- K2 : CONSTANT K := 5;
- END GENPKG;
-
- TASK FOOEY IS
- ENTRY ENT1 (I : IN INTEGER);
- END FOOEY;
-
- TASK BODY FOOEY IS
- BEGIN
- ACCEPT ENT1 (I : IN INTEGER) DO
- DECLARE
- TX1 : INTEGER RENAMES I;
- BEGIN
- IF TX1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE");
- END IF;
- END;
- END ENT1;
- END FOOEY;
-
- PACKAGE BODY GENPKG IS
- KX1 : INTEGER RENAMES K1;
- KX2 : K RENAMES K2;
- BEGIN
- IF KX1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF KX1");
- END IF;
-
- IF KX2 /= K(IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF KX2");
- END IF;
- END GENPKG;
-
- PROCEDURE PROC (I : IN INTEGER) IS
- PX1 : INTEGER RENAMES I;
- BEGIN
- IF PX1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF PX1");
- END IF;
- END PROC;
-
- PACKAGE PKG IS NEW GENPKG(4);
-
-BEGIN
- TEST ("C85004B", "CHECK THAT A RENAMED CONSTANT OBJECT, 'IN' " &
- "PARAMETER OF A SUBPROGRAM OR ENTRY, 'IN' FORMAL GENERIC, " &
- "RECORD DISCRIMINANT, LOOP PARAMETER, DEFERRED CONSTANT, " &
- "OR RENAMED CONSTANT HAS THE CORRECT VALUE");
-
- FOOEY.ENT1(2);
-
- PROC(3);
-
- IF X1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF X1");
- END IF;
-
- IF X2 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF X2");
- END IF;
-
- IF X3 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF X3");
- END IF;
-
- IF X4 /= IDENT_INT(10) THEN
- FAILED ("INCORRECT VALUE OF X4");
- END IF;
-
- IF X5 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF X5");
- END IF;
-
- IF X6 /= IDENT_INT(10) THEN
- FAILED ("INCORRECT VALUE OF X6");
- END IF;
-
- IF X7 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF X7");
- END IF;
-
- FOR I IN 1..IDENT_INT(2) LOOP
- DECLARE
- X8 : INTEGER RENAMES I;
- BEGIN
- IF X8 /= IDENT_INT(I) THEN
- FAILED ("INCORRECT VALUE OF X8");
- END IF;
- END;
- END LOOP;
-
- RESULT;
-
-END C85004B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005a.ada b/gcc/testsuite/ada/acats/tests/c8/c85005a.ada
deleted file mode 100644
index 05dc328..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005a.ada
+++ /dev/null
@@ -1,391 +0,0 @@
--- C85005A.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 VARIABLE CREATED BY AN OBJECT DECLARATION CAN BE
--- RENAMED AND HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN
--- BE USED IN AN ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL
--- SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN
--- ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF
--- THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED
--- BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005A IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- K1 : INTEGER := 0;
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1;
- TK1 : IN OUT INTEGER);
- END TASK2;
-
- I1 : INTEGER := 0;
- A1 : ARRAY1(1..3) := (OTHERS => 0);
- R1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- P1 : POINTER1 := NEW INTEGER'(0);
- V1 : PACK1.PRIVY := PACK1.ZERO;
- T1 : TASK1;
-
- XI1 : INTEGER RENAMES I1;
- XA1 : ARRAY1 RENAMES A1;
- XR1 : RECORD1 RENAMES R1;
- XP1 : POINTER1 RENAMES P1;
- XV1 : PACK1.PRIVY RENAMES V1;
- XT1 : TASK1 RENAMES T1;
- XK1 : INTEGER RENAMES PACK1.K1;
-
- I : INTEGER;
- CHK_TASK : TASK2;
-
- GENERIC
- GI1 : IN OUT INTEGER;
- GA1 : IN OUT ARRAY1;
- GR1 : IN OUT RECORD1;
- GP1 : IN OUT POINTER1;
- GV1 : IN OUT PACK1.PRIVY;
- GT1 : IN OUT TASK1;
- GK1 : IN OUT INTEGER;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
- PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
- PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1;
- PK1 : OUT INTEGER) IS
-
- BEGIN
- PI1 := PI1 + 1;
- PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
- PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
- PP1 := NEW INTEGER'(P1.ALL + 1);
- PV1 := PACK1.NEXT(V1);
- PT1.NEXT;
- PK1 := PACK1.K1 + 1;
- END PROC1;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GI1 := GI1 + 1;
- GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- GR1 := (D => 1, FIELD1 => GR1.FIELD1+1);
- GP1 := NEW INTEGER'(GP1.ALL + 1);
- GV1 := PACK1.NEXT(GV1);
- GT1.NEXT;
- GK1 := GK1 + 1;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1;
- TK1 : IN OUT INTEGER) DO
-
- TI1 := I1 + 1;
- TA1 := (A1(1)+1, A1(2)+1, A1(3)+1);
- TR1 := (D => 1, FIELD1 => R1.FIELD1 + 1);
- TP1 := NEW INTEGER'(TP1.ALL + 1);
- TV1 := PACK1.NEXT(TV1);
- TT1.NEXT;
- TK1 := TK1 + 1;
- END ENTRY1;
- END TASK2;
-
-BEGIN
- TEST ("C85005A", "CHECK THAT A VARIABLE CREATED BY AN OBJECT " &
- "DECLARATION CAN BE RENAMED AND HAS THE " &
- "CORRECT VALUE, AND THAT THE NEW NAME CAN " &
- "BE USED IN AN ASSIGNMENT STATEMENT " &
- "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
- "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
- "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
- "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
- "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
- "VALUE OF THE NEW NAME");
-
- DECLARE
- PACKAGE GENPACK1 IS NEW
- GENERIC1 (XI1, XA1, XR1, XP1, XV1, XT1, XK1);
- BEGIN
- NULL;
- END;
-
- IF XI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XI1 (1)");
- END IF;
-
- IF XA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XA1 (1)");
- END IF;
-
- IF XR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XR1 (1)");
- END IF;
-
- IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XP1 (1)");
- END IF;
-
- IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XV1 (1)");
- END IF;
-
- XT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (1)");
- END IF;
-
- IF XK1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XK1 (1)");
- END IF;
-
- PROC1(XI1, XA1, XR1, XP1, XV1, XT1, XK1);
-
- IF XI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XI1 (2)");
- END IF;
-
- IF XA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XA1 (2)");
- END IF;
-
- IF XR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XR1 (2)");
- END IF;
-
- IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XP1 (2)");
- END IF;
-
- IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XV1 (2)");
- END IF;
-
- XT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XT1.VALU (2)");
- END IF;
-
- IF XK1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XK1 (2)");
- END IF;
-
- CHK_TASK.ENTRY1(XI1, XA1, XR1, XP1, XV1, XT1, XK1);
-
- IF XI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XI1 (3)");
- END IF;
-
- IF XA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XA1 (3)");
- END IF;
-
- IF XR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XR1 (3)");
- END IF;
-
- IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XP1 (3)");
- END IF;
-
- IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XV1 (3)");
- END IF;
-
- XT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (3)");
- END IF;
-
- IF XK1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XK1 (3)");
- END IF;
-
- XI1 := XI1 + 1;
- XA1 := (XA1(1)+1, XA1(2)+1, XA1(3)+1);
- XR1 := (D => 1, FIELD1 => XR1.FIELD1 + 1);
- XP1 := NEW INTEGER'(XP1.ALL + 1);
- XV1 := PACK1.NEXT(XV1);
- XT1.NEXT;
- XK1 := XK1 + 1;
-
- IF XI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XI1 (4)");
- END IF;
-
- IF XA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XA1 (4)");
- END IF;
-
- IF XR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XR1 (4)");
- END IF;
-
- IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XP1 (4)");
- END IF;
-
- IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XV1 (4)");
- END IF;
-
- XT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (4)");
- END IF;
-
- IF XK1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XK1 (4)");
- END IF;
-
- I1 := I1 + 1;
- A1 := (A1(1)+1, A1(2)+1, A1(3)+1);
- R1 := (D => 1, FIELD1 => R1.FIELD1 + 1);
- P1 := NEW INTEGER'(P1.ALL + 1);
- V1 := PACK1.NEXT(V1);
- T1.NEXT;
- PACK1.K1 := PACK1.K1 + 1;
-
- IF XI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XI1 (5)");
- END IF;
-
- IF XA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XA1 (5)");
- END IF;
-
- IF XR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XR1 (5)");
- END IF;
-
- IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XP1 (5)");
- END IF;
-
- IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XV1 (5)");
- END IF;
-
- XT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (5)");
- END IF;
-
- IF XK1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XK1 (5)");
- END IF;
-
- T1.STOP;
-
- RESULT;
-END C85005A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005b.ada b/gcc/testsuite/ada/acats/tests/c8/c85005b.ada
deleted file mode 100644
index 9c4f6fe..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005b.ada
+++ /dev/null
@@ -1,366 +0,0 @@
--- C85005B.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 VARIABLE CREATED BY A SUBPROGRAM 'IN OUT' FORMAL
--- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT
--- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED
--- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER,
--- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE
--- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS
--- REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005B IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- DI1 : INTEGER := 0;
- DA1 : ARRAY1(1..3) := (OTHERS => 0);
- DR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- DP1 : POINTER1 := NEW INTEGER'(0);
- DV1 : PACK1.PRIVY := PACK1.ZERO;
- DT1 : TASK1;
-
- I : INTEGER;
-
- GENERIC
- GI1 : IN OUT INTEGER;
- GA1 : IN OUT ARRAY1;
- GR1 : IN OUT RECORD1;
- GP1 : IN OUT POINTER1;
- GV1 : IN OUT PACK1.PRIVY;
- GT1 : IN OUT TASK1;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GI1 := GI1 + 1;
- GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
- GP1 := NEW INTEGER'(GP1.ALL + 1);
- GV1 := PACK1.NEXT(GV1);
- GT1.NEXT;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
- PROCEDURE PROC (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
- PR1 : IN OUT RECORD1; PP1 : IN OUT POINTER1;
- PV1 : IN OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS
- XPI1 : INTEGER RENAMES PI1;
- XPA1 : ARRAY1 RENAMES PA1;
- XPR1 : RECORD1 RENAMES PR1;
- XPP1 : POINTER1 RENAMES PP1;
- XPV1 : PACK1.PRIVY RENAMES PV1;
- XPT1 : TASK1 RENAMES PT1;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1);
- END TASK2;
-
- CHK_TASK : TASK2;
-
- PROCEDURE PROC1 (PPI1 : IN OUT INTEGER; PPA1 : IN OUT ARRAY1;
- PPR1 : IN OUT RECORD1; PPP1 : OUT POINTER1;
- PPV1 : OUT PACK1.PRIVY;
- PPT1 : IN OUT TASK1) IS
- BEGIN
- PPI1 := PPI1 + 1;
- PPA1 := (PPA1(1)+1, PPA1(2)+1, PPA1(3)+1);
- PPR1 := (D => 1, FIELD1 => PPR1.FIELD1 + 1);
- PPP1 := NEW INTEGER'(PP1.ALL + 1);
- PPV1 := PACK1.NEXT(PV1);
- PPT1.NEXT;
- END PROC1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1)
- DO
- TI1 := PI1 + 1;
- TA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
- TR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
- TP1 := NEW INTEGER'(TP1.ALL + 1);
- TV1 := PACK1.NEXT(TV1);
- TT1.NEXT;
- END ENTRY1;
- END TASK2;
-
- PACKAGE GENPACK1 IS NEW GENERIC1
- (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
-
- BEGIN
- IF XPI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XPI1 (1)");
- END IF;
-
- IF XPA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XPA1 (1)");
- END IF;
-
- IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XPR1 (1)");
- END IF;
-
- IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XPP1 (1)");
- END IF;
-
- IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XPV1 (1)");
- END IF;
-
- XPT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (1)");
- END IF;
-
- PROC1(XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
-
- IF XPI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XPI1 (2)");
- END IF;
-
- IF XPA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XPA1 (2)");
- END IF;
-
- IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XPR1 (2)");
- END IF;
-
- IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XPP1 (2)");
- END IF;
-
- IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XPV1 (2)");
- END IF;
-
- XPT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XPT1.VALU (2)");
- END IF;
-
- CHK_TASK.ENTRY1 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1);
-
- IF XPI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XPI1 (3)");
- END IF;
-
- IF XPA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XPA1 (3)");
- END IF;
-
- IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XPR1 (3)");
- END IF;
-
- IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XPP1 (3)");
- END IF;
-
- IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XPV1 (3)");
- END IF;
-
- XPT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (3)");
- END IF;
-
- XPI1 := XPI1 + 1;
- XPA1 := (XPA1(1)+1, XPA1(2)+1, XPA1(3)+1);
- XPR1 := (D => 1, FIELD1 => XPR1.FIELD1 + 1);
- XPP1 := NEW INTEGER'(XPP1.ALL + 1);
- XPV1 := PACK1.NEXT(XPV1);
- XPT1.NEXT;
-
- IF XPI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XPI1 (4)");
- END IF;
-
- IF XPA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XPA1 (4)");
- END IF;
-
- IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XPR1 (4)");
- END IF;
-
- IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XPP1 (4)");
- END IF;
-
- IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XPV1 (4)");
- END IF;
-
- XPT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (4)");
- END IF;
-
- PI1 := PI1 + 1;
- PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
- PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
- PP1 := NEW INTEGER'(PP1.ALL + 1);
- PV1 := PACK1.NEXT(PV1);
- PT1.NEXT;
-
- IF XPI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XPI1 (5)");
- END IF;
-
- IF XPA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XPA1 (5)");
- END IF;
-
- IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XPR1 (5)");
- END IF;
-
- IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XPP1 (5)");
- END IF;
-
- IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XPV1 (5)");
- END IF;
-
- XPT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (5)");
- END IF;
- END PROC;
-
-BEGIN
- TEST ("C85005B", "CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM " &
- "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
- "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
- "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
- "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
- "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
- "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
- "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
- "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
- "VALUE OF THE NEW NAME");
-
- PROC (DI1, DA1, DR1, DP1, DV1, DT1);
-
- DT1.STOP;
-
- RESULT;
-END C85005B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005c.ada b/gcc/testsuite/ada/acats/tests/c8/c85005c.ada
deleted file mode 100644
index fe2acb0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005c.ada
+++ /dev/null
@@ -1,416 +0,0 @@
--- C85005C.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 VARIABLE CREATED BY AN ENTRY 'IN OUT' FORMAL
--- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT
--- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED
--- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER,
--- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE
--- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS
--- REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005C IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- DI1 : INTEGER := 0;
- DA1 : ARRAY1(1..3) := (OTHERS => 0);
- DR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- DP1 : POINTER1 := NEW INTEGER'(0);
- DV1 : PACK1.PRIVY := PACK1.ZERO;
- DT1 : TASK1;
-
- I : INTEGER;
-
- GENERIC
- GI1 : IN OUT INTEGER;
- GA1 : IN OUT ARRAY1;
- GR1 : IN OUT RECORD1;
- GP1 : IN OUT POINTER1;
- GV1 : IN OUT PACK1.PRIVY;
- GT1 : IN OUT TASK1;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GI1 := GI1 + 1;
- GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
- GP1 := NEW INTEGER'(GP1.ALL + 1);
- GV1 := PACK1.NEXT(GV1);
- GT1.NEXT;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85005C", "CHECK THAT A VARIABLE CREATED BY AN ENTRY " &
- "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
- "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
- "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
- "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
- "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
- "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
- "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
- "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
- "VALUE OF THE NEW NAME");
-
- DECLARE
- TASK MAIN_TASK IS
- ENTRY START (TI1 : IN OUT INTEGER; TA1 : IN OUT ARRAY1;
- TR1 : IN OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1);
- END MAIN_TASK;
-
- TASK BODY MAIN_TASK IS
- BEGIN
- ACCEPT START (TI1: IN OUT INTEGER; TA1: IN OUT ARRAY1;
- TR1: IN OUT RECORD1; TP1: IN OUT POINTER1;
- TV1: IN OUT PACK1.PRIVY;
- TT1: IN OUT TASK1) DO
- DECLARE
- XTI1 : INTEGER RENAMES TI1;
- XTA1 : ARRAY1 RENAMES TA1;
- XTR1 : RECORD1 RENAMES TR1;
- XTP1 : POINTER1 RENAMES TP1;
- XTV1 : PACK1.PRIVY RENAMES TV1;
- XTT1 : TASK1 RENAMES TT1;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TTI1 : OUT INTEGER;
- TTA1 : OUT ARRAY1;
- TTR1 : OUT RECORD1;
- TTP1 : IN OUT POINTER1;
- TTV1 : IN OUT PACK1.PRIVY;
- TTT1 : IN OUT TASK1);
- END TASK2;
-
- CHK_TASK : TASK2;
-
- PROCEDURE PROC1 (PTI1 : IN OUT INTEGER;
- PTA1 : IN OUT ARRAY1;
- PTR1 : IN OUT RECORD1;
- PTP1 : OUT POINTER1;
- PTV1 : OUT PACK1.PRIVY;
- PTT1 : IN OUT TASK1) IS
- BEGIN
- PTI1 := PTI1 + 1;
- PTA1 := (PTA1(1)+1, PTA1(2)+1, PTA1(3)+1);
- PTR1 := (D => 1,
- FIELD1 => PTR1.FIELD1 + 1);
- PTP1 := NEW INTEGER'(TP1.ALL + 1);
- PTV1 := PACK1.NEXT(TV1);
- PTT1.NEXT;
- END PROC1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TTI1 : OUT INTEGER;
- TTA1 : OUT ARRAY1;
- TTR1 : OUT RECORD1;
- TTP1 : IN OUT POINTER1;
- TTV1 : IN OUT PACK1.PRIVY;
- TTT1 : IN OUT TASK1)
- DO
- TTI1 := TI1 + 1;
- TTA1 := (TA1(1)+1,
- TA1(2)+1, TA1(3)+1);
- TTR1 := (D => 1,
- FIELD1 => TR1.FIELD1 + 1);
- TTP1 := NEW INTEGER'(TTP1.ALL + 1);
- TTV1 := PACK1.NEXT(TTV1);
- TTT1.NEXT;
- END ENTRY1;
- END TASK2;
-
- PACKAGE GENPACK1 IS NEW GENERIC1
- (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1);
- BEGIN
- IF XTI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XTI1 (1)");
- END IF;
-
- IF XTA1 /= (IDENT_INT(1),IDENT_INT(1),
- IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XTA1 (1)");
- END IF;
-
- IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(1))
- THEN
- FAILED ("INCORRECT VALUE OF XTR1 (1)");
- END IF;
-
- IF XTP1 /= IDENT(TP1) OR
- XTP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XTP1 (1)");
- END IF;
-
- IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.ONE))
- THEN
- FAILED ("INCORRECT VALUE OF XTV1 (1)");
- END IF;
-
- XTT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XTT1.VALU (1)");
- END IF;
-
- PROC1(XTI1, XTA1, XTR1, XTP1, XTV1, XTT1);
-
- IF XTI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XTI1 (2)");
- END IF;
-
- IF XTA1 /= (IDENT_INT(2),IDENT_INT(2),
- IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XTA1 (2)");
- END IF;
-
- IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(2))
- THEN
- FAILED ("INCORRECT VALUE OF XTR1 (2)");
- END IF;
-
- IF XTP1 /= IDENT(TP1) OR
- XTP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XTP1 (2)");
- END IF;
-
- IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.TWO))
- THEN
- FAILED ("INCORRECT VALUE OF XTV1 (2)");
- END IF;
-
- XTT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM " &
- "XTT1.VALU (2)");
- END IF;
-
- CHK_TASK.ENTRY1
- (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1);
-
- IF XTI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XTI1 (3)");
- END IF;
-
- IF XTA1 /= (IDENT_INT(3),IDENT_INT(3),
- IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XTA1 (3)");
- END IF;
-
- IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XTR1 (3)");
- END IF;
-
- IF XTP1 /= IDENT(TP1) OR
- XTP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XTP1 (3)");
- END IF;
-
- IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.THREE))
- THEN
- FAILED ("INCORRECT VALUE OF XTV1 (3)");
- END IF;
-
- XTT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XTT1.VALU (3)");
- END IF;
-
- XTI1 := XTI1 + 1;
- XTA1 := (XTA1(1)+1, XTA1(2)+1, XTA1(3)+1);
- XTR1 := (D => 1, FIELD1 => XTR1.FIELD1 + 1);
- XTP1 := NEW INTEGER'(XTP1.ALL + 1);
- XTV1 := PACK1.NEXT(XTV1);
- XTT1.NEXT;
-
- IF XTI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XTI1 (4)");
- END IF;
-
- IF XTA1 /= (IDENT_INT(4),IDENT_INT(4),
- IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XTA1 (4)");
- END IF;
-
- IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(4))
- THEN
- FAILED ("INCORRECT VALUE OF XTR1 (4)");
- END IF;
-
- IF XTP1 /= IDENT(TP1) OR
- XTP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XTP1 (4)");
- END IF;
-
- IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FOUR))
- THEN
- FAILED ("INCORRECT VALUE OF XTV1 (4)");
- END IF;
-
- XTT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XTT1.VALU (4)");
- END IF;
-
- TI1 := TI1 + 1;
- TA1 := (TA1(1)+1, TA1(2)+1, TA1(3)+1);
- TR1 := (D => 1, FIELD1 => TR1.FIELD1 + 1);
- TP1 := NEW INTEGER'(TP1.ALL + 1);
- TV1 := PACK1.NEXT(TV1);
- TT1.NEXT;
-
- IF XTI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XTI1 (5)");
- END IF;
-
- IF XTA1 /= (IDENT_INT(5),IDENT_INT(5),
- IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XTA1 (5)");
- END IF;
-
- IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(5))
- THEN
- FAILED ("INCORRECT VALUE OF XTR1 (5)");
- END IF;
-
- IF XTP1 /= IDENT(TP1) OR
- XTP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XTP1 (5)");
- END IF;
-
- IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FIVE))
- THEN
- FAILED ("INCORRECT VALUE OF XTV1 (5)");
- END IF;
-
- XTT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XTT1.VALU (5)");
- END IF;
- END;
- END START;
- END MAIN_TASK;
-
- BEGIN
- MAIN_TASK.START (DI1, DA1, DR1, DP1, DV1, DT1);
- END;
-
- DT1.STOP;
-
- RESULT;
-END C85005C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005d.ada b/gcc/testsuite/ada/acats/tests/c8/c85005d.ada
deleted file mode 100644
index c745aee..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005d.ada
+++ /dev/null
@@ -1,378 +0,0 @@
--- C85005D.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 VARIABLE CREATED BY A GENERIC 'IN OUT' FORMAL
--- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND
--- THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND
--- PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT'
--- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
--- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
--- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005D IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- DI1 : INTEGER := 0;
- DA1 : ARRAY1(1..3) := (OTHERS => 0);
- DR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- DP1 : POINTER1 := NEW INTEGER'(0);
- DV1 : PACK1.PRIVY := PACK1.ZERO;
- DT1 : TASK1;
-
- I : INTEGER;
-
- GENERIC
- GI1 : IN OUT INTEGER;
- GA1 : IN OUT ARRAY1;
- GR1 : IN OUT RECORD1;
- GP1 : IN OUT POINTER1;
- GV1 : IN OUT PACK1.PRIVY;
- GT1 : IN OUT TASK1;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- XGI1 : INTEGER RENAMES GI1;
- XGA1 : ARRAY1 RENAMES GA1;
- XGR1 : RECORD1 RENAMES GR1;
- XGP1 : POINTER1 RENAMES GP1;
- XGV1 : PACK1.PRIVY RENAMES GV1;
- XGT1 : TASK1 RENAMES GT1;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1);
- END TASK2;
-
- G_CHK_TASK : TASK2;
-
- GENERIC
- GGI1 : IN OUT INTEGER;
- GGA1 : IN OUT ARRAY1;
- GGR1 : IN OUT RECORD1;
- GGP1 : IN OUT POINTER1;
- GGV1 : IN OUT PACK1.PRIVY;
- GGT1 : IN OUT TASK1;
- PACKAGE GENERIC2 IS
- END GENERIC2;
-
- PACKAGE BODY GENERIC2 IS
- BEGIN
- GGI1 := GGI1 + 1;
- GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1);
- GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1);
- GGP1 := NEW INTEGER'(GGP1.ALL + 1);
- GGV1 := PACK1.NEXT(GGV1);
- GGT1.NEXT;
- END GENERIC2;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1)
- DO
- TI1 := GI1 + 1;
- TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
- TP1 := NEW INTEGER'(TP1.ALL + 1);
- TV1 := PACK1.NEXT(TV1);
- TT1.NEXT;
- END ENTRY1;
- END TASK2;
-
- PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
- PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
- PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS
- BEGIN
- PI1 := PI1 + 1;
- PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
- PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
- PP1 := NEW INTEGER'(GP1.ALL + 1);
- PV1 := PACK1.NEXT(GV1);
- PT1.NEXT;
- END PROC1;
-
- PACKAGE GENPACK2 IS NEW GENERIC2
- (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
-
- BEGIN
- IF XGI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XGI1 (1)");
- END IF;
-
- IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XGA1 (1)");
- END IF;
-
- IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XGR1 (1)");
- END IF;
-
- IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XGP1 (1)");
- END IF;
-
- IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XGV1 (1)");
- END IF;
-
- XGT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)");
- END IF;
-
- PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
-
- IF XGI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XGI1 (2)");
- END IF;
-
- IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XGA1 (2)");
- END IF;
-
- IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XGR1 (2)");
- END IF;
-
- IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XGP1 (2)");
- END IF;
-
- IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XGV1 (2)");
- END IF;
-
- XGT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)");
- END IF;
-
- G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1);
-
- IF XGI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XGI1 (3)");
- END IF;
-
- IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XGA1 (3)");
- END IF;
-
- IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XGR1 (3)");
- END IF;
-
- IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XGP1 (3)");
- END IF;
-
- IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XGV1 (3)");
- END IF;
-
- XGT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)");
- END IF;
-
- XGI1 := XGI1 + 1;
- XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1);
- XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1);
- XGP1 := NEW INTEGER'(XGP1.ALL + 1);
- XGV1 := PACK1.NEXT(XGV1);
- XGT1.NEXT;
-
- IF XGI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XGI1 (4)");
- END IF;
-
- IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XGA1 (4)");
- END IF;
-
- IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XGR1 (4)");
- END IF;
-
- IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XGP1 (4)");
- END IF;
-
- IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XGV1 (4)");
- END IF;
-
- XGT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)");
- END IF;
-
- GI1 := GI1 + 1;
- GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
- GP1 := NEW INTEGER'(GP1.ALL + 1);
- GV1 := PACK1.NEXT(GV1);
- GT1.NEXT;
-
- IF XGI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XGI1 (5)");
- END IF;
-
- IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XGA1 (5)");
- END IF;
-
- IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XGR1 (5)");
- END IF;
-
- IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XGP1 (5)");
- END IF;
-
- IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XGV1 (5)");
- END IF;
-
- XGT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)");
- END IF;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " &
- "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " &
- "AND HAS THE CORRECT VALUE, AND THAT THE NEW " &
- "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " &
- "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " &
- "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " &
- "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " &
- "WHEN THE VALUE OF THE RENAMED VARIABLE IS " &
- "CHANGED, THE NEW VALUE IS REFLECTED BY THE " &
- "VALUE OF THE NEW NAME");
-
- DECLARE
- PACKAGE GENPACK1 IS NEW
- GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1);
- BEGIN
- NULL;
- END;
-
- DT1.STOP;
-
- RESULT;
-END C85005D;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005e.ada b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada
deleted file mode 100644
index 1f6ffc3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005e.ada
+++ /dev/null
@@ -1,397 +0,0 @@
--- C85005E.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 VARIABLE CREATED BY AN ALLOCATOR CAN BE RENAMED AND
--- HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN
--- ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR
--- ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC
--- 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED
--- VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF
--- THE NEW NAME.
-
--- HISTORY:
--- JET 03/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005E IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PACKACC IS ACCESS INTEGER;
- AK1 : PACKACC := NEW INTEGER'(0);
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- GENERIC
- GI1 : IN OUT INTEGER;
- GA1 : IN OUT ARRAY1;
- GR1 : IN OUT RECORD1;
- GP1 : IN OUT POINTER1;
- GV1 : IN OUT PACK1.PRIVY;
- GT1 : IN OUT TASK1;
- GK1 : IN OUT INTEGER;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GI1 := GI1 + 1;
- GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1);
- GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1);
- GP1 := NEW INTEGER'(GP1.ALL + 1);
- GV1 := PACK1.NEXT(GV1);
- GT1.NEXT;
- GK1 := GK1 + 1;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85005E", "CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR " &
- "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " &
- "THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT" &
- " STATEMENT AND PASSED ON AS AN ACTUAL " &
- "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE " &
- "IS REFLECTED BY THE VALUE OF THE NEW NAME");
-
- DECLARE
- TYPE ACCINT IS ACCESS INTEGER;
- TYPE ACCARR IS ACCESS ARRAY1;
- TYPE ACCREC IS ACCESS RECORD1;
- TYPE ACCPTR IS ACCESS POINTER1;
- TYPE ACCPVT IS ACCESS PACK1.PRIVY;
- TYPE ACCTSK IS ACCESS TASK1;
-
- AI1 : ACCINT := NEW INTEGER'(0);
- AA1 : ACCARR := NEW ARRAY1'(0, 0, 0);
- AR1 : ACCREC := NEW RECORD1'(D => 1, FIELD1 => 0);
- AP1 : ACCPTR := NEW POINTER1'(NEW INTEGER'(0));
- AV1 : ACCPVT := NEW PACK1.PRIVY'(PACK1.ZERO);
- AT1 : ACCTSK := NEW TASK1;
-
- XAI1 : INTEGER RENAMES AI1.ALL;
- XAA1 : ARRAY1 RENAMES AA1.ALL;
- XAR1 : RECORD1 RENAMES AR1.ALL;
- XAP1 : POINTER1 RENAMES AP1.ALL;
- XAV1 : PACK1.PRIVY RENAMES AV1.ALL;
- XAK1 : INTEGER RENAMES PACK1.AK1.ALL;
- XAT1 : TASK1 RENAMES AT1.ALL;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1; TK1 : IN OUT INTEGER);
- END TASK2;
-
- I : INTEGER;
- A_CHK_TASK : TASK2;
-
- PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1;
- PR1 : IN OUT RECORD1; PP1 : OUT POINTER1;
- PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1;
- PK1 : OUT INTEGER) IS
-
- BEGIN
- PI1 := PI1 + 1;
- PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1);
- PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1);
- PP1 := NEW INTEGER'(AP1.ALL.ALL + 1);
- PV1 := PACK1.NEXT(AV1.ALL);
- PT1.NEXT;
- PK1 := PACK1.AK1.ALL + 1;
- END PROC1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1;
- TR1 : OUT RECORD1; TP1 : IN OUT POINTER1;
- TV1 : IN OUT PACK1.PRIVY;
- TT1 : IN OUT TASK1;
- TK1 : IN OUT INTEGER) DO
- TI1 := AI1.ALL + 1;
- TA1 := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1);
- TR1 := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1);
- TP1 := NEW INTEGER'(TP1.ALL + 1);
- TV1 := PACK1.NEXT(TV1);
- TT1.NEXT;
- TK1 := TK1 + 1;
- END ENTRY1;
- END TASK2;
-
- PACKAGE GENPACK2 IS NEW
- GENERIC1 (XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
-
- BEGIN
- IF XAI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1 (1)");
- END IF;
-
- IF XAA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAA1 (1)");
- END IF;
-
- IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1 (1)");
- END IF;
-
- IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAP1 (1)");
- END IF;
-
- IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1 (1)");
- END IF;
-
- XAT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (1)");
- END IF;
-
- IF XAK1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAK1 (1)");
- END IF;
-
- PROC1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
-
- IF XAI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1 (2)");
- END IF;
-
- IF XAA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAA1 (2)");
- END IF;
-
- IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1 (2)");
- END IF;
-
- IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAP1 (2)");
- END IF;
-
- IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1 (2)");
- END IF;
-
- XAT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (2)");
- END IF;
-
- IF XAK1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAK1 (2)");
- END IF;
-
- A_CHK_TASK.ENTRY1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1);
-
- IF XAI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1 (3)");
- END IF;
-
- IF XAA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAA1 (3)");
- END IF;
-
- IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1 (3)");
- END IF;
-
- IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAP1 (3)");
- END IF;
-
- IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1 (3)");
- END IF;
-
- XAT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (3)");
- END IF;
-
- IF XAK1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAK1 (3)");
- END IF;
-
- XAI1 := XAI1 + 1;
- XAA1 := (XAA1(1)+1, XAA1(2)+1, XAA1(3)+1);
- XAR1 := (D => 1, FIELD1 => XAR1.FIELD1 + 1);
- XAP1 := NEW INTEGER'(XAP1.ALL + 1);
- XAV1 := PACK1.NEXT(XAV1);
- XAT1.NEXT;
- XAK1 := XAK1 + 1;
-
- IF XAI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1 (4)");
- END IF;
-
- IF XAA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAA1 (4)");
- END IF;
-
- IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1 (4)");
- END IF;
-
- IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAP1 (4)");
- END IF;
-
- IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1 (4)");
- END IF;
-
- XAT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (4)");
- END IF;
-
- IF XAK1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAK1 (4)");
- END IF;
-
- AI1.ALL := AI1.ALL + 1;
- AA1.ALL := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1);
- AR1.ALL := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1);
- AP1.ALL := NEW INTEGER'(AP1.ALL.ALL + 1);
- AV1.ALL := PACK1.NEXT(AV1.ALL);
- AT1.NEXT;
- PACK1.AK1.ALL := PACK1.AK1.ALL + 1;
-
- IF XAI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1 (5)");
- END IF;
-
- IF XAA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAA1 (5)");
- END IF;
-
- IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1 (5)");
- END IF;
-
- IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAP1 (5)");
- END IF;
-
- IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1 (5)");
- END IF;
-
- XAT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (5)");
- END IF;
-
- IF XAK1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAK1 (5)");
- END IF;
-
- AT1.STOP;
- END;
-
- RESULT;
-END C85005E;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005f.ada b/gcc/testsuite/ada/acats/tests/c8/c85005f.ada
deleted file mode 100644
index adc87f9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005f.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C85005F.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 A RENAMED VARIABLE DESIGNATED BY AN ACCESS VALUE,
--- A CHANGE IN THE ACCESS VALUE DOES NOT AFFECT WHICH VARIABLE IS
--- DENOTED BY THE NEW NAME.
-
--- HISTORY:
--- JET 07/26/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005F IS
- TYPE ACC IS ACCESS INTEGER;
-
- BUMP : INTEGER := 0;
-
- A : ACC := NULL;
-
- FUNCTION GET_POINTER RETURN ACC IS
- BEGIN
- BUMP := IDENT_INT(BUMP) + 1;
- RETURN NEW INTEGER'(BUMP);
- END GET_POINTER;
-
-BEGIN
- TEST ("C85005F", "CHECK THAT, FOR A RENAMED VARIABLE DESIGNATED " &
- "BY AN ACCESS VALUE, A CHANGE IN THE ACCESS " &
- "VALUE DOES NOT AFFECT WHICH VARIABLE IS " &
- "DENOTED BY THE NEW NAME");
-
- A := GET_POINTER;
-
- DECLARE
- X1 : INTEGER RENAMES A.ALL;
- X2 : INTEGER RENAMES GET_POINTER.ALL;
- BEGIN
- A := GET_POINTER;
-
- IF X1 /= 1 THEN
- FAILED("CHANGING ACCESS VALUE CHANGED RENAMED VARIABLE");
- END IF;
-
- IF X2 /= 2 THEN
- FAILED("INCORRECT RESULT FROM FUNCTION AS PREFIX");
- END IF;
- END;
-
- RESULT;
-END C85005F;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85005g.ada b/gcc/testsuite/ada/acats/tests/c8/c85005g.ada
deleted file mode 100644
index 2c1f7f0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85005g.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C85005G.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 ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED
--- IN THE RENAMING DECLARATION IS IGNORED, AND THE SUBTYPE
--- CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS USED INSTEAD.
-
--- *** 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:
--- JET 07/26/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85005G IS
-
- SUBTYPE INT IS INTEGER RANGE -100 .. 100;
-
- I : INTEGER := IDENT_INT(INTEGER'LAST);
- J : INT := IDENT_INT(INT'LAST);
-
- DG1 : INTEGER := IDENT_INT(INTEGER'LAST);
- DG2 : INT := IDENT_INT(INT'LAST);
-
- XI : INT RENAMES I;
- XJ : INTEGER RENAMES J;
-
- GENERIC
- G1 : IN OUT INT;
- G2 : IN OUT INTEGER;
- PROCEDURE GEN;
-
- PROCEDURE GEN IS
- XG1 : INT RENAMES G1;
- XG2 : INTEGER RENAMES G2;
- BEGIN
- IF XG1 /= INTEGER'LAST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G1");
- END IF;
-
- XG1 := IDENT_INT(INTEGER'FIRST);
-
- IF XG1 /= INTEGER'FIRST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G2");
- END IF;
-
- IF XG2 /= INT'LAST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G3");
- END IF;
-
- XG2 := IDENT_INT(INT'FIRST);
-
- IF XG2 /= INT'FIRST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G4");
- END IF;
-
- BEGIN
- XG2 := IDENT_INT(INTEGER'LAST);
- FAILED ("NO EXCEPTION RAISED BY XG2 := INTEGER'LAST");
- IF NOT EQUAL(XG2,XG2) THEN
- COMMENT ("DON'T OPTIMIZE XG2");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION (G)");
- END;
- END GEN;
-
- PROCEDURE PROC IS NEW GEN(DG1, DG2);
-
-BEGIN
- TEST ("C85005G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " &
- "THE TYPE MARK USED IN THE RENAMING " &
- "DECLARATION IS IGNORED, AND THE SUBTYPE " &
- "CONSTRAINT ASSOCIATED WITH THE RENAMED " &
- "VARIABLE IS USED INSTEAD");
-
- IF XI /= INTEGER'LAST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 1");
- END IF;
-
- XI := IDENT_INT(INTEGER'FIRST);
-
- IF XI /= INTEGER'FIRST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 2");
- END IF;
-
- IF XJ /= INT'LAST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 3");
- END IF;
-
- XJ := IDENT_INT(INT'FIRST);
-
- IF XJ /= INT'FIRST THEN
- FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 4");
- END IF;
-
- BEGIN
- XJ := IDENT_INT(INTEGER'LAST);
- FAILED ("NO EXCEPTION RAISED BY XJ := INTEGER'LAST");
- IF NOT EQUAL(XJ,XJ) THEN
- COMMENT ("DON'T OPTIMIZE XJ");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - 1");
- END;
-
- PROC;
-
- RESULT;
-EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION - 2");
- RESULT;
-END C85005G;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006a.ada b/gcc/testsuite/ada/acats/tests/c8/c85006a.ada
deleted file mode 100644
index be04e4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006a.ada
+++ /dev/null
@@ -1,681 +0,0 @@
--- C85006A.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 COMPONENT OR SLICE OF A VARIABLE CREATED BY AN
--- OBJECT DECLARATION CAN BE RENAMED AND HAS THE CORRECT VALUE,
--- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT
--- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT'
--- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
--- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
--- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006A IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER;
- TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3);
- TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1);
- TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1;
- TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY;
- TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1;
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY; TRT1 : IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK);
- END TASK2;
-
- TYPE REC_TYPE IS RECORD
- RI1 : INTEGER := 0;
- RA1 : ARRAY1(1..3) := (OTHERS => 0);
- RR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- RP1 : POINTER1 := NEW INTEGER'(0);
- RV1 : PACK1.PRIVY := PACK1.ZERO;
- RT1 : TASK1;
- END RECORD;
-
- REC : REC_TYPE;
-
- AI1 : ARR_INT(1..8) := (OTHERS => 0);
- AA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0));
- AR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0));
- AP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0));
- AV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO);
- AT1 : ARR_TSK(1..8);
-
- XRI1 : INTEGER RENAMES REC.RI1;
- XRA1 : ARRAY1 RENAMES REC.RA1;
- XRR1 : RECORD1 RENAMES REC.RR1;
- XRP1 : POINTER1 RENAMES REC.RP1;
- XRV1 : PACK1.PRIVY RENAMES REC.RV1;
- XRT1 : TASK1 RENAMES REC.RT1;
- XAI1 : ARR_INT RENAMES AI1(1..3);
- XAA1 : ARR_ARR RENAMES AA1(2..4);
- XAR1 : ARR_REC RENAMES AR1(3..5);
- XAP1 : ARR_PTR RENAMES AP1(4..6);
- XAV1 : ARR_PVT RENAMES AV1(5..7);
- XAT1 : ARR_TSK RENAMES AT1(6..8);
-
- I : INTEGER;
- CHK_TASK : TASK2;
-
- GENERIC
- GRI1 : IN OUT INTEGER;
- GRA1 : IN OUT ARRAY1;
- GRR1 : IN OUT RECORD1;
- GRP1 : IN OUT POINTER1;
- GRV1 : IN OUT PACK1.PRIVY;
- GRT1 : IN OUT TASK1;
- GAI1 : IN OUT ARR_INT;
- GAA1 : IN OUT ARR_ARR;
- GAR1 : IN OUT ARR_REC;
- GAP1 : IN OUT ARR_PTR;
- GAV1 : IN OUT ARR_PVT;
- GAT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1;
- PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1;
- PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1;
- PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR;
- PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR;
- PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS
-
- BEGIN
- PRI1 := PRI1 + 1;
- PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1);
- PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1);
- PRP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- PRV1 := PACK1.NEXT(REC.RV1);
- PRT1.NEXT;
- PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1);
- PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1));
- PAR1 := (OTHERS => (D => 1,
- FIELD1 => (PAR1(PAR1'FIRST).FIELD1 + 1)));
- PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1));
- FOR J IN PAV1'RANGE LOOP
- PAV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN PAT1'RANGE LOOP
- PAT1(J).NEXT;
- END LOOP;
- END PROC1;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GRI1 := GRI1 + 1;
- GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1);
- GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1);
- GRP1 := NEW INTEGER'(GRP1.ALL + 1);
- GRV1 := PACK1.NEXT(GRV1);
- GRT1.NEXT;
- GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1);
- GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1));
- GAR1 := (OTHERS => (D => 1,
- FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1)));
- GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1));
- FOR J IN GAV1'RANGE LOOP
- GAV1(J) := PACK1.NEXT(GAV1(J));
- END LOOP;
- FOR J IN GAT1'RANGE LOOP
- GAT1(J).NEXT;
- END LOOP;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY; TRT1: IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK)
- DO
- TRI1 := REC.RI1 + 1;
- TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- TRP1 := NEW INTEGER'(TRP1.ALL + 1);
- TRV1 := PACK1.NEXT(TRV1);
- TRT1.NEXT;
- TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1);
- TAA1 := (OTHERS => (OTHERS => AA1(TAA1'FIRST)(1) + 1));
- TAR1 := (OTHERS => (D => 1,
- FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1)));
- TAP1 := (OTHERS => NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1));
- FOR J IN TAV1'RANGE LOOP
- TAV1(J) := PACK1.NEXT(TAV1(J));
- END LOOP;
- FOR J IN TAT1'RANGE LOOP
- TAT1(J).NEXT;
- END LOOP;
- END ENTRY1;
- END TASK2;
-
-BEGIN
- TEST ("C85006A", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " &
- "CREATED BY AN OBJECT DECLARATION CAN BE " &
- "RENAMED AND HAS THE CORRECT VALUE, AND THAT " &
- "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " &
- "STATEMENT AND PASSED ON AS AN ACTUAL " &
- "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " &
- "REFLECTED BY THE VALUE OF THE NEW NAME");
-
- DECLARE
- PACKAGE GENPACK1 IS NEW
- GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
- BEGIN
- NULL;
- END;
-
- IF XRI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (1)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (1)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (1)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (1)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (1)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) &
- ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) &
- ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) &
- ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(1)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) &
- ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) &
- ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (1)");
- END IF;
- END LOOP;
-
- PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (2)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (2)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (2)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (2)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (2)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) &
- ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) &
- ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) &
- ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(2)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) &
- ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) &
- ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (2)");
- END IF;
- END LOOP;
-
- CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (3)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (3)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (3)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (3)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (3)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) &
- ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) &
- ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) &
- ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(3)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) &
- ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) &
- ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (3)");
- END IF;
- END LOOP;
-
- XRI1 := XRI1 + 1;
- XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1);
- XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1);
- XRP1 := NEW INTEGER'(XRP1.ALL + 1);
- XRV1 := PACK1.NEXT(XRV1);
- XRT1.NEXT;
- XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1);
- XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1));
- XAR1 := (OTHERS => (D => 1,
- FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1)));
- XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- XAV1(J) := PACK1.NEXT(XAV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (4)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (4)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (4)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (4)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (4)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) &
- ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) &
- ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) &
- ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(4)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) &
- ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) &
- ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (4)");
- END IF;
- END LOOP;
-
- REC.RI1 := REC.RI1 + 1;
- REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- REC.RV1 := PACK1.NEXT(REC.RV1);
- REC.RT1.NEXT;
- AI1 := (OTHERS => AI1(XAI1'FIRST) + 1);
- AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1));
- AR1 := (OTHERS => (D => 1,
- FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1)));
- AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- AV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- AT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (5)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (5)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (5)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (5)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (5)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) &
- ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) &
- ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) &
- ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(5)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) &
- ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) &
- ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (5)");
- END IF;
- END LOOP;
-
- REC.RT1.STOP;
-
- FOR I IN AT1'RANGE LOOP
- AT1(I).STOP;
- END LOOP;
-
- RESULT;
-END C85006A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006b.ada b/gcc/testsuite/ada/acats/tests/c8/c85006b.ada
deleted file mode 100644
index 885d839..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006b.ada
+++ /dev/null
@@ -1,699 +0,0 @@
--- C85006B.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 COMPONENT OR SLICE OF A VARIABLE CREATED BY A
--- SUBPROGRAM 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE
--- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT
--- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT'
--- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
--- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
--- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006B IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER;
- TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3);
- TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1);
- TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1;
- TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY;
- TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1;
-
- TYPE REC_TYPE IS RECORD
- RI1 : INTEGER := 0;
- RA1 : ARRAY1(1..3) := (OTHERS => 0);
- RR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- RP1 : POINTER1 := NEW INTEGER'(0);
- RV1 : PACK1.PRIVY := PACK1.ZERO;
- RT1 : TASK1;
- END RECORD;
-
- DREC : REC_TYPE;
-
- DAI1 : ARR_INT(1..8) := (OTHERS => 0);
- DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0));
- DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0));
- DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0));
- DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO);
- DAT1 : ARR_TSK(1..8);
-
- GENERIC
- GRI1 : IN OUT INTEGER;
- GRA1 : IN OUT ARRAY1;
- GRR1 : IN OUT RECORD1;
- GRP1 : IN OUT POINTER1;
- GRV1 : IN OUT PACK1.PRIVY;
- GRT1 : IN OUT TASK1;
- GAI1 : IN OUT ARR_INT;
- GAA1 : IN OUT ARR_ARR;
- GAR1 : IN OUT ARR_REC;
- GAP1 : IN OUT ARR_PTR;
- GAV1 : IN OUT ARR_PVT;
- GAT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GRI1 := GRI1 + 1;
- GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1);
- GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1);
- GRP1 := NEW INTEGER'(GRP1.ALL + 1);
- GRV1 := PACK1.NEXT(GRV1);
- GRT1.NEXT;
- GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1);
- GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1));
- GAR1 := (OTHERS => (D => 1,
- FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1)));
- GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1));
- FOR J IN GAV1'RANGE LOOP
- GAV1(J) := PACK1.NEXT(GAV1(J));
- END LOOP;
- FOR J IN GAT1'RANGE LOOP
- GAT1(J).NEXT;
- END LOOP;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
- PROCEDURE PROC (REC : IN OUT REC_TYPE;
- AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR;
- AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR;
- AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK) IS
-
- XRI1 : INTEGER RENAMES REC.RI1;
- XRA1 : ARRAY1 RENAMES REC.RA1;
- XRR1 : RECORD1 RENAMES REC.RR1;
- XRP1 : POINTER1 RENAMES REC.RP1;
- XRV1 : PACK1.PRIVY RENAMES REC.RV1;
- XRT1 : TASK1 RENAMES REC.RT1;
- XAI1 : ARR_INT RENAMES AI1(1..3);
- XAA1 : ARR_ARR RENAMES AA1(2..4);
- XAR1 : ARR_REC RENAMES AR1(3..5);
- XAP1 : ARR_PTR RENAMES AP1(4..6);
- XAV1 : ARR_PVT RENAMES AV1(5..7);
- XAT1 : ARR_TSK RENAMES AT1(6..8);
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1 : IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK);
- END TASK2;
-
- I : INTEGER;
- CHK_TASK : TASK2;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1;
- TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1: IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK)
- DO
- TRI1 := REC.RI1 + 1;
- TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- TRP1 := NEW INTEGER'(TRP1.ALL + 1);
- TRV1 := PACK1.NEXT(TRV1);
- TRT1.NEXT;
- TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1);
- TAA1 := (OTHERS => (OTHERS =>
- AA1(TAA1'FIRST)(1) + 1));
- TAR1 := (OTHERS => (D => 1,
- FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1)));
- TAP1 := (OTHERS =>
- NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1));
- FOR J IN TAV1'RANGE LOOP
- TAV1(J) := PACK1.NEXT(TAV1(J));
- END LOOP;
- FOR J IN TAT1'RANGE LOOP
- TAT1(J).NEXT;
- END LOOP;
- END ENTRY1;
- END TASK2;
-
- PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1;
- PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1;
- PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1;
- PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR;
- PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR;
- PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS
- BEGIN
- PRI1 := PRI1 + 1;
- PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1);
- PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1);
- PRP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- PRV1 := PACK1.NEXT(REC.RV1);
- PRT1.NEXT;
- PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1);
- PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1));
- PAR1 := (OTHERS => (D => 1, FIELD1 =>
- (PAR1(PAR1'FIRST).FIELD1 + 1)));
- PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL+1));
- FOR J IN PAV1'RANGE LOOP
- PAV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN PAT1'RANGE LOOP
- PAT1(J).NEXT;
- END LOOP;
- END PROC1;
-
- PACKAGE GENPACK1 IS NEW
- GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- BEGIN
- IF XRI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (1)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (1)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (1)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (1)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (1)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(1)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (1)");
- END IF;
- END LOOP;
-
- PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (2)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (2)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (2)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (2)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (2)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (2)");
- END IF;
- END LOOP;
-
- CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (3)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (3)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (3)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (3)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (3)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (3)");
- END IF;
- END LOOP;
-
- XRI1 := XRI1 + 1;
- XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1);
- XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1);
- XRP1 := NEW INTEGER'(XRP1.ALL + 1);
- XRV1 := PACK1.NEXT(XRV1);
- XRT1.NEXT;
- XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1);
- XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1));
- XAR1 := (OTHERS => (D => 1,
- FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1)));
- XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- XAV1(J) := PACK1.NEXT(XAV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (4)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (4)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (4)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (4)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (4)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (4)");
- END IF;
- END LOOP;
-
- REC.RI1 := REC.RI1 + 1;
- REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- REC.RV1 := PACK1.NEXT(REC.RV1);
- REC.RT1.NEXT;
- AI1 := (OTHERS => AI1(XAI1'FIRST) + 1);
- AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1));
- AR1 := (OTHERS => (D => 1,
- FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1)));
- AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- AV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- AT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (5)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (5)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (5)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (5)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (5)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (5)");
- END IF;
- END LOOP;
-
- END PROC;
-
-BEGIN
- TEST ("C85006B", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " &
- "CREATED BY A SUBPROGRAM 'IN OUT' FORMAL " &
- "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " &
- "VALUE, AND THAT THE NEW NAME CAN BE USED IN " &
- "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " &
- "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " &
- "REFLECTED BY THE VALUE OF THE NEW NAME");
-
- PROC (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1);
-
- DREC.RT1.STOP;
-
- FOR I IN DAT1'RANGE LOOP
- DAT1(I).STOP;
- END LOOP;
-
- RESULT;
-END C85006B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006c.ada b/gcc/testsuite/ada/acats/tests/c8/c85006c.ada
deleted file mode 100644
index 74a7dbf..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006c.ada
+++ /dev/null
@@ -1,778 +0,0 @@
--- C85006C.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 COMPONENT OR SLICE OF A VARIABLE CREATED BY AN ENTRY
--- 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE CORRECT
--- VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT
--- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY
--- 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT'
--- PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS
--- CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006C IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER;
- TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3);
- TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1);
- TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1;
- TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY;
- TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1;
-
- TYPE REC_TYPE IS RECORD
- RI1 : INTEGER := 0;
- RA1 : ARRAY1(1..3) := (OTHERS => 0);
- RR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- RP1 : POINTER1 := NEW INTEGER'(0);
- RV1 : PACK1.PRIVY := PACK1.ZERO;
- RT1 : TASK1;
- END RECORD;
-
- DREC : REC_TYPE;
-
- DAI1 : ARR_INT(1..8) := (OTHERS => 0);
- DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0));
- DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0));
- DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0));
- DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO);
- DAT1 : ARR_TSK(1..8);
-
- I : INTEGER;
-
- GENERIC
- GRI1 : IN OUT INTEGER;
- GRA1 : IN OUT ARRAY1;
- GRR1 : IN OUT RECORD1;
- GRP1 : IN OUT POINTER1;
- GRV1 : IN OUT PACK1.PRIVY;
- GRT1 : IN OUT TASK1;
- GAI1 : IN OUT ARR_INT;
- GAA1 : IN OUT ARR_ARR;
- GAR1 : IN OUT ARR_REC;
- GAP1 : IN OUT ARR_PTR;
- GAV1 : IN OUT ARR_PVT;
- GAT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GRI1 := GRI1 + 1;
- GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1);
- GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1);
- GRP1 := NEW INTEGER'(GRP1.ALL + 1);
- GRV1 := PACK1.NEXT(GRV1);
- GRT1.NEXT;
- GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1);
- GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1));
- GAR1 := (OTHERS => (D => 1,
- FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1)));
- GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1));
- FOR J IN GAV1'RANGE LOOP
- GAV1(J) := PACK1.NEXT(GAV1(J));
- END LOOP;
- FOR J IN GAT1'RANGE LOOP
- GAT1(J).NEXT;
- END LOOP;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85006C", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " &
- "CREATED BY AN ENTRY 'IN OUT' FORMAL PARAMETER " &
- "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " &
- "THAT THE NEW NAME CAN BE USED IN AN ASSIGN" &
- "MENT STATEMENT AND PASSED ON AS AN ACTUAL " &
- "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " &
- "REFLECTED BY THE VALUE OF THE NEW NAME");
-
- DECLARE
- TASK MAIN_TASK IS
- ENTRY START (REC : IN OUT REC_TYPE;
- AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR;
- AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR;
- AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK);
- END MAIN_TASK;
-
- TASK BODY MAIN_TASK IS
- BEGIN
- ACCEPT START (REC : IN OUT REC_TYPE;
- AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR;
- AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR;
- AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK)
- DO
- DECLARE
- XRI1 : INTEGER RENAMES REC.RI1;
- XRA1 : ARRAY1 RENAMES REC.RA1;
- XRR1 : RECORD1 RENAMES REC.RR1;
- XRP1 : POINTER1 RENAMES REC.RP1;
- XRV1 : PACK1.PRIVY RENAMES REC.RV1;
- XRT1 : TASK1 RENAMES REC.RT1;
- XAI1 : ARR_INT RENAMES AI1(1..3);
- XAA1 : ARR_ARR RENAMES AA1(2..4);
- XAR1 : ARR_REC RENAMES AR1(3..5);
- XAP1 : ARR_PTR RENAMES AP1(4..6);
- XAV1 : ARR_PVT RENAMES AV1(5..7);
- XAT1 : ARR_TSK RENAMES AT1(6..8);
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TRI1 : OUT INTEGER;
- TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1;
- TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1 : IN OUT TASK1;
- TAI1 : OUT ARR_INT;
- TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC;
- TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK);
- END TASK2;
-
- CHK_TASK : TASK2;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TRI1 : OUT INTEGER;
- TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1;
- TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1: IN OUT TASK1;
- TAI1 : OUT ARR_INT;
- TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC;
- TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK)
- DO
- TRI1 := REC.RI1 + 1;
- TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1,
- REC.RA1(3)+1);
- TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- TRP1 := NEW INTEGER'(TRP1.ALL + 1);
- TRV1 := PACK1.NEXT(TRV1);
- TRT1.NEXT;
- TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1);
- TAA1 := (OTHERS => (OTHERS =>
- AA1(TAA1'FIRST)(1) + 1));
- TAR1 := (OTHERS => (D => 1, FIELD1 =>
- (AR1(TAR1'FIRST).FIELD1 + 1)));
- TAP1 := (OTHERS =>
- NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1));
- FOR J IN TAV1'RANGE LOOP
- TAV1(J) := PACK1.NEXT(TAV1(J));
- END LOOP;
- FOR J IN TAT1'RANGE LOOP
- TAT1(J).NEXT;
- END LOOP;
- END ENTRY1;
- END TASK2;
-
- PROCEDURE PROC1 (PRI1 : IN OUT INTEGER;
- PRA1 : IN OUT ARRAY1;
- PRR1 : IN OUT RECORD1;
- PRP1 : OUT POINTER1;
- PRV1 : OUT PACK1.PRIVY;
- PRT1 : IN OUT TASK1;
- PAI1 : IN OUT ARR_INT;
- PAA1 : IN OUT ARR_ARR;
- PAR1 : IN OUT ARR_REC;
- PAP1 : OUT ARR_PTR;
- PAV1 : OUT ARR_PVT;
- PAT1 : IN OUT ARR_TSK) IS
- BEGIN
- PRI1 := PRI1 + 1;
- PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1);
- PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1);
- PRP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- PRV1 := PACK1.NEXT(REC.RV1);
- PRT1.NEXT;
- PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1);
- PAA1 := (OTHERS => (OTHERS =>
- PAA1(PAA1'FIRST)(1) + 1));
- PAR1 := (OTHERS => (D => 1, FIELD1 =>
- (PAR1(PAR1'FIRST).FIELD1+1)));
- PAP1 := (OTHERS =>
- NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1));
- FOR J IN PAV1'RANGE LOOP
- PAV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN PAT1'RANGE LOOP
- PAT1(J).NEXT;
- END LOOP;
- END PROC1;
-
- PACKAGE GENPACK2 IS NEW GENERIC1
- (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- BEGIN
- IF XRI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (1)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),
- IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (1)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1))
- THEN
- FAILED ("INCORRECT VALUE OF XRR1 (1)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR
- XRP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (1)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE))
- THEN
- FAILED ("INCORRECT VALUE OF XRV1 (1)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XRT1.VALU (1)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),
- IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1,
- FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J),
- PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE " &
- "FROM XAT1(" & INTEGER'IMAGE(J) &
- ").VALU (1)");
- END IF;
- END LOOP;
-
- PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (2)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),
- IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (2)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2))
- THEN
- FAILED ("INCORRECT VALUE OF XRR1 (2)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR
- XRP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (2)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO))
- THEN
- FAILED ("INCORRECT VALUE OF XRV1 (2)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM " &
- "XRT1.VALU (2)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),
- IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1,
- FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J),
- PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE " &
- "FROM XAT1(" & INTEGER'IMAGE(J) &
- ").VALU (2)");
- END IF;
- END LOOP;
-
- CHK_TASK.ENTRY1
- (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (3)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),
- IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (3)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XRR1 (3)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR
- XRP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (3)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE))
- THEN
- FAILED ("INCORRECT VALUE OF XRV1 (3)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XRT1.VALU (3)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),
- IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1,
- FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J),
- PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE " &
- "FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (3)");
- END IF;
- END LOOP;
-
- XRI1 := XRI1 + 1;
- XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1);
- XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1);
- XRP1 := NEW INTEGER'(XRP1.ALL + 1);
- XRV1 := PACK1.NEXT(XRV1);
- XRT1.NEXT;
- XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1);
- XAA1 := (OTHERS =>
- (OTHERS => XAA1(XAA1'FIRST)(1) + 1));
- XAR1 := (OTHERS => (D => 1, FIELD1 =>
- (XAR1(XAR1'FIRST).FIELD1 + 1)));
- XAP1 := (OTHERS =>
- NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- XAV1(J) := PACK1.NEXT(XAV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (4)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),
- IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (4)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4))
- THEN
- FAILED ("INCORRECT VALUE OF XRR1 (4)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR
- XRP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (4)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR))
- THEN
- FAILED ("INCORRECT VALUE OF XRV1 (4)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XRT1.VALU (4)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),
- IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 =>
- IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J),
- PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE " &
- "FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (4)");
- END IF;
- END LOOP;
-
- REC.RI1 := REC.RI1 + 1;
- REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1,
- REC.RA1(3)+1);
- REC.RR1 := (D => 1, FIELD1 =>
- REC.RR1.FIELD1 + 1);
- REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- REC.RV1 := PACK1.NEXT(REC.RV1);
- REC.RT1.NEXT;
- AI1(XAI1'RANGE) := (OTHERS =>
- AI1(XAI1'FIRST) + 1);
- AA1(XAA1'RANGE) := (OTHERS =>
- (OTHERS => AA1(XAA1'FIRST)(1) + 1));
- AR1(XAR1'RANGE) := (OTHERS => (D => 1,
- FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1)));
- AP1(XAP1'RANGE) := (OTHERS =>
- NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- AV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- AT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (5)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),
- IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (5)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5))
- THEN
- FAILED ("INCORRECT VALUE OF XRR1 (5)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR
- XRP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (5)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE))
- THEN
- FAILED ("INCORRECT VALUE OF XRV1 (5)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF " &
- "XRT1.VALU (5)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),
- IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 =>
- IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J),
- PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE " &
- "FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (5)");
- END IF;
- END LOOP;
- END;
- END START;
- END MAIN_TASK;
-
- BEGIN
- MAIN_TASK.START (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1);
- END;
-
- DREC.RT1.STOP;
-
- FOR I IN DAT1'RANGE LOOP
- DAT1(I).STOP;
- END LOOP;
-
- RESULT;
-END C85006C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006d.ada b/gcc/testsuite/ada/acats/tests/c8/c85006d.ada
deleted file mode 100644
index b936402..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006d.ada
+++ /dev/null
@@ -1,712 +0,0 @@
--- C85006D.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 COMPONENT OR SLICE OF A VARIABLE CREATED BY A
--- GENERIC 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE
--- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT
--- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT'
--- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
--- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
--- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006D IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER;
- TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3);
- TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1);
- TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1;
- TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY;
- TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1;
-
- TYPE REC_TYPE IS RECORD
- RI1 : INTEGER := 0;
- RA1 : ARRAY1(1..3) := (OTHERS => 0);
- RR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- RP1 : POINTER1 := NEW INTEGER'(0);
- RV1 : PACK1.PRIVY := PACK1.ZERO;
- RT1 : TASK1;
- END RECORD;
-
- DREC : REC_TYPE;
-
- DAI1 : ARR_INT(1..8) := (OTHERS => 0);
- DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0));
- DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0));
- DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0));
- DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO);
- DAT1 : ARR_TSK(1..8);
-
- GENERIC
- REC : IN OUT REC_TYPE;
- AI1 : IN OUT ARR_INT;
- AA1 : IN OUT ARR_ARR;
- AR1 : IN OUT ARR_REC;
- AP1 : IN OUT ARR_PTR;
- AV1 : IN OUT ARR_PVT;
- AT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- XRI1 : INTEGER RENAMES REC.RI1;
- XRA1 : ARRAY1 RENAMES REC.RA1;
- XRR1 : RECORD1 RENAMES REC.RR1;
- XRP1 : POINTER1 RENAMES REC.RP1;
- XRV1 : PACK1.PRIVY RENAMES REC.RV1;
- XRT1 : TASK1 RENAMES REC.RT1;
- XAI1 : ARR_INT RENAMES AI1(1..3);
- XAA1 : ARR_ARR RENAMES AA1(2..4);
- XAR1 : ARR_REC RENAMES AR1(3..5);
- XAP1 : ARR_PTR RENAMES AP1(4..6);
- XAV1 : ARR_PVT RENAMES AV1(5..7);
- XAT1 : ARR_TSK RENAMES AT1(6..8);
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1 : IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK);
- END TASK2;
-
- CHK_TASK : TASK2;
- I : INTEGER;
-
- GENERIC
- GRI1 : IN OUT INTEGER;
- GRA1 : IN OUT ARRAY1;
- GRR1 : IN OUT RECORD1;
- GRP1 : IN OUT POINTER1;
- GRV1 : IN OUT PACK1.PRIVY;
- GRT1 : IN OUT TASK1;
- GAI1 : IN OUT ARR_INT;
- GAA1 : IN OUT ARR_ARR;
- GAR1 : IN OUT ARR_REC;
- GAP1 : IN OUT ARR_PTR;
- GAV1 : IN OUT ARR_PVT;
- GAT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC2 IS
- END GENERIC2;
-
- PACKAGE BODY GENERIC2 IS
- BEGIN
- GRI1 := GRI1 + 1;
- GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1);
- GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1);
- GRP1 := NEW INTEGER'(GRP1.ALL + 1);
- GRV1 := PACK1.NEXT(GRV1);
- GRT1.NEXT;
- GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1);
- GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1));
- GAR1 := (OTHERS => (D => 1,
- FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1)));
- GAP1 := (OTHERS =>
- NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1));
- FOR J IN GAV1'RANGE LOOP
- GAV1(J) := PACK1.NEXT(GAV1(J));
- END LOOP;
- FOR J IN GAT1'RANGE LOOP
- GAT1(J).NEXT;
- END LOOP;
- END GENERIC2;
-
- PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1;
- PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1;
- PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1;
- PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR;
- PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR;
- PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS
- BEGIN
- PRI1 := PRI1 + 1;
- PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1);
- PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1);
- PRP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- PRV1 := PACK1.NEXT(REC.RV1);
- PRT1.NEXT;
- PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1);
- PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1));
- PAR1 := (OTHERS => (D => 1, FIELD1 =>
- (PAR1(PAR1'FIRST).FIELD1 + 1)));
- PAP1 := (OTHERS =>
- NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1));
- FOR J IN PAV1'RANGE LOOP
- PAV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN PAT1'RANGE LOOP
- PAT1(J).NEXT;
- END LOOP;
- END PROC1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1;
- TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1: IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK)
- DO
- TRI1 := REC.RI1 + 1;
- TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- TRP1 := NEW INTEGER'(TRP1.ALL + 1);
- TRV1 := PACK1.NEXT(TRV1);
- TRT1.NEXT;
- TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1);
- TAA1 := (OTHERS => (OTHERS =>
- AA1(TAA1'FIRST)(1) + 1));
- TAR1 := (OTHERS => (D => 1, FIELD1 =>
- (AR1(TAR1'FIRST).FIELD1 + 1)));
- TAP1 := (OTHERS =>
- NEW INTEGER'(TAP1(TAP1'FIRST).ALL + 1));
- FOR J IN TAV1'RANGE LOOP
- TAV1(J) := PACK1.NEXT(TAV1(J));
- END LOOP;
- FOR J IN TAT1'RANGE LOOP
- TAT1(J).NEXT;
- END LOOP;
- END ENTRY1;
- END TASK2;
-
- PACKAGE GENPACK2 IS NEW
- GENERIC2 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- BEGIN
- IF XRI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (1)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (1)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (1)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (1)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (1)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(1)
- THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (1)");
- END IF;
- END LOOP;
-
- PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (2)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (2)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (2)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (2)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (2)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (2)");
- END IF;
- END LOOP;
-
- CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (3)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (3)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (3)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (3)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (3)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (3)");
- END IF;
- END LOOP;
-
- XRI1 := XRI1 + 1;
- XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1);
- XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1);
- XRP1 := NEW INTEGER'(XRP1.ALL + 1);
- XRV1 := PACK1.NEXT(XRV1);
- XRT1.NEXT;
- XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1);
- XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1));
- XAR1 := (OTHERS => (D => 1,
- FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1)));
- XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- XAV1(J) := PACK1.NEXT(XAV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (4)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (4)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (4)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (4)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (4)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (4)");
- END IF;
- END LOOP;
-
- REC.RI1 := REC.RI1 + 1;
- REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1);
- REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1);
- REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1);
- REC.RV1 := PACK1.NEXT(REC.RV1);
- REC.RT1.NEXT;
- AI1 := (OTHERS => AI1(XAI1'FIRST) + 1);
- AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1));
- AR1 := (OTHERS => (D => 1,
- FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1)));
- AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- AV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- AT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (5)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (5)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (5)");
- END IF;
-
- IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (5)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (5)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (5)");
- END IF;
- END LOOP;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85006D", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " &
- "CREATED BY A GENERIC 'IN OUT' FORMAL " &
- "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " &
- "VALUE, AND THAT THE NEW NAME CAN BE USED IN " &
- "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " &
- "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " &
- "REFLECTED BY THE VALUE OF THE NEW NAME");
-
- DECLARE
- PACKAGE GENPACK IS NEW
- GENERIC1 (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1);
- BEGIN
- NULL;
- END;
-
- DREC.RT1.STOP;
-
- FOR I IN DAT1'RANGE LOOP
- DAT1(I).STOP;
- END LOOP;
-
- RESULT;
-END C85006D;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006e.ada b/gcc/testsuite/ada/acats/tests/c8/c85006e.ada
deleted file mode 100644
index 3c92003..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006e.ada
+++ /dev/null
@@ -1,702 +0,0 @@
--- C85006E.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 COMPONENT OR SLICE OF A VARIABLE CREATED BY AN
--- ALLOCATOR CAN BE RENAMED AND HAS THE CORRECT VALUE,
--- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT
--- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT'
--- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER,
--- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED,
--- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME.
-
--- HISTORY:
--- JET 03/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006E IS
-
- TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- TYPE RECORD1 (D : INTEGER) IS
- RECORD
- FIELD1 : INTEGER := 1;
- END RECORD;
- TYPE POINTER1 IS ACCESS INTEGER;
-
- PACKAGE PACK1 IS
- TYPE PRIVY IS PRIVATE;
- ZERO : CONSTANT PRIVY;
- ONE : CONSTANT PRIVY;
- TWO : CONSTANT PRIVY;
- THREE : CONSTANT PRIVY;
- FOUR : CONSTANT PRIVY;
- FIVE : CONSTANT PRIVY;
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY;
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY;
- PRIVATE
- TYPE PRIVY IS RANGE 0..127;
- ZERO : CONSTANT PRIVY := 0;
- ONE : CONSTANT PRIVY := 1;
- TWO : CONSTANT PRIVY := 2;
- THREE : CONSTANT PRIVY := 3;
- FOUR : CONSTANT PRIVY := 4;
- FIVE : CONSTANT PRIVY := 5;
- END PACK1;
-
- TASK TYPE TASK1 IS
- ENTRY ASSIGN (J : IN INTEGER);
- ENTRY VALU (J : OUT INTEGER);
- ENTRY NEXT;
- ENTRY STOP;
- END TASK1;
-
- TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER;
- TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3);
- TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1);
- TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1;
- TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY;
- TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1;
-
- TYPE REC_TYPE IS RECORD
- RI1 : INTEGER := 0;
- RA1 : ARRAY1(1..3) := (OTHERS => 0);
- RR1 : RECORD1(1) := (D => 1, FIELD1 => 0);
- RP1 : POINTER1 := NEW INTEGER'(0);
- RV1 : PACK1.PRIVY := PACK1.ZERO;
- RT1 : TASK1;
- END RECORD;
-
- GENERIC
- GRI1 : IN OUT INTEGER;
- GRA1 : IN OUT ARRAY1;
- GRR1 : IN OUT RECORD1;
- GRP1 : IN OUT POINTER1;
- GRV1 : IN OUT PACK1.PRIVY;
- GRT1 : IN OUT TASK1;
- GAI1 : IN OUT ARR_INT;
- GAA1 : IN OUT ARR_ARR;
- GAR1 : IN OUT ARR_REC;
- GAP1 : IN OUT ARR_PTR;
- GAV1 : IN OUT ARR_PVT;
- GAT1 : IN OUT ARR_TSK;
- PACKAGE GENERIC1 IS
- END GENERIC1;
-
- FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS
- BEGIN
- IF EQUAL (3,3) THEN
- RETURN P;
- ELSE
- RETURN NULL;
- END IF;
- END IDENT;
-
- PACKAGE BODY PACK1 IS
- FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN I;
- ELSE
- RETURN PRIVY'(0);
- END IF;
- END IDENT;
-
- FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS
- BEGIN
- RETURN I+1;
- END NEXT;
- END PACK1;
-
- PACKAGE BODY GENERIC1 IS
- BEGIN
- GRI1 := GRI1 + 1;
- GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1);
- GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1);
- GRP1 := NEW INTEGER'(GRP1.ALL + 1);
- GRV1 := PACK1.NEXT(GRV1);
- GRT1.NEXT;
- GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1);
- GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1));
- GAR1 := (OTHERS => (D => 1,
- FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1)));
- GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1));
- FOR J IN GAV1'RANGE LOOP
- GAV1(J) := PACK1.NEXT(GAV1(J));
- END LOOP;
- FOR J IN GAT1'RANGE LOOP
- GAT1(J).NEXT;
- END LOOP;
- END GENERIC1;
-
- TASK BODY TASK1 IS
- TASK_VALUE : INTEGER := 0;
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ASSIGN (J : IN INTEGER) DO
- TASK_VALUE := J;
- END ASSIGN;
- OR
- ACCEPT VALU (J : OUT INTEGER) DO
- J := TASK_VALUE;
- END VALU;
- OR
- ACCEPT NEXT DO
- TASK_VALUE := TASK_VALUE + 1;
- END NEXT;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END TASK1;
-
-BEGIN
- TEST ("C85006E", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " &
- "CREATED BY AN ALLOCATOR CAN BE " &
- "RENAMED AND HAS THE CORRECT VALUE, AND THAT " &
- "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " &
- "STATEMENT AND PASSED ON AS AN ACTUAL " &
- "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " &
- "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " &
- "PARAMETER, AND THAT WHEN THE VALUE OF THE " &
- "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " &
- "REFLECTED BY THE VALUE OF THE NEW NAME");
-
- DECLARE
- TYPE AREC_TYPE IS ACCESS REC_TYPE;
- AREC : AREC_TYPE := NEW REC_TYPE;
-
- TYPE ACC_INT IS ACCESS ARR_INT;
- TYPE ACC_ARR IS ACCESS ARR_ARR;
- TYPE ACC_REC IS ACCESS ARR_REC;
- TYPE ACC_PTR IS ACCESS ARR_PTR;
- TYPE ACC_PVT IS ACCESS ARR_PVT;
- TYPE ACC_TSK IS ACCESS ARR_TSK;
-
- AI1 : ACC_INT := NEW ARR_INT'(1..8 => 0);
- AA1 : ACC_ARR := NEW ARR_ARR'(1..8 => (OTHERS => 0));
- AR1 : ACC_REC := NEW ARR_REC'(1..8 => (D => 1, FIELD1 => 0));
- AP1 : ACC_PTR := NEW ARR_PTR'(1..8 => NEW INTEGER'(0));
- AV1 : ACC_PVT := NEW ARR_PVT'(1..8 => PACK1.ZERO);
- AT1 : ACC_TSK := NEW ARR_TSK(1..8);
-
- XRI1 : INTEGER RENAMES AREC.RI1;
- XRA1 : ARRAY1 RENAMES AREC.RA1;
- XRR1 : RECORD1 RENAMES AREC.RR1;
- XRP1 : POINTER1 RENAMES AREC.RP1;
- XRV1 : PACK1.PRIVY RENAMES AREC.RV1;
- XRT1 : TASK1 RENAMES AREC.RT1;
- XAI1 : ARR_INT RENAMES AI1(1..3);
- XAA1 : ARR_ARR RENAMES AA1(2..4);
- XAR1 : ARR_REC RENAMES AR1(3..5);
- XAP1 : ARR_PTR RENAMES AP1(4..6);
- XAV1 : ARR_PVT RENAMES AV1(5..7);
- XAT1 : ARR_TSK RENAMES AT1(6..8);
-
- TASK TYPE TASK2 IS
- ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1 : IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK);
- END TASK2;
-
- I : INTEGER;
- CHK_TASK : TASK2;
-
- PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1;
- PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1;
- PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1;
- PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR;
- PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR;
- PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS
- BEGIN
- PRI1 := PRI1 + 1;
- PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1);
- PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1);
- PRP1 := NEW INTEGER'(AREC.RP1.ALL + 1);
- PRV1 := PACK1.NEXT(AREC.RV1);
- PRT1.NEXT;
- PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1);
- PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1));
- PAR1 := (OTHERS => (D => 1, FIELD1 =>
- (PAR1(PAR1'FIRST).FIELD1 + 1)));
- PAP1 := (OTHERS =>
- NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1));
- FOR J IN PAV1'RANGE LOOP
- PAV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN PAT1'RANGE LOOP
- PAT1(J).NEXT;
- END LOOP;
- END PROC1;
-
- TASK BODY TASK2 IS
- BEGIN
- ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1;
- TRR1 : OUT RECORD1;
- TRP1 : IN OUT POINTER1;
- TRV1 : IN OUT PACK1.PRIVY;
- TRT1: IN OUT TASK1;
- TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR;
- TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR;
- TAV1 : IN OUT ARR_PVT;
- TAT1 : IN OUT ARR_TSK)
- DO
- TRI1 := AREC.RI1 + 1;
- TRA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1,
- AREC.RA1(3)+1);
- TRR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1);
- TRP1 := NEW INTEGER'(TRP1.ALL + 1);
- TRV1 := PACK1.NEXT(TRV1);
- TRT1.NEXT;
- TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1);
- TAA1 := (OTHERS => (OTHERS =>
- AA1(TAA1'FIRST)(1) + 1));
- TAR1 := (OTHERS => (D => 1, FIELD1 =>
- (AR1(TAR1'FIRST).FIELD1 + 1)));
- TAP1 := (OTHERS =>
- NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1));
- FOR J IN TAV1'RANGE LOOP
- TAV1(J) := PACK1.NEXT(TAV1(J));
- END LOOP;
- FOR J IN TAT1'RANGE LOOP
- TAT1(J).NEXT;
- END LOOP;
- END ENTRY1;
- END TASK2;
-
- PACKAGE GENPACK2 IS NEW
- GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
- BEGIN
- IF XRI1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (1)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (1)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (1)");
- END IF;
-
- IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (1)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (1)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(1) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (1)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (1)");
- END IF;
- END LOOP;
-
- PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (2)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (2)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (2)");
- END IF;
-
- IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (2)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (2)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(2) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (2)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (2)");
- END IF;
- END LOOP;
-
- CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1,
- XAI1, XAA1, XAR1, XAP1, XAV1, XAT1);
-
- IF XRI1 /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (3)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (3)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (3)");
- END IF;
-
- IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (3)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (3)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(3) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (3)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (3)");
- END IF;
- END LOOP;
-
- XRI1 := XRI1 + 1;
- XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1);
- XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1);
- XRP1 := NEW INTEGER'(XRP1.ALL + 1);
- XRV1 := PACK1.NEXT(XRV1);
- XRT1.NEXT;
- XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1);
- XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1));
- XAR1 := (OTHERS => (D => 1,
- FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1)));
- XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- XAV1(J) := PACK1.NEXT(XAV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (4)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (4)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (4)");
- END IF;
-
- IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (4)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (4)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(4) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (4)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (4)");
- END IF;
- END LOOP;
-
- AREC.RI1 := AREC.RI1 + 1;
- AREC.RA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1, AREC.RA1(3)+1);
- AREC.RR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1);
- AREC.RP1 := NEW INTEGER'(AREC.RP1.ALL + 1);
- AREC.RV1 := PACK1.NEXT(AREC.RV1);
- AREC.RT1.NEXT;
- AI1(XAI1'RANGE) := (OTHERS => AI1(XAI1'FIRST) + 1);
- AA1(XAA1'RANGE) := (OTHERS =>
- (OTHERS => AA1(XAA1'FIRST)(1) + 1));
- AR1(XAR1'RANGE) := (OTHERS => (D => 1,
- FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1)));
- AP1(XAP1'RANGE) := (OTHERS =>
- NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1));
- FOR J IN XAV1'RANGE LOOP
- AV1(J) := PACK1.NEXT(AV1(J));
- END LOOP;
- FOR J IN XAT1'RANGE LOOP
- AT1(J).NEXT;
- END LOOP;
-
- IF XRI1 /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRI1 (5)");
- END IF;
-
- IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRA1 (5)");
- END IF;
-
- IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XRR1 (5)");
- END IF;
-
- IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XRP1 (5)");
- END IF;
-
- IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XRV1 (5)");
- END IF;
-
- XRT1.VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)");
- END IF;
-
- FOR J IN XAI1'RANGE LOOP
- IF XAI1(J) /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAI1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAA1'RANGE LOOP
- IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5))
- THEN
- FAILED ("INCORRECT VALUE OF XAA1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAR1'RANGE LOOP
- IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN
- FAILED ("INCORRECT VALUE OF XAR1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAP1'RANGE LOOP
- IF XAP1(J) /= IDENT(AP1(J)) OR
- XAP1(J).ALL /= IDENT_INT(5) THEN
- FAILED ("INCORRECT VALUE OF XAP1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAV1'RANGE LOOP
- IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN
- FAILED ("INCORRECT VALUE OF XAV1(" &
- INTEGER'IMAGE(J) & ") (5)");
- END IF;
- END LOOP;
-
- FOR J IN XAT1'RANGE LOOP
- XAT1(J).VALU(I);
- IF I /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RETURN VALUE FROM XAT1(" &
- INTEGER'IMAGE(J) & ").VALU (5)");
- END IF;
- END LOOP;
-
- AREC.RT1.STOP;
-
- FOR I IN AT1'RANGE LOOP
- AT1(I).STOP;
- END LOOP;
- END;
-
- RESULT;
-END C85006E;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006f.ada b/gcc/testsuite/ada/acats/tests/c8/c85006f.ada
deleted file mode 100644
index bbfe63e..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006f.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C85006F.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 RENAMED SLICE CAN BE SLICED AND INDEXED FOR PURPOSES
--- OF ASSIGNMENT AND TO READ THE VALUE.
-
--- HISTORY:
--- JET 07/26/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006F IS
-
- S : STRING(1..30) := "IT WAS A DARK AND STORMY NIGHT";
-
- ADJECTIVES : STRING RENAMES S(10..24);
-
-BEGIN
- TEST ("C85006F", "CHECK THAT A RENAMED SLICE CAN BE SLICED AND " &
- "INDEXED FOR PURPOSES OF ASSIGNMENT AND TO " &
- "READ THE VALUE");
-
- ADJECTIVES(19..24) := "STARRY";
-
- IF ADJECTIVES /= IDENT_STR("DARK AND STARRY") THEN
- FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (1)");
- END IF;
-
- IF S /= IDENT_STR("IT WAS A DARK AND STARRY NIGHT") THEN
- FAILED ("INCORRECT VALUE OF ORIGINAL STRING (1)");
- END IF;
-
- ADJECTIVES(17) := ''';
-
- IF ADJECTIVES /= IDENT_STR("DARK AN' STARRY") THEN
- FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (2)");
- END IF;
-
- IF S /= IDENT_STR("IT WAS A DARK AN' STARRY NIGHT") THEN
- FAILED ("INCORRECT VALUE OF ORIGINAL STRING (2)");
- END IF;
-
- IF ADJECTIVES(10..13) /= IDENT_STR("DARK") THEN
- FAILED ("INCORRECT VALUE OF SLICE WHEN READING");
- END IF;
-
- RESULT;
-
-END C85006F;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85006g.ada b/gcc/testsuite/ada/acats/tests/c8/c85006g.ada
deleted file mode 100644
index 9d6d59f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85006g.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- C85006G.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 ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED
--- IN THE SLICE RENAMING DECLARATION IS IGNORED, AND THAT THE
--- SUBTYPE CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS
--- USED INSTEAD.
-
--- HISTORY:
--- JET 07/26/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85006G IS
-
- SUBTYPE STR IS STRING(1..10);
-
- S : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT");
- T : STR := IDENT_STR("0123456789");
-
- DG1 : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT");
- DG2 : STR := IDENT_STR("0123456789");
-
- XS : STR RENAMES S(10..24);
- XT : STRING RENAMES T(1..5);
-
- GENERIC
- G1 : IN OUT STR;
- G2 : IN OUT STRING;
- PACKAGE GEN IS
- XG1 : STR RENAMES G1(10..24);
- XG2 : STRING RENAMES G2(1..5);
- END GEN;
-
- PACKAGE PACK IS NEW GEN(DG1, DG2);
- USE PACK;
-
-BEGIN
- TEST ("C85006G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " &
- "THE TYPE MARK USED IN THE SLICE RENAMING " &
- "DECLARATION IS IGNORED, AND THAT THE SUBTYPE " &
- "CONSTRAINT ASSOCIATED WITH THE RENAMED " &
- "VARIABLE IS USED INSTEAD");
-
- IF XS'FIRST /= IDENT_INT(10) OR
- XS'LAST /= IDENT_INT(24) OR
- XS'LENGTH /= IDENT_INT(15) THEN
- FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 1");
- END IF;
-
- IF XS /= "DARK AND STORMY" THEN
- FAILED("INCORRECT VALUE OF RENAMING SLICE - 1");
- END IF;
-
- XS := IDENT_STR("STORMY AND DARK");
-
- IF S /= "IT WAS A STORMY AND DARK NIGHT" THEN
- FAILED("INCORRECT VALUE OF ORIGINAL STRING - 1");
- END IF;
-
- IF XT'FIRST /= IDENT_INT(1) OR
- XT'LAST /= IDENT_INT(5) OR
- XT'LENGTH /= IDENT_INT(5) THEN
- FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 2");
- END IF;
-
- IF XT /= "01234" THEN
- FAILED("INCORRECT VALUE OF RENAMING SLICE - 2");
- END IF;
-
- XT := IDENT_STR("43210");
-
- IF T /= "4321056789" THEN
- FAILED("INCORRECT VALUE OF ORIGINAL STRING - 2");
- END IF;
-
- IF XG1'FIRST /= IDENT_INT(10) OR
- XG1'LAST /= IDENT_INT(24) OR
- XG1'LENGTH /= IDENT_INT(15) THEN
- FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G1");
- END IF;
-
- IF XG1 /= "DARK AND STORMY" THEN
- FAILED("INCORRECT VALUE OF RENAMING SLICE - G1");
- END IF;
-
- XG1 := IDENT_STR("STORMY AND DARK");
-
- IF DG1 /= "IT WAS A STORMY AND DARK NIGHT" THEN
- FAILED("INCORRECT VALUE OF ORIGINAL STRING - G1");
- END IF;
-
- IF XG2'FIRST /= IDENT_INT(1) OR
- XG2'LAST /= IDENT_INT(5) OR
- XG2'LENGTH /= IDENT_INT(5) THEN
- FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G2");
- END IF;
-
- IF XG2 /= "01234" THEN
- FAILED("INCORRECT VALUE OF RENAMING SLICE - G2");
- END IF;
-
- XG2 := IDENT_STR("43210");
-
- IF DG2 /= "4321056789" THEN
- FAILED("INCORRECT VALUE OF ORIGINAL STRING - G2");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED");
- RESULT;
-END C85006G;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85007a.ada b/gcc/testsuite/ada/acats/tests/c8/c85007a.ada
deleted file mode 100644
index 87eda14..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85007a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- C85007A.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 DISCRIMINANTS OF A RENAMED OUT FORMAL PARAMETER, AS
--- WELL AS THE DISCRIMINANTS OF THE RENAMED SUBCOMPONENTS OF AN OUT
--- FORMAL PARAMETER, MAY BE READ INSIDE THE PROCEDURE.
-
--- SPS 02/17/84 (SEE C62006A-B.ADA)
--- EG 02/21/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C85007A IS
-
-BEGIN
-
- TEST ("C85007A", "CHECK THAT THE DISCRIMINANTS OF A RENAMED OUT " &
- "FORMAL PARAMETER CAN BE READ INSIDE THE PROCEDURE");
-
- DECLARE
-
- TYPE R1 (D1 : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- TYPE R2 (D2 : POSITIVE) IS RECORD
- C : R1 (2);
- END RECORD;
-
- SUBTYPE R1_2 IS R1(2);
-
- R : R2 (5);
-
- PROCEDURE PROC (REC : OUT R2) IS
-
- REC1 : R2 RENAMES REC;
- REC2 : R1_2 RENAMES REC.C;
- REC3 : R2 RENAMES REC1;
- REC4 : R1_2 RENAMES REC1.C;
- REC5 : R1_2 RENAMES REC4;
-
- BEGIN
-
- IF REC1.D2 /= 5 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" &
- " A RENAMED OUT PARAMETER");
- END IF;
-
- IF REC1.C.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- "OF THE SUBCOMPONENT OF A RENAMED OUT " &
- "PARAMETER");
- END IF;
-
- IF REC2.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- "OF A RENAMED SUBCOMPONENT OF AN OUT " &
- "PARAMETER");
- END IF;
-
- IF REC3.D2 /= 5 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" &
- " A RENAME OF A RENAMED OUT PARAMETER");
- END IF;
-
- IF REC3.C.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- "OF THE SUBCOMPONENT OF A RENAME OF A " &
- "RENAMED OUT PARAMETER");
- END IF;
-
- IF REC4.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- "OF A RENAMED SUBCOMPONENT OF A RENAMED" &
- " OUT PARAMETER");
- END IF;
-
- IF REC5.D1 /= 2 THEN
- FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
- "OF A RENAME OF RENAMED SUBCOMPONENT OF" &
- " A RENAMED OUT PARAMETER");
- END IF;
-
- END PROC;
-
- BEGIN
-
- PROC (R);
-
- END;
-
- RESULT;
-
-END C85007A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85007e.ada b/gcc/testsuite/ada/acats/tests/c8/c85007e.ada
deleted file mode 100644
index da1f955..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85007e.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- C85007E.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 RENAMED OUT PARAMETER, OUT PARAMETER COMPONENT, OR
--- OUT PARAMETER SLICE CAN BE ASSIGNED TO.
-
--- EG 02/22/84
-
-WITH REPORT;
-
-PROCEDURE C85007E IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C85007E","CHECK THAT A RENAMED OUT PARAMETER, PARAMETER " &
- "COMPONENT, OR PARAMETER SLICE CAN BE ASSIGNED TO");
-
- DECLARE
-
- TYPE AT1 IS ARRAY(1 .. 3) OF INTEGER;
- TYPE RT (A : INTEGER) IS
- RECORD
- B : AT1;
- C : INTEGER;
- END RECORD;
-
- A1, B1 : INTEGER;
- A2, B2 : AT1;
- A3, B3 : RT(1);
-
- PROCEDURE PROC1 (A : OUT INTEGER;
- B : OUT AT1;
- C : OUT RT) IS
-
- AA : INTEGER RENAMES A;
- BB : AT1 RENAMES B;
- CC : RT RENAMES C;
-
- BEGIN
-
- AA := -1;
- BB := (1 .. 3 => -2);
- CC := (1, (2, 3, 4), 5);
-
- END PROC1;
-
- PROCEDURE PROC2 (X : OUT AT1;
- Y : OUT INTEGER;
- Z : OUT RT) IS
-
- XX : AT1 RENAMES X;
- YY : INTEGER RENAMES Y;
- ZZ : RT RENAMES Z;
-
- BEGIN
-
- PROC1 (YY, XX, ZZ);
-
- END PROC2;
-
- BEGIN
-
- PROC1 (A1, A2, A3);
- IF A1 /= IDENT_INT(-1) OR A2 /= (1 .. 3 => IDENT_INT(-2)) OR
- A3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN
- FAILED ("CASE 1 : ERROR IN ASSIGNMENT");
- END IF;
-
- PROC2 (B2, B1, B3);
- IF B1 /= IDENT_INT(-1) OR B2 /= (1 .. 3 => IDENT_INT(-2)) OR
- B3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN
- FAILED ("CASE 2 : ERROR IN ASSIGNMENT");
- END IF;
-
- END;
-
- RESULT;
-
-END C85007E;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85009a.ada b/gcc/testsuite/ada/acats/tests/c8/c85009a.ada
deleted file mode 100644
index 23d3c60..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85009a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- C85009A.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 PREDEFINED AND USER-DEFINED EXCEPTIONS CAN BE RENAMED
--- AND THAT HANDLERS REFERRING TO EITHER NAME ARE INVOKED WHEN THE
--- EXCEPTION IS RAISED, EVEN BY AN EXPLICIT 'RAISE' STATEMENT
--- REFERRING TO THE OTHER NAME.
-
--- HISTORY:
--- JET 03/24/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85009A IS
-
- MY_EXCEPTION : EXCEPTION;
-
- MY_EXCEPTION2 : EXCEPTION RENAMES MY_EXCEPTION;
-
- CONSTRAINT_ERROR2 : EXCEPTION RENAMES CONSTRAINT_ERROR;
-
- I : INTEGER := 1;
-
-BEGIN
- TEST ("C85009A", "CHECK THAT PREDEFINED AND USER-DEFINED " &
- "EXCEPTIONS CAN BE RENAMED AND THAT HANDLERS " &
- "REFERRING TO EITHER NAME ARE INVOKED WHEN " &
- "THE EXCEPTION IS RAISED, EVEN BY AN EXPLICIT " &
- "'RAISE' STATEMENT REFERRING TO THE OTHER NAME");
-
- BEGIN
- RAISE MY_EXCEPTION;
- FAILED ("MY_EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN MY_EXCEPTION2 =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION");
- END;
-
- BEGIN
- RAISE MY_EXCEPTION2;
- FAILED ("MY_EXCEPTION2 NOT RAISED");
- EXCEPTION
- WHEN MY_EXCEPTION =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION2");
- END;
-
- DECLARE
- TYPE COLORS IS (RED, BLUE, YELLOW);
- E : COLORS := RED;
- BEGIN
- E := COLORS'PRED(E);
- IF NOT EQUAL(COLORS'POS(E),COLORS'POS(E)) THEN
- COMMENT("DON'T OPTIMIZE E");
- END IF;
- FAILED ("CONSTRAINT_ERROR NOT RAISED BY PRED(RED)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR2 =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY PRED(RED)");
- END;
-
- BEGIN
- RAISE CONSTRAINT_ERROR;
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR2 =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR");
- END;
-
- BEGIN
- RAISE CONSTRAINT_ERROR2;
- FAILED ("CONSTRAINT_ERROR2 NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR2");
- END;
-
- RESULT;
-END C85009A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85011a.ada b/gcc/testsuite/ada/acats/tests/c8/c85011a.ada
deleted file mode 100644
index 538f9c2..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85011a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- C85011A.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 PACKAGE CAN BE RENAMED AND THE NEW NAME CAN APPEAR
--- IN A RENAMING DECLARATION, AND THAT A 'USE' CLAUSE CAN REFER TO
--- THE PACKAGE BY EITHER NAME, INCLUDING RENAMINGS OF GENERIC AND
--- NONGENERIC PACKAGES INSIDE THEMSELVES.
-
--- HISTORY:
--- JET 04/28/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85011A IS
-
- PACKAGE PACK1 IS
- I : NATURAL := 0;
- PACKAGE PACKA RENAMES PACK1;
- END PACK1;
-
- GENERIC
- TYPE T IS RANGE <>;
- PACKAGE GPACK IS
- J : T := T'FIRST;
- PACKAGE PACKB RENAMES GPACK;
- END GPACK;
-
- PACKAGE PACK2 IS NEW GPACK(NATURAL);
-
- PACKAGE PACK3 RENAMES PACK1;
- PACKAGE PACK4 RENAMES PACK2;
- PACKAGE PACK5 RENAMES PACK3;
- PACKAGE PACK6 RENAMES PACK4;
-
-BEGIN
- TEST ("C85011A", "CHECK THAT A PACKAGE CAN BE RENAMED AND THE " &
- "NEW NAME CAN APPEAR IN A RENAMING " &
- "DECLARATION, AND THAT A 'USE' CLAUSE CAN " &
- "REFER TO THE PACKAGE BY EITHER NAME, " &
- "INCLUDING RENAMINGS OF GENERIC AND NONGENERIC " &
- "PACKAGES INSIDE THEMSELVES");
-
- IF PACK1.I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK1.I");
- END IF;
-
- IF PACK2.J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK2.J");
- END IF;
-
- IF PACK3.I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK3.I");
- END IF;
-
- IF PACK4.J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK4.J");
- END IF;
-
- IF PACK5.I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK5.I");
- END IF;
-
- IF PACK6.J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK6.J");
- END IF;
-
- IF PACK1.PACKA.I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK1.PACKA.I");
- END IF;
-
- IF PACK2.PACKB.J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF PACK2.PACKB.J");
- END IF;
-
- DECLARE
- USE PACK1, PACK2;
- BEGIN
- IF I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF I (1)");
- END IF;
-
- IF J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF J (1)");
- END IF;
- END;
-
- DECLARE
- USE PACK3, PACK4;
- BEGIN
- IF I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF I (2)");
- END IF;
-
- IF J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF J (2)");
- END IF;
- END;
-
- DECLARE
- USE PACK5, PACK6;
- BEGIN
- IF I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF I (3)");
- END IF;
-
- IF J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF J (3)");
- END IF;
- END;
-
- DECLARE
- USE PACK1.PACKA, PACK2.PACKB;
- BEGIN
- IF I /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF I (4)");
- END IF;
-
- IF J /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF J (4)");
- END IF;
- END;
-
- RESULT;
-END C85011A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85013a.ada b/gcc/testsuite/ada/acats/tests/c8/c85013a.ada
deleted file mode 100644
index 9877760..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85013a.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- C85013A.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) A SUBPROGRAM OR ENTRY CAN BE RENAMED WITH:
--- A1) DIFFERENT PARAMETER NAMES;
--- A2) DIFFERENT DEFAULT VALUES;
--- A3) DIFFERENT PARAMETERS HAVING DEFAULT VALUES;
--- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME
--- IS USED IN A CALL.
-
--- B) FORMAL PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN
--- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY.
-
--- EG 02/22/84
-
-WITH REPORT;
-
-PROCEDURE C85013A IS
-
- USE REPORT;
-
-BEGIN
-
- TEST("C85013A","CHECK THAT A SUBPROGRAM CAN BE RENAMED AND " &
- "THAT THE NEW NAMES/DEFAULTS ARE USED WITH " &
- "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED" &
- " ENTITY");
-
- DECLARE
-
- TYPE TA IS ARRAY(1 .. 5) OF INTEGER;
-
- FUNCTION PROC1 (A : INTEGER := 1;
- B : TA := (1 .. 5 => 1)) RETURN INTEGER;
- FUNCTION PROCA (C : INTEGER := 1;
- D : TA := (1 .. 5 => 1)) RETURN INTEGER
- RENAMES PROC1;
- FUNCTION PROCB (B : INTEGER := 1;
- A : TA := (1 .. 5 => 1)) RETURN INTEGER
- RENAMES PROC1;
- FUNCTION PROCC (A : INTEGER := 2;
- B : TA := (1, 2, 3, 4, 5)) RETURN INTEGER
- RENAMES PROC1;
- FUNCTION PROCD (C : INTEGER := 2;
- D : TA := (1, 2, 3, 4, 5))RETURN INTEGER
- RENAMES PROC1;
-
- FUNCTION PROC1 (A : INTEGER := 1;
- B : TA := (1 .. 5 => 1)) RETURN INTEGER IS
- BEGIN
- FOR I IN 1 .. 5 LOOP
- IF A = B(I) THEN
- RETURN I;
- END IF;
- END LOOP;
- RETURN 0;
- END PROC1;
-
- BEGIN
-
- IF PROC1 /= 1 THEN
- FAILED ("CASE A : PARAMETERS NOT PROPERLY INITIALIZED");
- END IF;
- IF PROC1(A => 2) /= 0 THEN
- FAILED ("CASE A : INCORRECT RESULT");
- END IF;
- IF PROCA /= 1 THEN
- FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)");
- END IF;
- IF PROCA(D => (5, 4, 3, 2, 1)) /= 5 THEN
- FAILED ("CASE A1 : INCORRECT RESULT");
- END IF;
- IF PROCB /= 1 THEN
- FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)");
- END IF;
- IF PROCB(A => (5, 4, 3, 2, 1), B => 2) /= 4 THEN
- FAILED ("CASE A1 : INCORRECT RESULT ");
- END IF;
- IF PROCC /= 2 THEN
- FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)");
- END IF;
- IF PROCC(3) /= 3 THEN
- FAILED ("CASE A2 : INCORRECT RESULT ");
- END IF;
- IF PROCD /= 2 THEN
- FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)");
- END IF;
- IF PROCD(4) /= 4 THEN
- FAILED ("CASE A2 : INCORRECT RESULT ");
- END IF;
-
- END;
-
- DECLARE
-
- TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE STA1 IS TA(1 .. 5);
- SUBTYPE STA2 IS TA(11 .. 15);
-
- PROCEDURE PROC1 (A : STA1;
- ID : STRING);
- PROCEDURE PROC2 (A : STA2;
- ID : STRING) RENAMES PROC1;
-
- PROCEDURE PROC1 (A : STA1;
- ID : STRING) IS
- BEGIN
- IF A'FIRST /= IDENT_INT(1) THEN
- FAILED ("CASE B : INCORRECT LOWER BOUND " &
- "GENERATED BY " & ID);
- END IF;
- IF A'LAST /= IDENT_INT(5) THEN
- FAILED ("CASE B : INCORRECT UPPER BOUND " &
- "GENERATED BY " & ID);
- END IF;
- END PROC1;
-
- BEGIN
-
- PROC1 ((1, 2, 3, 4, 5),"PROC1");
- PROC2 ((6, 7, 8, 9, 10),"PROC2");
-
- END;
-
- RESULT;
-
-END C85013A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014a.ada b/gcc/testsuite/ada/acats/tests/c8/c85014a.ada
deleted file mode 100644
index cd924ac..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85014a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- C85014A.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 NUMBER OF FORMAL PARAMETERS IS USED TO DETERMINE
--- WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED.
-
--- HISTORY:
--- JET 03/24/88 CREATED ORIGINAL TEST.
--- BCB 04/18/90 CORRECTED ERROR MESSAGE FOR ENTRY2.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85014A IS
-
- TASK TYPE T1 IS
- ENTRY ENTER (I1: IN OUT INTEGER);
- ENTRY STOP;
- END T1;
-
- TASK TYPE T2 IS
- ENTRY ENTER (I1, I2: IN OUT INTEGER);
- ENTRY STOP;
- END T2;
-
- TASK1 : T1;
- TASK2 : T2;
-
- FUNCTION F RETURN T1 IS
- BEGIN
- RETURN TASK1;
- END F;
-
- FUNCTION F RETURN T2 IS
- BEGIN
- RETURN TASK2;
- END F;
-
- PROCEDURE PROC (I1: IN OUT INTEGER) IS
- BEGIN
- I1 := I1 + 1;
- END PROC;
-
- PROCEDURE PROC (I1, I2: IN OUT INTEGER) IS
- BEGIN
- I1 := I1 + 2;
- I2 := I2 + 2;
- END PROC;
-
- TASK BODY T1 IS
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ENTER (I1 : IN OUT INTEGER) DO
- I1 := I1 + 1;
- END ENTER;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END T1;
-
- TASK BODY T2 IS
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ENTER (I1, I2 : IN OUT INTEGER) DO
- I1 := I1 + 2;
- I2 := I2 + 2;
- END ENTER;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END T2;
-
-BEGIN
- TEST ("C85014A", "CHECK THAT THE NUMBER OF FORMAL PARAMETERS IS " &
- "USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY " &
- "IS BEING RENAMED");
-
- DECLARE
- PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC;
- PROCEDURE PROC2 (J1, J2: IN OUT INTEGER) RENAMES PROC;
-
- PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER;
- PROCEDURE ENTRY2 (J1, J2: IN OUT INTEGER) RENAMES F.ENTER;
-
- K1, K2 : INTEGER := 0;
- BEGIN
- PROC1(K1);
- IF K1 /= IDENT_INT(1) THEN
- FAILED("INCORRECT RETURN VALUE FROM PROC1");
- END IF;
-
- ENTRY1(K2);
- IF K2 /= IDENT_INT(1) THEN
- FAILED("INCORRECT RETURN VALUE FROM ENTRY1");
- END IF;
-
- PROC2(K1, K2);
- IF K1 /= IDENT_INT(3) OR K2 /= IDENT_INT(3) THEN
- FAILED("INCORRECT RETURN VALUE FROM PROC2");
- END IF;
-
- ENTRY2(K1, K2);
- IF K1 /= IDENT_INT(5) OR K2 /= IDENT_INT(5) THEN
- FAILED("INCORRECT RETURN VALUE FROM ENTRY2");
- END IF;
- END;
-
- TASK1.STOP;
- TASK2.STOP;
-
- RESULT;
-END C85014A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014b.ada b/gcc/testsuite/ada/acats/tests/c8/c85014b.ada
deleted file mode 100644
index ba19561..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85014b.ada
+++ /dev/null
@@ -1,192 +0,0 @@
--- C85014B.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 BASE TYPE OF THE FORMAL PARAMETER AND THE RESULT
--- TYPE ARE USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING
--- RENAMED.
-
--- HISTORY:
--- JET 03/24/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85014B IS
-
- TYPE INT IS NEW INTEGER;
- SUBTYPE SUBINT0 IS INT RANGE 0..INT'LAST;
- SUBTYPE SUBINT1 IS INT RANGE 1..INT'LAST;
-
- TASK TYPE T1 IS
- ENTRY ENTER (I1: IN OUT INTEGER);
- ENTRY STOP;
- END T1;
-
- TASK TYPE T2 IS
- ENTRY ENTER (I1: IN OUT INT);
- ENTRY STOP;
- END T2;
-
- TASK1 : T1;
- TASK2 : T2;
-
- FUNCTION F RETURN T1 IS
- BEGIN
- RETURN TASK1;
- END F;
-
- FUNCTION F RETURN T2 IS
- BEGIN
- RETURN TASK2;
- END F;
-
- PROCEDURE PROC (I1: IN OUT INTEGER) IS
- BEGIN
- I1 := I1 + 1;
- END PROC;
-
- PROCEDURE PROC (I1: IN OUT INT) IS
- BEGIN
- I1 := I1 + 2;
- END PROC;
-
- FUNCTION FUNK (I1: INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN I1 + 1;
- END FUNK;
-
- FUNCTION FUNK (I1: INTEGER) RETURN INT IS
- BEGIN
- RETURN INT(I1) + 2;
- END FUNK;
-
- FUNCTION FUNKX (N : NATURAL) RETURN POSITIVE IS
- BEGIN
- RETURN N + 1;
- END FUNKX;
-
- FUNCTION FUNKX (N : SUBINT0) RETURN SUBINT1 IS
- BEGIN
- RETURN N + 2;
- END FUNKX;
-
- TASK BODY T1 IS
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ENTER (I1 : IN OUT INTEGER) DO
- I1 := I1 + 1;
- END ENTER;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END T1;
-
- TASK BODY T2 IS
- ACCEPTING_ENTRIES : BOOLEAN := TRUE;
- BEGIN
- WHILE ACCEPTING_ENTRIES LOOP
- SELECT
- ACCEPT ENTER (I1 : IN OUT INT) DO
- I1 := I1 + 2;
- END ENTER;
- OR
- ACCEPT STOP DO
- ACCEPTING_ENTRIES := FALSE;
- END STOP;
- END SELECT;
- END LOOP;
- END T2;
-
-BEGIN
- TEST ("C85014B", "CHECK THAT THE BASE TYPE OF THE FORMAL " &
- "PARAMETER AND THE RESULT TYPE ARE USED TO " &
- "DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING " &
- "RENAMED");
-
- DECLARE
- PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC;
- PROCEDURE PROC2 (J1: IN OUT INT) RENAMES PROC;
-
- FUNCTION FUNK1 (J1: INTEGER) RETURN INTEGER RENAMES FUNK;
- FUNCTION FUNK2 (J1: INTEGER) RETURN INT RENAMES FUNK;
-
- PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER;
- PROCEDURE ENTRY2 (J1: IN OUT INT) RENAMES F.ENTER;
-
- FUNCTION FUNK3 (J1: POSITIVE) RETURN NATURAL RENAMES FUNKX;
- FUNCTION FUNK4 (J1: SUBINT1) RETURN SUBINT0 RENAMES FUNKX;
-
- K1 : INTEGER := 0;
- K2 : INT := 0;
- BEGIN
- PROC1(K1);
- IF K1 /= IDENT_INT(1) THEN
- FAILED("INCORRECT RETURN VALUE FROM PROC1");
- END IF;
-
- K1 := FUNK1(K1);
- IF K1 /= IDENT_INT(2) THEN
- FAILED("INCORRECT RETURN VALUE FROM FUNK1");
- END IF;
-
- ENTRY1(K1);
- IF K1 /= IDENT_INT(3) THEN
- FAILED("INCORRECT RETURN VALUE FROM ENTRY1");
- END IF;
-
- K1 := FUNK3(K1);
- IF K1 /= IDENT_INT(4) THEN
- FAILED("INCORRECT RETURN VALUE FROM FUNK3");
- END IF;
-
- PROC2(K2);
- IF INTEGER(K2) /= IDENT_INT(2) THEN
- FAILED("INCORRECT RETURN VALUE FROM PROC2");
- END IF;
-
- K2 := FUNK2(INTEGER(K2));
- IF INTEGER(K2) /= IDENT_INT(4) THEN
- FAILED("INCORRECT RETURN VALUE FROM FUNK2");
- END IF;
-
- ENTRY2(K2);
- IF INTEGER(K2) /= IDENT_INT(6) THEN
- FAILED("INCORRECT RETURN VALUE FROM ENTRY2");
- END IF;
-
- K2 := FUNK4(K2);
- IF INTEGER(K2) /= IDENT_INT(8) THEN
- FAILED("INCORRECT RETURN VALUE FROM FUNK4");
- END IF;
- END;
-
- TASK1.STOP;
- TASK2.STOP;
-
- RESULT;
-END C85014B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85014c.ada b/gcc/testsuite/ada/acats/tests/c8/c85014c.ada
deleted file mode 100644
index 6e91f8f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85014c.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- C85014C.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 PRESENCE OR ABSENCE OF A RESULT TYPE IS USED TO
--- DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED.
-
--- HISTORY:
--- JET 03/24/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85014C IS
-
- I, J : INTEGER;
-
- TASK TYPE T IS
- ENTRY Q (I1 : INTEGER);
- END T;
-
- TASK0 : T;
-
- PACKAGE FUNC IS
- FUNCTION Q (I1 : INTEGER) RETURN INTEGER;
- FUNCTION FUNC RETURN T;
- END FUNC;
- USE FUNC;
-
- PROCEDURE PROC (I1: INTEGER) IS
- BEGIN
- I := I1;
- END PROC;
-
- FUNCTION PROC (I1: INTEGER) RETURN INTEGER IS
- BEGIN
- I := I1 + 1;
- RETURN 0;
- END PROC;
-
- TASK BODY T IS
- BEGIN
- ACCEPT Q (I1 : INTEGER) DO
- I := I1;
- END Q;
- END T;
-
- PACKAGE BODY FUNC IS
- FUNCTION Q (I1 : INTEGER) RETURN INTEGER IS
- BEGIN
- I := I1 + 1;
- RETURN 0;
- END Q;
-
- FUNCTION FUNC RETURN T IS
- BEGIN
- RETURN TASK0;
- END FUNC;
- END FUNC;
-
-BEGIN
- TEST ("C85014C", "CHECK THAT THE PRESENCE OR ABSENCE OF A " &
- "RESULT TYPE IS USED TO DETERMINE WHICH " &
- "SUBPROGRAM OR ENTRY IS BEING RENAMED");
-
- DECLARE
- PROCEDURE PROC1 (J1: INTEGER) RENAMES PROC;
-
- FUNCTION PROC2 (J1: INTEGER) RETURN INTEGER RENAMES PROC;
- BEGIN
- PROC1(1);
- IF I /= IDENT_INT(1) THEN
- FAILED("INCORRECT VALUE OF I AFTER PROC1");
- END IF;
-
- J := PROC2(1);
- IF I /= IDENT_INT(2) THEN
- FAILED("INCORRECT VALUE OF I AFTER PROC2");
- END IF;
- END;
-
- DECLARE
- PROCEDURE FUNC1 (J1 : INTEGER) RENAMES FUNC.FUNC.Q;
-
- FUNCTION FUNC2 (J1 : INTEGER) RETURN INTEGER RENAMES FUNC.Q;
- BEGIN
- FUNC1(1);
- IF I /= IDENT_INT(1) THEN
- FAILED("INCORRECT VALUE OF I AFTER FUNC1");
- END IF;
-
- J := FUNC2(1);
- IF I /= IDENT_INT(2) THEN
- FAILED("INCORRECT VALUE OF I AFTER FUNC2");
- END IF;
- END;
-
- RESULT;
-END C85014C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85017a.ada b/gcc/testsuite/ada/acats/tests/c8/c85017a.ada
deleted file mode 100644
index 4424a65..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85017a.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- C85017A.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 RENAMING A PREDEFINED OPERATION WITH AN IDENTIFIER
--- AND THEN RENAMING THE IDENTIFIER AS AN OPERATOR SYMBOL ALLOWS THE
--- NEW NAME TO BE USED IN A STATIC EXPRESSION.
-
--- HISTORY:
--- JET 03/24/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C85017A IS
-
- FUNCTION PLUS (L,R : INTEGER) RETURN INTEGER RENAMES "+";
- FUNCTION MINUS (L,R : INTEGER) RETURN INTEGER RENAMES "-";
-
- FUNCTION "-" (L,R : INTEGER) RETURN INTEGER RENAMES PLUS;
- FUNCTION "+" (L,R : INTEGER) RETURN INTEGER RENAMES MINUS;
-
- I1 : CONSTANT INTEGER := 10 + 10;
- I2 : CONSTANT INTEGER := 10 - 10;
-
- TYPE INT IS RANGE I1 .. I2;
-BEGIN
- TEST("C85017A","CHECK THAT RENAMING A PREDEFINED OPERATION WITH " &
- "AN IDENTIFIER AND THEN RENAMING THE IDENTIFIER " &
- "AS AN OPERATOR SYMBOL ALLOWS THE NEW NAME TO BE " &
- "USED IN A STATIC EXPRESSION");
-
- IF I1 /= IDENT_INT(0) THEN
- FAILED ("INCORRECT VALUE OF I1: " & INTEGER'IMAGE(I1));
- END IF;
-
- IF I2 /= IDENT_INT(20) THEN
- FAILED ("INCORRECT VALUE OF I2: " & INTEGER'IMAGE(I2));
- END IF;
-
- RESULT;
-END C85017A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85018a.ada b/gcc/testsuite/ada/acats/tests/c8/c85018a.ada
deleted file mode 100644
index e826808..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85018a.ada
+++ /dev/null
@@ -1,140 +0,0 @@
--- C85018A.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 ENTRY FAMILY MEMBER CAN BE RENAMED WITH:
--- 1) DIFFERENT PARAMETER NAMES;
--- 2) DIFFERENT DEFAULT VALUES;
--- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME
--- IS USED IN A CALL.
-
--- RJW 6/3/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C85018A IS
-
-BEGIN
-
- TEST( "C85018A", "CHECK THAT AN ENTRY FAMILY MEMBER CAN BE " &
- "RENAMED AND THAT THE NEW NAMES/DEFAULTS ARE " &
- "THOSE ASSOCIATED WITH THE RENAMED ENTITY" );
-
- DECLARE
-
- RESULTS : INTEGER;
-
- TYPE TA IS ARRAY(1 .. 5) OF INTEGER;
-
- TASK T IS
- ENTRY ENT1 (BOOLEAN)
- (A : INTEGER := 1; B : TA := (1 .. 5 => 1));
- END T;
-
- PROCEDURE ENTA (C : INTEGER := 1; D : TA := (1 .. 5 => 1))
- RENAMES T.ENT1 (TRUE);
-
- PROCEDURE ENTB (B : INTEGER := 1; A : TA := (1 .. 5 => 1))
- RENAMES T.ENT1 (TRUE);
-
- PROCEDURE ENTC (A : INTEGER := 2; B : TA := (1, 2, 3, 4, 5))
- RENAMES T.ENT1 (TRUE);
-
- PROCEDURE ENTD (C : INTEGER := 2; D : TA := (1, 2, 3, 4, 5))
- RENAMES T.ENT1 (TRUE);
-
- TASK BODY T IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT1 (IDENT_BOOL (TRUE))
- (A : INTEGER := 1;
- B : TA := (1 .. 5 => 1)) DO
- IF A IN 1 .. 5 THEN
- RESULTS := B(A);
- ELSE
- RESULTS := 0;
- END IF;
- END;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T;
-
- BEGIN
-
- T.ENT1 (TRUE);
- IF RESULTS /= 1 THEN
- FAILED ( "PARAMETERS NOT PROPERLY INITIALIZED" );
- END IF;
-
- T.ENT1 (TRUE) (A => 6);
- IF RESULTS /= 0 THEN
- FAILED ( "INCORRECT RESULTS" );
- END IF;
-
- ENTA;
- IF RESULTS /= 1 THEN
- FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" );
- END IF;
-
- ENTA(D => (5, 4, 3, 2, 1));
- IF RESULTS /= 5 THEN
- FAILED ( "CASE 1 : INCORRECT RESULTS" );
- END IF;
-
- ENTB;
- IF RESULTS /= 1 THEN
- FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" );
- END IF;
-
- ENTB(A => (5, 4, 3, 2, 1), B => 2);
- IF RESULTS /= 4 THEN
- FAILED ( "CASE 1 : INCORRECT RESULTS " );
- END IF;
-
- ENTC;
- IF RESULTS /= 2 THEN
- FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" );
- END IF;
-
- ENTC(3);
- IF RESULTS /= 3 THEN
- FAILED ( "CASE 2 : INCORRECT RESULTS " );
- END IF;
-
- ENTD;
- IF RESULTS /= 2 THEN
- FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" );
- END IF;
-
- ENTD(4);
- IF RESULTS /= 4 THEN
- FAILED ( "CASE 2 : INCORRECT RESULTS " );
- END IF;
-
- END;
- RESULT;
-
-END C85018A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85018b.ada b/gcc/testsuite/ada/acats/tests/c8/c85018b.ada
deleted file mode 100644
index 44fbb56..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85018b.ada
+++ /dev/null
@@ -1,288 +0,0 @@
--- C85018B.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 WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL
--- PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN
--- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY.
-
--- HISTORY:
--- RJW 06/03/86 CREATED ORIGINAL TEST.
--- DHH 10/15/87 CORRECTED RANGE ERRORS.
--- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT).
--- PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED.
--- PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY.
--- PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C85018B IS
-
-BEGIN
-
- TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " &
- "RENAMED THE FORMAL PARAMETER CONSTRAINTS " &
- "FOR THE NEW NAME ARE IGNORED IN FAVOR OF " &
- "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " &
- "ENTITY" );
-
- DECLARE
- TYPE INT IS RANGE 1 .. 10;
- SUBTYPE INT1 IS INT RANGE 1 .. 5;
- SUBTYPE INT2 IS INT RANGE 6 .. 10;
-
- OBJ1 : INT1 := 5;
- OBJ2 : INT2 := 6;
-
- SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C';
-
- TASK T IS
- ENTRY ENT1 (SHORTCHAR)
- (A : INT1; OK : BOOLEAN);
- END T;
-
- PROCEDURE ENT2 (A : INT2; OK : BOOLEAN)
- RENAMES T.ENT1 ('C');
-
- TASK BODY T IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT1 ('C')
- (A : INT1; OK : BOOLEAN) DO
- IF NOT OK THEN
- FAILED ( "WRONG CALL EXECUTED " &
- "WITH INTEGER TYPE" );
- END IF;
- END;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T;
- BEGIN
- BEGIN
- ENT2 (OBJ1, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "INTEGER TYPE" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "INTEGER TYPE - 1" );
- END;
-
- BEGIN
- ENT2 (OBJ2, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "INTEGER TYPE - 2" );
- END;
- END;
-
- DECLARE
- TYPE REAL IS DIGITS 3;
- SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0;
- SUBTYPE REAL2 IS REAL RANGE 0.0 .. 2.0;
-
- OBJ1 : REAL1 := -0.25;
- OBJ2 : REAL2 := 0.25;
-
- SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11;
-
- TASK T IS
- ENTRY ENT1 (SHORTINT)
- (A : REAL1; OK : BOOLEAN);
- END T;
-
- PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN)
- RENAMES T.ENT1 (10);
-
- TASK BODY T IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT1 (10)
- (A : REAL1; OK : BOOLEAN) DO
- IF NOT OK THEN
- FAILED ( "WRONG CALL EXECUTED " &
- "WITH FLOATING POINT " &
- "TYPE" );
- END IF;
- END;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T;
- BEGIN
- BEGIN
- ENT2 (OBJ1, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "FLOATING POINT " &
- "TYPE" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "FLOATING POINT " &
- "TYPE - 1" );
- END;
-
- BEGIN
- ENT2 (OBJ2, FALSE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "FLOATING POINT " &
- "TYPE - 2" );
- END;
- END;
-
- DECLARE
- TYPE COLOR IS (RED, YELLOW, BLUE, GREEN);
-
- TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
- SUBTYPE FIXED1 IS FIXED RANGE 0.0 .. 0.5;
- SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0;
-
- OBJ1 : FIXED1 := 0.125;
- OBJ2 : FIXED2 := -0.125;
-
- TASK T IS
- ENTRY ENT1 (COLOR)
- (A : FIXED1; OK : BOOLEAN);
- END T;
-
- PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN)
- RENAMES T.ENT1 (BLUE);
-
- TASK BODY T IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT1 (BLUE)
- (A : FIXED1; OK : BOOLEAN) DO
- IF NOT OK THEN
- FAILED ( "WRONG CALL EXECUTED " &
- "WITH FIXED POINT " &
- "TYPE" );
- END IF;
- END;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T;
- BEGIN
- BEGIN
- ENT2 (OBJ1, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "FIXED POINT " &
- "TYPE" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "FIXED POINT " &
- "TYPE - 1" );
- END;
-
- BEGIN
- ENT2 (OBJ2, FALSE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "FIXED POINT " &
- "TYPE - 2" );
- END;
- END;
-
- DECLARE
- TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE STA1 IS TA(1 .. 5);
- SUBTYPE STA2 IS TA(6 .. 10);
-
- OBJ1 : STA1 := (1, 2, 3, 4, 5);
- OBJ2 : STA2 := (6, 7, 8, 9, 10);
-
- TASK T IS
- ENTRY ENT1 (BOOLEAN)
- (A : STA1; OK : BOOLEAN);
- END T;
-
- PROCEDURE ENT2 (A : STA2; OK : BOOLEAN)
- RENAMES T.ENT1 (FALSE);
-
- TASK BODY T IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT1 (FALSE)
- (A : STA1; OK : BOOLEAN) DO
- IF NOT OK THEN
- FAILED ( "WRONG CALL EXECUTED " &
- "WITH CONSTRAINED " &
- "ARRAY" );
- END IF;
- END;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T;
- BEGIN
- BEGIN
- ENT2 (OBJ1, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "CONSTRAINED ARRAY" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "CONSTRAINED ARRAY - 1" );
- END;
-
- BEGIN
- ENT2 (OBJ2, TRUE);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "CONSTRAINED ARRAY" );
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED WITH " &
- "CONSTRAINED ARRAY - 2" );
- END;
- END;
-
- RESULT;
-
-END C85018B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c85019a.ada b/gcc/testsuite/ada/acats/tests/c8/c85019a.ada
deleted file mode 100644
index 6aec3ae..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c85019a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C85019A.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 CHARACTER OR OTHER ENUMERATION LITERAL MAY BE RENAMED
--- AS A FUNCTION.
-
--- RJW 6/4/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C85019A IS
-
-BEGIN
-
- TEST( "C85019A", "CHECK THAT A CHARACTER OR OTHER ENUMERATION " &
- "LITERAL MAY BE RENAMED AS A FUNCTION" );
-
- DECLARE
- FUNCTION SEA RETURN CHARACTER RENAMES 'C';
-
- TYPE COLOR IS (RED, YELLOW, BLUE, GREEN);
-
- FUNCTION TEAL RETURN COLOR RENAMES BLUE;
-
- BEGIN
- IF SEA /= 'C' THEN
- FAILED ( "SEA IS NOT EQUAL TO 'C'" );
- END IF;
-
- IF TEAL /= BLUE THEN
- FAILED ( "TEAL IS NOT EQUAL TO BLUE" );
- END IF;
-
- END;
-
- RESULT;
-
-END C85019A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854001.a b/gcc/testsuite/ada/acats/tests/c8/c854001.a
deleted file mode 100644
index 5a128ba..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854001.a
+++ /dev/null
@@ -1,277 +0,0 @@
--- C854001.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 subprogram declaration can be completed by a
--- subprogram renaming declaration. In particular, check that such a
--- renaming-as-body can be given in a package body to complete a
--- subprogram declared in the package specification. Check that calls
--- to the subprogram invoke the body of the renamed subprogram. Check
--- that a renaming allows a copy of an inherited or predefined subprogram
--- before overriding it later. Check that renaming a dispatching
--- operation calls the correct body in case of overriding.
---
--- TEST DESCRIPTION:
--- This test declares a record type, an integer type, and a tagged type
--- with a set of operations in a package. A renaming of a predefined
--- equality operation of a tagged type is also defined in this package.
--- The predefined operation is overridden in the private part. In a
--- separate package, a subtype of the record type and integer type
--- are declared. Subset of the full set of operations for the record
--- and types is reexported using renamings-as-bodies. Other operations
--- are given explicit bodies. The test verifies that the appropriate
--- body is executed for each operation on the subtype.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package C854001_0 is
-
- type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value);
-
- type Root is record
- Called : Component := Op_Of_Subtype;
- end record;
-
- procedure Root_Proc (P: in out Root);
- procedure Over_Proc (P: in out Root);
-
- function Root_Func return Root;
- function Over_Func return Root;
-
- type Short_Int is range 1 .. 98;
-
- function "+" (P1, P2 : Short_Int) return Short_Int;
- function Name (P1, P2 : Short_Int) return Short_Int;
-
- type Tag_Type is tagged record
- C : Component := Initial_Value;
- end record;
- -- Inherits predefined operator "=" and others.
-
- function Predefined_Equal (P1, P2 : Tag_Type) return Boolean
- renames "=";
- -- Renames predefined operator "=" before overriding.
-
-private
- function "=" (P1, P2 : Tag_Type)
- return Boolean; -- Overrides predefined operator "=".
-
-
-end C854001_0;
-
-
- --==================================================================--
-
-
-package body C854001_0 is
-
- procedure Root_Proc (P: in out Root) is
- begin
- P.Called := Initial_Value;
- end Root_Proc;
-
- ---------------------------------------
- procedure Over_Proc (P: in out Root) is
- begin
- P.Called := Op_Of_Type;
- end Over_Proc;
-
- ---------------------------------------
- function Root_Func return Root is
- begin
- return (Called => Op_Of_Type);
- end Root_Func;
-
- ---------------------------------------
- function Over_Func return Root is
- begin
- return (Called => Initial_Value);
- end Over_Func;
-
- ---------------------------------------
- function "+" (P1, P2 : Short_Int) return Short_Int is
- begin
- return 15;
- end "+";
-
- ---------------------------------------
- function Name (P1, P2 : Short_Int) return Short_Int is
- begin
- return 47;
- end Name;
-
- ---------------------------------------
- function "=" (P1, P2 : Tag_Type) return Boolean is
- begin
- return False;
- end "=";
-
-end C854001_0;
-
- --==================================================================--
-
-
-with C854001_0;
-package C854001_1 is
-
- subtype Root_Subtype is C854001_0.Root;
- subtype Short_Int_Subtype is C854001_0.Short_Int;
-
- procedure Ren_Proc (P: in out Root_Subtype);
- procedure Same_Proc (P: in out Root_Subtype);
-
- function Ren_Func return Root_Subtype;
- function Same_Func return Root_Subtype;
-
- function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
- function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
-
- function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean
- renames C854001_0."="; -- Executes body of the
- -- overriding declaration in
- -- the private part.
-end C854001_1;
-
-
- --==================================================================--
-
-
-with C854001_0;
-package body C854001_1 is
-
- --
- -- Renaming-as-body for procedure:
- --
-
- procedure Ren_Proc (P: in out Root_Subtype)
- renames C854001_0.Root_Proc;
- procedure Same_Proc (P: in out Root_Subtype)
- renames C854001_0.Over_Proc;
-
- --
- -- Renaming-as-body for function:
- --
-
- function Ren_Func return Root_Subtype renames C854001_0.Root_Func;
- function Same_Func return Root_Subtype renames C854001_0.Over_Func;
-
- function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
- renames C854001_0."+";
- function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
- renames C854001_0.Name;
-
-end C854001_1;
-
-
- --==================================================================--
-
-with C854001_0;
-with C854001_1; -- Subtype and associated operations.
-use C854001_1;
-
-with Report;
-
-procedure C854001 is
- Operand1 : Root_Subtype;
- Operand2 : Root_Subtype;
- Operand3 : Root_Subtype;
- Operand4 : Root_Subtype;
- Operand5 : Short_Int_Subtype := 55;
- Operand6 : Short_Int_Subtype := 46;
- Operand7 : Short_Int_Subtype;
- Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have
- Operand9 : C854001_0.Tag_Type; -- the same default values.
-
- -- Direct visibility to operator symbols
- use type C854001_0.Component;
- use type C854001_0.Short_Int;
-
-begin
- Report.Test ("C854001", "Check that a renaming-as-body can be given " &
- "in a package body to complete a subprogram " &
- "declared in the package specification. " &
- "Check that calls to the subprogram invoke " &
- "the body of the renamed subprogram");
-
- --
- -- Only operations of the subtype are available.
- --
-
- Ren_Proc (Operand1);
- if Operand1.Called /= C854001_0.Initial_Value then
- Report.Failed ("Error calling procedure Ren_Proc");
- end if;
-
- ---------------------------------------
- Same_Proc (Operand2);
- if Operand2.Called /= C854001_0.Op_Of_Type then
- Report.Failed ("Error calling procedure Same_Proc");
- end if;
-
- ---------------------------------------
- Operand3 := Ren_Func;
- if Operand3.Called /= C854001_0.Op_Of_Type then
- Report.Failed ("Error calling function Ren_Func");
- end if;
-
- ---------------------------------------
- Operand4 := Same_Func;
- if Operand4.Called /= C854001_0.Initial_Value then
- Report.Failed ("Error calling function Same_Func");
- end if;
-
- ---------------------------------------
- Operand7 := C854001_1."-" (Operand5, Operand6);
- if Operand7 /= 47 then
- Report.Failed ("Error calling function & ""-""");
- end if;
-
- ---------------------------------------
- Operand7 := Other_Name (Operand5, Operand6);
- if Operand7 /= 15 then
- Report.Failed ("Error calling function Other_Name");
- end if;
-
- ---------------------------------------
- -- Executes body of the overriding declaration in the private part
- -- of C854001_0.
- if User_Defined_Equal (Operand8, Operand9) then
- Report.Failed ("Error calling function User_Defined_Equal");
- end if;
-
- ---------------------------------------
- -- Executes predefined operation.
- if not C854001_0.Predefined_Equal (Operand8, Operand9) then
- Report.Failed ("Error calling function Predefined_Equal");
- end if;
-
- Report.Result;
-
-end C854001;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854002.a b/gcc/testsuite/ada/acats/tests/c8/c854002.a
deleted file mode 100644
index 19bca35..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854002.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- C854002.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 WHATSOVER, 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 the requirements of the new 8.5.4(8.A) from Technical
--- Corrigendum 1 (originally discussed as AI95-00064).
--- This paragraph requires an elaboration check on renamings-as-body:
--- even if the body of the ultimately-called subprogram has been
--- elaborated, the check should fail if the renaming-as-body
--- itself has not yet been elaborated.
---
--- TEST DESCRIPTION
--- We declare two functions F and G, and ensure that they are
--- elaborated before anything else, by using pragma Pure. Then we
--- declare two renamings-as-body: the renaming of F is direct, and
--- the renaming of G is via an access-to-function object. We call
--- the renamings during elaboration, and check that they raise
--- Program_Error. We then call them again after elaboration; this
--- time, they should work.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 28 JUN 2002 RLB Added pragma Elaborate_All for Report.
---!
-
-package C854002_1 is
- pragma Pure;
- -- Empty.
-end C854002_1;
-
-package C854002_1.Pure is
- pragma Pure;
- function F return String;
- function G return String;
-end C854002_1.Pure;
-
-with C854002_1.Pure;
-package C854002_1.Renamings is
-
- F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F.
- function Renamed_F return String;
-
- G_Result: constant String := C854002_1.Pure.G;
- type String_Function is access function return String;
- G_Pointer: String_Function := null;
- -- Will be set to C854002_1.Pure.G'Access in the body.
- function Renamed_G return String;
-
-end C854002_1.Renamings;
-
-package C854002_1.Caller is
-
- -- These procedures call the renamings; when called during elaboration,
- -- we pass Should_Fail => True, which checks that Program_Error is
- -- raised. Later, we use Should_Fail => False.
-
- procedure Call_Renamed_F(Should_Fail: Boolean);
- procedure Call_Renamed_G(Should_Fail: Boolean);
-
-end C854002_1.Caller;
-
-with Report; use Report; pragma Elaborate_All (Report);
-with C854002_1.Renamings;
-package body C854002_1.Caller is
-
- Some_Error: exception;
-
- procedure Call_Renamed_F(Should_Fail: Boolean) is
- begin
- if Should_Fail then
- begin
- Failed(C854002_1.Renamings.Renamed_F);
- raise Some_Error;
- -- This raise statement is necessary, because the
- -- Report package has a bug -- if Failed is called
- -- before Test, then the failure is ignored, and the
- -- test prints "PASSED".
- -- Presumably, this raise statement will cause the
- -- program to crash, thus avoiding the PASSED message.
- exception
- when Program_Error =>
- Comment("Program_Error -- OK");
- end;
- else
- if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then
- Failed("Bad result from renamed F");
- end if;
- end if;
- end Call_Renamed_F;
-
- procedure Call_Renamed_G(Should_Fail: Boolean) is
- begin
- if Should_Fail then
- begin
- Failed(C854002_1.Renamings.Renamed_G);
- raise Some_Error;
- exception
- when Program_Error =>
- Comment("Program_Error -- OK");
- end;
- else
- if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then
- Failed("Bad result from renamed G");
- end if;
- end if;
- end Call_Renamed_G;
-
-begin
- -- At this point, the bodies of Renamed_F and Renamed_G have not yet
- -- been elaborated, so calling them should raise Program_Error:
- Call_Renamed_F(Should_Fail => True);
- Call_Renamed_G(Should_Fail => True);
-end C854002_1.Caller;
-
-package body C854002_1.Pure is
-
- function F return String is
- begin
- return "This is function F";
- end F;
-
- function G return String is
- begin
- return "This is function G";
- end G;
-
-end C854002_1.Pure;
-
-with C854002_1.Pure;
-with C854002_1.Caller; pragma Elaborate(C854002_1.Caller);
- -- This pragma ensures that this package body (Renamings)
- -- will be elaborated after Caller, so that when Caller calls
- -- the renamings during its elaboration, the renamings will
- -- not have been elaborated (although what the rename have been).
-package body C854002_1.Renamings is
-
- function Renamed_F return String renames C854002_1.Pure.F;
-
- package Dummy is end; -- So we can insert statements here.
- package body Dummy is
- begin
- G_Pointer := C854002_1.Pure.G'Access;
- end Dummy;
-
- function Renamed_G return String renames G_Pointer.all;
-
-end C854002_1.Renamings;
-
-with Report; use Report;
-with C854002_1.Caller;
-procedure C854002 is
-begin
- Test("C854002",
- "An elaboration check is performed for a call to a subprogram"
- & " whose body is given as a renaming-as-body");
-
- -- By the time we get here, all library units have been elaborated,
- -- so the following calls should not raise Program_Error:
- C854002_1.Caller.Call_Renamed_F(Should_Fail => False);
- C854002_1.Caller.Call_Renamed_G(Should_Fail => False);
-
- Result;
-end C854002;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854003.a b/gcc/testsuite/ada/acats/tests/c8/c854003.a
deleted file mode 100644
index 9ab2364..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854003.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- C854003.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 renaming-as-body used before the subprogram is frozen only
--- requires mode conformance. (Defect Report 8652/0028, as reflected in
--- Technical Corrigendum 1, RM95 8.5.4(5/1)).
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Report;
-use Report;
-procedure C854003 is
-
- package P is
- type T is private;
- C1 : constant T;
- C2 : constant T;
- private
- type T is new Integer'Base;
- C1 : constant T := T (Ident_Int (1));
- C2 : constant T := T (Ident_Int (1));
- end P;
-
- function Equals (X, Y : P.T) return Boolean;
- function Equals (X, Y : P.T) return Boolean renames P."=";
-
-begin
- Test ("C854003",
- "Check that a renaming-as-body used before the subprogram " &
- "is frozen only requires mode conformance");
-
- if not Equals (P.C1, P.C2) then
- Failed ("Equality returned an unexpected result");
- end if;
-
- Result;
-end C854003;
-
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86003a.ada b/gcc/testsuite/ada/acats/tests/c8/c86003a.ada
deleted file mode 100644
index 92b3663..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86003a.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- C86003A.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 'STANDARD' IS NOT TREATED AS A RESERVED WORD IN
--- SELECTED COMPONENT NAMES.
-
--- RM 01/21/80
--- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
--- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION.
-
-WITH REPORT ;
-PROCEDURE C86003A IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST("C86003A" , "CHECK THAT 'STANDARD' IS NOT TREATED AS A" &
- " RESERVED WORD IN SELECTED COMPONENT NAMES" );
-
- DECLARE -- A
- BEGIN
-
- DECLARE
-
- PACKAGE STANDARD IS
- CHARACTER : BOOLEAN ;
- TYPE INTEGER IS (FALSE, TRUE) ;
- CONSTRAINT_ERROR : EXCEPTION ;
- END STANDARD ;
-
- TYPE REC2 IS
- RECORD
- AA , BB : BOOLEAN := FALSE ;
- END RECORD;
-
- TYPE REC1 IS
- RECORD
- STANDARD : REC2 ;
- END RECORD;
-
- A : REC1 ;
- TYPE ASI IS ACCESS STANDARD.INTEGER ;
- VASI : ASI ;
- VI : INTEGER RANGE 1 .. 10; -- THE "REAL" STANDARD
- -- TYPE 'INTEGER'
-
- BEGIN
-
- VASI := NEW STANDARD.INTEGER'(STANDARD.FALSE);
- STANDARD.CHARACTER := A.STANDARD.BB ;
-
- IF STANDARD.CHARACTER THEN FAILED( "RES. (VAR.)" );
- END IF;
-
- VI := IDENT_INT(11); -- TO CAUSE THE "REAL"
- -- (PREDEFINED) CONSTRAINT_ERROR
- -- EXCEPTION.
- IF VI /= IDENT_INT(11) THEN
- FAILED ("WRONG VALUE - V1");
- ELSE
- FAILED ("OUT OF RANGE VALUE - V1");
- END IF;
- EXCEPTION
-
- WHEN STANDARD.CONSTRAINT_ERROR => FAILED ("RES. (EXC.)");
-
- WHEN CONSTRAINT_ERROR => NULL;
-
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED - A");
-
- END ;
-
- EXCEPTION
-
- WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECL. (A)" );
-
- END ; -- A
-
-
- DECLARE -- B
-
- TYPE REC IS
- RECORD
- INTEGER : BOOLEAN := FALSE ;
- END RECORD;
-
- STANDARD : REC ;
-
- BEGIN
-
- IF STANDARD.INTEGER THEN FAILED( "RESERVED - REC.,INT.");
- END IF;
-
- END ; -- B
-
-
- RESULT ;
-
-
-END C86003A ;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004a.ada b/gcc/testsuite/ada/acats/tests/c8/c86004a.ada
deleted file mode 100644
index 937e5f3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C86004A.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 LIBRARY SUBPROGRAM DECLARATION IS PRECEDED BY A
--- "WITH" CLAUSE FOR A GENERIC LIBRARY PROCEDURE M, THEN IN THE
--- BODY OF THE SUBPROGRAM, "STANDARD.M" IS A LEGAL NAME
--- FOR THE GENERIC PROCEDURE.
-
--- HISTORY:
--- DHH 03/14/88 CREATED ORIGINAL TEST.
-
--- BEGIN BUILDING LIBRARY PROCEDURES
-
-GENERIC
- TYPE ITEM IS (<>);
-PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM);
-
-PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM) IS
- T : ITEM;
-BEGIN
- T := X;
- X := Y;
- Y := T;
-END C86004A_SWAP;
-
-WITH C86004A_SWAP; WITH REPORT; USE REPORT;
-PROCEDURE C86004A1 IS
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
- A : INT := IDENT_INT(10);
- B : INT := IDENT_INT(0);
- PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT);
-BEGIN
- SWITCH(A,B);
-
- IF A /= IDENT_INT(0) THEN
- FAILED("STANDARD.GENERIC PROCEDURE - 1");
- END IF;
-
- IF B /= IDENT_INT(10) THEN
- FAILED("STANDARD.GENERIC PROCEDURE - 2");
- END IF;
-END C86004A1;
-
-WITH C86004A_SWAP; WITH REPORT; USE REPORT;
-PROCEDURE C86004A2;
-
-PROCEDURE C86004A2 IS
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
- A : INT := IDENT_INT(10);
- B : INT := IDENT_INT(0);
-BEGIN
- DECLARE
- PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT);
- BEGIN
- SWITCH(A,B);
- END;
- IF A /= IDENT_INT(0) THEN
- FAILED("STANDARD.GENERIC PROCEDURE - B-0");
- END IF;
- IF B /= IDENT_INT(10) THEN
- FAILED("STANDARD.GENERIC PROCEDURE - B-10");
- END IF;
-END C86004A2;
-
-WITH C86004A1; WITH C86004A2;
-WITH REPORT; USE REPORT;
-PROCEDURE C86004A IS
-BEGIN
- TEST("C86004A", "CHECK THAT IF A LIBRARY SUBPROGRAM DECLARATION " &
- "IS PRECEDED BY A ""WITH"" CLAUSE FOR A GENERIC " &
- "LIBRARY PROCEDURE M, THEN IN THE BODY OF THE " &
- "SUBPROGRAM, ""STANDARD.M"" IS A " &
- "LEGAL NAME FOR THE GENERIC PROCEDURE");
- C86004A1;
- C86004A2;
-
- RESULT;
-END C86004A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada
deleted file mode 100644
index 5b9d7c5..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada
+++ /dev/null
@@ -1,44 +0,0 @@
--- C86004B0.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:
--- INDEPENDENT FUNCTION AND SUBPROGRAM SPECIFICATION FOR C86004B
--- TEST.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-FUNCTION C86004B0(X : INTEGER) RETURN INTEGER IS
-BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0;
- END IF;
-END C86004B0;
-
-WITH C86004B0;
-WITH REPORT; USE REPORT; -- SPEC
-PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4));
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada
deleted file mode 100644
index 09ae4fa..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- C86004B1.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:
--- LIBRARY SUBPROGRAM BODY FOR C86004B TEST.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4)) IS
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
- A : INT := STANDARD.C86004B0(10);
- B : INT := STANDARD.C86004B0(INTGR);
-
-BEGIN
- TEST("C86004B", "CHECK THAT IF THE SPECIFICATION OF A LIBRARY " &
- "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A LIBRARY " &
- "SUBPROGRAM M, THEN IN THE FORMAL PART AND IN " &
- "THE BODY (IN ANOTHER FILE), ""STANDARD.M"" IS " &
- "A LEGAL NAME FOR THE SUBPROGRAM M");
-
- IF B /= STANDARD.C86004B0(0) THEN
- FAILED("STANDARD.SUBPROGRAM - B");
- END IF;
-
- IF A /= STANDARD.C86004B0(10) THEN
- FAILED("STANDARD.SUBPROGRAM - A");
- END IF;
-
- RESULT;
-END C86004B1;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada b/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada
deleted file mode 100644
index cb9cd23..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada
+++ /dev/null
@@ -1,46 +0,0 @@
--- C86004B2M.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 THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A
--- "WITH" CLAUSE FOR A LIBRARY SUBPROGRAM M, THEN IN THE FORMAL PART
--- AND IN THE BODY (IN ANOTHER FILE), "STANDARD.M" IS A LEGAL NAME
--- FOR THE SUBPROGRAM M.
-
--- SEPARATE FILES ARE:
--- C86004B0 A LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM
--- SPECIFICATION.
--- C86004B1 A LIBRARY SUBPROGRAM BODY FOR THE C86004B0
--- SPECIFICATION.
--- C86004B2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004B1.
-
--- HISTORY:
--- DHH 08/15/88 CREATED ORIGINAL TEST.
-
-WITH C86004B1;
-WITH REPORT; USE REPORT;
-PROCEDURE C86004B2M IS
-BEGIN
- C86004B1(IDENT_INT(0));
-END C86004B2M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada
deleted file mode 100644
index f3a1b3e..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C86004C0.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:
--- INDEPENDENT GENERIC FUNCTION AND SUBPROGRAM FOR C86004C TEST.
-
--- HISTORY:
--- DHH 09/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-GENERIC
-FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER;
-
-FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER IS
-BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- ELSE
- RETURN 0;
- END IF;
-END C86004C0_GEN;
-
-WITH C86004C0_GEN;
-PRAGMA ELABORATE(C86004C0_GEN);
-FUNCTION C86004C0 IS NEW C86004C0_GEN;
-
-WITH C86004C0;
-WITH REPORT; USE REPORT;
-PROCEDURE C86004C01(INTGR : INTEGER := STANDARD.C86004C0(4)) IS
-
- SUBTYPE INT IS INTEGER RANGE 0 .. 10;
- A : INT := STANDARD.C86004C0(10);
- B : INT := STANDARD.C86004C0(INTGR);
-
- PROCEDURE C86004C1 IS SEPARATE;
-
-BEGIN
- C86004C1;
-END;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada
deleted file mode 100644
index b896a8e..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- C86004C1.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:
--- SUBUNIT FOR THE C86004C01 PARENT.
-
--- HISTORY:
--- DHH 09/14/88 CREATED ORIGINAL TEST.
-
-SEPARATE (C86004C01)
-PROCEDURE C86004C1 IS
-BEGIN
- TEST("C86004C", "CHECK THAT IF THE SPECIFICATION OF A " &
- "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A GENERIC " &
- "SUBPROGRAM INSTANTIANTION M, THEN IN THE " &
- "FORMAL PART AND IN THE BODY (A SUBUNIT IN " &
- "ANOTHER FILE), ""STANDARD.M"" IS " &
- "A LEGAL NAME FOR THE SUBPROGRAM M");
-
- IF B /= STANDARD.C86004C0(0) THEN
- FAILED("STANDARD.SUBPROGRAM - B");
- END IF;
-
- IF A /= STANDARD.C86004C0(10) THEN
- FAILED("STANDARD.SUBPROGRAM - A");
- END IF;
-
- RESULT;
-END C86004C1;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada b/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada
deleted file mode 100644
index ffe1e05..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada
+++ /dev/null
@@ -1,45 +0,0 @@
--- C86004C2M.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 THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A
--- "WITH" CLAUSE FOR A GENERIC SUBPROGRAM INSTANTIATION M, THEN IN
--- THE FORMAL PART AND IN THE BODY (A SUBUNIT IN ANOTHER FILE),
--- "STANDARD.M" IS A LEGAL NAME FOR THE SUBPROGRAM M.
-
--- SEPARATE FILES ARE:
--- C86004C0 A GENERIC LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM
--- DECLARING A SEPARATE SUBUNIT.
--- C86004C1 A SUBUNIT FOR THE C86004C0 PARENT.
--- C86004C2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004C0.
-
--- HISTORY:
--- DHH 09/14/88 CREATED ORIGINAL TEST.
-
-WITH C86004C01;
-WITH REPORT; USE REPORT;
-PROCEDURE C86004C2M IS
-BEGIN
- C86004C01(IDENT_INT(0));
-END C86004C2M;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86006i.ada b/gcc/testsuite/ada/acats/tests/c8/c86006i.ada
deleted file mode 100644
index 38778f9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86006i.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- C86006I.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 IDENTIFIERS "BOOLEAN, TRUE, AND FALSE" AND THE
--- IDENTIFIERS "INTEGER, NATURAL, AND POSITIVE" ARE DECLARED IN
--- THE PACKAGE "STANDARD", ALONG WITH THE OPERATORS OF THE TYPE
--- BOOLEAN AND THE TYPE INTEGER.
-
--- HISTORY:
--- DTN 04/15/92 CONSOLIDATION OF C86006A AND C86006B.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C86006I IS
-
- ABOOL, BBOOL : STANDARD.BOOLEAN := STANDARD.FALSE;
- CBOOL : STANDARD.BOOLEAN := STANDARD.TRUE;
- INT1 : STANDARD.INTEGER := -2;
- NAT1 : STANDARD.NATURAL := 0;
- POS1, POS2 : STANDARD.POSITIVE := 2;
-
-BEGIN
-
- TEST("C86006I", "CHECK THAT THE IDENTIFIERS ""BOOLEAN, TRUE, AND " &
- "FALSE"" AND THE IDENTIFIERS ""INTEGER, NATURAL, " &
- "AND POSITIVE"" ARE DECLARED IN THE PACKAGE " &
- """STANDARD"", ALONG WITH THE OPERATORS OF THE " &
- "TYPE BOOLEAN AND THE TYPE INTEGER");
-
- -- STANDARD.">" OPERATOR.
-
- IF STANDARD.">"(ABOOL,BBOOL) THEN
- FAILED("STANDARD.> FAILED FOR BOOLEAN TYPE");
- END IF;
-
- IF STANDARD.">"(INT1,NAT1) THEN
- FAILED("STANDARD.> FAILED FOR INTEGER-NATURAL TYPE");
- END IF;
-
- -- STANDARD."/=" OPERATOR.
-
- IF STANDARD."/="(ABOOL,BBOOL) THEN
- FAILED("STANDARD./= FAILED FOR BOOLEAN TYPE");
- END IF;
-
- IF STANDARD."/="(POS1,POS2) THEN
- FAILED("STANDARD./= FAILED FOR INTEGER-POSITIVE TYPE");
- END IF;
-
- -- STANDARD."AND" OPERATOR.
-
- IF STANDARD."AND"(CBOOL,ABOOL) THEN
- FAILED("STANDARD.AND FAILED");
- END IF;
-
- -- STANDARD."-" BINARY OPERATOR.
-
- IF STANDARD."-"(INT1,POS1) /= IDENT_INT(-4) THEN
- FAILED("STANDARD.- FAILED");
- END IF;
-
- -- STANDARD."-" UNARY OPERATOR.
-
- IF STANDARD."-"(INT1) /= IDENT_INT(2) THEN
- FAILED("STANDARD.UNARY - FAILED");
- END IF;
-
- -- STANDARD."REM" OPERATOR.
-
- IF STANDARD."REM"(IDENT_INT(14),IDENT_INT(5)) /= IDENT_INT(4) THEN
- FAILED("STANDARD.REM (++=+) FAILED");
- END IF;
-
- -- STANDARD."MOD" OPERATOR.
-
- IF STANDARD."MOD"(IDENT_INT(14),IDENT_INT(-5)) /= IDENT_INT(-1) THEN
- FAILED("STANDARD.MOD (+-=-) FAILED");
- END IF;
-
- RESULT;
-
-END C86006I;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c86007a.ada b/gcc/testsuite/ada/acats/tests/c8/c86007a.ada
deleted file mode 100644
index ba41e176..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c86007a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C86007A.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 EXPANDED NAME FOR AN ENTITY DECLARED IN THE VISIBLE
--- PART OF A LIBRARY PACKAGE CAN START WITH THE NAME "STANDARD".
-
--- HISTORY:
--- DHH 03/15/88 CREATED ORIGINAL TEST.
--- RJW 10/26/89 ADDED "PRAGMA ELABORATE (REPORT);"
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE C86007A_PACK IS
- SUBTYPE ITEM IS INTEGER RANGE 0 .. 10;
- Y : STANDARD.C86007A_PACK.ITEM := IDENT_INT(5);
- TYPE ACC IS ACCESS STANDARD.C86007A_PACK.ITEM;
- PROCEDURE SWAP(X,Y: IN OUT ITEM);
- PROCEDURE PROC;
-END C86007A_PACK;
-
-PACKAGE BODY C86007A_PACK IS
- PROCEDURE SWAP(X,Y: IN OUT STANDARD.C86007A_PACK.ITEM) IS
- T : STANDARD.C86007A_PACK.ITEM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END SWAP;
-
- PROCEDURE PROC IS
- X : STANDARD.C86007A_PACK.ITEM := IDENT_INT(10);
- W : STANDARD.C86007A_PACK.ACC;
- BEGIN
-
- W := NEW STANDARD.C86007A_PACK.ITEM;
- W.ALL := X;
- STANDARD.C86007A_PACK.SWAP(X, STANDARD.C86007A_PACK.Y);
- IF STANDARD.C86007A_PACK.Y /= IDENT_INT(10) THEN
- FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-10");
- END IF;
- IF X /= IDENT_INT(5) THEN
- FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-5");
- END IF;
- END PROC;
-END C86007A_PACK;
-
-WITH C86007A_PACK; WITH REPORT; USE REPORT;
-PROCEDURE C86007A IS
-BEGIN
- TEST("C86007A", "CHECK THAT AN EXPANDED NAME FOR AN ENTITY " &
- "DECLARED IN THE VISIBLE PART OF A LIBRARY " &
- "PACKAGE CAN START WITH THE NAME ""STANDARD""");
-
- STANDARD.C86007A_PACK.PROC;
-
- RESULT;
-END C86007A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada b/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada
deleted file mode 100644
index 8efbbde..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- C87A05A.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 FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE
--- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION.
---
--- PART 1 : CORRECT RESOLUTION IS INDEXED COMPONENT EXPRESSION
-
--- TRH 13 JULY 82
--- DSJ 09 JUNE 83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87A05A IS
-
- OK : BOOLEAN := TRUE;
- TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN;
-
- PROCEDURE P (ARG : BOOLEAN) IS -- THIS IS CORRECT P
- BEGIN
- OK := ARG;
- END P;
-
- PROCEDURE P (ARG : CHARACTER) IS
- BEGIN
- OK := FALSE;
- END P;
-
- FUNCTION Y RETURN VECTOR IS -- THIS IS CORRECT Y
- BEGIN
- RETURN (VECTOR'RANGE => TRUE);
- END Y;
-
- FUNCTION Y (ARG : INTEGER) RETURN FLOAT IS
- BEGIN
- OK := FALSE;
- RETURN 0.0;
- END Y;
-
- FUNCTION Y (ARG : CHARACTER) RETURN CHARACTER IS
- BEGIN
- OK := FALSE;
- RETURN 'A';
- END Y;
-
- FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS
- BEGIN
- OK := FALSE;
- RETURN 0.0;
- END Y;
-
- FUNCTION Y RETURN BOOLEAN IS
- BEGIN
- OK := FALSE;
- RETURN FALSE;
- END Y;
-
- FUNCTION Y (ARG : CHARACTER := 'A') RETURN BOOLEAN IS
- BEGIN
- OK := FALSE;
- RETURN FALSE;
- END Y;
-
- FUNCTION Z RETURN INTEGER IS -- THIS IS CORRECT Z
- BEGIN
- RETURN 3;
- END Z;
-
- FUNCTION Z RETURN FLOAT IS
- BEGIN
- OK := FALSE;
- RETURN 3.0;
- END Z;
-
-BEGIN
- TEST ("C87A05A","OVERLOADING RESOLUTION FOR DISTINGUISHING " &
- "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE INDEXED " &
- "COMPONENTS ARE CORRECT");
-
- P (Y (Z) );
-
- IF NOT OK THEN
- FAILED ("RESOLUTION INCORRECT");
- END IF;
-
- RESULT;
-END C87A05A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada b/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada
deleted file mode 100644
index 7d99c95..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- C87A05B.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 FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE
--- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION.
---
--- PART 2 : CORRECT RESOLUTION IS FUNCTION CALL
-
--- TRH 15 JULY 82
--- DSJ 09 JUNE 83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87A05B IS
-
- OK : BOOLEAN := TRUE;
- TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN;
-
- PROCEDURE P (ARG : CHARACTER := 'A') IS
- BEGIN
- OK := FALSE;
- END P;
-
- PROCEDURE P IS
- BEGIN
- OK := FALSE;
- END P;
-
- PROCEDURE P (ARG : INTEGER) IS -- THIS IS CORRECT P
- BEGIN
- OK := (ARG = 1);
- END P;
-
- FUNCTION Y RETURN VECTOR IS
- BEGIN
- OK := FALSE;
- RETURN (VECTOR'RANGE => TRUE);
- END Y;
-
- FUNCTION Y RETURN CHARACTER IS
- BEGIN
- OK := FALSE;
- RETURN 'A';
- END Y;
-
- FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS
- BEGIN
- OK := FALSE;
- RETURN 0.0;
- END Y;
-
- FUNCTION Y (ARG : CHARACTER) RETURN INTEGER IS
- BEGIN
- OK := FALSE;
- RETURN 0;
- END Y;
-
- FUNCTION Y (ARG : FLOAT) RETURN INTEGER IS -- THIS IS CORRECT Y
- BEGIN
- RETURN 1;
- END Y;
-
- FUNCTION Z RETURN INTEGER IS
- BEGIN
- OK := FALSE;
- RETURN 3;
- END Z;
-
- FUNCTION Z RETURN FLOAT IS -- THIS IS CORRECT Z
- BEGIN
- RETURN 3.0;
- END Z;
-
-BEGIN
- TEST ("C87A05B","OVERLOADING RESOLUTION FOR DISTINGUISHING " &
- "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE CORRECT " &
- "RESOLUTION IS FUNCTION CALL");
-
- P (Y (Z) );
-
- IF NOT OK THEN
- FAILED ("RESOLUTION INCORRECT");
- END IF;
-
- RESULT;
-END C87A05B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada
deleted file mode 100644
index 9f789c9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C87B02A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A CONSTANT DECLARATION, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE CONSTANT'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 17 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B02A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B02A","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN CONSTANT DECLARATIONS");
- DECLARE
-
- FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- I1 : CONSTANT INTEGER := F1 (0, 0);
- W1 : CONSTANT WHOLE := F1 (0, 0);
- C1 : CONSTANT CITRUS := F1 (0, 0);
- H1 : CONSTANT HUE := F1 (0, 0);
-
- I2 : CONSTANT INTEGER := "*" (0, 0);
- W2 : CONSTANT WHOLE := "*" (0, 0);
- C2 : CONSTANT CITRUS := "*" (0, 0);
- H2 : CONSTANT HUE := "*" (0, 0);
-
- I3 : CONSTANT INTEGER := (0 * 0);
- W3 : CONSTANT WHOLE := (0 * 0);
- C3 : CONSTANT CITRUS := (0 * 0);
- H3 : CONSTANT HUE := (0 * 0);
-
- C4 : CONSTANT CITRUS := ORANGE;
- H4 : CONSTANT HUE := ORANGE;
-
- BEGIN
- IF I1 /= -1 OR W1 /= 0 OR
- CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF I2 /= -1 OR W2 /= 0 OR
- CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL");
- END IF;
-
- IF I3 /= -1 OR W3 /= 0 OR
- CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL");
- END IF;
- END;
-
- RESULT;
-END C87B02A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada
deleted file mode 100644
index 5f2db7c..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- C87B02B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A VARIABLE DECLARATION, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE VARIABLE'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 17 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B02B IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B02B","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN VARIABLE DECLARATIONS");
- DECLARE
-
- FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "REM" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "REM" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "REM" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
-
- I2 : INTEGER := "REM" (0, 0);
- W2 : WHOLE := "REM" (0, 0);
- C2 : CITRUS := "REM" (0, 0);
- H2 : HUE := "REM" (0, 0);
-
- I3 : INTEGER := (0 REM 0);
- W3 : WHOLE := (0 REM 0);
- C3 : CITRUS := (0 REM 0);
- H3 : HUE := (0 REM 0);
-
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE;
-
- BEGIN
- IF I1 /= -1 OR W1 /= 0 OR
- CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF I2 /= -1 OR W2 /= 0 OR
- CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL");
- END IF;
-
- IF I3 /= -1 OR W3 /= 0 OR
- CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL");
- END IF;
- END;
-
- RESULT;
-END C87B02B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada
deleted file mode 100644
index d0b3722..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- C87B03A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE EXPRESSION IN A NUMBER DECLARATION MUST BE EITHER OF THE TYPE
--- UNIVERSAL_INTEGER OR UNIVERSAL_REAL.
-
--- TRH 16 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B03A IS
-
-BEGIN
- TEST ("C87B03A","OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS");
-
- DECLARE
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER
- RENAMES STANDARD."-";
-
- FUNCTION "+" (X, Y : FLOAT) RETURN FLOAT
- RENAMES STANDARD."-";
-
- I1 : CONSTANT := 1 + 1;
- I2 : CONSTANT INTEGER := 1 + 1;
-
- R1 : CONSTANT := 1.0 + 1.0;
- R2 : CONSTANT FLOAT := 1.0 + 1.0;
-
- BEGIN
- IF I1 /= 2 OR I2 /= 0 OR
- R1 /= 2.0 OR R2 /= 0.0 THEN
- FAILED ("OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS" &
- " RESOLVED INCORRECTLY");
- END IF;
- END;
-
- RESULT;
-END C87B03A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada
deleted file mode 100644
index ea2e65c..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C87B04A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS
--- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S
--- EXPLICIT TYPEMARK.
-
--- TRH 28 JUNE 82
--- JBG 3/8/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C87B04A IS
-
- TYPE AGE IS NEW INTEGER RANGE 1 .. 120;
- TYPE BASE10 IS NEW INTEGER RANGE 0 .. 9;
-
- FUNCTION F1 RETURN AGE IS
- BEGIN
- RETURN 18;
- END F1;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " &
- "SUBTYPE INDICATION");
- RETURN 0;
- END F1;
-
- FUNCTION "+" (X : INTEGER) RETURN BASE10 IS
- BEGIN
- RETURN 1;
- END "+";
-
- FUNCTION "+" (X : INTEGER) RETURN INTEGER IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " &
- "SUBTYPE INDICATION");
- RETURN -X;
- END "+";
-
-BEGIN
- TEST ("C87B04A","OVERLOADED EXPRESSIONS IN RANGE CONTRAINTS" &
- " OF SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE MINOR IS AGE RANGE 1 .. F1;
-
- BEGIN
- FOR I IN BASE10 RANGE +(INTEGER'(0)) .. 0 LOOP
- FAILED ("RESOLUTION INCORRECT - SUBTYPE INDICATION " &
- " IN LOOP CONSTRUCT");
- END LOOP;
- END;
-
- RESULT;
-END C87B04A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada
deleted file mode 100644
index 681011b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C87B04B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- IN AN ACCURACY CONSTRAINT OF A SUBTYPE INDICATION, THE
--- EXPRESSIONS FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE
--- WITH THE SUBTYPE'S EXPLICIT TYPEMARK.
-
--- HISTORY:
--- TRH 06/29/82 CREATED ORIGINAL TEST.
--- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. CORRECTED
--- CONSTRAINT ERRORS.
--- KAS 11/24/95 DELETED SUBTYPE DIGITS CONSTRAINT
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B04B IS
-
- TYPE EXACT IS DIGITS 5 RANGE -1.0 .. 1.0;
- TYPE HEX IS DELTA 2.0 ** (-4) RANGE -1.0 .. 1.0;
-
- FUNCTION F1 RETURN EXACT IS
- BEGIN
- RETURN 0.0;
- END F1;
-
- FUNCTION F1 RETURN FLOAT IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " &
- "SUBTYPE INDICATION - F1");
- RETURN 0.0;
- END F1;
-
- FUNCTION "+" (X : INTEGER) RETURN HEX IS
- BEGIN
- RETURN 0.0;
- END "+";
-
- FUNCTION "+" (X : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " &
- "SUBTYPE INDICATION - +");
- RETURN 0.0;
- END "+";
-
-BEGIN
- TEST ("C87B04B","OVERLOADED EXPRESSIONS IN ACCURACY CONTRAINTS" &
- " OF FLOATING/FIXED POINT SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE CLOSE IS EXACT RANGE -1.0 .. F1;
- SUBTYPE BIN IS HEX DELTA 2.0 ** (-1) RANGE "+" (0) .. 0.5;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B04B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada
deleted file mode 100644
index df67059..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C87B04C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS
--- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S
--- EXPLICIT TYPEMARK.
-
--- TRH 29 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B04C IS
-
- TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN);
- TYPE ORB IS (SUN, MOON, MARS, EARTH);
-
- TYPE GRADE IS ('A', 'B', 'C', 'D', 'F');
- TYPE VOWEL IS ('C', 'E', 'A', 'O', 'I', 'U', 'Y');
-
-BEGIN
- TEST ("C87B04C","OVERLOADED EXPRESSIONS IN RANGE CONSTRAINTS" &
- " OF ENUMERATION SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE PASSING IS GRADE RANGE 'A' .. 'C';
- SUBTYPE DISTANT IS ORB RANGE SUN .. MARS;
-
- BEGIN
- IF DISTANT'POS (DISTANT'FIRST) /= 0 OR
- PASSING'POS (PASSING'FIRST) /= 0 THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " &
- " ENUMERATION LITERALS");
- END IF;
- END;
-
- RESULT;
-END C87B04C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada
deleted file mode 100644
index f50ce37..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- C87B05A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN AN INTEGER TYPE DEFINITION WITH A RANGE CONSTRAINT, THE BOUNDS
--- OF THE RANGE MUST BE OF SOME INTEGER TYPE.
-
--- TRH 1 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B05A IS
-
- ERR : BOOLEAN := FALSE;
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE AGE IS NEW INTEGER RANGE 0 .. 120;
-
- FUNCTION "+" (X : WHOLE) RETURN FLOAT IS
- BEGIN
- ERR := TRUE;
- RETURN 2.0;
- END "+";
-
- FUNCTION "-" (X : AGE) RETURN BOOLEAN IS
- BEGIN
- ERR := TRUE;
- RETURN FALSE;
- END "-";
-
-BEGIN
- TEST ("C87B05A","OVERLOADED EXPRESSIONS IN RANGE BOUNDS " &
- " OF INTEGER TYPE DEFINITIONS");
-
- DECLARE
- TYPE ADULT IS RANGE 18 .. "+" (WHOLE'(120));
- TYPE MINOR IS RANGE "-" (AGE'(0)) .. "+" (WHOLE'(17));
- TYPE NEG10 IS RANGE "-" (AGE'(10)) .. "-" (AGE'(1));
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT - INTEGER TYPE " &
- "DEFINITIONS MUST HAVE INTEGER TYPE " &
- "RANGE BOUNDS");
- END IF;
- END;
-
- RESULT;
-END C87B05A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada
deleted file mode 100644
index a5c64b4..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C87B06A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR EACH INTEGER TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT
--- CONVERTS A UNIVERSAL INTEGER VALUE INTO THE CORRESPONDING VALUE
--- OF THE INTEGER TYPE. THIS TEST USES LITERALS AS UNIVERSAL INTEGER
--- VALUES.
-
--- HISTORY:
--- TRH 08/11/82 CREATED ORIGINAL TEST.
--- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B06A IS
-
- TYPE MINOR IS NEW INTEGER RANGE 0 .. 17;
- TYPE FIXED IS NEW DURATION;
- TYPE REAL IS NEW FLOAT;
-
- ERR : BOOLEAN := FALSE;
-
- PROCEDURE P (X : BOOLEAN) IS
- BEGIN
- ERR := TRUE;
- END P;
- PROCEDURE P (X : FIXED) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : REAL) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : FLOAT) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : STRING) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : MINOR) IS
- BEGIN
- NULL;
- END P;
-
-BEGIN
- TEST("C87B06A","OVERLOADING RESOLUTION WITH IMPLICIT CONVERSION " &
- "OF UNIVERSAL INTEGER VALUES TO INTEGER VALUES. " &
- "CONVERSIONS TO INTEGER VALUES EXISTS FOR ANY INTEGER TYPE");
-
- P (2);
- P (2 * 2 + 2);
-
- IF ERR THEN
- FAILED("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL " &
- " INTEGER VALUES TO INTEGER TYPE VALUES");
- END IF;
-
- RESULT;
-END C87B06A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada
deleted file mode 100644
index 635a8fc..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C87B07A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR THE ATTRIBUTE OF THE FORM T'POS (X), THE OPERAND X MUST
--- BE A VALUE OF TYPE T. THE RESULT IS OF TYPE UNIVERSAL_INTEGER.
-
--- TRH 13 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B07A IS
-
- TYPE NATURAL IS NEW INTEGER RANGE 1 .. INTEGER'LAST;
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE COLOR IS (BROWN, RED, WHITE);
- TYPE SCHOOL IS (HARVARD, BROWN, YALE);
- TYPE SUGAR IS (DEXTROSE, CANE, BROWN);
-
- FUNCTION "+" (X, Y : NATURAL) RETURN NATURAL
- RENAMES "*";
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES "-";
-
-BEGIN
- TEST ("C87B07A","OVERLOADED OPERANDS TO THE 'POS' ATTRIBUTE");
-
- IF NATURAL'POS (1 + 1) /= 1 OR COLOR'POS (BROWN) /= 0 OR
- WHOLE'POS (1 + 1) /= 0 OR SCHOOL'POS (BROWN) /= 1 OR
- INTEGER'POS (1 + 1) /= 2 OR SUGAR'POS (BROWN) /= 2 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERAND TO 'POS' ATTRIBUTE");
- END IF;
-
- IF NATURAL'POS (3 + 3) + 1 /= 10 OR -- SECOND "+" IS UNIVERSAL.
- WHOLE'POS (3 + 3) + 1 /= 1 OR -- SECOND "+" IS UNIVERSAL.
- INTEGER'POS (3 + 3) + 1 /= 7 THEN -- SECOND "+" IS UNIVERSAL.
- FAILED ("RESOLUTION INCORRECT - 'POS' ATTRIBUTE RETURNS " &
- "A UNIVERSAL_INTEGER VALUE");
- END IF;
-
- RESULT;
-END C87B07A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada
deleted file mode 100644
index ec2c0a1..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- C87B07B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MAY
--- BE OF ANY INTEGER TYPE. THE RESULT IS OF TYPE T.
-
--- TRH 15 SEPT 82
--- DSJ 06 JUNE 83
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B07B IS
-
- TYPE NEW_INT IS NEW INTEGER;
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE FLAG IS (PASS, FAIL);
-
- FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT
- RENAMES "-";
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES "*";
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("THE 'VAL' ATTRIBUTE TAKES AN OPERAND " &
- "OF AN INTEGER TYPE");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (CHARACTER, '1', FAIL);
- FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL);
- FUNCTION F IS NEW F1 (FLOAT, 1.0, FAIL);
- FUNCTION F IS NEW F1 (NEW_INT, 1, PASS);
-
-BEGIN
- TEST ("C87B07B","OVERLOADED OPERANDS TO THE 'VAL' ATTRIBUTE");
-
- IF (INTEGER'VAL (F) /= 1) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 1");
- END IF;
-
- IF (INTEGER'VAL (3 + 3) + 1 /= 7) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 2");
- END IF;
-
- IF (NEW_INT'VAL (F) /= 1) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 3");
- END IF;
-
- IF (NEW_INT'VAL (3 + 3) + 1 /= 5) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 4");
- END IF;
-
- IF (WHOLE'VAL (F) /= 1) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 5");
- END IF;
-
- IF (WHOLE'VAL (3 + 3) + 1 /= 6) THEN
- FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " &
- "MUST RETURN A VALUE OF TYPE T - 6");
- END IF;
-
- RESULT;
-END C87B07B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada
deleted file mode 100644
index 851143a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- C87B07C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST
--- BE OF THE PREDEFINED TYPE STRING. THE RESULT IS OF TYPE T.
-
--- TRH 13 SEPT 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B07C IS
-
- TYPE CHAR IS NEW CHARACTER;
- TYPE LITS IS (' ', '+', '1');
- TYPE WORD IS ARRAY (POSITIVE RANGE 1..4) OF CHARACTER;
- TYPE LINE IS ARRAY (POSITIVE RANGE 1..4) OF CHAR;
- TYPE LIST IS ARRAY (POSITIVE RANGE 1..4) OF LITS;
- TYPE STR IS ARRAY (POSITIVE RANGE 1..4) OF STRING (1 .. 1);
- TYPE STR2 IS NEW STRING (1..4);
- TYPE FLAG IS (PASS, FAIL);
- SUBTYPE MY_STRING IS STRING (1..4);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("THE 'VALUE' ATTRIBUTE TAKES AN OPERAND" &
- " OF THE TYPE PREDEFINED STRING");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (STR2, " +1 ", FAIL);
- FUNCTION F IS NEW F1 (LIST, " +1 ", FAIL);
- FUNCTION F IS NEW F1 (WORD, (' ', '+', '1', ' '), FAIL);
- FUNCTION F IS NEW F1 (STR, (" ", "+", "1", " "), FAIL);
- FUNCTION F IS NEW F1 (LINE, (' ', '+', '1', ' '), FAIL);
- FUNCTION F IS NEW F1 (MY_STRING, " +1 ", PASS);
-
-BEGIN
- TEST ("C87B07C","OVERLOADED OPERANDS TO THE 'VALUE' ATTRIBUTE");
-
- DECLARE
- TYPE INT IS NEW INTEGER;
- FUNCTION "-" (X : INT) RETURN INT
- RENAMES "+";
-
- BEGIN
- IF INT'VALUE (F) /= -1 THEN
- FAILED ("THE ATTRIBUTE T'VALUE MUST RETURN A VALUE" &
- " OF TYPE T");
- END IF;
- END;
-
- RESULT;
-END C87B07C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada
deleted file mode 100644
index 0e93649..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- C87B07D.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE ATTRIBUTES OF THE FORM T'SUCC (X) AND T'PRED (X) TAKE AN
--- OPERAND X OF TYPE T AND RETURN A VALUE OF TYPE T.
-
--- TRH 15 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B07D IS
-
- TYPE NEW_INT IS NEW INTEGER;
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
-
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES "*";
- FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT
- RENAMES "-";
-
-BEGIN
- TEST ("C87B07D","OVERLOADED OPERANDS TO THE ATTRIBUTES " &
- "'PRED' AND 'SUCC'");
-
- IF INTEGER'SUCC (1 + 1) /= 3 OR INTEGER'SUCC (3 + 3) + 1 /= 8 OR
- NEW_INT'SUCC (1 + 1) /= 1 OR NEW_INT'SUCC (3 + 3) + 1 /= 0 OR
- WHOLE'SUCC (1 + 1) /= 2 OR WHOLE'SUCC (3 + 3) + 1 /= 10 OR
- INTEGER'PRED (1 + 1) /= 1 OR INTEGER'PRED (3 + 3) + 1 /= 6 OR
- NEW_INT'PRED (1 + 1) /= -1 OR NEW_INT'PRED (3 + 3) + 1 /= -2 OR
- WHOLE'PRED (1 + 1) /= 0 OR WHOLE'PRED (3 + 3) + 1 /= 8
- THEN FAILED ("RESOLUTION INCORRECT FOR OPERAND OR RESULT OF" &
- " THE 'PRED' OR 'SUCC' ATTRIBUTE");
- END IF;
-
- RESULT;
-END C87B07D;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada b/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada
deleted file mode 100644
index 83e5c90..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- C87B07E.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR THE ATTRIBUTE OF THE FORM T'IMAGE (X), THE OPERAND X MUST
--- BE OF TYPE T. THE RESULT IS OF THE PREDEFINED TYPE STRING.
-
--- TRH 15 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B07E IS
-
- TYPE NEW_INT IS NEW INTEGER;
- TYPE NUMBER IS NEW INTEGER;
- TYPE NEW_STR IS NEW STRING;
-
- FUNCTION "+" (X : NEW_INT) RETURN NEW_INT
- RENAMES "-";
- FUNCTION "-" (X : NUMBER) RETURN NUMBER
- RENAMES "+";
-
- PROCEDURE P (X : NEW_STR) IS
- BEGIN
- FAILED ("THE IMAGE ATTRIBUTE MUST RETURN A VALUE OF THE" &
- " PREDEFINED TYPE STRING");
- END P;
-
- PROCEDURE P (X : STRING) IS
- BEGIN
- NULL;
- END P;
-
-BEGIN
- TEST ("C87B07E","OVERLOADED OPERANDS TO THE IMAGE ATTRIBUTE");
-
- IF INTEGER'IMAGE (+12) & INTEGER'IMAGE (-12) &
- NEW_INT'IMAGE (+12) & NEW_INT'IMAGE (-12) &
- NUMBER'IMAGE (+12) & NUMBER'IMAGE (-12) /=
- " 12-12-12-12 12 12" THEN
- FAILED ("RESOLUTION INCORRECT FOR THE 'IMAGE' ATTRIBUTE");
- END IF;
-
- P (INTEGER'IMAGE (+1) & NEW_INT'IMAGE (+1) & NUMBER'IMAGE (-1));
-
- RESULT;
-END C87B07E;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada
deleted file mode 100644
index b999845..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- C87B08A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR EACH REAL TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT
--- CONVERTS A UNIVERSAL REAL VALUE INTO THE CORRESPONDING VALUE
--- OF THE REAL TYPE. THIS TEST USES LITERALS AS UNIVERSAL REAL
--- VALUES.
-
--- TRH 16 AUG 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B08A IS
-
- TYPE FIXED IS DELTA 0.1 RANGE -2.0 .. 2.0;
- TYPE FLT IS DIGITS 2 RANGE -2.0 .. 2.0;
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- STAT : IN FLAG;
- PROCEDURE P1 (X : T);
-
- PROCEDURE P1 (X : T) IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL" &
- " REAL VALUES TO REAL TYPE VALUES");
- END IF;
- END P1;
-
- PROCEDURE P IS NEW P1 (INTEGER, FAIL);
- PROCEDURE P IS NEW P1 (FLT, PASS);
- PROCEDURE Q IS NEW P1 (FIXED, PASS);
- PROCEDURE Q IS NEW P1 (BOOLEAN, FAIL);
- PROCEDURE Q IS NEW P1 (CHARACTER, FAIL);
-
-BEGIN
- TEST ("C87B08A","IMPLICIT CONVERSION OF UNIVERSAL REAL " &
- "VALUES TO REAL VALUES EXISTS FOR ANY REAL TYPE");
-
- P (0.0);
- P (1.0 + 1.0);
- Q (1.0);
- Q (1.0 - 1.0);
-
- RESULT;
-END C87B08A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada
deleted file mode 100644
index bcdcad6..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- C87B09A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST
--- BE OF SOME INTEGER TYPE.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B09A IS
-
- FUNCTION "+" (X : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGER TYPE");
- RETURN 2.0;
- END "+";
-
-BEGIN
- TEST ("C87B09A","OVERLOADED DIGITS EXPRESSIONS IN " &
- "FLOATING POINT TYPE DEFINITIONS");
-
- DECLARE
- TYPE EXACT IS DIGITS "+" (3);
- TYPE CLOSE IS DIGITS "+" (1) RANGE -1.0 .. 1.0;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B09A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada
deleted file mode 100644
index 4a7ce12..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C87B09C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST
--- BE OF SOME INTEGRAL TYPE. SIMILARLY, THE DELTA EXPRESSION IN A
--- FIXED POINT TYPE DEFINITION MUST BE OF SOME REAL TYPE.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B09C IS
-
- FUNCTION "+" (X : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGRAL TYPE");
- RETURN 2.0;
- END "+";
-
- FUNCTION "+" (X : FLOAT) RETURN INTEGER IS
- BEGIN
- FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE");
- RETURN 2;
- END "+";
-
-BEGIN
- TEST ("C87B09C","OVERLOADED DIGITS/DELTA EXPRESSIONS IN " &
- "REAL TYPE DEFINITIONS");
-
- DECLARE
- TYPE EXACT IS DIGITS "+" (4);
- TYPE CENTI IS DELTA "+" (0.01) RANGE -2.0 .. 2.0;
- TYPE CLOSE IS DIGITS "+" (2) RANGE -1.0 .. 1.0;
- TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B09C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada
deleted file mode 100644
index a09db60..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C87B10A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A RANGE CONSTRAINT OF A FIXED POINT OR FLOATING POINT TYPE
--- DEFINITION, BOTH BOUNDS MUST BE OF SOME REAL TYPE, ALTHOUGH
--- THE TWO BOUNDS DO NOT HAVE TO BE OF THE SAME TYPE.
-
--- TRH 7/28/82
--- DSJ 6/10/83
--- JBG 9/19/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B10A IS
-
- SUBTYPE DUR IS DURATION;
-
- FUNCTION "+" (X : FLOAT) RETURN INTEGER IS
- BEGIN
- FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " &
- "MUST HAVE REAL BOUNDS");
- RETURN -10;
- END "+";
-
- FUNCTION "+" (X, Y : FLOAT) RETURN INTEGER IS
- BEGIN
- FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " &
- "MUST HAVE REAL BOUNDS");
- RETURN -10;
- END "+";
-
-BEGIN
- TEST ("C87B10A","RANGE BOUNDS IN REAL TYPE DEFINITIONS MUST BE" &
- " OF SOME (NOT NECESSARILY THE SAME) REAL TYPE");
-
- DECLARE
- TYPE R1 IS DIGITS 2 RANGE 0.0 .. 1.0 + FLOAT'(1.0);
- TYPE R2 IS DELTA 0.1 RANGE FLOAT'(1.0) + 1.0 .. DUR'(2.0);
- TYPE R3 IS DIGITS 2 RANGE +1.0 .. "+" (FLOAT'(2.0), 2.0);
- TYPE R4 IS DELTA 0.1 RANGE 0.0 + FLOAT'(0.0) .. +1.0;
-
-
- BEGIN
- IF 2.0 NOT IN R1 OR -1.0 IN R2 OR
- -1.0 IN R3 OR -0.9 IN R4 THEN
- FAILED ("RANGE BOUNDS IN REAL TYPE DEFINITIONS DO NOT "
- & "HAVE TO BE OF THE SAME REAL TYPE");
- END IF;
- END;
-
- RESULT;
-END C87B10A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada
deleted file mode 100644
index 07a3737..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- C87B11A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A FIXED POINT TYPE DEFINITION, THE DELTA EXPRESSION MUST
--- BE OF SOME REAL TYPE.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B11A IS
-
- FUNCTION "+" (X : FLOAT) RETURN INTEGER IS
- BEGIN
- FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE");
- RETURN 2;
- END "+";
-
-BEGIN
- TEST ("C87B11A","OVERLOADED DELTA EXPRESSIONS IN " &
- "FIXED POINT TYPE DEFINITIONS");
-
- DECLARE
- TYPE SEMI IS DELTA "+" (0.5) RANGE -2.0 .. 2.0;
- TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B11A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada
deleted file mode 100644
index 654603a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada
+++ /dev/null
@@ -1,57 +0,0 @@
--- C87B11B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A SUBTYPE INDICATION, THE DELTA EXPRESSION FOR A FIXED POINT
--- NUMBER MUST BE OF SOME REAL TYPE.
-
--- TRH 29 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B11B IS
-
- TYPE DELT3 IS DELTA 3.0 RANGE -30.0 .. 30.0;
-
- FUNCTION "+" (X : FLOAT) RETURN INTEGER IS
- BEGIN
- FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE");
- RETURN 2;
- END "+";
-
-BEGIN
- TEST ("C87B11B","OVERLOADED DELTA EXPRESSIONS IN " &
- "FIXED POINT SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE DELT2 IS DELT3 DELTA "+"(6.0);
- SUBTYPE DELT1 IS DELT3 DELTA "+"(10.0) RANGE -10.0 .. 10.0;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B11B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada
deleted file mode 100644
index c46b6f0..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C87B13A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE LOWER AND UPPER BOUNDS OF AN INDEX CONSTRAINT IN A CONSTRAINED
--- ARRAY TYPE DEFINITION MUST BE DISCRETE AND OF THE SAME TYPE.
-
--- TRH 1 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B13A IS
-
- TYPE CENTI IS DELTA 0.01 RANGE -1.0 .. 1.0;
-
- FUNCTION F1 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F1;
-
- FUNCTION F1 (X : INTEGER) RETURN CENTI IS
- BEGIN
- FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " &
- " OF THE SAME TYPE");
- RETURN 0.0;
- END F1;
-
- FUNCTION F1 (X : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " &
- " OF THE SAME TYPE");
- RETURN 1.0;
- END F1;
-
-BEGIN
- TEST ("C87B13A","OVERLOADED INDEX CONSTRAINTS IN " &
- "CONSTRAINED ARRAY TYPE DEFINITIONS");
-
- DECLARE
- TYPE A1 IS ARRAY (F1 (1) .. F1 (1)) OF BOOLEAN;
- TYPE A2 IS ARRAY (1 .. F1 (2)) OF BOOLEAN;
- TYPE A3 IS ARRAY (F1 (1) .. 2) OF BOOLEAN;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B13A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada
deleted file mode 100644
index 1ef0516..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C87B14A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER
--- BOUNDS MUST BE OF THE INDEX BASE TYPE.
---
--- TEST (A): INDEX CONSTRAINTS WITH OVERLOADED FUNCTIONS.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B14A IS
-
- SUBTYPE WHOLE IS INTEGER RANGE 0 .. INTEGER'LAST;
- SUBTYPE BASE10 IS INTEGER RANGE 0 .. 9;
- TYPE LIST IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
- TYPE GRID IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF BOOLEAN;
-
- FUNCTION F1 RETURN WHOLE IS
- BEGIN
- RETURN 1;
- END F1;
-
- FUNCTION F1 RETURN BOOLEAN IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN TRUE;
- END F1;
-
- FUNCTION F2 RETURN BASE10 IS
- BEGIN
- RETURN 2;
- END F2;
-
- FUNCTION F2 RETURN FLOAT IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN 2.0;
- END F2;
-
-BEGIN
- TEST ("C87B14A","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " &
- "OF SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE LIST1 IS LIST (1 .. F1);
- SUBTYPE LIST2 IS LIST (F1 .. 1);
- SUBTYPE LIST3 IS LIST (F2 .. F2);
- SUBTYPE LIST4 IS LIST (F1 .. F2);
-
- SUBTYPE GRID1 IS GRID (1 .. F1, F1 .. 1);
- SUBTYPE GRID2 IS GRID (F1 .. 2, 2 .. F2);
- SUBTYPE GRID3 IS GRID (F1 .. F1, F2 .. F2);
- SUBTYPE GRID4 IS GRID (F1 .. F2, 1 .. 2);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B14A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada
deleted file mode 100644
index 2d6a512..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- C87B14B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER
--- BOUNDS MUST BE OF THE INDEX BASE TYPE.
---
--- TEST (B): INDEX CONSTRAINTS WITH OVERLOADED OPERATOR SYMBOLS.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B14B IS
-
- SUBTYPE CHAR IS CHARACTER;
- SUBTYPE VAR IS CHAR RANGE 'X' .. 'Z';
- SUBTYPE NOTE IS CHAR RANGE 'A' .. 'G';
- TYPE LIST IS ARRAY (CHAR RANGE <>) OF CHAR;
- TYPE GRID IS ARRAY (CHAR RANGE <>, CHAR RANGE <>) OF CHAR;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN VAR IS
- BEGIN
- RETURN 'X';
- END "*";
-
- FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN TRUE;
- END "*";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN NOTE IS
- BEGIN
- RETURN 'A';
- END "+";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN 2.0;
- END "+";
-
-BEGIN
- TEST ("C87B14B","OVERLOADED OPERATOR SYMBOLS IN INDEX " &
- "CONSTRAINTS OF SUBTYPE INDICATIONS");
-
- DECLARE
-
- SUBTYPE LIST1 IS LIST ('W' .. "*" (0, 0));
- SUBTYPE LIST2 IS LIST ("+" (0, 0) .. 'C');
- SUBTYPE LIST3 IS LIST ("+" (0, 0) .. "*" (0, 0));
- SUBTYPE LIST4 IS LIST ("*" (0, 0) .. "*" (0, 0));
-
- SUBTYPE GRID1 IS GRID ('V' .. "*" (0, 0), "*" (0, 0) .. 'Y');
- SUBTYPE GRID2 IS GRID ("*" (0, 0) .. 'W', 'H' .. "+" (0, 0));
- SUBTYPE GRID3 IS GRID
- ("*" (0, 0) .. "*" (0, 0), "+" (0, 0) .. "+" (0, 0));
- SUBTYPE GRID4 IS GRID ("+" (0, 0) .. "*" (0, 0),'L' .. 'N');
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B14B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada
deleted file mode 100644
index 9bdb041..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- C87B14C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER
--- BOUNDS MUST BE OF THE INDEX BASE TYPE.
---
--- TEST (C): INDEX CONSTRAINTS WITH OVERLOADED INFIX OPERATORS.
-
--- TRH 30 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B14C IS
-
- TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN);
- TYPE LIST IS ARRAY (DAY RANGE <>) OF BOOLEAN;
- TYPE GRID IS ARRAY (DAY RANGE <>, DAY RANGE <>) OF BOOLEAN;
- SUBTYPE WEEKEND IS DAY RANGE SAT .. SUN;
- SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN WEEKDAY IS
- BEGIN
- RETURN MON;
- END "*";
-
- FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN TRUE;
- END "*";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN WEEKEND IS
- BEGIN
- RETURN SAT;
- END "+";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " &
- " IN SUBTYPE INDICATIONS");
- RETURN 2.0;
- END "+";
-
-BEGIN
- TEST ("C87B14C","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " &
- "OF SUBTYPE INDICATIONS");
-
- DECLARE
- SUBTYPE LIST1 IS LIST (WED .. (0 + 0));
- SUBTYPE LIST2 IS LIST ( 0 * 0 .. TUE);
- SUBTYPE LIST3 IS LIST ((0 + 0) .. (0 + 0));
- SUBTYPE LIST4 IS LIST ((0 * 0) .. (0 + 0));
-
- SUBTYPE GRID1 IS GRID (MON .. (0 * 0), (0 * 0) .. TUE);
- SUBTYPE GRID2 IS GRID ((0 * 0) .. WED, FRI .. (0 + 0));
- SUBTYPE GRID3 IS GRID
- ((0 * 0) .. (0 * 0), (0 + 0) .. (0 + 0));
- SUBTYPE GRID4 IS GRID ((0 * 0) .. (0 + 0), TUE .. THU);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B14C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada b/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada
deleted file mode 100644
index cf1c4d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- C87B14D.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, IF A BOUND IS OF
--- TYPE UNIVERSAL_INTEGER, IT IS IMPLICITLY CONVERTED TO THE
--- INDEX BASE TYPE.
-
--- TRH 7 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B14D IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE LIST IS ARRAY (WHOLE RANGE <>) OF BOOLEAN;
-
-BEGIN
- TEST ("C87B14D","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " &
- "OF SUBTYPE INDICATIONS WITH UNIVERSAL_INTEGER BOUNDS");
-
- DECLARE
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES "*";
-
- SUBTYPE LIST1 IS LIST (1 + 1 .. 1 + 1);
- SUBTYPE LIST2 IS LIST (1 .. 3 + 3);
- SUBTYPE LIST3 IS LIST (1 + 1 .. 2);
-
- BEGIN
- IF LIST1'FIRST /= 1 OR LIST1'LAST /= 1 OR
- LIST2'FIRST /= 1 OR LIST2'LAST /= 9 OR
- LIST3'FIRST /= 1 OR LIST3'LAST /= 2 THEN
- FAILED ("RESOLUTION INCORRECT - IMPLICIT CONVERSION " &
- "OF UNIVERSAL_INTEGER TYPE TO INDEX CONSTRAINT " &
- "BASE TYPE");
- END IF;
- END;
-
- RESULT;
-END C87B14D;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada
deleted file mode 100644
index 92a14de..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- C87B15A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE ARRAY ATTRIBUTES OF THE FORM: A'FIRST (N), A'LAST (N),
--- A'RANGE (N) AND A'LENGTH (N) MUST HAVE A PARAMETER (N) WHICH IS OF
--- THE TYPE UNIVERSAL_INTEGER.
-
--- TRH 26 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B15A IS
-
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER
- RENAMES STANDARD."*";
-
- TYPE BOX IS ARRAY (0 .. 1, 3 .. 6, 5 .. 11) OF BOOLEAN;
- B1 : BOX;
-
-BEGIN
- TEST ("C87B15A","ARRAY ATTRIBUTES: FIRST (N), LAST (N), RANGE " &
- "(N) AND LENGTH (N) TAKE UNIVERSAL_INTEGER OPERANDS");
-
- IF BOX'FIRST (1 + 0) /= 0 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 1");
- END IF;
-
- IF B1'FIRST (1 + 1) /= 3 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 2");
- END IF;
-
- IF B1'FIRST (2 + 1) /= 5 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 3");
- END IF;
-
- IF BOX'LAST (0 + 1) /= 1 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 4");
- END IF;
-
- IF B1'LAST (1 + 1) /= 6 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 5");
- END IF;
-
- IF B1'LAST (1 + 2) /= 11 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 6");
- END IF;
-
- IF BOX'LENGTH (0 + 1) /= 2 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 7");
- END IF;
-
- IF B1'LENGTH (1 + 1) /= 4 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 8");
- END IF;
-
- IF B1'LENGTH (2 + 1) /= 7 THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 9");
- END IF;
-
- IF 1 NOT IN BOX'RANGE (0 + 1) THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 10");
- END IF;
-
- IF 4 NOT IN B1'RANGE (1 + 1) THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 11");
- END IF;
-
- IF 9 NOT IN B1'RANGE (2 + 1) THEN
- FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " &
- "UNIVERSAL_INTEGER - 12");
- END IF;
-
- RESULT;
-END C87B15A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada
deleted file mode 100644
index 307ca0e..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- C87B16A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR A DEFAULT RECORD COMPONENT, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE COMPONENTS'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 23 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B16A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B16A","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN DEFAULT RECORD COMPONENTS");
- DECLARE
-
- FUNCTION "-" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "-" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "-" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "-" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- TYPE REC IS
- RECORD
- I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
-
- I2 : INTEGER := "-" (0, 0);
- W2 : WHOLE := "-" (0, 0);
- C2 : CITRUS := "-" (0, 0);
- H2 : HUE := "-" (0, 0);
-
- I3 : INTEGER := (0 - 0);
- W3 : WHOLE := (0 - 0);
- C3 : CITRUS := (0 - 0);
- H3 : HUE := (0 - 0);
-
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE;
- END RECORD;
-
- R1 : REC;
-
- BEGIN
- IF R1.I1 /= -1 OR R1.W1 /= 0 OR
- CITRUS'POS (R1.C1) /= 2 OR HUE'POS (R1.H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF R1.I2 /= -1 OR R1.W2 /= 0 OR
- CITRUS'POS (R1.C2) /= 2 OR HUE'POS (R1.H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL");
- END IF;
-
- IF R1.I3 /= -1 OR R1.W3 /= 0 OR
- CITRUS'POS (R1.C3) /= 2 OR HUE'POS (R1.H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (R1.C4) /= 2 OR HUE'POS (R1.H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL");
- END IF;
- END;
-
- RESULT;
-END C87B16A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada
deleted file mode 100644
index 96405d6..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- C87B17A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- THE INITIALIZATION EXPRESSION FOR A DEFAULT DISCRIMINANT
--- IN A TYPE DECLARATION MUST MATCH THE DISCRIMINANT'S EXPLICIT
--- TYPEMARK.
---
--- THE THREE KINDS OF TYPE DECLARATIONS TESTED HERE ARE:
---
--- (A): RECORD TYPE.
--- (B): PRIVATE TYPE.
--- (C): INCOMPLETE RECORD TYPE.
-
--- TRH 18 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B17A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B17A","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN DEFAULT DISCRIMINANTS");
-
- DECLARE
-
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "+" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "+" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- TYPE REC1 (I1 : INTEGER := 0 + 0; H1 : HUE := F1 (0, 0) ) IS
- RECORD
- NULL;
- END RECORD;
-
- PACKAGE PVT IS
- TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 )
- IS PRIVATE;
- PRIVATE
- TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 ) IS
- RECORD
- NULL;
- END RECORD;
- END PVT;
- USE PVT;
-
- TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0));
-
- TYPE LINK IS ACCESS REC3;
-
- TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0)) IS
- RECORD
- NULL;
- END RECORD;
-
- R1 : REC1;
- R2 : REC2;
- R3 : REC3;
-
- BEGIN
- IF R1.I1 /= -1 OR HUE'POS (R1.H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT FOR RECORD TYPES");
- END IF;
-
- IF HUE'POS (R2.H2) /= 1 OR R2.W2 /= 0 THEN
- FAILED ("(B): RESOLUTION INCORRECT FOR PRIVATE TYPES");
- END IF;
-
- IF CITRUS'POS (R3.C1) /= 2 OR R3.W1 /= 0 THEN
- FAILED ("(C): RESOLUTION INCORRECT FOR INCOMPLETE" &
- " RECORD TYPES");
- END IF;
- END;
-
- RESULT;
-END C87B17A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada
deleted file mode 100644
index fdb2ad3..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C87B18A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE TYPES OF THE EXPRESSIONS IN A DISCRIMINANT CONSTRAINT IN
--- A SUBTYPE INDICATION MUST MATCH THE DISCRIMINANT'S EXPLICIT
--- TYPEMARK.
-
--- TRH 1 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B18A IS
-
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F1 RETURN INTEGER IS
- BEGIN
- RETURN 1;
- END F1;
-
- FUNCTION F1 RETURN FLOAT IS
- BEGIN
- ERR := TRUE;
- RETURN 0.0;
- END F1;
-
- FUNCTION F2 RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END F2;
-
- FUNCTION F2 RETURN STRING IS
- BEGIN
- ERR := TRUE;
- RETURN "STRING";
- END F2;
-
-BEGIN
- TEST ("C87B18A","OVERLOADED EXPRESSIONS IN DISCRIMINANT " &
- "CONSTRAINTS");
-
- DECLARE
- TYPE REC (X : INTEGER := 0; Y : BOOLEAN := TRUE) IS
- RECORD
- NULL;
- END RECORD;
-
- R1 : REC (F1, F2);
- R2 : REC (Y => F2, X => F1);
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT - DISCRIMINANT " &
- "CONSTRAINT MUST MATCH DISCRIMINANT TYPE");
- END IF;
- END;
-
- RESULT;
-END C87B18A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada
deleted file mode 100644
index f0824b9..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- C87B18B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE EXPRESSION IN A NAMED OR POSITIONAL DISCRIMINANT ASSOCIATION
--- MUST MATCH THE TYPE OF THE CORRESPONDING DISCRIMINANT.
-
--- TRH 9 AUG 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B18B IS
-
- TYPE REC (W, X : CHARACTER; Y, Z : BOOLEAN) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("DISCRIMINANT ASSOCIATION EXPRESSION MUST " &
- "MATCH THE TYPE OF THE CORRESPONDING " &
- "DISCRIMINANT");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (FLOAT, 2.0, FAIL);
- FUNCTION F IS NEW F1 (INTEGER, 5, FAIL);
- FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION F IS NEW F1 (CHARACTER, 'E', PASS);
-
- FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL);
- FUNCTION G IS NEW F1 (INTEGER, 5, FAIL);
- FUNCTION G IS NEW F1 (BOOLEAN, TRUE, PASS);
- FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL);
-
-BEGIN
- TEST ("C87B18B","OVERLOADED DISCRIMINANT ASSOCIATIONS");
-
- DECLARE
- SUBTYPE R1 IS REC (F, F, G, G);
- SUBTYPE R2 IS REC (X => F, Y => G, Z => G, W => F);
- SUBTYPE R3 IS REC (F, F, Z => G, Y => G);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B18B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada
deleted file mode 100644
index aa1960d..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- C87B19A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- SIMPLE EXPRESSIONS AND RANGE BOUNDS OF VARIANT CHOICES MUST MATCH
--- THE TYPE OF THE DISCRIMINANT'S EXPLICIT TYPEMARK.
-
---HISTORY:
--- DSJ 06/15/83 CREATED ORIGINAL TEST.
--- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B19A IS
-
- TYPE COLOR IS (YELLOW, RED, BLUE, GREEN, BROWN);
- TYPE SCHOOL IS (YALE, HARVARD, PRINCETON, BROWN, STANFORD);
- TYPE COOK IS (BROIL, BAKE, BROWN, TOAST, FRY);
- TYPE MIXED IS (GREEN, BROWN, YALE, BAKE, BLUE, FRY);
-
- RATING : INTEGER := 0;
-
- FUNCTION OK RETURN BOOLEAN IS
- BEGIN
- RATING := RATING + 1;
- RETURN FALSE;
- END OK;
-
- FUNCTION ERR RETURN BOOLEAN IS
- BEGIN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF DISCRIMINANT");
- RETURN FALSE;
- END ERR;
-
-BEGIN
- TEST ("C87B19A","OVERLOADED EXPRESSIONS AND RANGE BOUNDS" &
- " OF VARIANT CHOICES");
- DECLARE
-
- TYPE REC (X : MIXED := BROWN) IS
- RECORD
- CASE X IS
- WHEN GREEN .. BROWN => NULL;
- WHEN BLUE => NULL;
- WHEN FRY => NULL;
- WHEN YALE => NULL;
- WHEN OTHERS => NULL;
- END CASE;
- END RECORD;
-
- R1 : REC (X => FRY);
- R2 : REC (X => BLUE);
- R3 : REC (X => BAKE);
- R4 : REC (X => YALE);
- R5 : REC (X => BROWN);
- R6 : REC (X => GREEN);
-
- BEGIN
- IF MIXED'POS(R1.X) /= 5 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R1");
- END IF;
- IF MIXED'POS(R2.X) /= 4 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R2");
- END IF;
- IF MIXED'POS(R3.X) /= 3 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R3");
- END IF;
- IF MIXED'POS(R4.X) /= 2 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R4");
- END IF;
- IF MIXED'POS(R5.X) /= 1 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R5");
- END IF;
- IF MIXED'POS(R6.X) /= 0 THEN
- FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " &
- "DISCRIMINANT-R6");
- END IF;
-
- END;
-
- RESULT;
-END C87B19A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada
deleted file mode 100644
index 5cfa1d8..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- C87B23A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR AN INDEXED COMPONENT OF AN ARRAY, THE PREFIX MUST BE
--- APPROPRIATE FOR AN ARRAY TYPE. EACH EXPRESSION FOR THE INDEXED
--- COMPONENT MUST BE OF THE TYPE OF THE CORRESPONDING INDEX AND
--- THERE MUST BE ONE SUCH EXPRESSION FOR EACH INDEX POSITION OF THE
--- ARRAY TYPE.
-
--- TRH 15 SEPT 82
--- DSJ 07 JUNE 83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B23A IS
-
- SUBTYPE CHAR IS CHARACTER;
- TYPE GRADE IS (A, B, C, D, F);
- TYPE NOTE IS (A, B, C, D, E, F, G);
- TYPE INT IS NEW INTEGER;
- TYPE POS IS NEW INTEGER RANGE 1 .. INTEGER'LAST;
- TYPE NAT IS NEW POS;
- TYPE BOOL IS NEW BOOLEAN;
- TYPE BIT IS NEW BOOL;
- TYPE LIT IS (FALSE, TRUE);
- TYPE FLAG IS (PASS, FAIL);
-
- TYPE NUM2 IS DIGITS(2);
- TYPE NUM3 IS DIGITS(2);
- TYPE NUM4 IS DIGITS(2);
-
- TYPE A1 IS ARRAY (POS'(1)..5, NOTE'(A)..D, BOOL'(FALSE)..TRUE)
- OF FLOAT;
- TYPE A2 IS ARRAY (INT'(1)..5, NOTE'(A)..D, BIT'(FALSE)..TRUE)
- OF NUM2;
- TYPE A3 IS ARRAY (POS'(1)..5, GRADE'(A)..D, BOOL'(FALSE)..TRUE)
- OF NUM3;
- TYPE A4 IS ARRAY (NAT'(1)..5, NOTE'(A)..D, LIT'(FALSE)..TRUE)
- OF NUM4;
-
- OBJ1 : A1 := (OTHERS => (OTHERS => (OTHERS => 0.0)));
- OBJ2 : A2 := (OTHERS => (OTHERS => (OTHERS => 0.0)));
- OBJ3 : A3 := (OTHERS => (OTHERS => (OTHERS => 0.0)));
- OBJ4 : A4 := (OTHERS => (OTHERS => (OTHERS => 0.0)));
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("PREFIX OR INDEX IS NOT APPROPRIATE FOR" &
- " INDEXED COMPONENT");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION A IS NEW F1 (A1, OBJ1, PASS);
- FUNCTION A IS NEW F1 (A2, OBJ2, FAIL);
- FUNCTION A IS NEW F1 (A3, OBJ3, FAIL);
- FUNCTION A IS NEW F1 (A4, OBJ4, FAIL);
-
-BEGIN
- TEST ("C87B23A","OVERLOADED ARRAY INDEXES");
-
- DECLARE
- F1 : FLOAT := A (3, C, TRUE);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B23A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada
deleted file mode 100644
index abfaad6..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C87B24A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- THE PREFIX OF A SLICE MUST BE APPROPRIATE FOR A ONE DIMENSIONAL
--- ARRAY TYPE.
-
--- TRH 26 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B24A IS
-
- TYPE LIST IS ARRAY (1 .. 5) OF INTEGER;
- TYPE GRID IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER;
- TYPE CUBE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER;
- TYPE HYPE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER;
- TYPE FLAG IS (PASS, FAIL);
-
- L : LIST := (1 .. 5 => 0);
- G : GRID := (1 .. 5 => (1 .. 5 => 0));
- C : CUBE := (1 .. 5 => (1 .. 5 => (1 .. 5 => 0)));
- H : HYPE := (1 .. 5 => (1 .. 5 => (1 .. 5 => (1 .. 5 => 0))));
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("SLICE PREFIX MUST BE APPROPRIATE FOR ONE " &
- "DIMENSIONAL ARRAY");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F2 IS NEW F1 (LIST, L, PASS);
- FUNCTION F2 IS NEW F1 (GRID, G, FAIL);
- FUNCTION F2 IS NEW F1 (CUBE, C, FAIL);
- FUNCTION F2 IS NEW F1 (HYPE, H, FAIL);
-
-BEGIN
- TEST ("C87B24A","OVERLOADED PREFIX FOR SLICE RESOLVED TO " &
- "ONE DIMENSIONAL ARRAY TYPE");
-
- DECLARE
- S1 : INTEGER;
-
- BEGIN
- S1 := F2 (2 .. 3)(2);
- END;
-
- RESULT;
-END C87B24A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada
deleted file mode 100644
index 537cf9b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- C87B24B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- THE RANGE BOUNDS FOR A SLICE MUST BE DISCRETE AND OF THE SAME BASE
--- TYPE AS THE ARRAY INDEX.
-
--- TRH 15 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B24B IS
-
- TYPE PIECE IS ARRAY (INTEGER RANGE <>) OF INTEGER;
-
- PI : PIECE (1 .. 8) := (3, 1, 4, 1, 5, 9, 2, 6);
- S1 : PIECE (1 .. 3);
- S2 : PIECE (4 .. 8);
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F1 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F1;
-
- FUNCTION F1 (X : INTEGER) RETURN FLOAT IS
- BEGIN
- ERR := TRUE;
- RETURN 0.0;
- END F1;
-
- FUNCTION F2 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F2;
-
- FUNCTION F2 (X :INTEGER) RETURN CHARACTER IS
- BEGIN
- ERR := TRUE;
- RETURN 'A';
- END F2;
-
-BEGIN
- TEST ("C87B24B","OVERLOADING RESOLUTION OF RANGE " &
- "CONSTRAINTS FOR SLICES");
-
- DECLARE
- FUNCTION "+" (X : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "+" (X : INTEGER) RETURN FLOAT
- RENAMES F1;
-
- FUNCTION "-" (X : INTEGER) RETURN INTEGER
- RENAMES F2;
-
- FUNCTION "-" (X : INTEGER) RETURN CHARACTER
- RENAMES F2;
-
- BEGIN
- S1 := PI ("+" (3) .. "-" (5));
- S1 := PI (F2 (2) .. "+" (4));
- S1 := PI ("-" (6) .. F1 (8));
- S1 := PI (F2 (1) .. F2 (3));
- S2 := PI (F2 (4) .. F1 (8));
- S2 := PI (2 .. "+" (6));
- S2 := PI (F1 (1) .. 5);
- S2 := PI ("+" (3) .. "+" (7));
-
- IF ERR THEN
- FAILED (" OVERLOADING RESOLUTION INCORRECT FOR SLICES");
- END IF;
- END;
-
- RESULT;
-END C87B24B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada
deleted file mode 100644
index 41f6ca4..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- C87B26B.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 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE MAY BE
--- USED WITH THE DESIGNATED OBJECTS OF ACCESS VALUES RETURNED FROM
--- OVERLOADED FUNCTIONS, AND THAT EXPLICIT DEREFERENCING IS USED BY
--- OVERLOADING RESOLUTION TO RESOLVE THE PREFIXES OF THE ATTRIBUTES.
-
--- DSJ 22 JUN 83
--- JBG 11/22/83
--- JBG 4/23/84
--- JBG 5/25/85
-
-WITH REPORT; WITH SYSTEM;
-USE REPORT; USE SYSTEM;
-
-PROCEDURE C87B26B IS
-
- TYPE REC (D : INTEGER) IS
- RECORD
- C1, C2 : INTEGER;
- END RECORD;
- TYPE P_REC IS ACCESS REC;
-
- P_REC_OBJECT : P_REC := NEW REC'(1,1,1);
-
- TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT;
- TASK TYPE TASK_TYPE IS
- -- NOTHING AT ALL
- END TASK_TYPE;
-
- TYPE P_TASK IS ACCESS TASK_TYPE;
-
- P_TASK_OBJECT : P_TASK;
-
- TASK BODY TASK_TYPE IS
- BEGIN
- NULL;
- END TASK_TYPE;
-
- ------------------------------------------------------------
-
- FUNCTION F RETURN REC IS
- BEGIN
- RETURN (0,0,0);
- END F;
-
- FUNCTION F RETURN P_REC IS
- BEGIN
- RETURN P_REC_OBJECT;
- END F;
-
- ------------------------------------------------------------
-
- FUNCTION G RETURN TASK_TYPE IS
- NEW_TASK : TASK_TYPE;
- BEGIN
- RETURN NEW_TASK;
- END G;
-
- FUNCTION G RETURN P_TASK IS
- BEGIN
- RETURN P_TASK_OBJECT;
- END G;
-
- ------------------------------------------------------------
-
-BEGIN
-
- TEST("C87B26B","CHECK THAT EXPLICIT DEREFERENCING IN AN " &
- "ATTRIBUTE PREFIX IS USED IN OVERLOADING RESOLUTION " &
- "WITH 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE");
-
- DECLARE
-
- A : ADDRESS; -- FOR 'ADDRESS OF RECORD
- B : BOOLEAN; -- FOR 'CONSTRAINED OF RECORD
- C : INTEGER; -- FOR 'SIZE OF RECORD
- D : ADDRESS; -- FOR 'ADDRESS OF TASK
- E : BIG_INT; -- FOR 'STORAGE_SIZE OF TASK
-
- BEGIN
-
- P_TASK_OBJECT := NEW TASK_TYPE;
- A := F.ALL'ADDRESS;
- B := F.ALL'CONSTRAINED;
- C := F.ALL'SIZE;
- D := G.ALL'ADDRESS;
- E := G.ALL'STORAGE_SIZE;
-
- IF A /= P_REC_OBJECT.ALL'ADDRESS THEN
- FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - REC");
- END IF;
-
- IF B /= P_REC_OBJECT.ALL'CONSTRAINED THEN
- FAILED("INCORRECT RESOLUTION FOR 'CONSTRAINED");
- END IF;
-
- IF C /= P_REC_OBJECT.ALL'SIZE THEN
- FAILED("INCORRECT RESOLUTION FOR 'SIZE");
- END IF;
-
- IF D /= P_TASK_OBJECT.ALL'ADDRESS THEN
- FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - TASK");
- END IF;
-
- IF E /= P_TASK_OBJECT.ALL'STORAGE_SIZE THEN
- FAILED("INCORRECT RESOLUTION FOR 'STORAGE_SIZE");
- END IF;
-
- IF A = P_REC_OBJECT'ADDRESS THEN
- FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - REC");
- END IF;
-
- IF C = P_REC_OBJECT'SIZE AND C /= P_REC_OBJECT.ALL'SIZE THEN
- FAILED("INCORRECT DEREFERENCING FOR 'SIZE");
- END IF;
-
- IF D = P_TASK_OBJECT'ADDRESS THEN
- FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - TASK");
- END IF;
-
-
- END;
-
- RESULT;
-
-END C87B26B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada
deleted file mode 100644
index 4b99792..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C87B27A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE TYPE OF A STRING LITERAL MUST BE DETERMINED FROM THE FACT
--- THAT A STRING LITERAL IS A VALUE OF A ONE DIMENSIONAL ARRAY OF
--- CHARACTER COMPONENTS.
-
--- TRH 18 AUG 82
--- DSJ 07 JUN 83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B27A IS
-
- TYPE ENUMLIT IS (A, B, C, D, E, F);
- TYPE NEW_CHAR IS NEW CHARACTER RANGE 'G' .. 'Z';
- TYPE CHARS3 IS ('G','H','I','K','M','N','P','R','S','T');
- TYPE CHARS4 IS ('S','T','R','I','N','G','Z','A','P');
- TYPE NEW_STR IS ARRAY (A .. F) OF NEW_CHAR;
- TYPE STRING3 IS ARRAY (11..16) OF CHARS3;
- TYPE STRING4 IS ARRAY (21..26) OF CHARS4;
- TYPE ENUM_VEC IS ARRAY (1 .. 6) OF ENUMLIT;
- TYPE CHAR_GRID IS ARRAY (D .. F, 1 .. 3) OF NEW_CHAR;
- TYPE STR_LIST IS ARRAY (1 .. 6) OF STRING (1 .. 1);
- ERR : BOOLEAN := FALSE;
-
- PROCEDURE P (X : NEW_STR) IS
- BEGIN
- NULL;
- END P;
-
- PROCEDURE P (X : ENUM_VEC) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : CHAR_GRID) IS
- BEGIN
- ERR := TRUE;
- END P;
-
- PROCEDURE P (X : STR_LIST) IS
- BEGIN
- ERR := TRUE;
- END P;
-
-BEGIN
- TEST ("C87B27A","OVERLOADING RESOLUTION OF STRING LITERALS");
-
- P ("STRING");
-
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR STRING LITERALS");
- END IF;
-
- RESULT;
-END C87B27A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada
deleted file mode 100644
index dfde694..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C87B28A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE TYPE OF THE LITERAL "NULL" MUST BE DETERMINED FROM THE FACT
--- THAT "NULL" IS A VALUE OF AN ACCESS TYPE.
-
--- TRH 13 AUG 82
--- JRK 2/2/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B28A IS
-
- ERR : BOOLEAN := FALSE;
-
- TYPE A2 IS ACCESS BOOLEAN;
- TYPE A3 IS ACCESS INTEGER;
- TYPE A1 IS ACCESS A2;
-
- FUNCTION F RETURN A1 IS
- BEGIN
- RETURN NEW A2;
- END F;
-
- FUNCTION F RETURN A2 IS
- BEGIN
- ERR := TRUE;
- RETURN NEW BOOLEAN;
- END F;
-
- FUNCTION F RETURN A3 IS
- BEGIN
- ERR := TRUE;
- RETURN (NEW INTEGER);
- END F;
-
-BEGIN
- TEST ("C87B28A", "OVERLOADING OF THE ACCESS TYPE LITERAL 'NULL'");
-
- F.ALL := NULL;
-
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR THE ACCESS TYPE LITERAL " &
- "'NULL'");
- END IF;
-
- RESULT;
-END C87B28A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada
deleted file mode 100644
index 594f719..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- C87B29A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- AGGREGATES CONTAINING A SINGLE COMPONENT ASSOCIATION MUST
--- USE ONLY NAMED NOTATION.
-
--- TRH 4 AUG 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B29A IS
-
- TYPE VECTOR IS ARRAY (1 .. 1) OF INTEGER;
-
- TYPE REC IS
- RECORD
- X : INTEGER;
- END RECORD;
-
- ERR : BOOLEAN := FALSE;
-
- PROCEDURE P1 (X : INTEGER) IS
- BEGIN
- NULL;
- END P1;
-
- PROCEDURE P1 (X : VECTOR) IS
- BEGIN
- ERR := TRUE;
- END P1;
-
- PROCEDURE P1 (X : REC) IS
- BEGIN
- ERR := TRUE;
- END P1;
-
-BEGIN
- TEST ("C87B29A","AGGREGATES CONTAINING A SINGLE COMPONENT " &
- "ASSOCIATION MUST USE NAMED NOTATION");
-
- P1 ( (0) ); -- INTEGER PARAMETER, NOT AN AGGREGATE PARAMETER
-
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT - AGGREGATES WITH A SINGLE " &
- "COMPONENT ASSOCIATION MUST USE NAMED NOTATION");
- END IF;
-
- RESULT;
-END C87B29A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada
deleted file mode 100644
index da57451..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- C87B30A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE EXPRESSION OF A COMPONENT ASSOCIATION MUST MATCH THE TYPE OF THE
--- ASSOCIATED RECORD COMPONENT.
-
--- TRH 9 AUG 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B30A IS
-
- TYPE REC IS
- RECORD
- W, X : FLOAT;
- Y, Z : INTEGER;
- END RECORD;
-
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("COMPONENT ASSOCIATION EXPRESSION MUST MATCH " &
- "RECORD COMPONENT TYPE");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS);
- FUNCTION F IS NEW F1 (INTEGER, 5, FAIL);
- FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL);
-
- FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL);
- FUNCTION G IS NEW F1 (INTEGER, 5, PASS);
- FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL);
-
-BEGIN
- TEST ("C87B30A","OVERLOADED EXPRESSIONS IN RECORD AGGREGATE " &
- "COMPONENT ASSOCIATIONS");
-
- DECLARE
- R1 : REC := (F, F, G, G);
- R2 : REC := (X => F, Y => G, Z => G, W => F);
- R3 : REC := (F, F, Z => G, Y => G);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B30A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada
deleted file mode 100644
index 7aebd41..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- C87B31A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IF THE TYPE OF AN AGGREGATE IS A ONE-DIMENSIONAL ARRAY TYPE
--- THEN EACH CHOICE MUST SPECIFY VALUES OF THE INDEX TYPE, AND
--- THE EXPRESSION OF EACH COMPONENT ASSOCIATION MUST BE OF THE
--- COMPONENT TYPE.
-
--- TRH 8 AUG 82
--- DSJ 15 JUN 83
--- JRK 2 FEB 84
--- JBG 4/23/84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B31A IS
-
- TYPE LETTER IS NEW CHARACTER RANGE 'A' .. 'Z';
- TYPE NOTE IS (A, B, C, D, E, F, G, H);
- TYPE STR IS NEW STRING (1 .. 1);
- TYPE BIT IS NEW BOOLEAN;
- TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE;
- TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE;
- TYPE BOOLEAN IS (FALSE, TRUE);
- TYPE LIST IS ARRAY (CHARACTER RANGE <>) OF BIT;
- TYPE FLAG IS (PASS, FAIL);
-
- SUBTYPE LIST_A IS LIST('A'..'A');
- SUBTYPE LIST_E IS LIST('E'..'E');
- SUBTYPE LIST_AE IS LIST('A'..'E');
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("RESOLUTION INCORRECT FOR EXPRESSIONS " &
- "IN ARRAY AGGREGATES");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION F IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION F IS NEW F1 (NO, FALSE, FAIL);
- FUNCTION F IS NEW F1 (BIT, TRUE, PASS);
-
- FUNCTION G IS NEW F1 (CHARACTER, 'A', PASS);
- FUNCTION G IS NEW F1 (LETTER, 'A', FAIL);
- FUNCTION G IS NEW F1 (STR, "A", FAIL);
-
- FUNCTION H IS NEW F1 (CHARACTER, 'E', PASS);
- FUNCTION H IS NEW F1 (LETTER, 'E', FAIL);
- FUNCTION H IS NEW F1 (STR, "E", FAIL);
-
-BEGIN
- TEST ("C87B31A", "OVERLOADED EXPRESSIONS IN ARRAY AGGREGATES");
-
- DECLARE
- L1, L2 : LIST_A := (OTHERS => FALSE);
- L3, L4 : LIST_E := (OTHERS => FALSE);
- L5, L6 : LIST_AE := (OTHERS => FALSE);
- L7, L8 : LIST_AE := (OTHERS => FALSE);
-
- BEGIN
- L1 := ('A' => F);
- L2 := ( G => F);
- L3 := ('E' => F);
- L4 := ( H => F);
- L5 := ('A'..'E' => F);
- L6 := (F,F,F,F,F);
- L7 := (F,F,F, OTHERS => F);
- L8 := LIST_AE'('E' => F, 'B' => F, OTHERS => F);
-
- IF L1 /= LIST_A'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L1");
- END IF;
- IF L2 /= LIST_A'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L2");
- END IF;
- IF L3 /= LIST_E'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L3");
- END IF;
- IF L4 /= LIST_E'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L4");
- END IF;
- IF L5 /= LIST_AE'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L5");
- END IF;
- IF L6 /= LIST_AE'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L6");
- END IF;
- IF L7 /= LIST_AE'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L7");
- END IF;
- IF L8 /= LIST_AE'(OTHERS => TRUE) THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" &
- " EXPRESSIONS IN ARRAY AGGREGATES - L8");
- END IF;
- END;
-
- RESULT;
-END C87B31A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada
deleted file mode 100644
index 1a31f11..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada
+++ /dev/null
@@ -1,199 +0,0 @@
--- C87B32A.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 OVERLOADING RESOLUTION USES THE FOLLOWING RULES:
-
--- FOR ATTRIBUTES OF THE FORM: T'SUCC (X), T'PRED (X), T'POS (X),
--- AND T'IMAGE (X) , THE OPERAND X MUST BE OF TYPE T.
---
--- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MUST BE
--- OF AN INTEGER TYPE.
---
--- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST
--- BE OF THE PREDEFINED TYPE STRING.
-
--- TRH 13 SEPT 82
--- JRK 12 JAN 84
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B32A IS
-
- TYPE COLOR IS (BROWN, RED, WHITE);
- TYPE SCHOOL IS (HARVARD, BROWN, YALE);
- TYPE COOK IS (SIMMER, SAUTE, BROWN, BOIL);
- TYPE SUGAR IS (DEXTROSE, CANE, GLUCOSE, BROWN);
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE LIT_CHAR IS ('+', '-', '0', '1', '2', '3', '4', '5', '6', '7',
- '8', '9');
- TYPE LIT_STRING IS ARRAY (POSITIVE RANGE <>) OF LIT_CHAR;
-
- FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE
- RENAMES "*";
-
- FUNCTION F1 RETURN STRING IS
- BEGIN
- RETURN "+10";
- END F1;
-
- FUNCTION F1 RETURN LIT_STRING IS
- BEGIN
- FAILED ("THE VALUE ATTRIBUTE TAKES A PREDEFINED STRING " &
- "OPERAND");
- RETURN "+3";
- END F1;
-
- FUNCTION F1 RETURN CHARACTER IS
- BEGIN
- FAILED ("THE VALUE ATTRIBUTE TAKES A STRING OPERAND");
- RETURN '2';
- END F1;
-
- FUNCTION F2 (X : INTEGER) RETURN FLOAT IS
- BEGIN
- FAILED ("THE VAL ATTRIBUTE TAKES AN INTEGER TYPE OPERAND");
- RETURN 0.0;
- END F2;
-
- FUNCTION F2 (X : INTEGER := 1) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F2;
-
-BEGIN
- TEST ("C87B32A","OVERLOADED OPERANDS FOR THE ATTRIBUTES " &
- "T'PRED, T'SUCC, T'POS, T'VAL, T'IMAGE AND T'VALUE");
-
- IF COLOR'POS (BROWN) /= 0 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 1");
- END IF;
-
- IF SCHOOL'POS (BROWN) /= 1 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 2");
- END IF;
-
- IF COOK'POS (BROWN) /= 2 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 3");
- END IF;
-
- IF SUGAR'POS (BROWN) /= 3 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 4");
- END IF;
-
- IF SCHOOL'PRED (BROWN) /= HARVARD THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 5");
- END IF;
-
- IF COOK'PRED (BROWN) /= SAUTE THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 6");
- END IF;
-
- IF SUGAR'PRED (BROWN) /= GLUCOSE THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 7");
- END IF;
-
- IF COLOR'SUCC (BROWN) /= RED THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 8");
- END IF;
-
- IF SCHOOL'SUCC (BROWN) /= YALE THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 9");
- END IF;
-
- IF COOK'SUCC (BROWN) /= BOIL THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 10");
- END IF;
-
- IF COLOR'VAL (F2 (0)) /= BROWN THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 11");
- END IF;
-
- IF SCHOOL'VAL (F2) /= BROWN THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 12");
- END IF;
-
- IF COOK'VAL (F2 (2)) /= BROWN THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 13");
- END IF;
-
- IF SUGAR'VAL (F2) /= CANE THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 14");
- END IF;
-
- IF WHOLE'POS (1 + 1) /= 1 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 15");
- END IF;
-
- IF WHOLE'VAL (1 + 1) /= 2 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 16");
- END IF;
-
- IF WHOLE'SUCC (1 + 1) /= 2 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 17");
- END IF;
-
- IF WHOLE'PRED (1 + 1) /= 0 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 18");
- END IF;
-
- IF WHOLE'VALUE ("+1") + 1 /= 1 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 19");
- END IF;
-
- IF WHOLE'IMAGE (1 + 1) /= " 1" THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 20");
- END IF;
-
- IF WHOLE'VALUE (F1) + 1 /= 10 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 21");
- END IF;
-
- IF WHOLE'VAL (1) + 1 /= 1 THEN
- FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" &
- " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 22");
- END IF;
-
- RESULT;
-END C87B32A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada
deleted file mode 100644
index 5c398d4..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- C87B33A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE SHORT CIRCUIT CONTROL FORMS "AND THEN" AND "OR ELSE" ARE
--- DEFINED AS BINARY BOOLEAN OPERATORS WHICH RETURN A BOOLEAN VALUE
--- OF THE SAME TYPE AS THE OPERANDS.
-
--- TRH 13 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B33A IS
-
- TYPE ON IS NEW BOOLEAN RANGE TRUE .. TRUE;
- TYPE OFF IS NEW BOOLEAN RANGE FALSE .. FALSE;
- TYPE YES IS NEW ON;
- TYPE NO IS NEW OFF;
- TYPE BIT IS NEW BOOLEAN;
- TYPE FLAG IS (PASS, FAIL);
-
- TYPE BOOLEAN IS (FALSE, TRUE); -- STANDARD BOOLEAN HIDDEN.
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT " &
- "CONTROL FORMS 'AND THEN' AND 'OR ELSE' ");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION A IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION A IS NEW F1 (NO, FALSE, PASS);
- FUNCTION A IS NEW F1 (ON, TRUE, FAIL);
- FUNCTION A IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION B IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION B IS NEW F1 (NO, FALSE, FAIL);
- FUNCTION B IS NEW F1 (OFF, FALSE, FAIL);
- FUNCTION B IS NEW F1 (BIT, TRUE, FAIL);
- FUNCTION C IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION C IS NEW F1 (YES, TRUE, PASS);
- FUNCTION C IS NEW F1 (ON, TRUE, FAIL);
- FUNCTION C IS NEW F1 (NO, FALSE, FAIL);
- FUNCTION D IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION D IS NEW F1 (OFF, FALSE, FAIL);
- FUNCTION D IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION D IS NEW F1 (BIT, TRUE, FAIL);
- FUNCTION E IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION E IS NEW F1 (BIT, TRUE, PASS);
- FUNCTION E IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION E IS NEW F1 (NO, FALSE, FAIL);
- FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION F IS NEW F1 (BIT, TRUE, PASS);
- FUNCTION F IS NEW F1 (ON, TRUE, FAIL);
- FUNCTION F IS NEW F1 (OFF, FALSE, FAIL);
- FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION G IS NEW F1 (BIT, FALSE, PASS);
- FUNCTION G IS NEW F1 (NO, FALSE, FAIL);
- FUNCTION G IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION H IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION H IS NEW F1 (BIT, FALSE, PASS);
- FUNCTION H IS NEW F1 (OFF, FALSE, FAIL);
- FUNCTION H IS NEW F1 (ON, TRUE, FAIL);
-
-BEGIN
- TEST ("C87B33A","OVERLOADED OPERANDS FOR SHORT CIRCUIT CONTROL " &
- "FORMS 'AND THEN' AND 'OR ELSE' ");
-
- IF (A AND THEN B) THEN
- FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - A&B");
- END IF;
-
- IF NOT (C OR ELSE D) THEN
- FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - C&D");
- END IF;
-
- IF NOT (E AND THEN F AND THEN E
- AND THEN F AND THEN E AND THEN F) THEN
- FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - E&F");
- END IF;
-
- IF (G OR ELSE H OR ELSE G
- OR ELSE H OR ELSE G OR ELSE H) THEN
- FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - G&H");
- END IF;
-
- RESULT;
-END C87B33A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada
deleted file mode 100644
index 4291197..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada
+++ /dev/null
@@ -1,68 +0,0 @@
--- C87B34A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE MEMBERSHIP TESTS "IN" AND "NOT IN" RESULT IN THE PREDEFINED
--- TYPE BOOLEAN.
-
--- TRH 4 AUG 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B34A IS
-
- TYPE BIT IS NEW BOOLEAN;
- TYPE FLAG IS NEW BOOLEAN;
-
- ERR : BOOLEAN := FALSE;
-
- PROCEDURE P1 (X : BIT) IS
- BEGIN
- ERR := TRUE;
- END P1;
-
- PROCEDURE P1 (X : FLAG) IS
- BEGIN
- ERR := TRUE;
- END P1;
-
- PROCEDURE P1 (X : BOOLEAN) IS
- BEGIN
- NULL;
- END P1;
-
-BEGIN
- TEST ("C87B34A","MEMBERSHIP TESTS 'IN' AND 'NOT IN' RETURN " &
- "TYPE PREDEFINED BOOLEAN");
-
- P1 (3 IN 1 .. 5);
- P1 (3 NOT IN 1 .. 5);
-
- IF ERR THEN
- FAILED ("MEMBERSHIP TESTS MUST RETURN PREDEFINED BOOLEAN TYPE");
- END IF;
-
- RESULT;
-END C87B34A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada
deleted file mode 100644
index 17cdbce..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- C87B34B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- THE "IN" (OR MEMBERSHIP) OPERATOR OF THE FORM: X IN L .. R
--- REQUIRES THE OPERANDS X, L AND R TO BE OF THE SAME SCALAR TYPE.
-
--- TRH 19 JULY 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B34B IS
-
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("RESOLUTION INCORRECT FOR 'IN' MEMBERSHIP TEST");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION X IS NEW F1 (FLOAT, 2.0, PASS);
- FUNCTION L IS NEW F1 (FLOAT, -1.0, PASS);
- FUNCTION R IS NEW F1 (FLOAT, 1.0, PASS);
- FUNCTION X IS NEW F1 (INTEGER, 5, FAIL);
- FUNCTION L IS NEW F1 (INTEGER, 1, FAIL);
- FUNCTION L IS NEW F1 (CHARACTER, 'A', FAIL);
- FUNCTION R IS NEW F1 (CHARACTER, 'E', FAIL);
- FUNCTION X IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION R IS NEW F1 (BOOLEAN, TRUE, FAIL);
-
-BEGIN
- TEST ("C87B34B","OVERLOADED MEMBERSHIP OPERANDS");
-
- IF X IN L .. R THEN
- FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP OPERATOR");
- END IF;
-
- RESULT;
-END C87B34B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada
deleted file mode 100644
index 7b8dc59..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- C87B34C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- FOR A MEMBERSHIP RELATION WITH A TYPEMARK, THE TYPE OF THE
--- SIMPLE EXPRESSION MUST BE THE BASE TYPE OF THE TYPEMARK.
-
--- TRH 15 SEPT 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B34C IS
-
- TYPE VOWEL IS (A, E, I, O, U, VOCALIC_Y);
- TYPE ALPHA IS (A, 'A');
- TYPE GRADE IS (A, B, C, D, F);
- SUBTYPE BAD_GRADE IS GRADE RANGE D .. F;
- SUBTYPE PASSING IS GRADE RANGE A .. C;
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - EXPRESSION IN MEMBER" &
- "SHIP TEST WITH TYPEMARK MUST MATCH TYPEMARK");
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (CHARACTER, 'A');
- FUNCTION F IS NEW F1 (DURATION, 1.0);
- FUNCTION F IS NEW F1 (INTEGER, -10);
- FUNCTION F IS NEW F1 (BOOLEAN, TRUE);
- FUNCTION F IS NEW F1 (FLOAT, 1.0);
- FUNCTION F IS NEW F1 (VOWEL, A);
- FUNCTION F IS NEW F1 (ALPHA, A);
-
-BEGIN
- TEST ("C87B34C","OVERLOADED EXPRESSION IN MEMBERSHIP TEST " &
- "WITH A TYPEMARK");
-
- IF (F NOT IN GRADE) OR (F NOT IN BAD_GRADE)
- OR (F IN PASSING) THEN
- FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP TEST " &
- "WITH TYPEMARK");
- END IF;
-
- RESULT;
-
-END C87B34C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada
deleted file mode 100644
index 89a839f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- C87B35C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE EXPONENT OPERAND OF A FLOATING POINT EXPONENTIATION MUST BE
--- OF THE TYPE PREDEFINED INTEGER.
-
--- TRH 4 AUG 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B35C IS
-
- TYPE FIXED IS DELTA 0.01 RANGE 0.0 .. 4.0;
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F1 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F1;
-
- FUNCTION F1 (X : INTEGER) RETURN FLOAT IS
- BEGIN
- ERR := TRUE;
- RETURN 1.0;
- END F1;
-
- FUNCTION F1 (X : INTEGER) RETURN FIXED IS
- BEGIN
- ERR := TRUE;
- RETURN 1.0;
- END F1;
-
-BEGIN
- TEST ("C87B35C","EXPONENT OPERAND FOR FLOATING POINT " &
- "EXPONENTIATION MUST BE OF TYPE PREDEFINED INTEGER");
-
- DECLARE
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER
- RENAMES STANDARD."*";
-
- BEGIN
- IF ( FLOAT'(2.0) ** F1(3) /= 8.0 OR
- FLOAT'(2.0) ** (3 + 1) /= 8.0 ) THEN
- FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION "
- & "MUST BE PREDEFINED INTEGER (A)");
- END IF;
- IF ( 2.0 ** F1(3) /= FLOAT'(8.0) OR
- 2.0 ** (3 + 1) /= FLOAT'(8.0) ) THEN
- FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION"
- & "MUST BE PREDEFINED INTEGER (B)");
- END IF;
- IF ERR THEN
- FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION"
- & "MUST BE PREDEFINED INTEGER (C)");
- END IF;
- END;
-
- RESULT;
-END C87B35C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada
deleted file mode 100644
index 46ba651..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- C87B38A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
-
--- IN A QUALIFIED EXPRESSION, THE OPERAND MUST HAVE THE SAME TYPE
--- AS THE BASE TYPE OF THE TYPEMARK.
-
--- TRH 13 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B38A IS
-
- SUBTYPE BOOL IS BOOLEAN;
- TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE;
- TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE;
- TYPE BIT IS NEW BOOLEAN;
- TYPE LIT IS (FALSE, TRUE);
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " &
- " OPERANDS OF QUALIFIED EXPRESSIONS");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (LIT, FALSE, FAIL);
- FUNCTION F IS NEW F1 (BIT, TRUE, FAIL);
- FUNCTION F IS NEW F1 (BOOLEAN, TRUE, PASS);
- FUNCTION F IS NEW F1 (YES, TRUE, FAIL);
- FUNCTION F IS NEW F1 (NO, FALSE, FAIL);
-
-BEGIN
- TEST ("C87B38A","OVERLOADED OPERANDS IN QUALIFIED EXPRESSIONS ");
-
- DECLARE
- B : BOOL;
-
- BEGIN
- B := BOOL' (F);
- B := BOOL' ((NOT F) OR ELSE (F AND THEN F));
- END;
-
- RESULT;
-END C87B38A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada
deleted file mode 100644
index 75c8559..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- C87B39A.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) AN OVERLOADED CALL CAN BE RESOLVED BECAUSE AN ALLOCATOR RETURNS
--- AN ACCESS TYPE WHOSE DESIGNATED TYPE IS THE TYPE REFERRED TO IN
--- THE ALLOCATOR.
---
--- B) IF THE NAME OF THE DESIGNATED TYPE IN AN ALLOCATOR DOES NOT
--- UNIQUELY DETERMINE THE ACCESS TYPE OF AN ALLOCATOR, THE CONTEXT
--- MUST DETERMINE THE TYPE.
-
--- JBG 1/30/84
-
-WITH REPORT; USE REPORT;
-PROCEDURE C87B39A IS
-
- TYPE S IS (M, F);
- TYPE R (D : S) IS
- RECORD NULL; END RECORD;
- SUBTYPE M1 IS R(M);
- SUBTYPE M2 IS R(M);
-
- TYPE ACC_M1 IS ACCESS M1;
- TYPE ACC_M2 IS ACCESS M2;
- TYPE ACC_BOOL IS ACCESS BOOLEAN;
- TYPE ACC_ACC_M1 IS ACCESS ACC_M1;
-
- TYPE WHICH IS (IS_M1, IS_M2, IS_BOOL);
-
- PROCEDURE P (X : ACC_M1; RESOLUTION : WHICH) IS
- BEGIN
- IF RESOLUTION /= IS_M1 THEN
- FAILED ("INCORRECT RESOLUTION -- ACC_M1");
- END IF;
- END P; -- ACC_M1
-
- PROCEDURE P (X : ACC_M2; RESOLUTION : WHICH) IS
- BEGIN
- IF RESOLUTION /= IS_M2 THEN
- FAILED ("INCORRECT RESOLUTION -- ACC_M2");
- END IF;
- END P; -- ACC_M2
-
- PROCEDURE P (X : ACC_BOOL; RESOLUTION : WHICH) IS
- BEGIN
- IF RESOLUTION /= IS_BOOL THEN
- FAILED ("INCORRECT RESOLUTION -- ACC_BOOL");
- END IF;
- END P; -- ACC_BOOL
-
- PROCEDURE P (X : ACC_ACC_M1; RESOLUTION : WHICH) IS
- BEGIN
- FAILED ("INCORRECT RESOLUTION -- ACC_ACC_M1");
- END P; -- ACC_ACC_M1
-
- PROCEDURE Q (X : ACC_M1) IS
- BEGIN
- NULL;
- END Q; -- ACC_M1
-
- PROCEDURE Q (X : ACC_BOOL) IS
- BEGIN
- FAILED ("INCORRECT RESOLUTION -- ACC_BOOL: Q");
- END Q; -- ACC_BOOL
-
-BEGIN
-
- TEST ("C87B39A", "OVERLOADING RESOLUTION FOR ALLOCATORS");
-
- P (ACC_M1'(NEW R(M)), IS_M1); -- B
-
- P (ACC_M2'(NEW M1), IS_M2); -- B
-
- P (NEW BOOLEAN'(TRUE), IS_BOOL); -- A
-
- Q (NEW M2); -- A
- Q (NEW M1); -- A
- Q (NEW R(M)); -- A
- Q (NEW R'(D => M)); -- A
-
- RESULT;
-
-END C87B39A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada
deleted file mode 100644
index 5fd04a1..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- C87B40A.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 OVERLOADING RESOLUTION USES THE FOLLOWING RULES:
---
--- THE SAME OPERATIONS ARE PREDEFINED FOR THE TYPE UNIVERSAL_INTEGER
--- AS FOR ANY INTEGER TYPE. THE SAME OPERATIONS ARE PREDEFINED FOR THE
--- TYPE UNIVERSAL_REAL AS FOR ANY FLOATING POINT TYPE. IN ADDITION
--- THESE OPERATIONS INCLUDE THE FOLLOWING MULTIPLICATION AND DIVISION
--- OPERATORS:
---
--- "*" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL
--- "*" (UNIVERSAL_INTEGER, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL
--- "*" (UNIVERSAL_REAL, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL
--- "*" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER
--- "/" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL
--- "**" (UNIVERSAL_INTEGER, INTEGER) RETURN UNIVERSAL_INTEGER
--- "**" (UNIVERSAL_REAL, INTEGER) RETURN UNIVERSAL_REAL
--- "MOD" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER
--- "DIV" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER
--- "ABS" (UNIVERSAL_INTEGER) RETURN UNIVERSAL INTEGER
--- "ABS" (UNIVERSAL_REAL) RETURN UNIVERSAL_REAL
-
--- TRH 15 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B40A IS
-
- ERR : BOOLEAN := FALSE;
- B : ARRAY (1 .. 12) OF BOOLEAN := (1 .. 12 => TRUE);
-
- FUNCTION "-" (X : INTEGER) RETURN INTEGER
- RENAMES STANDARD."+";
-
- FUNCTION "+" (X : INTEGER) RETURN INTEGER IS
- BEGIN
- ERR := TRUE;
- RETURN X;
- END "+";
-
- FUNCTION "+" (X : FLOAT) RETURN FLOAT IS
- BEGIN
- ERR := TRUE;
- RETURN X;
- END "+";
-
-BEGIN
- TEST ("C87B40A","OVERLOADING RESOLUTION OF UNIVERSAL " &
- "EXPRESSIONS");
-
- B(1) := 1.0 * (+1) IN 0.0 .. 0.0; -- 1.0 * 1
- B(2) := (+1) * 1.0 IN 0.0 .. 0.0; -- 1 * 1.0
- B(3) := 1.0 / (+1) IN 0.0 .. 0.0; -- 1.0 / 1
- B(4) := (+1) + (+1) <= (+1) - (+1); -- 1+1< 1 - 1
- B(5) := (+1) * (+1) > (+1) / (+1); -- 1*1 > 1/1
- B(6) := (+1) MOD (+1) /= (+1) REM (+1); -- 1 MOD 1 /= 1 REM 1
-
- BEGIN
- B(7) := (+2) ** (-2) < "-" (-1); -- 2**2 < 1
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("INCORRECT RESOLUTION FOR INTEGER EXPONENT - 7");
- END;
-
- B(8) := (+1) REM (+1) > "ABS" (+1); -- 1 REM 1 > ABS 1
- B(9) := (+1.0) + (+1.0) <= (+1.0) - (+1.0); -- 2.0 <= 0.0
- B(10) := (+1.0) * (+1.0) > (+1.0) / (+1.0); -- 1.0 > 1.0
- B(11) := (+2.0) ** (-1) < "-" (-1.0); -- 2.0 < 1.0
- B(12) := (+2.0) ** (-1) <= "ABS" (+1.0); -- 2.0 <= 1.0
-
- FOR I IN B'RANGE
- LOOP
- IF B(I) /= FALSE THEN
- FAILED("RESOLUTION OR OPERATIONS INCORRECT FOR "
- & "UNIVERSAL EXPRESSIONS - " & INTEGER'IMAGE(I) );
- END IF;
- END LOOP;
-
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR UNIVERSAL EXPRESSIONS");
- END IF;
-
- RESULT;
-END C87B40A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada
deleted file mode 100644
index ae60c8d..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C87B41A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE NAMED VARIABLE AND THE RIGHT HAND SIDE EXPRESSION
--- IN AN ASSIGNMENT STATEMENT MUST BE OF THE SAME TYPE. THIS TYPE
--- MUST NOT BE A LIMITED TYPE.
-
--- TRH 15 SEPT 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B41A IS
-
- TYPE NOTE IS (A, B, C, D, E, F, G);
- TYPE POSITIVE IS NEW INTEGER RANGE 1 .. INTEGER'LAST;
- TYPE ACC_CHAR IS ACCESS CHARACTER;
- TYPE ACC_DUR IS ACCESS DURATION;
- TYPE ACC_POS IS ACCESS POSITIVE;
- TYPE ACC_INT IS ACCESS INTEGER;
- TYPE ACC_BOOL IS ACCESS BOOLEAN;
- TYPE ACC_STR IS ACCESS STRING;
- TYPE ACC_FLT IS ACCESS FLOAT;
- TYPE ACC_NOTE IS ACCESS NOTE;
-
- TYPE NEW_CHAR IS NEW CHARACTER;
- TYPE NEW_DUR IS NEW DURATION;
- TYPE NEW_POS IS NEW POSITIVE;
- TYPE NEW_INT IS NEW INTEGER;
- TYPE NEW_BOOL IS NEW BOOLEAN;
- TYPE NEW_FLT IS NEW FLOAT;
- TYPE NEW_NOTE IS NEW NOTE RANGE A .. F;
- TASK TYPE T;
-
- TASK BODY T IS
- BEGIN
- NULL;
- END T;
-
- FUNCTION G RETURN T IS
- T1 : T;
- BEGIN
- FAILED ("LIMITED TYPES MAY NOT OCCUR IN ASSIGNMENT " &
- "STATEMENTS");
- RETURN T1;
- END G;
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- FAILED ("RESOLUTION INCORRECT - RIGHT HAND SIDE OF " &
- "ASSIGNMENT STATEMENT MUST MATCH TYPE OF VARIABLE");
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (ACC_CHAR, NEW CHARACTER);
- FUNCTION F IS NEW F1 (ACC_DUR, NEW DURATION);
- FUNCTION F IS NEW F1 (ACC_POS, NEW POSITIVE);
- FUNCTION F IS NEW F1 (ACC_INT, NEW INTEGER);
- FUNCTION F IS NEW F1 (ACC_BOOL, NEW BOOLEAN);
- FUNCTION F IS NEW F1 (ACC_STR, NEW STRING(1..2) );
- FUNCTION F IS NEW F1 (ACC_FLT, NEW FLOAT);
-
- FUNCTION F RETURN ACC_NOTE IS
- BEGIN
- RETURN (NEW NOTE);
- END F;
-
- FUNCTION G IS NEW F1 (NEW_CHAR, 'G');
- FUNCTION G IS NEW F1 (NEW_DUR, 1.0);
- FUNCTION G IS NEW F1 (NEW_POS, +10);
- FUNCTION G IS NEW F1 (NEW_INT, -10);
- FUNCTION G IS NEW F1 (NEW_BOOL, TRUE);
- FUNCTION G IS NEW F1 (NEW_FLT, 1.0);
- FUNCTION G IS NEW F1 (NEW_NOTE, F);
-
-BEGIN
- TEST ("C87B41A","OVERLOADED CONSTRUCTS ON BOTH SIDES OF THE " &
- "ASSIGNMENT STATEMENT");
-
- F.ALL := G;
-
- RESULT;
-
-END C87B41A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada
deleted file mode 100644
index 9365d58..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- C87B42A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- A CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN TYPE.
-
--- TRH 27 JULY 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B42A IS
-
- TYPE BIT IS NEW BOOLEAN;
- TYPE BOOLEAN IS (FALSE, TRUE);
- TYPE LIT IS (FALSE, TRUE);
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN" &
- " TYPE");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL);
- FUNCTION F IS NEW F1 (BIT, FALSE, PASS);
- FUNCTION F IS NEW F1 (LIT, FALSE, FAIL);
- FUNCTION F IS NEW F1 (INTEGER, -11, FAIL);
- FUNCTION F IS NEW F1 (FLOAT, +0.0, FAIL);
-
-BEGIN
- TEST ("C87B42A","OVERLOADED CONDITIONAL EXPRESSIONS");
-
- WHILE (F OR NOT F)
- LOOP
- IF (F OR ELSE NOT F) THEN
- NULL;
- END IF;
- EXIT WHEN (F AND NOT F);
- EXIT WHEN (F OR NOT F);
- EXIT WHEN (F);
- EXIT WHEN (NOT F);
- END LOOP;
-
- RESULT;
-END C87B42A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada
deleted file mode 100644
index 9bb11fd..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada
+++ /dev/null
@@ -1,60 +0,0 @@
--- C87B43A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A CASE STATEMENT, THE TYPE OF EACH CHOICE MUST MATCH THE TYPE
--- OF THE EXPRESSION.
-
--- TRH 3 AUG 82
--- DSJ 10 JUN 83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B43A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
-
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER
- RENAMES "*";
-
- ERR : BOOLEAN := FALSE;
- X : WHOLE := 6;
-
-BEGIN
- TEST ("C87B43A","TYPE OF CASE CHOICE MUST MATCH TYPE OF " &
- "EXPRESSION");
-
- CASE X IS
- WHEN (2 + 3) => ERR := TRUE;
- WHEN (3 + 3) => NULL;
- WHEN OTHERS => ERR := TRUE;
- END CASE;
-
- IF ERR THEN
- FAILED ("CASE STATEMENT CHOICE MUST MATCH TYPE OF EXPRESSION");
- END IF;
-
- RESULT;
-END C87B43A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada
deleted file mode 100644
index 66acd03..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- C87B44A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE TYPE OF THE EXPRESSION IN A RETURN STATEMENT MUST MATCH THE
--- EXPLICIT TYPEMARK IN THE RETURN CLAUSE OF THE FUNCTION'S
--- SPECIFICATION.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 25 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B44A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END "*";
-
- FUNCTION "*" (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END "*";
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B44A","OVERLOADED EXPRESSIONS IN RETURN STATEMENTS");
- DECLARE
-
- FUNCTION F2 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN F1 (X, Y);
- END F2;
-
- FUNCTION F2 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN "*" (X, Y);
- END F2;
-
- FUNCTION F2 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN (X * Y);
- END F2;
-
- FUNCTION F2 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F2;
-
-
- BEGIN
- IF INTEGER'(F2 (0, 0)) /= -1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF WHOLE'(F2 (0, 0)) /= 0 THEN
- FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL");
- END IF;
-
- IF HUE'POS (F2 (0, 0)) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (F2 (0, 0)) /= 2 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL");
- END IF;
- END;
-
- RESULT;
-END C87B44A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada
deleted file mode 100644
index 497de84..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- C87B45A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR A DEFAULT SUBPROGRAM PARAMETER, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 24 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B45A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B45A","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN DEFAULT SUBPROGRAM PARAMETERS");
- DECLARE
-
- FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "/" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- PROCEDURE P1 (I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
- I2 : INTEGER := "/" (0, 0);
- W2 : WHOLE := "/" (0, 0);
- C2 : CITRUS := "/" (0, 0);
- H2 : HUE := "/" (0, 0);
- I3 : INTEGER := (0 / 0);
- W3 : WHOLE := (0 / 0);
- C3 : CITRUS := (0 / 0);
- H3 : HUE := (0 / 0);
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE) IS
- BEGIN
- IF I1 /= -1 OR W1 /= 0 OR
- CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF I2 /= -1 OR W2 /= 0 OR
- CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT " &
- "- OPERATOR SYMBOL");
- END IF;
-
- IF I3 /= -1 OR W3 /= 0 OR
- CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " &
- "LITERAL");
- END IF;
- END P1;
-
- BEGIN
- P1;
- END;
-
- RESULT;
-END C87B45A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada
deleted file mode 100644
index d70687a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- C87B45C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR A DEFAULT ENTRY PARAMETER, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 7 JULY 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B45C IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B45C","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN DEFAULT ENTRY PARAMETERS");
- DECLARE
-
- FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- TASK T1 IS
- ENTRY E1 (I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
- I2 : INTEGER := "*" (0, 0);
- W2 : WHOLE := "*" (0, 0);
- C2 : CITRUS := "*" (0, 0);
- H2 : HUE := "*" (0, 0);
- I3 : INTEGER := (0 * 0);
- W3 : WHOLE := (0 * 0);
- C3 : CITRUS := (0 * 0);
- H3 : HUE := (0 * 0);
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE);
- END T1;
-
- TASK BODY T1 IS
- BEGIN
- ACCEPT E1 (I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
- I2 : INTEGER := "*" (0, 0);
- W2 : WHOLE := "*" (0, 0);
- C2 : CITRUS := "*" (0, 0);
- H2 : HUE := "*" (0, 0);
- I3 : INTEGER := (0 * 0);
- W3 : WHOLE := (0 * 0);
- C3 : CITRUS := (0 * 0);
- H3 : HUE := (0 * 0);
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE) DO
-
- IF I1 /= -1 OR W1 /= 0 OR
- CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION");
- END IF;
-
- IF I2 /= -1 OR W2 /= 0 OR
- CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT " &
- "- OPERATOR SYMBOL");
- END IF;
-
- IF I3 /= -1 OR W3 /= 0 OR
- CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX " &
- "OPERATOR");
- END IF;
-
- IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - " &
- "ENUMERATION LITERAL");
- END IF;
-
- END E1;
- END T1;
-
- BEGIN
- T1.E1;
- END;
-
- RESULT;
-END C87B45C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada
deleted file mode 100644
index c9a426f..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- C87B47A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- ACTUAL PARAMETERS MUST MATCH THE EXPLICIT TYPEMARK OF THE
--- PARAMETER.
-
--- TRH 8 AUG 82
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B47A IS
-
- TYPE FLAG IS (PASS, FAIL);
-
- GENERIC
- TYPE T IS PRIVATE;
- ARG : IN T;
- STAT : IN FLAG;
- FUNCTION F1 RETURN T;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("ACTUAL PARAMETER MUST MATCH PARAMETER TYPE");
- END IF;
- RETURN ARG;
- END F1;
-
- FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS);
- FUNCTION F IS NEW F1 (INTEGER, 5, FAIL);
- FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL);
- FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL);
- FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL);
-
-BEGIN
- TEST ("C87B47A","OVERLOADED ACTUAL PARAMETERS");
-
- DECLARE
- PROCEDURE P (X : FLOAT) IS
- BEGIN
- NULL;
- END P;
-
- BEGIN
- P (F);
- P (X => F);
- END;
-
- RESULT;
-END C87B47A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada
deleted file mode 100644
index d8d79b5..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- C87B48A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- NAMED ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS.
--- THIS TEST USES FUNCTIONS AND OPERATOR SYMBOLS ONLY.
-
--- TRH 13 AUG 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B48A IS
-
- ERR, B1, B2 : BOOLEAN := FALSE;
-
- PACKAGE A IS
- FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN;
- FUNCTION TOGGLE (X : BOOLEAN) RETURN BOOLEAN
- RENAMES "-";
- END A;
-
- PACKAGE BODY A IS
- FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN NOT X;
- END "-";
- END A;
-
- PACKAGE B IS
- FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN;
- FUNCTION TOGGLE (Y : BOOLEAN) RETURN BOOLEAN
- RENAMES "-";
- END B;
-
- PACKAGE BODY B IS
- FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- ERR := TRUE;
- RETURN NOT Y;
- END "-";
- END B;
-
- PACKAGE C IS
- FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN;
- FUNCTION TOGGLE (Z : BOOLEAN) RETURN BOOLEAN
- RENAMES "-";
- END C;
-
- PACKAGE BODY C IS
- FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- ERR := TRUE;
- RETURN NOT Z;
- END "-";
- END C;
-
- USE A, B, C;
-
-BEGIN
- TEST ("C87B48A","RESOLUTION OF OVERLOADED SUBPROGRAMS BY NAMED " &
- "ACTUAL PARAMETERS");
-
- B1 := "-" (X => FALSE);
- B2 := TOGGLE (X => FALSE);
-
- IF ERR OR ELSE NOT B1 OR ELSE NOT B2 THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUBPROGRAMS" &
- " WITH NAMED ACTUAL PARAMETERS");
- END IF;
-
- RESULT;
-END C87B48A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada
deleted file mode 100644
index 45037ec..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- C87B48B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- POSITIONAL ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS.
-
--- TRH 16 AUG 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B48B IS
-
- TYPE FLAG IS (PASS, FAIL);
- TYPE INT IS NEW INTEGER;
- TYPE BIT IS NEW BOOLEAN;
- TYPE WHL IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
-
- GENERIC
- TYPE T1 IS PRIVATE;
- TYPE T2 IS PRIVATE;
- TYPE T3 IS PRIVATE;
- TYPE T4 IS PRIVATE;
- STAT : IN FLAG;
- PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4);
-
- PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4) IS
- BEGIN
- IF STAT = FAIL THEN
- FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUB" &
- "PROGRAMS WITH POSITIONAL ACTUAL PARAMETERS");
- END IF;
- END P1;
-
- PROCEDURE P IS NEW P1 (WHL, INT, WHL, BIT, PASS);
- PROCEDURE P IS NEW P1 (WHL, WHL, BIT, INT, FAIL);
- PROCEDURE P IS NEW P1 (WHL, INT, BIT, WHL, FAIL);
- PROCEDURE P IS NEW P1 (INT, BIT, WHL, WHL, FAIL);
- PROCEDURE P IS NEW P1 (BIT, WHL, WHL, INT, FAIL);
- PROCEDURE P IS NEW P1 (BIT, INT, WHL, WHL, FAIL);
-
-BEGIN
- TEST ("C87B48B","OVERLOADING RESOLUTION OF SUBPROGRAMS WITH" &
- " POSITIONAL ACTUAL PARAMETERS");
-
- BEGIN
- P (0, 0, 0, TRUE);
- END;
-
- RESULT;
-END C87B48B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada
deleted file mode 100644
index ee287af..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- C87B50A.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 FUNCTION RENAMING DECLARATION CAN RESOLVE AND RENAME AN
--- OVERLOADED ENUMERATION LITERAL.
-
--- GOM 11/29/84
--- JWC 7/12/85
--- PWB 03/06/86 CORRECTED ERROR: ADDED "USE" CLAUSE TO MAKE
--- "/=" VISIBLE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE C87B50A IS
-
-BEGIN
- TEST ("C87B50A", "CHECK THAT A FUNCTION RENAMING DECLARATION " &
- "CAN RESOLVE AND RENAME AN OVERLOADED " &
- "ENUMERATION LITERAL");
-
- DECLARE
-
- PACKAGE A IS
- TYPE COLORS IS (RED,GREEN);
- TYPE LIGHT IS (BLUE,RED);
- END A;
-
- PACKAGE B IS
- FUNCTION RED RETURN A.COLORS RENAMES A.RED;
- FUNCTION GREEN RETURN A.COLORS RENAMES A.GREEN;
- END B;
-
- USE A; -- TO MAKE /= VISIBLE.
-
- BEGIN
-
- IF (A.RED /= B.RED) OR (A.GREEN /= B.GREEN) THEN
- FAILED ("RENAMED VALUES NOT EQUAL");
- END IF;
-
- END;
-
- RESULT;
-END C87B50A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada
deleted file mode 100644
index 26b4b14..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- C87B54A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- THE ARGUMENT OF THE DELAY STATEMENT IS OF THE PREDEFINED FIXED
--- POINT TYPE DURATION.
-
--- TRH 7 SEPT 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B54A IS
-
- TYPE TEMPS IS NEW DURATION;
- TYPE REAL IS NEW FLOAT;
- TYPE TEMPUS IS DELTA 0.1 RANGE -1.0 .. 1.0;
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F (X : TEMPS) RETURN TEMPS IS
- BEGIN
- ERR := TRUE;
- RETURN X;
- END F;
-
- FUNCTION F (X : REAL) RETURN REAL IS
- BEGIN
- ERR := TRUE;
- RETURN X;
- END F;
-
- FUNCTION F (X : TEMPUS) RETURN TEMPUS IS
- BEGIN
- ERR := TRUE;
- RETURN X;
- END F;
-
- FUNCTION F (X : DURATION) RETURN DURATION IS
- BEGIN
- RETURN X;
- END F;
-
-BEGIN
- TEST ("C87B54A","OVERLOADED EXPRESSION WITHIN DELAY STATEMENT");
-
- DECLARE
- TASK T IS
- ENTRY E;
- END T;
-
- TASK BODY T IS
- BEGIN
- DELAY F (0.0);
- DELAY F (1.0);
- DELAY F (-1.0);
- END T;
-
- BEGIN
- IF ERR THEN FAILED ("DELAY STATEMENT TAKES AN ARGUMENT OF " &
- "THE PREDEFINED FIXED POINT TYPE " &
- "DURATION");
- END IF;
- END;
-
- RESULT;
-END C87B54A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada
deleted file mode 100644
index 31d3b8a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- C87B57A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- FOR A DEFAULT GENERIC IN PARAMETER, THE TYPE OF THE INITIALIZATION
--- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK.
---
--- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE:
---
--- (A): A CALL TO AN OVERLOADED FUNCTION.
--- (B): AN OVERLOADED OPERATOR SYMBOL.
--- (C): AN OVERLOADED (INFIX) OPERATOR.
--- (D): AN OVERLOADED ENUMERATION LITERAL.
-
--- TRH 25 JUNE 82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B57A IS
-
- TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST;
- TYPE CITRUS IS (LEMON, LIME, ORANGE);
- TYPE HUE IS (RED, ORANGE, YELLOW);
-
- FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -1;
- END F1;
-
- FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS
- BEGIN
- RETURN 0;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
- FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS
- BEGIN
- RETURN ORANGE;
- END F1;
-
-BEGIN
- TEST ("C87B57A","OVERLOADED INITIALIZATION EXPRESSIONS" &
- " IN DEFAULT GENERIC IN PARAMETERS");
- DECLARE
-
- FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER
- RENAMES F1;
-
- FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE
- RENAMES F1;
-
- FUNCTION "/" (X, Y : INTEGER) RETURN HUE
- RENAMES F1;
-
- FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS
- RENAMES F1;
-
- GENERIC
- I1 : INTEGER := F1 (0, 0);
- W1 : WHOLE := F1 (0, 0);
- C1 : CITRUS := F1 (0, 0);
- H1 : HUE := F1 (0, 0);
- I2 : INTEGER := "/" (0, 0);
- W2 : WHOLE := "/" (0, 0);
- C2 : CITRUS := "/" (0, 0);
- H2 : HUE := "/" (0, 0);
- I3 : INTEGER := (0 / 0);
- W3 : WHOLE := (0 / 0);
- C3 : CITRUS := (0 / 0);
- H3 : HUE := (0 / 0);
- C4 : CITRUS := ORANGE;
- H4 : HUE := ORANGE;
-
- PACKAGE P IS
- END P;
-
- PACKAGE BODY P IS
- BEGIN
- IF I1 /= -1 OR W1 /= 0 OR
- CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN
- FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL");
- END IF;
-
- IF I2 /= -1 OR W2 /= 0 OR
- CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN
- FAILED ("(B): RESOLUTION INCORRECT " &
- "- OPERATOR SYMBOL");
- END IF;
-
- IF I3 /= -1 OR W3 /= 0 OR
- CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN
- FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR");
- END IF;
-
- IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN
- FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " &
- "LITERAL");
- END IF;
- END P;
-
- PACKAGE P1 IS NEW P;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END C87B57A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada
deleted file mode 100644
index 550d20b..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- C87B62A.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A LENGTH CLAUSE THAT SPECIFIES 'SIZE,
--- THE EXPRESSION MUST BE OF SOME INTEGER TYPE.
-
--- HISTORY:
--- TRH 09/08/82 CREATED ORIGINAL TEST.
--- PWB 02/19/85 ADDED COMMENTS CLARIFYING NON-APPLICABILITY;
--- DELETED TEXT NOT RELATED TO TEST OBJECTIVE.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B62A IS
-
- TYPE POS_INT IS RANGE 1 .. INTEGER'LAST;
- TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0;
- ERR : BOOLEAN := FALSE;
-
- FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS
- BEGIN
- ERR := TRUE;
- RETURN POS_FIX (X);
- END "+";
-
- FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS
- BEGIN
- ERR := TRUE;
- RETURN POS_INT (X);
- END "+";
-
-BEGIN
- TEST ("C87B62A","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " &
- "- SPECIFICATION OF ATTRIBUTE T'SIZE");
-
- DECLARE
- TYPE DECEM IS NEW INTEGER RANGE 1 .. 10;
- TYPE JUST_LIKE_DECEM IS NEW INTEGER RANGE 1 .. 10;
- DECEM_SIZE : CONSTANT := JUST_LIKE_DECEM'SIZE;
- TYPE CHECK IS NEW INTEGER RANGE 1 .. 10;
-
- FOR CHECK'SIZE USE DECEM_SIZE;
- FOR DECEM'SIZE USE + DECEM_SIZE;
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " &
- "LENGTH CLAUSE USING 'SIZE");
- END IF;
- END;
-
- RESULT;
-END C87B62A;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada
deleted file mode 100644
index 2b03442..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- C87B62B.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE,
--- THE EXPRESSION MUST BE OF SOME INTEGER TYPE.
--- ACCESS TYPES ARE HERE; TASK TYPES ARE IN C87B62D.DEP.
-
--- HISTORY:
--- TRH 09/08/82 CREATED ORIGINAL TEST.
--- EG 06/04/84
--- PWB 01/19/86 CLARIFIED COMMENTS REGARDING NON-APPLICABILITY;
--- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE
--- MOVED TASK TYPES TO C87B62D.DEP.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B62B IS
-
- TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0;
- TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9';
- TYPE BASE_5 IS ('0', '1', '2', '3', '4');
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F (X : INTEGER) RETURN NUMERAL IS
- BEGIN
- ERR := TRUE;
- RETURN ('9');
- END F;
-
- FUNCTION F (X : INTEGER) RETURN BASE_5 IS
- BEGIN
- ERR := TRUE;
- RETURN ('4');
- END F;
-
- FUNCTION F (X : INTEGER) RETURN POS_FIX IS
- BEGIN
- ERR := TRUE;
- RETURN POS_FIX (X);
- END F;
-
- FUNCTION F (X : INTEGER) RETURN POS_INT IS
- BEGIN
- RETURN POS_INT (X);
- END F;
-
-BEGIN
- TEST ("C87B62B","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " &
- "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " &
- "FOR ACCESS TYPES");
-
- DECLARE
-
- TYPE DECEM IS NEW INTEGER RANGE 1 .. 10;
- TYPE LINK IS ACCESS DECEM;
-
- TYPE JUST_LIKE_LINK IS ACCESS DECEM;
- TYPE CHECK IS ACCESS DECEM;
-
- FOR CHECK'STORAGE_SIZE
- USE 1024;
- FOR LINK'STORAGE_SIZE USE F (1024);
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " &
- "LENGTH CLAUSE USING 'STORAGE_SIZE");
- END IF;
- END;
-
- RESULT;
-END C87B62B;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada b/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada
deleted file mode 100644
index fb5d4ef..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- C87B62C.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 OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A LENGTH CLAUSE THAT SPECIFIES 'SMALL, THE EXPRESSION
--- MUST BE OF SOME REAL TYPE.
-
--- HISTORY:
--- TRH 09/08/82 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO CLARIFY NON-APPLICABILITY;
--- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B62C IS
-
- TYPE POS_INT IS NEW INTEGER RANGE 1 .. INTEGER'LAST;
- TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0;
- ERR : BOOLEAN := FALSE;
-
- FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS
- BEGIN
- ERR := TRUE;
- RETURN POS_FIX (X);
- END "+";
-
- FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS
- BEGIN
- ERR := TRUE;
- RETURN POS_INT (X);
- END "+";
-
-BEGIN
- TEST ("C87B62C","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " &
- "- SPECIFICATION OF ATTRIBUTE T'SMALL");
-
- DECLARE
- TYPE JUST_LIKE_FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0;
- TYPE FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0;
-
- FIKST_SMALL : CONSTANT := JUST_LIKE_FIXED'SMALL;
- TYPE CHECK IS DELTA 0.1 RANGE -1.0 .. 1.0;
-
- FOR CHECK'SMALL USE FIKST_SMALL;
- FOR FIXED'SMALL USE + FIKST_SMALL;
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " &
- "LENGTH CLAUSE USING 'SMALL");
- END IF;
- END;
-
- RESULT;
-END C87B62C;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst b/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst
deleted file mode 100644
index 296402a..0000000
--- a/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst
+++ /dev/null
@@ -1,105 +0,0 @@
--- C87B62D.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.
---*
--- OBJECTIVE:
--- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT:
---
--- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE,
--- THE EXPRESSION MUST BE OF SOME INTEGER TYPE.
--- TASK TYPE IS HERE; ACCESS TYPE IS IN C87B62B.DEP.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- TRH 09/08/82 CREATED ORIGINAL TEST.
--- EG 06/04/84
--- PWB 01/19/86 CREATED THIS TEST FILE FROM THE TASK TYPE PART
--- OF THE OLD C87B62B;
--- CLARIFIED COMMENTS REGARDING NON-APPLICABILITY.
--- BCB 01/04/88 MODIFIED HEADER.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE C87B62D IS
-
- TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST;
- TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0;
- TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9';
- TYPE BASE_5 IS ('0', '1', '2', '3', '4');
- ERR : BOOLEAN := FALSE;
-
- FUNCTION F (X : INTEGER) RETURN NUMERAL IS
- BEGIN
- ERR := TRUE;
- RETURN ('9');
- END F;
-
- FUNCTION F (X : INTEGER) RETURN BASE_5 IS
- BEGIN
- ERR := TRUE;
- RETURN ('4');
- END F;
-
- FUNCTION F (X : INTEGER) RETURN POS_FIX IS
- BEGIN
- ERR := TRUE;
- RETURN POS_FIX (X);
- END F;
-
- FUNCTION F (X : INTEGER) RETURN POS_INT IS
- BEGIN
- RETURN POS_INT (X);
- END F;
-
-BEGIN
- TEST ("C87B62D","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " &
- "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " &
- "FOR TASK TYPES ");
-
- DECLARE
-
- TASK TYPE TSK1 IS
- END TSK1;
-
- FOR TSK1'STORAGE_SIZE USE F (TASK_STORAGE_SIZE);
-
- TASK BODY TSK1 IS
- BEGIN
- NULL;
- END TSK1;
-
- BEGIN
- IF ERR THEN
- FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " &
- "LENGTH CLAUSE USING 'STORAGE_SIZE");
- END IF;
- END;
-
- RESULT;
-END C87B62D;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910001.a b/gcc/testsuite/ada/acats/tests/c9/c910001.a
deleted file mode 100644
index 416e13c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910001.a
+++ /dev/null
@@ -1,224 +0,0 @@
--- 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
deleted file mode 100644
index dc0b9b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910002.a
+++ /dev/null
@@ -1,143 +0,0 @@
--- 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
deleted file mode 100644
index b2e11ce..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910003.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- 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
deleted file mode 100644
index 16a17cf..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c91004b.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- 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
deleted file mode 100644
index a075433..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c91004c.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- 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
deleted file mode 100644
index 1217d14..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c91006a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- 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
deleted file mode 100644
index d2b21b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c91007a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index 879cf36..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c92002a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- 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
deleted file mode 100644
index ff42680..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c92003a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- 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
deleted file mode 100644
index 6766c57..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c92005a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- 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
deleted file mode 100644
index e5672a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c92005b.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- 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
deleted file mode 100644
index f0fd0c8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c92006a.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- 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
deleted file mode 100644
index 8745189..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c930001.a
+++ /dev/null
@@ -1,153 +0,0 @@
--- 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
deleted file mode 100644
index 3a3b983..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93001a.ada
+++ /dev/null
@@ -1,296 +0,0 @@
--- 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
deleted file mode 100644
index a9999ad..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93002a.ada
+++ /dev/null
@@ -1,231 +0,0 @@
--- 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
deleted file mode 100644
index 48dced3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93003a.ada
+++ /dev/null
@@ -1,351 +0,0 @@
--- 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
deleted file mode 100644
index 688bec1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93004a.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- 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
deleted file mode 100644
index 0b140f5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93004b.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- 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
deleted file mode 100644
index bb4d68b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93004c.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- 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
deleted file mode 100644
index 40eb01f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93004d.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- 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
deleted file mode 100644
index 9267d3e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93004f.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- 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
deleted file mode 100644
index 95626f6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- 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
deleted file mode 100644
index 1b621c0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005b.ada
+++ /dev/null
@@ -1,273 +0,0 @@
--- 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
deleted file mode 100644
index 87322ee..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005c.ada
+++ /dev/null
@@ -1,250 +0,0 @@
--- 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
deleted file mode 100644
index 70925a1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005d.ada
+++ /dev/null
@@ -1,289 +0,0 @@
--- 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
deleted file mode 100644
index c5d6e29..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005e.ada
+++ /dev/null
@@ -1,247 +0,0 @@
--- 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
deleted file mode 100644
index c6d6aeb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005f.ada
+++ /dev/null
@@ -1,255 +0,0 @@
--- 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
deleted file mode 100644
index c46a730..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005g.ada
+++ /dev/null
@@ -1,245 +0,0 @@
--- 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
deleted file mode 100644
index 6641347..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93005h.ada
+++ /dev/null
@@ -1,250 +0,0 @@
--- 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
deleted file mode 100644
index 81954f2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93006a.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- 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
deleted file mode 100644
index 9653d66..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93007a.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- 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
deleted file mode 100644
index 633d17d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93008a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- 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
deleted file mode 100644
index 2853acd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c93008b.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- 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
deleted file mode 100644
index 2bc1a9f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940001.a
+++ /dev/null
@@ -1,212 +0,0 @@
--- 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
deleted file mode 100644
index 420f544..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940002.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- 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
deleted file mode 100644
index 059c97f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940004.a
+++ /dev/null
@@ -1,416 +0,0 @@
--- 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
deleted file mode 100644
index 47a97bf..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940005.a
+++ /dev/null
@@ -1,370 +0,0 @@
--- 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
deleted file mode 100644
index 36e6c91..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940006.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- 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
deleted file mode 100644
index 41e80f4..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940007.a
+++ /dev/null
@@ -1,427 +0,0 @@
--- 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
deleted file mode 100644
index c4a6705..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940010.a
+++ /dev/null
@@ -1,269 +0,0 @@
--- 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
deleted file mode 100644
index 6522866..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940011.a
+++ /dev/null
@@ -1,175 +0,0 @@
--- 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
deleted file mode 100644
index d4bd207..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940012.a
+++ /dev/null
@@ -1,174 +0,0 @@
--- 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
deleted file mode 100644
index 58d34bc..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940013.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- 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
deleted file mode 100644
index 0eb53ea..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940014.a
+++ /dev/null
@@ -1,177 +0,0 @@
--- 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
deleted file mode 100644
index 92a6699..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940015.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- 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
deleted file mode 100644
index 2226eef..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940016.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- 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
deleted file mode 100644
index e23a3b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001a.ada
+++ /dev/null
@@ -1,259 +0,0 @@
--- 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
deleted file mode 100644
index e3e2eda..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001b.ada
+++ /dev/null
@@ -1,268 +0,0 @@
--- 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
deleted file mode 100644
index 1d06255..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001c.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- 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
deleted file mode 100644
index 4ab502c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001e.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- 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
deleted file mode 100644
index 82adc32..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001f.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- 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
deleted file mode 100644
index 294bb53..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94001g.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- 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
deleted file mode 100644
index 6db8f96..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002a.ada
+++ /dev/null
@@ -1,331 +0,0 @@
--- 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
deleted file mode 100644
index 1f226f7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002b.ada
+++ /dev/null
@@ -1,208 +0,0 @@
--- 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
deleted file mode 100644
index 372fac0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002d.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- 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
deleted file mode 100644
index 940fd32..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002e.ada
+++ /dev/null
@@ -1,207 +0,0 @@
--- 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
deleted file mode 100644
index 47f0b4d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002f.ada
+++ /dev/null
@@ -1,227 +0,0 @@
--- 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
deleted file mode 100644
index 1b6108f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94002g.ada
+++ /dev/null
@@ -1,350 +0,0 @@
--- 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
deleted file mode 100644
index b895f8c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94004a.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- 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
deleted file mode 100644
index 3a578fd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94004b.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index 321bfee..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94004c.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- 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
deleted file mode 100644
index 71c5846..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94005a.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- 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
deleted file mode 100644
index 2a481b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94005b.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- 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
deleted file mode 100644
index cac5fc6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94006a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- 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
deleted file mode 100644
index e0a2c3f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94007a.ada
+++ /dev/null
@@ -1,270 +0,0 @@
--- 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
deleted file mode 100644
index 87e45b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94007b.ada
+++ /dev/null
@@ -1,224 +0,0 @@
--- 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
deleted file mode 100644
index 90b31d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94008a.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- 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
deleted file mode 100644
index e72d489..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94008b.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- 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
deleted file mode 100644
index fb2eee9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94008c.ada
+++ /dev/null
@@ -1,265 +0,0 @@
--- 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
deleted file mode 100644
index 15ca616..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94008d.ada
+++ /dev/null
@@ -1,235 +0,0 @@
--- 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
deleted file mode 100644
index 3fe4bd6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94010a.ada
+++ /dev/null
@@ -1,243 +0,0 @@
--- 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
deleted file mode 100644
index c504f06..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94011a.ada
+++ /dev/null
@@ -1,268 +0,0 @@
--- 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
deleted file mode 100644
index 4a5037e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c94020a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- 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
deleted file mode 100644
index 22876d2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940a03.a
+++ /dev/null
@@ -1,350 +0,0 @@
--- 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
deleted file mode 100644
index 4343e65..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95008a.ada
+++ /dev/null
@@ -1,426 +0,0 @@
--- 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
deleted file mode 100644
index 30830e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95009a.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- 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
deleted file mode 100644
index 3629560..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95010a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- 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
deleted file mode 100644
index 1e91a84..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95011a.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- 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
deleted file mode 100644
index 2f7efaa..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95012a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- 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
deleted file mode 100644
index a0c047b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95021a.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- 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
deleted file mode 100644
index c7e4bcb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95022a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
---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
deleted file mode 100644
index cd1e3ff..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95022b.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- 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
deleted file mode 100644
index 53c3548..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95033a.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- 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
deleted file mode 100644
index a72f3b6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95033b.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- 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
deleted file mode 100644
index c597bf2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95034a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- 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
deleted file mode 100644
index 3c491e7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95034b.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- 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
deleted file mode 100644
index ce78166..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95035a.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- 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
deleted file mode 100644
index aa302bd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95040a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- 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
deleted file mode 100644
index aee275f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95040b.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- 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
deleted file mode 100644
index cc7db58..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95040c.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- 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
deleted file mode 100644
index cfe0a77..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95040d.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- 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
deleted file mode 100644
index 4f676b3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95041a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index 2224ddd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065a.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- 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
deleted file mode 100644
index 81226af..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065b.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- 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
deleted file mode 100644
index 3a7732e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065c.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index 36fc22c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065d.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- 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
deleted file mode 100644
index 95086f0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065e.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- 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
deleted file mode 100644
index 3451707..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95065f.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index f9405d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95066a.ada
+++ /dev/null
@@ -1,214 +0,0 @@
--- 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
deleted file mode 100644
index d4393d5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95067a.ada
+++ /dev/null
@@ -1,302 +0,0 @@
--- 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
deleted file mode 100644
index a715399..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95071a.ada
+++ /dev/null
@@ -1,230 +0,0 @@
--- 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
deleted file mode 100644
index 261007b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95072a.ada
+++ /dev/null
@@ -1,197 +0,0 @@
--- 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
deleted file mode 100644
index ba1b91e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95072b.ada
+++ /dev/null
@@ -1,278 +0,0 @@
--- 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
deleted file mode 100644
index f8b1e0d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95073a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- 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
deleted file mode 100644
index 872a592..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95074c.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- 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
deleted file mode 100644
index ba00cee..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95076a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- 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
deleted file mode 100644
index 399be96..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95078a.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- 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
deleted file mode 100644
index 1c3c3b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95080b.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- 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
deleted file mode 100644
index f02e35d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95082g.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- 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
deleted file mode 100644
index fc7e0dc..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085a.ada
+++ /dev/null
@@ -1,279 +0,0 @@
--- 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
deleted file mode 100644
index 27ef170..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085b.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- 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
deleted file mode 100644
index f2875e3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085c.ada
+++ /dev/null
@@ -1,245 +0,0 @@
--- 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
deleted file mode 100644
index 0592981..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085d.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index 86c446c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085e.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- 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
deleted file mode 100644
index 7a71659..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085f.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- 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
deleted file mode 100644
index 2004164..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085g.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- 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
deleted file mode 100644
index a467204..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085h.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- 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
deleted file mode 100644
index b2b0854..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085i.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- 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
deleted file mode 100644
index d1ea3ce..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085j.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- 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
deleted file mode 100644
index 37952f0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085k.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index cb62ff2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085l.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- 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
deleted file mode 100644
index 45e73ff..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085m.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- 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
deleted file mode 100644
index 7f7e3a6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085n.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- 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
deleted file mode 100644
index f5cd288..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95085o.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- 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
deleted file mode 100644
index e26e8b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- 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
deleted file mode 100644
index bc222eb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086b.ada
+++ /dev/null
@@ -1,202 +0,0 @@
--- 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
deleted file mode 100644
index 9c2050b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086c.ada
+++ /dev/null
@@ -1,250 +0,0 @@
--- 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
deleted file mode 100644
index 616c025..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086d.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- 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
deleted file mode 100644
index 4e4f42b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086e.ada
+++ /dev/null
@@ -1,282 +0,0 @@
--- 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
deleted file mode 100644
index 00b8444..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95086f.ada
+++ /dev/null
@@ -1,282 +0,0 @@
--- 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
deleted file mode 100644
index 535cea4..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95087a.ada
+++ /dev/null
@@ -1,412 +0,0 @@
--- 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
deleted file mode 100644
index 1d6c878..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95087b.ada
+++ /dev/null
@@ -1,267 +0,0 @@
--- 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
deleted file mode 100644
index 2061af4..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95087c.ada
+++ /dev/null
@@ -1,299 +0,0 @@
--- 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
deleted file mode 100644
index 6e44913..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95087d.ada
+++ /dev/null
@@ -1,268 +0,0 @@
--- 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
deleted file mode 100644
index 053abeb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95088a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- 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
deleted file mode 100644
index b66897c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95089a.ada
+++ /dev/null
@@ -1,175 +0,0 @@
--- 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
deleted file mode 100644
index 24dc179..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95090a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- 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
deleted file mode 100644
index 47e96b5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95092a.ada
+++ /dev/null
@@ -1,193 +0,0 @@
--- 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
deleted file mode 100644
index 9c443fa..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95093a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- 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
deleted file mode 100644
index 0cd0295..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95095a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- 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
deleted file mode 100644
index f3c9c0d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95095b.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- 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
deleted file mode 100644
index 694c7d3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95095c.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- 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
deleted file mode 100644
index f2ad7d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95095d.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- 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
deleted file mode 100644
index 0195169..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c95095e.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- 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
deleted file mode 100644
index c1cf965..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c951001.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- 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
deleted file mode 100644
index 65b696c..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c951002.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- 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
deleted file mode 100644
index bc9c85f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953001.a
+++ /dev/null
@@ -1,188 +0,0 @@
--- 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
deleted file mode 100644
index d821bb2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953002.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- 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
deleted file mode 100644
index 4ac9116..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953003.a
+++ /dev/null
@@ -1,189 +0,0 @@
--- 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
deleted file mode 100644
index 3112cce..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954001.a
+++ /dev/null
@@ -1,273 +0,0 @@
--- 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
deleted file mode 100644
index ac39c89..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954010.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- 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
deleted file mode 100644
index 159b32d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954011.a
+++ /dev/null
@@ -1,384 +0,0 @@
--- 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
deleted file mode 100644
index 44575b1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954012.a
+++ /dev/null
@@ -1,496 +0,0 @@
--- 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
deleted file mode 100644
index 70ea3f5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954013.a
+++ /dev/null
@@ -1,521 +0,0 @@
--- 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 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
deleted file mode 100644
index 53e45a0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954014.a
+++ /dev/null
@@ -1,485 +0,0 @@
--- 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
deleted file mode 100644
index c86e107..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954015.a
+++ /dev/null
@@ -1,549 +0,0 @@
--- 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
deleted file mode 100644
index 1390801..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954016.a
+++ /dev/null
@@ -1,182 +0,0 @@
--- 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
deleted file mode 100644
index a5447a7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954017.a
+++ /dev/null
@@ -1,184 +0,0 @@
--- 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
deleted file mode 100644
index a9da1e0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954018.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- 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
deleted file mode 100644
index fafc6aa..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954019.a
+++ /dev/null
@@ -1,314 +0,0 @@
--- 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
deleted file mode 100644
index bc08a6b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954020.a
+++ /dev/null
@@ -1,422 +0,0 @@
--- 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
deleted file mode 100644
index 626f2f9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954021.a
+++ /dev/null
@@ -1,524 +0,0 @@
--- 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
deleted file mode 100644
index 5ebff8d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954022.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- 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
deleted file mode 100644
index bfa69dc..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954023.a
+++ /dev/null
@@ -1,558 +0,0 @@
--- 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
deleted file mode 100644
index 7f19a81..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954024.a
+++ /dev/null
@@ -1,380 +0,0 @@
--- 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
deleted file mode 100644
index c4993f7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954025.a
+++ /dev/null
@@ -1,237 +0,0 @@
--- 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
deleted file mode 100644
index 9e26124..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954026.a
+++ /dev/null
@@ -1,269 +0,0 @@
--- 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
deleted file mode 100644
index 3ea545a..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a01.a
+++ /dev/null
@@ -1,262 +0,0 @@
--- 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
deleted file mode 100644
index 7d61aea..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a02.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- 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
deleted file mode 100644
index 13d2131..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a03.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- 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
deleted file mode 100644
index 4eaa1f4..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960001.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- 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
deleted file mode 100644
index 06edaf0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960002.a
+++ /dev/null
@@ -1,171 +0,0 @@
--- 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
deleted file mode 100644
index f394aab..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960004.a
+++ /dev/null
@@ -1,206 +0,0 @@
--- 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
deleted file mode 100644
index f958ea1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96001a.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- 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
deleted file mode 100644
index b1f769b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada
+++ /dev/null
@@ -1,280 +0,0 @@
--- 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.
--- RLB 12/18/06 Changed so that the test will work for Ada 2005
--- implementations.
-
-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(2100);
- IF NOT EQUAL (YR, YR) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
- BEGIN
- YR := 2399;
- IF NOT EQUAL (YR, YR) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("ADA 2005 CASE RAISED EXCEPTION ON 2399 - (A)");
- END;
- BEGIN
- YR := IDENT_INT(2400);
- IF NOT EQUAL (YR, YR) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
- FAILED ("EXCEPTION NOT RAISED - (A)3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- Comment ("Upper bound of Year_Number is appropriate" &
- " for Ada 2005");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- Comment ("Upper bound of Year_Number is appropriate" &
- " for Ada 95");
- 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
deleted file mode 100644
index ca6fc5b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96005a.ada
+++ /dev/null
@@ -1,239 +0,0 @@
--- 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
deleted file mode 100644
index f4665b1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96005b.tst
+++ /dev/null
@@ -1,135 +0,0 @@
--- 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
deleted file mode 100644
index 8caba3e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96005d.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- 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
deleted file mode 100644
index 89e3d57..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96005f.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- 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
deleted file mode 100644
index 0f6448b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96006a.ada
+++ /dev/null
@@ -1,298 +0,0 @@
--- 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
deleted file mode 100644
index 15ac5e9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada
+++ /dev/null
@@ -1,205 +0,0 @@
--- 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
--- RLB 12/18/06 - Changed so that the test will work for Ada 2005
--- implementations.
-
-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 - YEAR_NUM'LAST+1 (B)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - YEAR_NUM'LAST+1 (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
deleted file mode 100644
index 33b59d8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96008a.ada
+++ /dev/null
@@ -1,203 +0,0 @@
--- 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
deleted file mode 100644
index 7a23bcf..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c96008b.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- 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
deleted file mode 100644
index ef7dca2..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97112a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- 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
deleted file mode 100644
index f05d438..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97113a.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- 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
deleted file mode 100644
index 2a28fe8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97114a.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- 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
deleted file mode 100644
index 8e9845e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97115a.ada
+++ /dev/null
@@ -1,189 +0,0 @@
--- 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
deleted file mode 100644
index 737d252..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97116a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- 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
deleted file mode 100644
index cf5e1b91..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97117a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- 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
deleted file mode 100644
index bc05ebf..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97117b.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- 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
deleted file mode 100644
index cda4280..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97117c.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- 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
deleted file mode 100644
index e1eceaf..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97118a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- 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
deleted file mode 100644
index 4fd5293..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97120a.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- 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
deleted file mode 100644
index 5cc9806..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97120b.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- 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
deleted file mode 100644
index 18186cb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201a.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- 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
deleted file mode 100644
index d8e44b0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201b.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- 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
deleted file mode 100644
index e09d01e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201c.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- 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
deleted file mode 100644
index 2ea7ba0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201d.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- 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
deleted file mode 100644
index 5473b57..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201e.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- 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
deleted file mode 100644
index ae5fad3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201g.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- 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
deleted file mode 100644
index ad4a461..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201h.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- 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
deleted file mode 100644
index e7f74d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97201x.ada
+++ /dev/null
@@ -1,170 +0,0 @@
--- 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
deleted file mode 100644
index 3856e7f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97202a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- 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
deleted file mode 100644
index 64510dd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97203a.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- 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
deleted file mode 100644
index 0898154..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97203b.ada
+++ /dev/null
@@ -1,131 +0,0 @@
--- 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
deleted file mode 100644
index d8d9bf5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97203c.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- 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
deleted file mode 100644
index a1913a0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97204a.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- 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
deleted file mode 100644
index 9e52a9d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97204b.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- 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
deleted file mode 100644
index a0bd4d9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97205a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- 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
deleted file mode 100644
index ec49ad5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97205b.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- 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
deleted file mode 100644
index 81c65fb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97301a.ada
+++ /dev/null
@@ -1,158 +0,0 @@
--- 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
deleted file mode 100644
index f6dead3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97301b.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- 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
deleted file mode 100644
index a2b3abb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97301c.ada
+++ /dev/null
@@ -1,101 +0,0 @@
--- 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
deleted file mode 100644
index e473fa7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97301d.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- 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
deleted file mode 100644
index 39bf159..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97301e.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- 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
deleted file mode 100644
index 18c7afb..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97302a.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- 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
deleted file mode 100644
index 67504fc..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97303a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- 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
deleted file mode 100644
index 5043fa1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97303b.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- 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
deleted file mode 100644
index a614303..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97303c.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- 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
deleted file mode 100644
index 8e45047..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97304a.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- 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
deleted file mode 100644
index 1d7f4cd..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97304b.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- 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
deleted file mode 100644
index 81349b8..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97305a.ada
+++ /dev/null
@@ -1,100 +0,0 @@
--- 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
deleted file mode 100644
index 13a28a3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97305b.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- 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
deleted file mode 100644
index ee9953b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97305c.ada
+++ /dev/null
@@ -1,90 +0,0 @@
--- 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
deleted file mode 100644
index 022b0ad..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97305d.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- 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
deleted file mode 100644
index 32d26e6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c97307a.ada
+++ /dev/null
@@ -1,209 +0,0 @@
--- 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
deleted file mode 100644
index 04ac93e..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974001.a
+++ /dev/null
@@ -1,152 +0,0 @@
--- 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
deleted file mode 100644
index 1138e8d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974002.a
+++ /dev/null
@@ -1,209 +0,0 @@
--- 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
deleted file mode 100644
index c353a91..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974003.a
+++ /dev/null
@@ -1,249 +0,0 @@
--- 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
deleted file mode 100644
index b1200c1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974004.a
+++ /dev/null
@@ -1,273 +0,0 @@
--- 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
deleted file mode 100644
index 196a8ed..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974005.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- 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
deleted file mode 100644
index f6f4d92..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974006.a
+++ /dev/null
@@ -1,197 +0,0 @@
--- 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
deleted file mode 100644
index 07007b9..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974007.a
+++ /dev/null
@@ -1,205 +0,0 @@
--- 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
deleted file mode 100644
index b76db7b..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974008.a
+++ /dev/null
@@ -1,229 +0,0 @@
--- 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
deleted file mode 100644
index 419f2a3..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974009.a
+++ /dev/null
@@ -1,206 +0,0 @@
--- 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
deleted file mode 100644
index caeb9d5..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974010.a
+++ /dev/null
@@ -1,209 +0,0 @@
--- 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
deleted file mode 100644
index 4682db6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974011.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- 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
deleted file mode 100644
index 4e43c72..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974012.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- 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
deleted file mode 100644
index 4a930da..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974013.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- 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
deleted file mode 100644
index 03ca915..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974014.a
+++ /dev/null
@@ -1,132 +0,0 @@
--- 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
deleted file mode 100644
index 3bd4196..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980001.a
+++ /dev/null
@@ -1,303 +0,0 @@
--- 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
deleted file mode 100644
index f2b9c52..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980002.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- 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
deleted file mode 100644
index dd69fc7..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980003.a
+++ /dev/null
@@ -1,294 +0,0 @@
--- 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
deleted file mode 100644
index 8774314..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c99004a.ada
+++ /dev/null
@@ -1,166 +0,0 @@
--- 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
deleted file mode 100644
index f3bcbaa6..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c99005a.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- 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
deleted file mode 100644
index e8d7706..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- 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
deleted file mode 100644
index 1247243..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- 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
deleted file mode 100644
index 9339930..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada
+++ /dev/null
@@ -1,293 +0,0 @@
--- 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
deleted file mode 100644
index ba3b084..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- 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
deleted file mode 100644
index 89b7390..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- 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
deleted file mode 100644
index e100a9f..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- 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
deleted file mode 100644
index 7dea8a4..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- 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
deleted file mode 100644
index 914fce1..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- 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
deleted file mode 100644
index 553b72d..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- 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
deleted file mode 100644
index 1d415b0..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- 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
deleted file mode 100644
index fe1ba16..0000000
--- a/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- 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;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada
deleted file mode 100644
index b3476b4..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- CA1003A.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 MORE THAN ONE COMPLETELY INDEPENDENT COMPILATION
--- UNIT CAN BE SUBMITTED IN A SINGLE FILE.
-
--- JRK 5/13/81
--- JBG 8/25/83
-
-PROCEDURE CA1003A_P (I : IN OUT INTEGER) IS
-BEGIN
- I := I + 1;
-END CA1003A_P;
-
-
-PACKAGE CA1003A_PKG IS
- I : INTEGER := 0;
-END CA1003A_PKG;
-
-
-FUNCTION CA1003A_F (I : INTEGER) RETURN INTEGER IS
-BEGIN
- RETURN -I;
-END CA1003A_F;
-
-
-WITH REPORT, CA1003A_P, CA1003A_PKG, CA1003A_F;
-USE REPORT;
-
-PROCEDURE CA1003A IS
-
- I : INTEGER := IDENT_INT (0);
-
-BEGIN
- TEST ("CA1003A", "INDEPENDENT UNITS IN A SINGLE FILE");
-
- CA1003A_P (I);
- IF I /= 1 THEN
- FAILED ("INDEPENDENT PROCEDURE NOT INVOKED");
- END IF;
-
- CA1003A_PKG.I := CA1003A_PKG.I + IDENT_INT(10);
- IF CA1003A_PKG.I /= 10 THEN
- FAILED ("INDEPENDENT PACKAGE VARIABLE ACCESSED INCORRECTLY");
- END IF;
-
- IF CA1003A_F(IDENT_INT(5)) /= -5 THEN
- FAILED ("INDEPENDENT FUNCTION NOT INVOKED");
- END IF;
-
- RESULT;
-END CA1003A;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada
deleted file mode 100644
index def868e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CA1004A.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 PACKAGE DECLARATION AND BODY CAN BE
--- SUBMITTED TOGETHER FOR COMPILATION.
-
--- JRK 5/12/81
-
-
-PACKAGE CA1004A_PKG IS
-
- I : INTEGER := 0;
-
- PROCEDURE P (I : IN OUT INTEGER);
-
-END CA1004A_PKG;
-
-
-PACKAGE BODY CA1004A_PKG IS
-
- PROCEDURE P (I : IN OUT INTEGER) IS
- BEGIN
- I := I + 1;
- END P;
-
-BEGIN
-
- I := 10;
-
-END CA1004A_PKG;
-
-
-WITH REPORT, CA1004A_PKG;
-USE REPORT;
-
-PROCEDURE CA1004A IS
-
- I : INTEGER := IDENT_INT (0);
-
-BEGIN
- TEST ("CA1004A", "A PACKAGE DECLARATION AND BODY SUBMITTED " &
- "TOGETHER");
-
- CA1004A_PKG.I := CA1004A_PKG.I + IDENT_INT(5);
- IF CA1004A_PKG.I /= 15 THEN
- FAILED ("PACKAGED VARIABLE NOT ACCESSIBLE OR " &
- "PACKAGE BODY NOT EXECUTED");
- END IF;
-
- CA1004A_PKG.P (I);
- IF I /= 1 THEN
- FAILED ("PACKAGED PROCEDURE NOT EXECUTED");
- END IF;
-
- RESULT;
-END CA1004A;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada
deleted file mode 100644
index 9f9e2a2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- CA1005A.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 SUBPROGRAM DECLARATION AND BODY CAN BE
--- SUBMITTED TOGETHER FOR COMPILATION.
-
--- JRK 5/14/81
-
-
-FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER;
-
-
-FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER IS
-BEGIN
- RETURN I + 1;
-END CA1005A_F;
-
-
-PROCEDURE CA1005A_P (I : IN OUT INTEGER);
-
-
-PROCEDURE CA1005A_P (I : IN OUT INTEGER) IS
-BEGIN
- I := -I;
-END CA1005A_P;
-
-
-WITH REPORT, CA1005A_F, CA1005A_P;
-USE REPORT;
-
-PROCEDURE CA1005A IS
-
- I : INTEGER := IDENT_INT (7);
-
-BEGIN
- TEST ("CA1005A", "SUBPROGRAM DECLARATIONS AND BODIES " &
- "SUBMITTED TOGETHER");
-
- IF CA1005A_F (IDENT_INT(2)) /= 3 THEN
- FAILED ("FUNCTION NOT EXECUTED");
- END IF;
-
- CA1005A_P (I);
- IF I /= -7 THEN
- FAILED ("PROCEDURE NOT EXECUTED");
- END IF;
-
- RESULT;
-END CA1005A;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada
deleted file mode 100644
index 7b3527f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CA1006A.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 LIBRARY UNIT AND ITS SUBUNITS CAN BE
--- SUBMITTED TOGETHER FOR COMPILATION.
-
--- JRK 5/14/81
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CA1006A IS
-
- I : INTEGER := IDENT_INT (0);
-
- PACKAGE CALL_TEST IS
- END CALL_TEST;
-
- PACKAGE BODY CALL_TEST IS
- BEGIN
- TEST ("CA1006A", "A LIBRARY UNIT AND ITS SUBUNITS " &
- "SUBMITTED TOGETHER");
- END CALL_TEST;
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS SEPARATE;
-
- PACKAGE PKG IS
- I : INTEGER := IDENT_INT (0);
- PROCEDURE P (I : IN OUT INTEGER);
- END PKG;
-
- PACKAGE BODY PKG IS SEPARATE;
-
- PROCEDURE P (I : IN OUT INTEGER) IS SEPARATE;
-
-BEGIN
-
- IF PKG.I /= 10 THEN
- FAILED ("PACKAGE BODY STATEMENTS NOT EXECUTED");
- END IF;
-
- IF F(IDENT_INT(5)) /= -5 THEN
- FAILED ("FUNCTION NOT ELABORATED/EXECUTED");
- END IF;
-
- PKG.P (I);
- IF I /= 3 THEN
- FAILED ("PACKAGED PROCEDURE NOT ELABORATED/EXECUTED");
- END IF;
-
- I := IDENT_INT (-20);
- P (I);
- IF I /= -24 THEN
- FAILED ("PROCEDURE NOT ELABORATED/EXECUTED");
- END IF;
-
- RESULT;
-END CA1006A;
-
-
-SEPARATE (CA1006A)
-FUNCTION F (I : INTEGER) RETURN INTEGER IS
-BEGIN
- RETURN -I;
-END F;
-
-
-SEPARATE (CA1006A)
-PACKAGE BODY PKG IS
-
- PROCEDURE P (I : IN OUT INTEGER) IS
- BEGIN
- I := I + 3;
- END P;
-
-BEGIN
- I := I + 10;
-END PKG;
-
-
-SEPARATE (CA1006A)
-PROCEDURE P (I : IN OUT INTEGER) IS
-BEGIN
- I := I - 4;
-END P;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada
deleted file mode 100644
index a1c1646..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA1011A0.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE CA1011A0 (X : IN OUT INTEGER; Y : IN INTEGER := 2) IS
-BEGIN
-
- X := Y;
- FAILED ("DID NOT REPLACE CA1011A0");
-
-END CA1011A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada
deleted file mode 100644
index 791d782..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA1011A1.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-PROCEDURE CA1011A0 (X : IN OUT INTEGER;
- Y : IN INTEGER := -1;
- Z : IN INTEGER := 2) IS
-
-BEGIN
-
- X := 3;
-
-END CA1011A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada
deleted file mode 100644
index 1125029..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA1011A2.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-WITH REPORT; USE REPORT;
-PROCEDURE CA1011A2 (X : INTEGER := 1; Y : IN OUT FLOAT) IS
-BEGIN
-
- Y := 2.0;
- FAILED ("DID NOT REPLACE CA1011A2");
-
-END CA1011A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada
deleted file mode 100644
index a37d04c..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA1011A3.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-PROCEDURE CA1011A2 (X : BOOLEAN := TRUE;
- Y : IN OUT FLOAT) IS
-BEGIN
-
- Y := 3.0;
-
-END CA1011A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada
deleted file mode 100644
index 68d39724..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA1011A4.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-WITH REPORT; USE REPORT;
-FUNCTION CA1011A4 RETURN INTEGER IS
-BEGIN
-
- FAILED ("DID NOT REPLACE CA1011A4");
- RETURN 2;
-
-END CA1011A4;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada
deleted file mode 100644
index 2485717..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada
+++ /dev/null
@@ -1,33 +0,0 @@
--- CA1011A5.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.
---*
--- BHS 7/20/84
--- JBG 5/23/85
-
-FUNCTION CA1011A4 RETURN FLOAT IS
-BEGIN
-
- RETURN 3.0;
-
-END CA1011A4;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada
deleted file mode 100644
index 40c562d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CA1011A6M.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 SUBPROGRAM BODY IS INITIALLY COMPILED, SUBSEQUENT
--- ATTEMPTS TO COMPILE A SUBPROGRAM BODY WITH A DIFFERENT PARAMETER AND
--- RESULT TYPE PROFILE ARE ACCEPTED (SEE AI-00199).
-
--- SEPARATE FILES ARE:
--- CA1011A0 A LIBRARY PROCEDURE (CA1011A0).
--- CA1011A1 A LIBRARY PROCEDURE (CA1011A0).
--- CA1011A2 A LIBRARY PROCEDURE (CA1011A2).
--- CA1011A3 A LIBRARY PROCEDURE (CA1011A2).
--- CA1011A4 A LIBRARY FUNCTION (CA1011A4).
--- CA1011A5 A LIBRARY FUNCTION (CA1011A4).
--- CA1011A6M THE MAIN PROCEDURE.
-
--- BHS 7/20/84
--- JBG 5/23/85
-
-WITH CA1011A0, CA1011A2, CA1011A4;
-WITH REPORT; USE REPORT;
-PROCEDURE CA1011A6M IS
-
- I : INTEGER := 5;
- J : FLOAT := 4.0;
-
-BEGIN
-
- TEST("CA1011A", "ATTEMPTS TO RECOMPILE A SUBPROGRAM WITH " &
- "NONCONFORMING PARAMETER OR RESULT TYPE " &
- "PROFILES ARE ACCEPTED");
-
- CA1011A0(X => I); -- EXPECT DEFAULT Y
- IF I = 3 THEN
- COMMENT ("SECOND DECLARATION OF CA1011A0 INVOKED CORRECTLY");
- END IF;
-
- CA1011A2(Y => J); -- USE DEFAULT X.
- IF J = 3.0 THEN
- COMMENT ("SECOND DECLARATION OF CA1011A2 INVOKED CORRECTLY");
- END IF;
-
- I := INTEGER(CA1011A4);
- IF I = 3 THEN
- COMMENT ("SECOND DECLARATION OF CA1011A4 INVOKED CORRECTLY");
- END IF;
-
- RESULT;
-
-END CA1011A6M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada
deleted file mode 100644
index eec972d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada
+++ /dev/null
@@ -1,41 +0,0 @@
--- CA1012A0.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.
---*
--- GENERIC PROCEDURE DECLARATION.
--- BODY IS IN CA1012A1.DEP.
--- INSTANTIATION IS IN CA1012A4M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- WKB 07/20/81 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
--- AND CLARIFY POSSIBLE NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-GENERIC
- TYPE INDEX IS RANGE <>;
-PROCEDURE CA1012A0 (I : IN OUT INDEX);
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada
deleted file mode 100644
index 0e2522f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada
+++ /dev/null
@@ -1,45 +0,0 @@
--- CA1012A1.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.
---*
--- GENERIC PROCEDURE BODY.
--- DECLARATION IS IN CA1012A0.DEP.
--- INSTANTIATION IN CA1012A4M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- WKB 07/20/81 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
--- IN TEST AND POSSIBLE NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-PROCEDURE CA1012A0 (I : IN OUT INDEX) IS
-
-BEGIN
-
- I := I + 1;
-
-END CA1012A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada
deleted file mode 100644
index 63300b3..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada
+++ /dev/null
@@ -1,41 +0,0 @@
--- CA1012A2.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.
---*
--- GENERIC FUNCTION DECLARATION.
--- BODY IS IN CA1012A3.DEP.
--- INSTANTIATION IS IN CA1012A4M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- WKB 07/20/81 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
--- AND POSSIBLE NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-GENERIC
- TYPE ELEMENT IS RANGE <>;
-FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada
deleted file mode 100644
index 3107775..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada
+++ /dev/null
@@ -1,45 +0,0 @@
--- CA1012A3.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.
---*
--- GENERIC FUNCTION BODY.
--- DECLARATION IS IN CA1012AB.DEP.
--- INSTANTIATION IS IN CA1012A4B.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- WKB 07/20/81 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
--- AND POSSIBLE NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT IS
-
-BEGIN
-
- RETURN J + 1;
-
-END CA1012A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada
deleted file mode 100644
index f81b97d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- CA1012A4M.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 GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE
--- COMPILED SEPARATELY.
-
--- SEPARATE FILES ARE:
--- CA1012A0 A LIBRARY GENERIC PROCEDURE DECLARATION.
--- CA1012A1 A LIBRARY GENERIC PROCEDURE BODY (CA1012A0).
--- CA1012A2 A LIBRARY GENERIC FUNCTION DECLARATION.
--- CA1012A3 A LIBRARY GENERIC FUNCTION BODY (CA1012A2).
--- CA1012A4M THE MAIN PROCEDURE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
--- THIS WAS NOT REQUIRED FOR ADA 83.
-
--- HISTORY:
--- WKB 07/20/81 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS REGARDING NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
--- RLB 09/15/99 REMOVED OBSOLETE COMMENT.
-
-WITH REPORT, CA1012A0, CA1012A2;
-USE REPORT;
-PROCEDURE CA1012A4M IS
-
- N : INTEGER := 1;
-
- SUBTYPE S50 IS INTEGER RANGE 1..50;
-
- PROCEDURE P IS NEW CA1012A0 (S50);
-
- FUNCTION F IS NEW CA1012A2 (INTEGER);
-
-BEGIN
- TEST ("CA1012A", "SEPARATELY COMPILED GENERIC SUBPROGRAM " &
- "DECLARATIONS AND BODIES");
-
- P(N);
- IF N /= 2 THEN
- FAILED ("PROCEDURE NOT INVOKED");
- END IF;
-
- N := 1;
- IF F(N) /= 2 THEN
- FAILED ("FUNCTION NOT INVOKED");
- END IF;
-
- RESULT;
-END CA1012A4M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada
deleted file mode 100644
index b260ca2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada
+++ /dev/null
@@ -1,37 +0,0 @@
--- CA1012B0.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.
---*
--- WKB 7/20/81
-
-GENERIC
- TYPE INDEX IS RANGE <>;
-PROCEDURE CA1012B0 (I : IN OUT INDEX);
-
-PROCEDURE CA1012B0 (I : IN OUT INDEX) IS
-
-BEGIN
-
- I := I + 1;
-
-END CA1012B0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada
deleted file mode 100644
index 46d2b93..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada
+++ /dev/null
@@ -1,37 +0,0 @@
--- CA1012B2.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.
---*
--- WKB 7/20/81
-
-GENERIC
- TYPE ELEMENT IS RANGE <>;
-FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT;
-
-FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT IS
-
-BEGIN
-
- RETURN J + 1;
-
-END CA1012B2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada
deleted file mode 100644
index 528ace0..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CA1012B4M.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 GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE
--- COMPILED SEPARATELY.
-
--- SEPARATE FILES ARE:
--- CA1012B0 A LIBRARY GENERIC PROCEDURE DECLARATION AND BODY.
--- CA1012B2 A LIBRARY GENERIC FUNCTION DECLARATION AND BODY.
--- CA1012B4M THE MAIN PROCEDURE.
-
--- WKB 7/20/81
-
-WITH REPORT, CA1012B0, CA1012B2;
-USE REPORT;
-PROCEDURE CA1012B4M IS
-
- N : INTEGER := 1;
-
- SUBTYPE S50 IS INTEGER RANGE 1..50;
-
- PROCEDURE P IS NEW CA1012B0 (S50);
-
- FUNCTION F IS NEW CA1012B2 (INTEGER);
-
-BEGIN
- TEST ("CA1012B", "SEPARATELY COMPILED GENERIC SUBPROGRAM " &
- "DECLARATIONS AND BODIES");
-
- P(N);
- IF N /= 2 THEN
- FAILED ("PROCEDURE NOT INVOKED");
- END IF;
-
- N := 1;
- IF F(N) /= 2 THEN
- FAILED ("FUNCTION NOT INVOKED");
- END IF;
-
- RESULT;
-
-END CA1012B4M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada
deleted file mode 100644
index 937c25f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- CA1013A0.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.
---*
--- WKB 7/20/81
--- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-
-GENERIC
- TYPE ELEM IS RANGE <>;
-PACKAGE CA1013A0 IS
-
- I : ELEM;
-
- PROCEDURE REQUIRE_BODY;
-
-END CA1013A0;
-
-
-PACKAGE BODY CA1013A0 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
-BEGIN
-
- I := 1;
-
-END CA1013A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada
deleted file mode 100644
index ddea320..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada
+++ /dev/null
@@ -1,39 +0,0 @@
--- CA1013A1.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.
---*
--- WKB 7/20/81
-
-
-GENERIC
- TYPE INDEX IS RANGE <>;
-PROCEDURE CA1013A1 (I : IN OUT INDEX);
-
-
-PROCEDURE CA1013A1 (I : IN OUT INDEX) IS
-
-BEGIN
-
- I := I + 1;
-
-END CA1013A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada
deleted file mode 100644
index a6843a8..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada
+++ /dev/null
@@ -1,39 +0,0 @@
--- CA1013A2.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.
---*
--- WKB 7/20/81
-
-
-GENERIC
- TYPE ITEM IS RANGE <>;
-FUNCTION CA1013A2 RETURN ITEM;
-
-
-FUNCTION CA1013A2 RETURN ITEM IS
-
-BEGIN
-
- RETURN 2;
-
-END CA1013A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada
deleted file mode 100644
index a4a805b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada
+++ /dev/null
@@ -1,31 +0,0 @@
--- CA1013A3.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.
---*
--- WKB 7/20/81
--- SPS 10/27/82
--- JBG 9/15/83
-
-WITH CA1013A0;
-PRAGMA ELABORATE (CA1013A0);
-PACKAGE CA1013A3 IS NEW CA1013A0 (INTEGER);
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada
deleted file mode 100644
index 9828c03..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada
+++ /dev/null
@@ -1,31 +0,0 @@
--- CA1013A4.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.
---*
--- WKB 7/20/81
--- SPS 10/27/82
--- JBG 9/15/83
-
-WITH CA1013A1;
-PRAGMA ELABORATE (CA1013A1);
-PROCEDURE CA1013A4 IS NEW CA1013A1 (INTEGER);
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada
deleted file mode 100644
index bc85853..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada
+++ /dev/null
@@ -1,30 +0,0 @@
--- CA1013A5.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.
---*
--- WKB 7/20/81
--- JBG 9/15/83
-
-WITH CA1013A2;
-PRAGMA ELABORATE (CA1013A2);
-FUNCTION CA1013A5 IS NEW CA1013A2 (INTEGER);
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada
deleted file mode 100644
index 16c266e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- CA1013A6M.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 GENERIC PACKAGE OR SUBPROGRAM INSTANTIATION
--- CAN BE SUBMITTED FOR SEPARATE COMPILATION.
-
--- SEPARATE FILES ARE:
--- CA1013A0 A LIBRARY GENERIC PACKAGE.
--- CA1013A1 A LIBRARY GENERIC PROCEDURE.
--- CA1013A2 A LIBRARY GENERIC FUNCTION.
--- CA1013A3 A LIBRARY GENERIC PACKAGE INSTANTIATION.
--- CA1013A4 A LIBRARY GENERIC PROCEDURE INSTANTIATION.
--- CA1013A5 A LIBRARY GENERIC FUNCTION INSTANTIATION.
--- CA1013A6M THE MAIN PROCEDURE.
-
--- WKB 7/20/81
--- SPS 11/5/82
-
-WITH REPORT;
-WITH CA1013A3, CA1013A4, CA1013A5;
-USE REPORT;
-PROCEDURE CA1013A6M IS
-
- J : INTEGER := 1;
-
-BEGIN
- TEST ("CA1013A", "GENERIC INSTANTIATIONS SUBMITTED " &
- "FOR SEPARATE COMPILATION");
-
- IF CA1013A3.I /= 1 THEN
- FAILED ("PACKAGE NOT ACCESSED");
- END IF;
-
- CA1013A4 (J);
- IF J /= 2 THEN
- FAILED ("PROCEDURE NOT INVOKED");
- END IF;
-
- IF CA1013A5 /= 2 THEN
- FAILED ("FUNCTION NOT INVOKED");
- END IF;
-
- RESULT;
-END CA1013A6M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada
deleted file mode 100644
index cf5e93d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CA1014A0M.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 SUBUNIT CAN BE SUBMITTED FOR COMPILATION
--- SEPARATELY FROM ITS PARENT UNIT.
-
--- SEPARATE FILES ARE:
--- CA1014A0M THE MAIN PROCEDURE.
--- CA1014A1 A SUBUNIT PROCEDURE BODY.
--- CA1014A2 A SUBUNIT PACKAGE BODY.
--- CA1014A3 A SUBUNIT FUNCTION BODY.
-
--- JRK 5/20/81
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CA1014A0M IS
-
- I : INTEGER := 0;
-
- PACKAGE CALL_TEST IS
- END CALL_TEST;
-
- PACKAGE BODY CALL_TEST IS
- BEGIN
- TEST ("CA1014A", "SUBUNITS SUBMITTED FOR COMPILATION " &
- "SEPARATELY FROM PARENT UNIT");
- END CALL_TEST;
-
- PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS SEPARATE;
-
- PACKAGE CA1014A2 IS
- I : INTEGER := 10;
- PROCEDURE P (I : IN OUT INTEGER);
- END CA1014A2;
-
- PACKAGE BODY CA1014A2 IS SEPARATE;
-
- FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS SEPARATE;
-
-BEGIN
-
- CA1014A1 (I);
- IF I /= 1 THEN
- FAILED ("SUBUNIT PROCEDURE NOT ELABORATED/EXECUTED");
- END IF;
-
- IF CA1014A2.I /= 15 THEN
- FAILED ("SUBUNIT PACKAGE BODY NOT ELABORATED/EXECUTED");
- END IF;
-
- I := 0;
- CA1014A2.P (I);
- IF I /= -20 THEN
- FAILED ("SUBUNIT PACKAGED PROCEDURE NOT ELABORATED/EXECUTED");
- END IF;
-
- IF CA1014A3(50) /= -50 THEN
- FAILED ("SUBUNIT FUNCTION NOT ELABORATED/EXECUTED");
- END IF;
-
- RESULT;
-END CA1014A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada
deleted file mode 100644
index d66b677..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA1014A1.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.
---*
--- JRK 5/20/81
-
-SEPARATE (CA1014A0M)
-PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS
-
-BEGIN
-
- I := I + 1;
-
-END CA1014A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada
deleted file mode 100644
index 9c23ef1..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada
+++ /dev/null
@@ -1,39 +0,0 @@
--- CA1014A2.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.
---*
--- JRK 5/20/81
-
-SEPARATE (CA1014A0M)
-PACKAGE BODY CA1014A2 IS
-
- PROCEDURE P (I : IN OUT INTEGER) IS
- BEGIN
- I := I - 20;
- END P;
-
-BEGIN
-
- I := I + 5;
-
-END CA1014A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada
deleted file mode 100644
index cd76acc..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA1014A3.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.
---*
--- JRK 5/20/81
-
-SEPARATE (CA1014A0M)
-FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS
-
-BEGIN
-
- RETURN -I;
-
-END CA1014A3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada
deleted file mode 100644
index 93ecc02..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- CA1020E0.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 SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
--- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
--- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS.
-
--- HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
--- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
--- DECLARED WITHOUT A BODY.
-
-GENERIC
- C : INTEGER;
-PROCEDURE GENPROC_CA1020E (X : OUT INTEGER);
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE GENPROC_CA1020E (X : OUT INTEGER) IS
-BEGIN
- X := IDENT_INT(C);
-END GENPROC_CA1020E;
-
-GENERIC
-FUNCTION GENFUNC_CA1020E RETURN INTEGER;
-
-FUNCTION GENFUNC_CA1020E RETURN INTEGER IS
-BEGIN
- RETURN 2;
-END GENFUNC_CA1020E;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada
deleted file mode 100644
index e5df714..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- CA1020E1.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 SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
--- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
--- SUBPROGRAMS TO BE REPLACED BY LATER GENERIC INSTANTIATIONS.
-
--- HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
--- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
--- DECLARED WITHOUT A BODY.
-
-PROCEDURE CA1020E_PROC1 (X : OUT INTEGER) IS
-BEGIN
- X := 3;
-END CA1020E_PROC1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA1020E_FUNC1 RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END CA1020E_FUNC1;
-
-PROCEDURE CA1020E_PROC2 (X : OUT INTEGER);
-PROCEDURE CA1020E_PROC2 (X : OUT INTEGER) IS
-BEGIN
- X := 3;
-END CA1020E_PROC2;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA1020E_FUNC2 RETURN FLOAT IS
-BEGIN
- RETURN FLOAT(IDENT_INT(4));
-END CA1020E_FUNC2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada
deleted file mode 100644
index 7497804..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- CA1020E2.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 SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
--- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
--- GENERIC INSTANTIATIONS REPLACING LIBRARY UNITS CREATED IN
--- CA1020E1.
-
--- HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
--- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
--- DECLARED WITHOUT A BODY.
-
-WITH GENPROC_CA1020E;
-PRAGMA ELABORATE (GENPROC_CA1020E);
-PROCEDURE CA1020E_PROC1 IS NEW GENPROC_CA1020E(1);
-
-WITH GENFUNC_CA1020E;
-PRAGMA ELABORATE (GENFUNC_CA1020E);
-FUNCTION CA1020E_FUNC1 IS NEW GENFUNC_CA1020E;
-
-WITH GENPROC_CA1020E;
-PRAGMA ELABORATE (GENPROC_CA1020E);
-PROCEDURE CA1020E_PROC2 IS NEW GENPROC_CA1020E(5);
-
-WITH GENFUNC_CA1020E;
-PRAGMA ELABORATE (GENFUNC_CA1020E);
-FUNCTION CA1020E_FUNC2 IS NEW GENFUNC_CA1020E;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada
deleted file mode 100644
index e8ad70f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CA1020E3M.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 SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
--- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
--- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS.
-
--- SEPARATE FILES ARE:
--- CA1020E0 -- GENERIC UNITS GENPROC_CA1020E AND GENFUNC_CA1020E.
--- CA1020E1 -- SUBPROGRAM LIBRARY UNIT BODIES (CA1020E_PROC1,
--- CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2).
--- CA1020E2 -- INSTANTIATIONS REPLACING UNITS COMPILED IN CA1020E1.
--- CA1020E3M -- MAIN PROGRAM.
-
--- HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
--- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
--- DECLARED WITHOUT A BODY.
-
-WITH REPORT; USE REPORT;
-WITH CA1020E_PROC1, CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2;
-PROCEDURE CA1020E3M IS
- TEMP : INTEGER := 0;
-BEGIN
- TEST ("CA1020E", "CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE " &
- "REPLACED BY A GENERIC INSTANTIATION HAVING " &
- "THE SAME IDENTIFIER");
-
- CA1020E_PROC1 (TEMP);
- IF TEMP /= IDENT_INT(1) THEN
- FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE");
- END IF;
-
- IF CA1020E_FUNC1 /= IDENT_INT(2) THEN
- FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION");
- END IF;
-
- CA1020E_PROC2 (TEMP);
- IF TEMP /= IDENT_INT(5) THEN
- FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE");
- END IF;
-
- IF CA1020E_FUNC2 /= IDENT_INT(2) THEN
- FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION");
- END IF;
-
- RESULT;
-END CA1020E3M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada
deleted file mode 100644
index c3788cc..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada
+++ /dev/null
@@ -1,43 +0,0 @@
--- CA1022A0.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.
---*
--- BHS 7/23/84
-
-PACKAGE CA1022A0 IS
-
- I : INTEGER := 2;
- PROCEDURE P0 (X : IN OUT INTEGER );
-
-END CA1022A0;
-
-PACKAGE BODY CA1022A0 IS
-
- PROCEDURE P0 (X : IN OUT INTEGER) IS
- BEGIN
-
- X := X + 1;
-
- END P0;
-
-END CA1022A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada
deleted file mode 100644
index 89ea748..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada
+++ /dev/null
@@ -1,33 +0,0 @@
--- CA1022A1.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.
---*
--- BHS 7/23/84
-
-WITH CA1022A0;
-PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS
-BEGIN
-
- CA1022A0.P0 (Y);
-
-END CA1022A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada
deleted file mode 100644
index c7e874b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada
+++ /dev/null
@@ -1,33 +0,0 @@
--- CA1022A2.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.
---*
--- BHS 7/23/84
-
-WITH CA1022A0;
-FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS
-BEGIN
-
- RETURN TRUE;
-
-END CA1022A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada
deleted file mode 100644
index 6c5e9de..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- CA1022A3.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.
---*
--- RECOMPILATION OF PACKAGE CA1022A0.
-
--- BHS 7/23/84
-
-PACKAGE CA1022A0 IS
-
- I, J : INTEGER;
- PROCEDURE P0 (X : IN OUT INTEGER);
- FUNCTION F RETURN INTEGER;
-
-END CA1022A0;
-
-PACKAGE BODY CA1022A0 IS
-
- PROCEDURE P0 (X : IN OUT INTEGER) IS
- BEGIN
-
- X := X + 2;
-
- END P0;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
-
- RETURN 3;
-
- END F;
-
-END CA1022A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada
deleted file mode 100644
index 17837a6..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA1022A4.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.
---*
--- RECOMPILATION OF PROCEDURE CA1022A1.
-
--- BHS 7/23/84
-
-WITH CA1022A0;
-PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS
-BEGIN
-
- Y := 3;
- CA1022A0.P0 (Y);
-
-END CA1022A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada
deleted file mode 100644
index 005748ee..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA1022A5.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.
---*
--- RECOMPILATION OF FUNCTION CA1022A2 (DECL AND BODY).
-
--- BHS 7/23/84
-
-FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS
-BEGIN
-
- RETURN Z /= 1;
-
-END CA1022A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada
deleted file mode 100644
index b011c9bc..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CA1022A6M.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 SUBPROGRAM BODY IS INITIALLY COMPILED WITH A CONTEXT
--- CLAUSE AND A UNIT NAMED IN THE CONTEXT CLAUSE IS RECOMPILED, THEN AN
--- ATTEMPT TO COMPILE THE BODY AGAIN WILL SUCCEED IF THE CONTEXT CLAUSE
--- IS PRESENT.
--- CHECK THAT IF THE RECOMPILED UNIT IS NOT NEEDED IN THE SUBPROGRAM
--- BODY, THE BODY CAN BE SUCCESSFULLY RECOMPILED WITHOUT MENTIONING THE
--- RECOMPILED UNIT.
-
--- SEPARATE FILES ARE:
--- CA1022A0 A LIBRARY PACKAGE.
--- CA1022A1 A LIBRARY PROCEDURE.
--- CA1022A2 A LIBRARY FUNCTION.
--- CA1022A3 A LIBRARY PACKAGE (CA1022A0).
--- CA1022A4 A LIBRARY PROCEDURE (CA1022A1).
--- CA1022A5 A LIBRARY FUNCTION (CA1022A2).
--- CA1022A6M THE MAIN PROCEDURE.
-
--- BHS 7/23/84
-
-WITH CA1022A1, CA1022A2;
-WITH REPORT; USE REPORT;
-PROCEDURE CA1022A6M IS
-
- I : INTEGER := 1;
-
-BEGIN
-
- TEST ("CA1022A", "USE OF CONTEXT CLAUSES NAMING RECOMPILED " &
- "UNITS WITH RECOMPILED SUBPROGRAMS");
-
- CA1022A1(I);
- IF I /= 5 THEN
- FAILED ("PROCEDURE CA1022A1 NOT INVOKED CORRECTLY");
- END IF;
-
- IF CA1022A2 THEN
- FAILED ("FUNCTION CA1022A2 NOT INVOKED CORRECTLY");
- END IF;
-
- RESULT;
-
-END CA1022A6M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11001.a b/gcc/testsuite/ada/acats/tests/ca/ca11001.a
deleted file mode 100644
index c9d1e48..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11001.a
+++ /dev/null
@@ -1,276 +0,0 @@
--- CA11001.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 child unit can be used to provide an alternate view and
--- operations on a private type in its parent package. Check that a
--- child unit can be a package. Check that a WITH of a child unit
--- includes an implicit WITH of its ancestor unit.
---
--- TEST DESCRIPTION:
--- Declare a private type in a package specification. Declare
--- subprograms for the type.
---
--- Add a public child to the above package. Within the body of this
--- package, access the private type. Declare operations to read and
--- write to its parent private type.
---
--- In the main program, "with" the child. Declare objects of the
--- parent private type. Access the subprograms from both parent and
--- child packages.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11001_0 is -- Cartesian_Complex
--- This package represents a Cartesian view of a complex number. It contains
--- a private type plus subprograms to construct and decompose a complex
--- number.
-
- type Complex_Int is range 0 .. 100;
-
- type Complex_Type is private;
-
- Constant_Complex : constant Complex_Type;
-
- Complex_Error : exception;
-
- procedure Cartesian_Assign (R, I : in Complex_Int;
- C : out Complex_Type);
-
- function Cartesian_Real_Part (C : Complex_Type)
- return Complex_Int;
-
- function Cartesian_Imag_Part (C : Complex_Type)
- return Complex_Int;
-
- function Complex (Real, Imaginary : Complex_Int)
- return Complex_Type;
-
-private
- type Complex_Type is -- Parent private type
- record
- Real, Imaginary : Complex_Int;
- end record;
-
- Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0);
-
-end CA11001_0; -- Cartesian_Complex
-
---=======================================================================--
-
-package body CA11001_0 is -- Cartesian_Complex
-
- procedure Cartesian_Assign (R, I : in Complex_Int;
- C : out Complex_Type) is
- begin
- C.Real := R;
- C.Imaginary := I;
- end Cartesian_Assign;
- -------------------------------------------------------------
- function Cartesian_Real_Part (C : Complex_Type)
- return Complex_Int is
- begin
- return C.Real;
- end Cartesian_Real_Part;
- -------------------------------------------------------------
- function Cartesian_Imag_Part (C : Complex_Type)
- return Complex_Int is
- begin
- return C.Imaginary;
- end Cartesian_Imag_Part;
- -------------------------------------------------------------
- function Complex (Real, Imaginary : Complex_Int)
- return Complex_Type is
- begin
- return (Real, Imaginary);
- end Complex;
-
-end CA11001_0; -- Cartesian_Complex
-
---=======================================================================--
-
-package CA11001_0.CA11001_1 is -- Polar_Complex
--- This public child provides a different view of the private type from its
--- parent. It provides a polar view by the provision of subprograms which
--- construct and decompose a complex number.
-
- procedure Polar_Assign (R, Theta : in Complex_Int;
- C : out Complex_Type);
- -- Complex_Type is a
- -- record of CA11001_0
-
- function Polar_Real_Part (C: Complex_Type) return Complex_Int;
-
- function Polar_Imag_Part (C: Complex_Type) return Complex_Int;
-
- function Equals_Const (Num : Complex_Type) return Boolean;
-
-end CA11001_0.CA11001_1; -- Polar_Complex
-
---=======================================================================--
-
-package body CA11001_0.CA11001_1 is -- Polar_Complex
-
- function Cos (Angle : Complex_Int) return Complex_Int is
- Num : constant Complex_Int := 2;
- begin
- return (Angle * Num); -- not true Cosine function
- end Cos;
- -------------------------------------------------------------
- function Sine (Angle : Complex_Int) return Complex_Int is
- begin
- return 1; -- not true Sine function
- end Sine;
- -------------------------------------------------------------
- function Sqrt (Num : Complex_Int)
- return Complex_Int is
- begin
- return (Num); -- not true Square root function
- end Sqrt;
- -------------------------------------------------------------
- function Tan (Angle : Complex_Int) return Complex_Int is
- begin
- return Angle; -- not true Tangent function
- end Tan;
- -------------------------------------------------------------
- procedure Polar_Assign (R, Theta : in Complex_Int;
- C : out Complex_Type) is
- begin
- if R = 0 and Theta = 0 then
- raise Complex_Error;
- end if;
- C.Real := R * Cos (Theta);
- C.Imaginary := R * Sine (Theta);
- end Polar_Assign;
- -------------------------------------------------------------
- function Polar_Real_Part (C: Complex_Type) return Complex_Int is
- begin
- return Sqrt ((Cartesian_Imag_Part (C)) ** 2 +
- (Cartesian_Real_Part (C)) ** 2);
- end Polar_Real_Part;
- -------------------------------------------------------------
- function Polar_Imag_Part (C: Complex_Type) return Complex_Int is
- begin
- return (Tan (Cartesian_Imag_Part (C) /
- Cartesian_Real_Part (C)));
- end Polar_Imag_Part;
- -------------------------------------------------------------
- function Equals_Const (Num : Complex_Type) return Boolean is
- begin
- return Num.Real = Constant_Complex.Real and
- Num.Imaginary = Constant_Complex.Imaginary;
- end Equals_Const;
-
-end CA11001_0.CA11001_1; -- Polar_Complex
-
---=======================================================================--
-
-with CA11001_0.CA11001_1; -- Polar_Complex
-with Report;
-
-procedure CA11001 is
-
- Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a
- -- record of CA11001_0
-
- Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2);
-
- Int_2 : CA11001_0.Complex_Int
- := CA11001_0.Complex_Int (Report.Ident_Int (2));
-
-begin
-
- Report.Test ("CA11001", "Check that a child unit can be used " &
- "to provide an alternate view and operations " &
- "on a private type in its parent package");
-
- Basic_View_Subtest:
-
- begin
- -- Assign using Cartesian coordinates.
- CA11001_0.Cartesian_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No);
-
- -- Read back in Polar coordinates.
- -- Polar values are surrogates used in checking for correct
- -- subprogram calls.
- if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No),
- CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/="
- (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No),
- CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then
- Report.Failed ("Incorrect Cartesian result");
- end if;
-
- end Basic_View_Subtest;
- -------------------------------------------------------------
- Alternate_View_Subtest:
- begin
- -- Assign using Polar coordinates.
- CA11001_0.CA11001_1.Polar_Assign
- (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No);
-
- -- Read back in Cartesian coordinates.
- if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part
- (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or
- CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2)
- then
- Report.Failed ("Incorrect Polar result");
- end if;
- end Alternate_View_Subtest;
- -------------------------------------------------------------
- Other_Subtest:
- begin
- -- Assign using Polar coordinates.
- CA11001_0.CA11001_1.Polar_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No);
-
- -- Compare with Complex_Num in CA11001_0.
- if not CA11001_0.CA11001_1.Equals_Const (Complex_No)
- then
- Report.Failed ("Incorrect result");
- end if;
- end Other_Subtest;
- -------------------------------------------------------------
- Exception_Subtest:
- begin
- -- Raised parent's exception.
- CA11001_0.CA11001_1.Polar_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (0)),
- CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No);
- Report.Failed ("Exception was not raised");
- exception
- when CA11001_0.Complex_Error =>
- null;
- when others =>
- Report.Failed ("Unexpected exception raised in test");
- end Exception_Subtest;
-
- Report.Result;
-
-end CA11001;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11002.a b/gcc/testsuite/ada/acats/tests/ca/ca11002.a
deleted file mode 100644
index 189e194..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11002.a
+++ /dev/null
@@ -1,238 +0,0 @@
--- CA11002.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 public child can utilize its parent unit's visible
--- definitions.
---
--- TEST DESCRIPTION:
--- Declare a parent package that contains the following: type, object,
--- constant, exception, and subprograms. Declare a public child unit
--- that utilizes the components found in the visible part of its parent.
---
--- Demonstrate utilization of the following parent components in the
--- child package:
---
--- Parent
--- Type X
--- Constant X
--- Object X
--- Subprogram X
--- Exception X
---
--- This abstraction simulates a portion of a simple operating system.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11002_0 is -- Package OS.
-
- type File_Descriptor is new Integer;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Only;
- Active_Mode : constant File_Mode := Read_Write;
-
- type File_Type is
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- end record;
-
- System_File : File_Type;
- File_Mode_Error : exception;
-
- function Next_Available_File return File_Descriptor;
-
- function Mode_Of_File (File : File_Type) return File_Mode;
-
-end CA11002_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11002_0 is -- Package body OS.
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count)); -- Type conversion.
- end Next_Available_File;
- --------------------------------------------------------------
- function Mode_Of_File (File : File_Type) return File_Mode is
- Mode : File_Mode := File.Mode;
- begin
- return (Mode);
- end Mode_Of_File;
-
-end CA11002_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11002_0.CA11002_1 is -- Child package OS.Operations.
-
- -- Dot qualification of types, objects, etc. from parent is not required
- -- in a child unit.
-
- procedure Create_File (Mode : in File_Mode:= Active_Mode;
- File : out File_Type);
-
-end CA11002_0.CA11002_1; -- Child package OS.Operations.
-
- --=================================================================--
-
-with Report;
-package body CA11002_0.CA11002_1 is -- Child package body OS.Operations.
-
- function New_File_Validated (File : File_Type) -- Ensure that a newly
- return Boolean is -- created file has
- Result : Boolean := False; -- appropriate values.
- begin
- if (File.Descriptor > System_File.Descriptor) and -- Parent object.
- (File.Mode in File_Mode ) -- Parent type.
- then
- Result := True;
- end if;
-
- return (Result);
-
- end New_File_Validated;
- --------------------------------------------------------------
- procedure Create_File
- (Mode : in File_Mode := Active_Mode; -- Parent constant.
- File : out File_Type) is -- Parent type.
-
- New_File : File_Type;
-
- begin
- New_File.Descriptor := Next_Available_File; -- Parent subprogram.
- New_File.Mode := Mode;
-
- if New_File_Validated (File => New_File) then
- File := New_File;
- end if;
-
- end Create_File;
-
-end CA11002_0.CA11002_1; -- Child Package body OS.Operations.
-
- --=================================================================--
-
--- Child library subprogram Convert_File_Mode specification.
-procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type.
- New_Mode : in File_Mode); -- Parent type.
-
-
- --=================================================================--
-with Report;
-
--- Child library subprogram Convert_File_Mode body.
-procedure CA11002_0.CA11002_2 (File : in out File_Type;
- New_Mode : in File_Mode) is
-begin
- if File.Mode = New_Mode then
- raise File_Mode_Error; -- Parent exception.
- Report.Failed ("Exception not raised in child unit");
- else
- File.Mode := New_Mode;
- end if;
-end CA11002_0.CA11002_2;
-
- --=================================================================--
-
-with Report;
-with CA11002_0.CA11002_1; -- Child package OS.Operations.
-with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode,
- -- Implicitly with parent, OS.
-use CA11002_0; -- All user-defined operators directly
- -- visible.
-procedure CA11002 is
-begin
-
- Report.Test ("CA11002", "Check that a public child can utilize its " &
- "parent unit's visible definitions");
-
- File_Creation: -- This processing block will demonstrate
- -- use of child package subroutine that
- -- takes advantage of components declared
- -- in the parent package.
- declare
- User_File : File_Type;
- begin
- CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode
- -- parameter used in
- -- this call.
- if (User_File.Descriptor = System_File.Descriptor) or
- (User_File.Mode = Default_Mode)
- then
- Report.Failed ("Incorrect file creation");
- end if;
-
- end File_Creation;
-
- --------------------------------------------------------------
- File_Mode_Conversion: -- This processing block will demonstrate
- -- the occurrence of a (forced) exception
- -- being raised in a child subprogram, and
- -- propagated to the caller. The exception
- -- is handled, and the child subprogram
- -- is called again, this time to perform
- -- without error.
- declare
- procedure Convert_File_Mode (File : in out File_Type;
- New_Mode : in File_Mode) renames CA11002_0.CA11002_2;
- New_File : File_Type;
- begin -- Raise an exception with this
- -- illegal conversion operation
- -- (attempt to change to current mode).
-
- Convert_File_Mode (File => New_File,
- New_Mode => Default_Mode);
- Report.Failed ("Exception should have been raised in child unit");
-
- exception
- when File_Mode_Error => -- Perform the conversion again, this
- -- time with a different file mode.
-
- Convert_File_Mode (File => New_File,
- New_Mode => CA11002_0.Active_Mode);
-
- if New_File.Mode /= Read_Write then
- Report.Failed ("Incorrect result from mode conversion operation");
- end if;
-
- when others =>
- Report.Failed ("Unexpected exception raised in File_Mode_Conversion");
-
- end File_Mode_Conversion;
-
- Report.Result;
-
-end CA11002;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11003.a b/gcc/testsuite/ada/acats/tests/ca/ca11003.a
deleted file mode 100644
index ff89425..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11003.a
+++ /dev/null
@@ -1,290 +0,0 @@
--- CA11003.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 public grandchild can utilize its ancestor unit's visible
--- definitions.
---
--- TEST DESCRIPTION:
--- Declare a public package, public child package, and public
--- grandchild package and library unit function. Within the
--- grandchild package and function, make use of components that are
--- declared in the ancestor packages, both parent and grandparent.
---
--- Use the following ancestral components in the grandchildren library
--- units:
--- Grandparent Parent
--- Type X X
--- Constant X X
--- Object X X
--- Subprogram X X
--- Exception X X
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified procedure Create_File
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11003_0 is -- Package OS
-
- type File_Descriptor is new Integer;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Only;
- File_Data_Error : exception;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Read_Write;
- end record;
-
- System_File : File_Type;
-
- function Next_Available_File return File_Descriptor;
-
- procedure Reclaim_File_Descriptor;
-
-end CA11003_0; -- Package OS
-
- --=================================================================--
-
-package body CA11003_0 is -- Package body OS
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count));
- end Next_Available_File;
- --------------------------------------------------
- procedure Reclaim_File_Descriptor is
- begin
- null; -- Dummy processing unit.
- end Reclaim_File_Descriptor;
-
-end CA11003_0; -- Package body OS
-
- --=================================================================--
-
-package CA11003_0.CA11003_1 is -- Child package OS.Operations
-
- subtype File_Length_Type is Integer range 0 .. 1000;
- Min_File_Size : File_Length_Type := File_Length_Type'First;
- Max_File_Size : File_Length_Type := File_Length_Type'Last;
-
- File_Duplication_Error : exception;
-
- type Extended_File_Type is new File_Type with private;
-
- procedure Create_File (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Duplicate_File (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type);
-
-private
- type Extended_File_Type is new File_Type with
- record
- Blocks : File_Length_Type := Min_File_Size;
- end record;
-
- System_Extended_File : Extended_File_Type;
-
-end CA11003_0.CA11003_1; -- Child Package OS.Operations
-
- --=================================================================--
-
-package body CA11003_0.CA11003_1 is -- Child package body OS.Operations
-
- procedure Create_File
- (Mode : in File_Mode;
- File : out Extended_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Parent subprogram.
- File.Mode := Default_Mode; -- Parent constant.
- File.Blocks := Min_File_Size;
- end Create_File;
- --------------------------------------------------
- procedure Duplicate_File (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type) is
- begin
- Duplicate.Descriptor := Next_Available_File; -- Parent subprogram.
- Duplicate.Mode := Original.Mode;
- Duplicate.Blocks := Original.Blocks;
- end Duplicate_File;
-
-end CA11003_0.CA11003_1; -- Child package body OS.Operations
-
- --=================================================================--
-
--- This package contains menu selectable operations for manipulating files.
--- This abstraction builds on the capabilities available from ancestor
--- packages.
-
-package CA11003_0.CA11003_1.CA11003_2 is
-
- procedure News (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Copy (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type);
-
- procedure Delete (File : in Extended_File_Type);
-
-end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu
-
- --=================================================================--
-
--- Grandchild subprogram Validate
-function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type)
- return Boolean;
-
- --=================================================================--
-
--- Grandchild subprogram Validate
-function CA11003_0.CA11003_1.CA11003_3
- (File : in Extended_File_Type) -- Parent type.
- return Boolean is
-
- function New_File_Validated (File : Extended_File_Type)
- return Boolean is
- begin
- if (File.Descriptor > System_File.Descriptor) and -- Grandparent
- (File.Mode in File_Mode ) and -- object and type
- not ((File.Blocks < System_Extended_File.Blocks) or
- (File.Blocks > Max_File_Size)) -- Parent object
- then -- and constant.
- return True;
- else
- return False;
- end if;
- end New_File_Validated;
-
-begin
- return (New_File_Validated (File)) and
- (File.Descriptor /= Null_File); -- Grandparent constant.
-
-end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate
-
- --=================================================================--
-
-with CA11003_0.CA11003_1.CA11003_3;
- -- Grandchild package body OS.Operations.Menu
-package body CA11003_0.CA11003_1.CA11003_2 is
-
- procedure News (Mode : in File_Mode;
- File : out Extended_File_Type) is -- Parent type.
- begin
- Create_File (Mode, File); -- Parent subprogram.
- if not CA11003_0.CA11003_1.CA11003_3 (File) then
- raise File_Data_Error; -- Grandparent exception.
- end if;
- end News;
- --------------------------------------------------
- procedure Copy (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type) is
- begin
- Duplicate_File (Original, Duplicate); -- Parent subprogram.
-
- if Original.Descriptor = Duplicate.Descriptor then
- raise File_Duplication_Error; -- Parent exception.
- end if;
-
- end Copy;
- --------------------------------------------------
- procedure Delete (File : in Extended_File_Type) is
- begin
- Reclaim_File_Descriptor; -- Grandparent
- end Delete; -- subprogram.
-
-end CA11003_0.CA11003_1.CA11003_2;
-
- --=================================================================--
-
-with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu
-with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate
-with Report;
-
-procedure CA11003 is
-
- package Menu renames CA11003_0.CA11003_1.CA11003_2;
-
-begin
-
- Report.Test ("CA11003", "Check that a public grandchild can utilize " &
- "its ancestor unit's visible definitions");
-
- File_Processing: -- Validate all of the capabilities contained in
- -- the Menu package by exercising them on specific
- -- files. This will demonstrate the use of child
- -- and grandchild functionality based on components
- -- that have been declared in the
- -- parent/grandparent package.
- declare
-
- function Validate (File : CA11003_0.CA11003_1.Extended_File_Type)
- return Boolean renames CA11003_0.CA11003_1.CA11003_3;
-
- MacWrite_File,
- Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type;
- MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write;
-
- begin
-
- Menu.News (MacWrite_File_Mode, MacWrite_File);
-
- if not Validate (MacWrite_File) then
- Report.Failed ("Incorrect initialization of files");
- end if;
-
- Menu.Copy (MacWrite_File, Backup_Copy);
-
- if not (Validate (MacWrite_File) and
- Validate (Backup_Copy))
- then
- Report.Failed ("Incorrect duplication of files");
- end if;
-
- Menu.Delete (Backup_Copy);
-
- exception
- when CA11003_0.File_Data_Error =>
- Report.Failed ("Exception raised during file validation");
- when CA11003_0.CA11003_1.File_Duplication_Error =>
- Report.Failed ("Exception raised during file duplication");
- when others =>
- Report.Failed ("Unexpected exception in test procedure");
-
- end File_Processing;
-
- Report.Result;
-
-end CA11003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110040.a b/gcc/testsuite/ada/acats/tests/ca/ca110040.a
deleted file mode 100644
index 72cc668..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110040.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- CA110040.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:
--- See CA110042.AM
---
--- TEST DESCRIPTION:
--- See CA110042.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- => CA110040.A
--- CA110041.A
--- CA110042.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
--- Elaborate_Body.
---
---!
-
-package CA110040 is -- Package Computer_System.
- pragma Elaborate_Body (CA110040);
-
- -- Types.
- type ID_Type is range 1 .. 4;
- type System_Account_Capacity is new ID_Type;
-
- type Account is tagged
- record
- User_ID : ID_Type;
- end record;
-
- -- Constants.
- Maximum_System_Accounts : constant System_Account_Capacity :=
- System_Account_Capacity'Last;
-
- System_Administrator : constant ID_Type :=
- ID_Type (System_Account_Capacity'First);
-
- Administrator_Account : constant Account :=
- (User_ID => System_Administrator);
-
- -- Objects.
- Total_Accounts : System_Account_Capacity := 1;
-
- -- Exceptions.
- Illegal_Account : exception;
- Account_Limit_Exceeded : exception;
-
- -- Subprograms.
- function Next_Available_ID return ID_Type;
-
-end CA110040; -- Package Computer_System.
-
- --=================================================================--
-
-package body CA110040 is -- Package body Computer_System.
-
- function Next_Available_ID return ID_Type is
- begin
- Total_Accounts := Total_Accounts + 1;
- return (ID_Type(Total_Accounts));
- end Next_Available_ID;
-
-end CA110040; -- Package body Computer_System.
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110041.a b/gcc/testsuite/ada/acats/tests/ca/ca110041.a
deleted file mode 100644
index 954df7f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110041.a
+++ /dev/null
@@ -1,118 +0,0 @@
--- CA110041.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:
--- See CA110042.AM
---
--- TEST DESCRIPTION:
--- See CA110042.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CA110040.A
--- => CA110041.A
--- CA110042.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-package CA110040.CA110041 is -- Child Package Computer_System.Manager
-
- type User_Account is new Account with private;
-
- procedure Initialize_User_Account (Acct : out User_Account);
-
-private
-
--- The private portion of this spec demonstrates that components contained
--- in the visible part of the parent are directly visible in the private
--- part of a public child.
-
- type Account_Access_Type is (None, Guest, User, System);
-
- type User_Account is new Account with -- Parent type.
- record
- Privilege : Account_Access_Type := None;
- end record;
-
- System_Account : User_Account :=
- (User_ID => Administrator_Account.User_ID, -- Parent constant.
- Privilege => System); -- User_ID has been
- -- set to 1.
- Auditor_Account : User_Account :=
- (User_ID => Next_Available_ID, -- Parent function.
- Privilege => System); -- User_ID has been
- -- set to 2.
- Total_Authorized_Accounts : System_Account_Capacity
- renames Total_Accounts; -- Parent object.
-
- Unauthorized_Account : exception
- renames Illegal_Account; -- Parent exception
-
-end CA110040.CA110041; -- Child Package Computer_System.Manager
-
- --=================================================================--
-
- -- Child Package body Computer_System.Manager
-package body CA110040.CA110041 is
-
- function Account_Limit_Reached return Boolean is
- begin
- if Total_Authorized_Accounts = Maximum_System_Accounts then
- return (True);
- else
- return (False);
- end if;
- end Account_Limit_Reached;
- ---------------------------------------------------------------
- function Valid_Account (Acct : User_Account) return Boolean is
- Result : Boolean := False;
- begin
- if (Acct.User_ID /= System_Account.User_ID) and
- (Acct.User_ID /= Auditor_Account.User_ID)
- then
- Result := True;
- end if;
- return (Result);
- end Valid_Account;
- ---------------------------------------------------------------
- procedure Initialize_User_Account (Acct : out User_Account) is
- begin
- if Account_Limit_Reached then
- raise Account_Limit_Exceeded;
- else
- Acct.User_ID := Next_Available_ID;
- Acct.Privilege := User;
- end if;
- if not Valid_Account (Acct) then
- raise Unauthorized_Account;
- end if;
- end Initialize_User_Account;
-
-end CA110040.CA110041; -- Child Package body Computer_System.Manager
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110042.am b/gcc/testsuite/ada/acats/tests/ca/ca110042.am
deleted file mode 100644
index 800ed8a..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110042.am
+++ /dev/null
@@ -1,130 +0,0 @@
--- CA110042.AM
---
--- 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 private part of a child library unit package can
--- utilize its parent unit's visible definitions.
---
--- TEST DESCRIPTION:
--- Declare a public library unit package and child package, with the
--- child package having a private part in the specification. Within
--- this child private part, make use of components that are declared in
--- the visible part of the parent.
---
--- Demonstrate visibility to the following parent components in the
--- child private part:
--- Parent
--- Type X
--- Constant X
--- Object X
--- Subprogram X
--- Exception X
---
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CA110040.A
--- CA110041.A
--- => CA110042.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-with Report;
-with CA110040.CA110041;
-
-procedure CA110042 is
-
- package System_Manager renames CA110040.CA110041;
- use CA110040;
- User1, User2, User3 : System_Manager.User_Account;
-
-begin
-
- Report.Test ("CA110042", "Check that the private part of a child " &
- "library unit package can utilize its " &
- "parent unit's visible definitions");
-
- Assign_New_Accounts: -- This code simulates the entering of new
- -- user accounts into a computer system.
- -- It also simulates the processing that
- -- could occur when the limit on system
- -- accounts has been exceeded.
-
- -- This processing block demonstrates the
- -- use of child package functionality that
- -- takes advantage of components declared in
- -- the parent package.
- begin
-
- if Total_Accounts /= 2 then
- Report.Failed ("Incorrect number of accounts currently allocated");
- end if; -- At this point, both
- -- System_Account and
- -- Auditor_Account have
- -- been declared and
- -- initialized in package
- -- CA110040.CA110041.
-
- System_Manager.Initialize_User_Account (User1); -- User_ID has been
- -- set to 3.
-
- System_Manager.Initialize_User_Account (User2); -- User_ID has been
- -- set to 4, which
- -- is the last value
- -- defined for the
- -- CA110040.ID_Type
- -- range.
-
- System_Manager.Initialize_User_Account (User3); -- This final call will
- -- result in an
- -- Account_Limit_Exceeded
- -- exception being raised.
-
- Report.Failed ("Control should have transferred with exception");
-
- exception
-
- when Account_Limit_Exceeded =>
- if (not (Administrator_Account.User_ID = ID_Type'First)) or
- (User2.User_ID /= CA110040.ID_Type'Last)
- then
- Report.Failed ("Account initialization failure");
- end if;
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Assign_New_Accounts;
-
- if (User1.User_ID /= 3) or (User2.User_ID /= 4) then
- Report.Failed ("Improper initialization of user accounts");
- end if;
-
- Report.Result;
-
-end CA110042;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110050.a b/gcc/testsuite/ada/acats/tests/ca/ca110050.a
deleted file mode 100644
index 8845576..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110050.a
+++ /dev/null
@@ -1,99 +0,0 @@
--- CA110050.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:
--- See CA110051.AM
---
--- TEST DESCRIPTION:
--- See CA110051.AM
---
--- TEST FILES:
--- The test consists of the following files:
---
--- => CA110050.A
--- CA110051.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified discriminant type
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
--- Elaborate_Body.
---
---!
-
-package CA110050_0 is -- Package Messages.
- pragma Elaborate_Body (CA110050_0);
-
- type Descriptor is new Integer;
-
- Null_Descriptor_Value : constant Descriptor := 0;
- Null_Message_Descriptor : constant Descriptor := 0;
-
- type Message_Type is tagged
- record
- Number : Descriptor := Null_Message_Descriptor;
- end record;
-
- function Next_Available_Message return Descriptor;
-
-end CA110050_0; -- Package Messages.
-
- --=================================================================--
-
-package body CA110050_0 is -- Package body Messages.
-
- Message_Count : Integer := 0;
-
- function Next_Available_Message return Descriptor is
- begin
- Message_Count := Message_Count + 5;
- return (Descriptor(Message_Count));
- end Next_Available_Message;
-
-end CA110050_0; -- Package body Messages.
-
- --=================================================================--
-
-package CA110050_0.CA110050_1 is -- Child package Messages.Text
-
- subtype Default_Length is Natural range 0 .. 80;
-
- type Text_Type (Max_Length : Default_Length := 0) is
- record
- Length : Default_Length := Max_Length;
- Text_Field : String (1 .. Max_Length);
- end record;
-
- type Text_Message_Type is new Message_Type with
- record
- Text : Text_Type;
- end record;
-
- Null_Text : Text_Type (0); -- Null range for
- -- Text_Field component.
-
-end CA110050_0.CA110050_1; -- Child package Messages.Text
---
--- No package body needed for this specification.
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110051.am b/gcc/testsuite/ada/acats/tests/ca/ca110051.am
deleted file mode 100644
index 91af068..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110051.am
+++ /dev/null
@@ -1,224 +0,0 @@
--- CA110051.AM
---
--- 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 entities and operations declared in a package can be used
--- in the private part of a child of a child of the package.
---
--- TEST DESCRIPTION:
--- Declare a series of library unit packages -- parent, child, and
--- grandchild. The grandchild package will have a private part.
--- From within the private part of the grandchild, make use of
--- components declared in the parent and grandparent packages.
---
--- TEST FILES:
--- The test consists of the following files:
---
--- CA110050.A
--- => CA110051.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- -- Grandchild Package Message.Text.Encoded
-package CA110050_0.CA110050_1.CA110050_2 is
-
- type Coded_Message is new Text_Message_Type with private;
-
- procedure Send (Message : in Coded_Message;
- Confirm : out Coded_Message;
- Status : out Boolean);
-
- function Encode (Message : Text_Message_Type) return Coded_Message;
- function Decode (Message : Coded_Message) return Boolean;
- function Test_Connection return Boolean;
-
-private
-
- Uncoded : Descriptor renames Null_Descriptor_Value; -- Grandparent object.
-
- type Coded_Message is new Text_Message_Type with -- Parent type.
- record
- Key : Descriptor := Uncoded;
- Coded_Key : Descriptor := Next_Available_Message;
- -- Grandparent type, grandparent function.
- Scrambled : Text_Type := Null_Text; -- Parent object.
- end record;
-
- Coded_Msg : Coded_Message;
-
- type Blank_Message is new Message_Type with -- Grandparent type.
- record
- ID : Descriptor := Next_Available_Message;
- -- Grandparent type, grandparent function.
- end record;
-
- Test_Message : Blank_Message;
-
- Confirm_String : constant String := "OK";
- Scrambled_String : constant String := "KO";
-
- Confirm_Text : Text_Type (Confirm_String'Length) :=
- (Max_Length => Confirm_String'Length,
- Length => Confirm_String'Length,
- Text_Field => Confirm_String);
-
- Scrambled_Text : Text_Type (Scrambled_String'Length) :=
- (Max_Length => Scrambled_String'Length,
- Length => Scrambled_String'Length,
- Text_Field => Scrambled_String);
-
-end CA110050_0.CA110050_1.CA110050_2; -- Grandchild Pkg Message.Text.Encoded
-
- --=================================================================--
-
- -- Grandchild Package body Message.Text.Encoded
-package body CA110050_0.CA110050_1.CA110050_2 is
-
- procedure Send (Message : in Coded_Message;
- Confirm : out Coded_Message;
- Status : out Boolean) is
-
- Confirmation_Message : Coded_Message :=
- (Number => Message.Number,
- Text => Confirm_Text,
- Key => Message.Number,
- Coded_Key => Message.Number,
- Scrambled => Scrambled_Text);
-
- begin -- Dummy processing unit.
- Confirm := Confirmation_Message;
- if Confirm.Number /= Null_Message_Descriptor then
- Status := True;
- else
- Status := False;
- end if;
- end Send;
- -------------------------------------------------------------------------
- function Encode (Message : Text_Message_Type) return Coded_Message is
- begin
- Coded_Msg.Number := Message.Number;
- if Message.Text.Length > 0 then
- Coded_Msg.Text := Message.Text; -- Record assignment.
- Coded_Msg.Key := Message.Number; -- Same as msg number.
- Coded_Msg.Coded_Key := Message.Number; -- Same as msg number.
- Coded_Msg.Scrambled := Message.Text; -- Dummy processing.
- end if;
- return (Coded_Msg);
- end Encode;
- -------------------------------------------------------------------------
- function Decode (Message : Coded_Message) return Boolean is
- Decoded : Boolean := False;
- begin
- if (Message.Text.Length = Confirm_String'Length) and then
- (Message.Text.Text_Field = Confirm_String) and then
- (Message.Scrambled.Length = Scrambled_String'Length) and then
- (Message.Scrambled.Text_Field = Scrambled_String) and then
- (Message.Coded_Key = 15)
- then
- Decoded := True;
- end if;
- return (Decoded);
- end Decode;
- -------------------------------------------------------------------------
- function Test_Connection return Boolean is
- begin
- return Test_Message.Id = 10;
- end Test_Connection;
-
-end CA110050_0.CA110050_1.CA110050_2;
- -- Grandchild Package body Message.Text.Encoded
-
- --=================================================================--
-
-with CA110050_0.CA110050_1.CA110050_2;
-with Report;
-
-procedure CA110051 is
-
- package Message_Package renames CA110050_0.CA110050_1;
- package Code_Package renames CA110050_0.CA110050_1.CA110050_2;
-
- Message_String : constant String := "One if by land, two if by sea";
-
- Message_Text : Message_Package.Text_Type (Message_String'Length) :=
- (Max_Length => Message_String'Length,
- Length => Message_String'Length,
- Text_Field => Message_String);
-
- Message : Message_Package.Text_Message_Type :=
- (Number => CA110050_0.Next_Available_Message,
- Text => Message_Text);
-
- Confirmation_Message : Code_Package.Coded_Message;
- Verification_OK : Boolean := False;
- Transmission_OK : Boolean := False;
-
-begin
-
--- This test simulates the use of child library unit packages to implement
--- a message encoding and transmission scheme. The full capability of the
--- encoding and transmission mechanisms are not developed here, but the
--- intent is to demonstrate that a grandchild library unit package with a
--- private part will provide the framework for this type of processing.
-
- Report.Test ("CA110051", "Check that entities and operations declared " &
- "in a package can be used in the private part " &
- "of a child of a child of the package");
-
- -- The following code demonstrates the use
- -- of functionality contained in a grandchild
- -- library unit. The grandchild unit made use
- -- of components declared in the ancestor
- -- packages.
-
- Code_Package.Send -- Message object declared
- (Message => Code_Package.Encode (Message), -- above in "encoded" by a
- Confirm => Confirmation_Message, -- call to grandchild pkg
- Status => Transmission_OK); -- function call, reseting
- -- fields and returning a
- -- coded message to the
- -- parameter. The confirm
- -- parameter receives an
- -- encoded message value
- -- from proc Send, which is
- -- "decoded"/verified below.
-
- if not Code_Package.Test_Connection then
- Report.Failed ("Bad initialization");
- end if;
-
- Verification_OK := Code_Package.Decode (Confirmation_Message);
-
- if not (Transmission_OK and Verification_OK) then
- Report.Failed ("Message transmission failure");
- end if;
-
- Report.Result;
-
-end CA110051;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11006.a b/gcc/testsuite/ada/acats/tests/ca/ca11006.a
deleted file mode 100644
index 5cd21fe..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11006.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- CA11006.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 private part of a child library unit can utilize
--- its parent unit's private definition.
---
--- TEST DESCRIPTION:
--- Declare a package and public child package, both with private
--- parts. The child package will have a private extension of a type
--- declared in the parent's private part. In addition, the private
--- part of the child package specification will make use of some of
--- the components declared in the private part of the parent.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11006_0 is -- Package File_Package
-
- type File_Descriptor is private;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
- type File_Type is tagged private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Measure is range 0 .. 1000;
- type File_Descriptor is new Integer;
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Write;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- end record;
-
- System_File : File_Type;
-
-end CA11006_0; -- Package File_Package
-
- --=================================================================--
-
-package body CA11006_0 is -- Package File_Package
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return File_Descriptor (File_Count);
- end Next_Available_File;
-
-end CA11006_0; -- Package File_Package
-
- --=================================================================--
-
-package CA11006_0.CA11006_1 is -- Child package File_Package.Operations
-
- type File_Length_Type is private;
- type Extended_File_Type is new File_Type with private;
-
- System_Extended_File : constant Extended_File_Type;
-
- procedure Create_File (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Compress_File (Original : in Extended_File_Type;
- Compressed_File : out Extended_File_Type);
-
- function Validate (File : in Extended_File_Type) return Boolean;
-
- function Validate_Compression (File : in Extended_File_Type)
- return Boolean;
- -- These two validation functions provide
- -- the capability to check the private
- -- components defined in the parent and
- -- child packages from within the client
- -- program.
-private
-
- type File_Length_Type is new File_Measure; -- Parent private type.
-
- Min_File_Size : File_Length_Type := File_Length_Type'First;
- Max_File_Size : File_Length_Type := File_Length_Type'Last;
-
- type Extended_File_Type is new File_Type with -- Parent type.
- record
- Blocks : File_Length_Type := Min_File_Size;
- end record;
-
- System_Extended_File : constant Extended_File_Type :=
- (Descriptor => System_File.Descriptor, -- Parent private object.
- Mode => Read_Only, -- Parent enumeration literal.
- Blocks => Min_File_Size);
-
-
-end CA11006_0.CA11006_1; -- Child Package File_Package.Operations
-
- --=================================================================--
-
- -- Child package body File_Package.Operations
-package body CA11006_0.CA11006_1 is
-
- procedure Create_File
- (Mode : in File_Mode;
- File : out Extended_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Parent subprogram.
- File.Mode := Default_Mode; -- Parent private constant.
- File.Blocks := Max_File_Size;
- end Create_File;
- ------------------------------------------------------------------------
- procedure Compress_File (Original : in Extended_File_Type;
- Compressed_File : out Extended_File_Type) is
- begin
- Compressed_File.Descriptor := Next_Available_File;
- Compressed_File.Mode := Read_Only;
- Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file
- end Compress_File; -- compression.
- ------------------------------------------------------------------------
- function Validate (File : in Extended_File_Type) return Boolean is
- begin
- if ((File.Descriptor /= System_Extended_File.Descriptor) and
- (File.Mode = Read_Write) and
- (File.Blocks = Max_File_Size)) then
- return True;
- else
- return False;
- end if;
- end Validate;
- ------------------------------------------------------------------------
- function Validate_Compression (File : in Extended_File_Type)
- return Boolean is
- begin
- if ((File.Descriptor /= System_File.Descriptor) and
- (File.Mode = Read_Only) and
- (File.Blocks = Max_File_Size/2)) then
- return True;
- else
- return False;
- end if;
- end Validate_Compression;
-
-end CA11006_0.CA11006_1; -- Child package body File_Package.Operations
-
- --=================================================================--
-
-with CA11006_0.CA11006_1; -- with Child package File_Package.Operations
-with Report;
-
-procedure CA11006 is
-
- package File renames CA11006_0;
- package File_Ops renames CA11006_0.CA11006_1;
-
- Validation_File_Mode : File.File_Mode := File.Read_Only;
- Validation_File,
- Storage_Copy : File_Ops.Extended_File_Type;
-
-begin
-
- Report.Test ("CA11006", "Check that the private part of a child " &
- "library unit can utilize its parent " &
- "unit's private definition");
-
- File_Ops.Create_File (Validation_File_Mode, Validation_File);
-
- if not File_Ops.Validate (Validation_File) then
- Report.Failed ("Incorrect initialization of file");
- end if;
-
- File_Ops.Compress_File (Validation_File, Storage_Copy);
-
- if not (File_Ops.Validate (Validation_File) and
- File_Ops.Validate_Compression (Storage_Copy))
- then
- Report.Failed ("Incorrect compression of file");
- end if;
-
- Report.Result;
-
-end CA11006;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11007.a b/gcc/testsuite/ada/acats/tests/ca/ca11007.a
deleted file mode 100644
index c4a6789a..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11007.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CA11007.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 private part of a grandchild library unit can
--- utilize its grandparent unit's private definition.
---
--- TEST DESCRIPTION:
--- Declare a package, child package, and grandchild package, all
--- with private parts in their specifications.
---
--- The private part of the grandchild package will make use of components
--- that have been declared in the private part of the grandparent
--- specification.
---
--- The child package demonstrates the extension of a parent file type
--- into an abstraction of an analog file structure. The grandchild package
--- extends the grandparent file type into an abstraction of a digital
--- file structure, and provides conversion capability to/from the parent
--- analog file structure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11007_0 is -- Package File_Package
-
- type File_Descriptor is private;
- type File_Type is tagged private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Measure_Type is range 0 .. 1000;
- type File_Descriptor is new Integer;
-
- Null_Measure : constant File_Measure_Type := File_Measure_Type'First;
- Null_File : constant File_Descriptor := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- end record;
-
-end CA11007_0; -- Package File_Package
-
- --=================================================================--
-
-package body CA11007_0 is -- Package body File_Package
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return File_Descriptor (File_Count);
- end Next_Available_File;
-
-end CA11007_0; -- Package body File_Package
-
- --=================================================================--
-
-package CA11007_0.CA11007_1 is -- Child package Analog
-
- type Analog_File_Type is new File_Type with private;
-
-private
-
- type Wavelength_Type is new File_Measure_Type;
-
- Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First;
-
- type Analog_File_Type is new File_Type with -- Parent type.
- record
- Wavelength : Wavelength_Type := Min_Wavelength;
- end record;
-
-end CA11007_0.CA11007_1; -- Child package Analog
-
- --=================================================================--
-
-package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital
-
- type Digital_File_Type is new File_Type with private;
-
- procedure Recording (File : out Digital_File_Type);
-
- procedure Convert (From : in Analog_File_Type;
- To : out Digital_File_Type);
-
- function Validate (File : in Digital_File_Type) return Boolean;
- function Valid_Conversion (To : Digital_File_Type) return Boolean;
- function Valid_Initial (From : Analog_File_Type) return Boolean;
-
-private
-
- type Track_Type is new File_Measure_Type; -- Grandparent type.
-
- Min_Tracks : constant Track_Type :=
- Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private
- Max_Tracks : constant Track_Type := -- constant.
- Track_Type (Null_Measure) + Track_Type'Last;
-
- type Digital_File_Type is new File_Type with -- Grandparent type.
- record
- Tracks : Track_Type := Min_Tracks;
- end record;
-
-end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital
-
- --=================================================================--
-
- -- Grandchild package body Digital
-package body CA11007_0.CA11007_1.CA11007_2 is
-
- procedure Recording (File : out Digital_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Assign new file descriptor.
- File.Tracks := Max_Tracks; -- Change initial value.
- end Recording;
- --------------------------------------------------------------------------
- procedure Convert (From : in Analog_File_Type;
- To : out Digital_File_Type) is
- begin
- To.Descriptor := From.Descriptor + 100; -- Dummy conversion.
- To.Tracks := Track_Type (From.Wavelength) / 2;
- end Convert;
- --------------------------------------------------------------------------
- function Validate (File : in Digital_File_Type) return Boolean is
- Result : Boolean := False;
- begin
- if not (File.Tracks /= Max_Tracks) then
- Result := True;
- end if;
- return Result;
- end Validate;
- --------------------------------------------------------------------------
- function Valid_Conversion (To : Digital_File_Type) return Boolean is
- begin
- return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2));
- end Valid_Conversion;
- --------------------------------------------------------------------------
- function Valid_Initial (From : Analog_File_Type) return Boolean is
- begin
- return (From.Wavelength = Min_Wavelength); -- Validate initial
- end Valid_Initial; -- conditions.
-
-end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital
-
- --=================================================================--
-
-with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital
-with Report;
-
-procedure CA11007 is
-
- package Analog renames CA11007_0.CA11007_1;
- package Digital renames CA11007_0.CA11007_1.CA11007_2;
-
- Original_Digital_File,
- Converted_Digital_File : Digital.Digital_File_Type;
-
- Original_Analog_File : Analog.Analog_File_Type;
-
-begin
-
- -- This code demonstrates how private extensions could be utilized
- -- in child packages to allow for recording on different media.
- -- The processing contained in the procedures and functions is
- -- "dummy" processing, not intended to perform actual recording,
- -- conversion, or validation operations, but simply to demonstrate
- -- this type of structural decomposition as a possible solution to
- -- a user's design problem.
-
- Report.Test ("CA11007", "Check that the private part of a grandchild " &
- "library unit can utilize its grandparent " &
- "unit's private definition");
-
- if not Digital.Valid_Initial (Original_Analog_File)
- then
- Report.Failed ("Incorrect initialization of Analog File");
- end if;
-
- ---
-
- Digital.Convert (From => Original_Analog_File, -- Convert file to
- To => Converted_Digital_File); -- digital format.
-
- if not Digital.Valid_Conversion (To => Converted_Digital_File) then
- Report.Failed ("Incorrect conversion of analog file");
- end if;
-
- ---
-
- Digital.Recording (Original_Digital_File); -- Create file in
- -- digital format.
- if not Digital.Validate (Original_Digital_File) then
- Report.Failed ("Incorrect recording of digital file");
- end if;
-
- Report.Result;
-
-end CA11007;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11008.a b/gcc/testsuite/ada/acats/tests/ca/ca11008.a
deleted file mode 100644
index 1161fbe..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11008.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- CA11008.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 private child package can use entities declared in the
--- visible part of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing types and objects used
--- by the system. Declare a private child package that uses the parent
--- components to provide functionality to the system.
---
--- The tagged file type defined in the parent has defaults for all
--- component fields. Prior to initialization, these values are checked
--- to ensure a correct start condition. The initial subprogram is
--- called, which utilizes the functionality provided in the private
--- child package. This subprogram changes the fields of the file object
--- to something other than the default values, and this process is then
--- verified at the conclusion of the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11008_0 is -- Package OS.
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System, Bypass);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Max_Files : constant File_Descriptor_Type := 100;
- Constant_Name : constant File_Name_Type := "AdaFileName";
- File_Counter : Integer := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
- function Initialize_File return File_Descriptor_Type;
-
-end CA11008_0; -- Package OS.
-
- --=================================================================--
-
--- Subprograms that perform the actual file operations are contained in a
--- private package so that they are not accessible to any client.
-
-private package CA11008_0.CA11008_1 is -- Package OS.Internals
-
- Private_File_Counter : Integer renames File_Counter; -- Parent
- -- object.
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent function.
- File_Mode : File_Mode_Type := Read_Write) -- Parent literal.
- return File_Descriptor_Type; -- Parent type.
-
-end CA11008_0.CA11008_1; -- Package OS.Internals
-
- --=================================================================--
-
-package body CA11008_0.CA11008_1 is -- Package body OS.Internals
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- -----------------------------------------------------------------
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent function
- File_Mode : File_Mode_Type := Read_Write) -- Parent literal
- return File_Descriptor_Type is -- Parent type
- Number : File_Descriptor_Type;
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Parent object
- File_Table(Number).Name := File_Name; -- Default parameter value
- File_Table(Number).Mode := File_Mode; -- Default parameter value
- File_Table(Number).Acct_Access := User;
- File_Table(Number).Current_Status := Open;
- return (Number);
- end Initialize;
-
-end CA11008_0.CA11008_1; -- Package body OS.Internals
-
- --=================================================================--
-
-with CA11008_0.CA11008_1; -- Private child package "withed" by
- -- parent body.
-
-package body CA11008_0 is -- Package body OS
-
- function Get_File_Name return File_Name_Type is
- begin
- return (Constant_Name); -- Of course if this was a real function, the
- end Get_File_Name; -- user would be asked to input a name, or
- -- there would be some type of similar process.
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- function Initialize_File return File_Descriptor_Type is
- begin
- return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed,
- -- since defaults have been
- -- provided.
- end Initialize_File;
-
-end CA11008_0; -- Package body OS
-
- --=================================================================--
-
-with CA11008_0; -- with Package OS.
-with Report;
-
-procedure CA11008 is
-
- package OS renames CA11008_0;
- use OS;
- Ada_File_Key : File_Descriptor_Type := Default_Descriptor;
-
-begin
-
- -- This test indicates one approach to file management operations.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a user situation, that being the implementation of certain functions
- -- being provided in a child package, with the parent package body
- -- utilizing these implementations.
-
- Report.Test ("CA11008", "Check that a private child package can use " &
- "entities declared in the visible part of its " &
- "parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- if (Ada_File_Key /= Default_Descriptor) or else
- (File_Table(1).Descriptor /= (Default_Descriptor) or
- (File_Table(1).Name /= Default_Filename)) or else
- (File_Table(1).Acct_Access /= (Default_Permission) or
- (File_Table(1).Mode /= Default_Mode)) or else
- (File_Table(1).Current_Status /= Default_Status)
- then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Call the initialization function. This will result in the resetting
- -- of the fields associated with the first entry in the File_Table (this
- -- is the first call of Initialize_File).
- -- No parameters are necessary for this call, due to the default values
- -- provided in the private child package routine Initialize.
-
- Ada_File_Key := Initialize_File;
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not ((File_Table(1).Descriptor = Ada_File_Key) and then
- (File_Table(1).Name = Constant_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- Report.Failed ("Initialization processing failure");
- end if;
-
- Report.Result;
-
-end CA11008;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11009.a b/gcc/testsuite/ada/acats/tests/ca/ca11009.a
deleted file mode 100644
index 84d7dc2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11009.a
+++ /dev/null
@@ -1,246 +0,0 @@
--- CA11009.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 private child package can use entities declared in the
--- visible part of the parent unit of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing types and objects used by the
--- system. Declare a public child package that provides a visible
--- interface to the system functionality.
--- Declare a private grandchild package that uses the visible grandparent
--- components to provide the actual functionality to the system.
---
--- The public child (parent of the private grandchild) uses the
--- functionality of its private child (grandchild package) to provide
--- the visible interface to operations of the system.
---
--- The test itself will utilize the visible interface provided in the
--- public child package to demonstrate a possible structure for
--- file management.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body.
---
---!
-
-package CA11009_0 is -- Package OS.
- pragma Elaborate_Body (CA11009_0);
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System, Bypass);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Max_Files : constant File_Descriptor_Type := 10;
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
- File_Counter : Integer := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11009_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11009_0 is -- Package body OS.
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name); -- Processing would be replace by a user
- -- prompt in a functioning system.
- end Get_File_Name;
-
-end CA11009_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager
-
- -- This package simulates a visible interface for the Operating System.
- -- The actual processing performed by this routine is encapsulated
- -- in the routines of private child package Internals, which is "withed"
- -- by the body of this package.
-
- procedure Create_File (Mode : in File_Mode_Type;
- File_Key : out File_Descriptor_Type);
-
-end CA11009_0.CA11009_1; -- Child Package OS.File_Manager
-
- --=================================================================--
-
--- Subprogram that performs the actual file operation is contained in a
--- private package so that it is not accessible to any client, and can be
--- modified/extended without requiring recompilation of the clients of the
--- parent (since this package is "withed" by the parent body only.)
-
-
- -- Grandchild Package OS.File_Manager.Internals
-private package CA11009_0.CA11009_1.CA11009_2 is
-
- Initial_Permission : constant Permission_Type := User; -- Grandparent
- Initial_Status : constant File_Status_Type := Open; -- literals.
- Initial_Filename : constant File_Name_Type := -- Grandparent type.
- Get_File_Name; -- Grandparent function.
-
- function Create (Mode : File_Mode_Type)
- return File_Descriptor_Type; -- Grandparent type.
-
-end CA11009_0.CA11009_1.CA11009_2;
- -- Grandchild Package OS.File_Manager.Internals
-
- --=================================================================--
-
- -- Grandchild Package body OS.File_Manager.Internals
-package body CA11009_0.CA11009_1.CA11009_2 is
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- File_Counter := File_Counter + 1; -- Grandparent object.
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- -------------------------------------------------------------------------
- function Create (Mode : File_Mode_Type) -- Grandparent literal.
- return File_Descriptor_Type is
- Number : File_Descriptor_Type; -- Grandparent type.
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Grandparent object.
- File_Table(Number).Name := Initial_Filename;
- File_Table(Number).Mode := Mode; -- Parameter.
- File_Table(Number).Acct_Access := Initial_Permission;
- File_Table(Number).Current_Status := Initial_Status;
- return (Number);
- end Create;
-
-end CA11009_0.CA11009_1.CA11009_2;
- -- Grandchild Package body OS.File_Manager.Internals
-
- --=================================================================--
-
- -- "With" of a child package
- -- by the parent body.
-with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals
-
-package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager
-
- package Internal renames CA11009_0.CA11009_1.CA11009_2;
-
- -- These subprograms utilize calls to subprograms contained in a private
- -- sibling to perform the actual processing.
-
- procedure Create_File (Mode : in File_Mode_Type;
- File_Key : out File_Descriptor_Type) is
- begin
- File_Key := Internal.Create (Mode);
- end Create_File;
-
-end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager
-
- --=================================================================--
-
-with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager
-with Report;
-
-procedure CA11009 is
-
- package OS renames CA11009_0;
- use OS;
- package File_Manager renames CA11009_0.CA11009_1;
-
- Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor;
- New_Mode : File_Mode_Type := Read_Write;
-
-begin
-
- -- This test indicates one approach to file management.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package could provide a solution
- -- to this type of situation.
-
- Report.Test ("CA11009", "Check that a private child package can use " &
- "entities declared in the visible part of the " &
- "parent unit of its parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- if (not (Data_Base_File_Key = Default_Descriptor)) and then
- (((not (File_Table(1).Name = Default_Filename)) or
- (File_Table(1).Descriptor /= Default_Descriptor)) or else
- ((File_Table(1).Acct_Access /= Default_Permission) or
- (not (File_Table(1).Mode = Default_Mode)) or
- (File_Table(1).Current_Status /= Default_Status)))
- then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Create/initialize file using the capability provided by the visible
- -- interface to the operating system, OS.File_Manager. The actual
- -- processing routine is contained in the private grandchild package
- -- Internals, which utilize the components from the grandparent package.
-
- File_Manager.Create_File (New_Mode, Data_Base_File_Key);
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then
- (File_Table(1).Name = An_Ada_File_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- Report.Failed ("File creation failure");
- end if;
-
- Report.Result;
-
-end CA11009;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11010.a b/gcc/testsuite/ada/acats/tests/ca/ca11010.a
deleted file mode 100644
index b13efd7..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11010.a
+++ /dev/null
@@ -1,254 +0,0 @@
--- CA11010.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 private child package can use entities declared in the
--- private part of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing private types, objects,
--- and functions used by the system. Declare a private child package that
--- uses the parent components to provide functionality to the system.
---
--- Declare an array of files with default values for all
--- component fields of the files (records). Check the initial state of
--- a specified file for proper default values. Perform the file "creation"
--- (initialization), which will modify the fields of the record object.
--- Again verify the file object to determine whether the fields have been
--- reset properly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
-
-package CA11010_0 is -- Package OS.
-
- type File_Descriptor_Type is private;
-
- Default_Descriptor : constant File_Descriptor_Type;
-
- function Initialize_File return File_Descriptor_Type;
- procedure Verify_Initial_Conditions (Status : out Boolean);
- function Final_Conditions_Valid return Boolean;
-
-private
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
- Max_Files : constant File_Descriptor_Type := 100;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
- File_Counter : Integer := 0;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11010_0; -- Package OS.
-
- --=================================================================--
-
--- Subprograms that perform the actual file operations are contained in a
--- private package so that they are not accessible to any client.
-
-private package CA11010_0.CA11010_1 is -- Package OS.Internals
-
- Private_File_Counter : Integer renames File_Counter; -- Parent priv. object.
-
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function.
- File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal.
- return File_Descriptor_Type; -- Parent type.
-
-end CA11010_0.CA11010_1; -- Package OS.Internals
-
- --=================================================================--
-
-package body CA11010_0.CA11010_1 is -- Package body OS.Internals
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- ----------------------------------------------------------------
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function
- File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal
- return File_Descriptor_Type is -- Parent type
- Number : File_Descriptor_Type;
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Parent priv. object
- File_Table(Number).Name := File_Name; -- Default parameter value
- File_Table(Number).Mode := File_Mode; -- Default parameter value
- File_Table(Number).Acct_Access := User;
- File_Table(Number).Current_Status := Open;
- return (Number);
- end Initialize;
-
-end CA11010_0.CA11010_1; -- Package body OS.Internals
-
- --=================================================================--
-
-with CA11010_0.CA11010_1; -- Private child package "withed" by
- -- parent body.
-
-package body CA11010_0 is -- Package body OS
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name); -- If this was a real function, the user
- end Get_File_Name; -- would be asked to input a name, or there
- -- would be some type of similar processing.
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- function Initialize_File return File_Descriptor_Type is
- begin
- return (CA11010_0.CA11010_1.Initialize); -- No parameters are needed,
- -- since defaults have been
- -- provided.
- end Initialize_File;
-
- --
- -- Separate subunits.
- --
-
- procedure Verify_Initial_Conditions (Status : out Boolean) is separate;
-
- function Final_Conditions_Valid return Boolean is separate;
-
-end CA11010_0; -- Package body OS
-
- --=================================================================--
-
-separate (CA11010_0)
-procedure Verify_Initial_Conditions (Status : out Boolean) is
-begin
- Status := False;
- if (File_Table(1).Descriptor = Default_Descriptor) and then
- (File_Table(1).Name = Default_Filename) and then
- (File_Table(1).Acct_Access = Default_Permission) and then
- (File_Table(1).Mode = Default_Mode) and then
- (File_Table(1).Current_Status = Default_Status)
- then
- Status := True;
- end if;
-end Verify_Initial_Conditions;
-
- --=================================================================--
-
-separate (CA11010_0)
-function Final_Conditions_Valid return Boolean is
-begin
- if ((File_Table(1).Descriptor /= Default_Descriptor) and then
- (File_Table(1).Name = An_Ada_File_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- return (True);
- else
- return (False);
- end if;
-end Final_Conditions_Valid;
-
- --=================================================================--
-
-with CA11010_0; -- with Package OS.
-with Report;
-
-procedure CA11010 is
-
- package OS renames CA11010_0;
-
- Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor;
- Initialization_Status : Boolean := False;
-
-begin
-
- -- This test indicates one approach to a file management operation.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a user situation, that being the implementation of certain functions
- -- being provided in a child package, with the parent package body
- -- utilizing these implementations.
-
- Report.Test ("CA11010", "Check that a private child package can use " &
- "entities declared in the private part of its " &
- "parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- OS.Verify_Initial_Conditions (Initialization_Status);
-
- if not Initialization_Status then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Call the initialization function. This will result in the resetting
- -- of the fields associated with the first entry in the File_Table (this
- -- is the first/only call of Initialize_File).
- -- No parameters are necessary for this call, due to the default values
- -- provided in the private child package routine Initialize.
-
- Ada_File_Key := OS.Initialize_File;
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not OS.Final_Conditions_Valid then
- Report.Failed ("Initialization processing failure");
- end if;
-
- Report.Result;
-
-end CA11010;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11011.a b/gcc/testsuite/ada/acats/tests/ca/ca11011.a
deleted file mode 100644
index a75261d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11011.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CA11011.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 private child package can use entities declared in the
--- private part of the parent unit of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing private types and objects
--- used by the system. Declare a public child package that
--- provides a visible interface to the system functionality.
--- Declare a private grandchild package that uses the visible grandparent
--- components to provide the actual functionality to the system.
---
--- The public child (parent of the private grandchild) uses the
--- functionality of its private child (grandchild package) to provide
--- the visible interface to operations of the system.
---
--- The test itself will utilize the visible interface provided in the
--- public child package to demonstrate a possible solution to file
--- management.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11011_0 is -- Package OS.
-
- type File_Descriptor_Type is private;
-
- Default_Descriptor : constant File_Descriptor_Type;
- First_File : constant File_Descriptor_Type;
-
- procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
- Status : out Boolean);
-
- function Final_Conditions_Valid (Key : File_Descriptor_Type)
- return Boolean;
-
-
-private
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- First_File : constant File_Descriptor_Type := 1;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Init_Permission : constant Permission_Type := User;
- Init_Mode : constant File_Mode_Type := Read_Write;
- Init_Status : constant File_Status_Type := Open;
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
-
- Max_Files : constant File_Descriptor_Type := 10;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
- File_Counter : Integer := 0;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11011_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11011_0 is -- Package body OS.
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name);
- end Get_File_Name;
- ---------------------------------------------------------------------
- procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
- Status : out Boolean) is
- begin
- Status := False;
- if (File_Table(Key).Descriptor = Default_Descriptor) and then
- (File_Table(Key).Name = Default_Filename) and then
- (File_Table(Key).Acct_Access = Default_Permission) and then
- (File_Table(Key).Mode = Default_Mode) and then
- (File_Table(Key).Current_Status = Default_Status)
- then
- Status := True;
- end if;
- end Verify_Initial_Conditions;
- ---------------------------------------------------------------------
- function Final_Conditions_Valid (Key : File_Descriptor_Type)
- return Boolean is
- begin
- if ((File_Table(Key).Descriptor = First_File) and then
- (File_Table(Key).Name = An_Ada_File_Name) and then
- (File_Table(Key).Acct_Access = Init_Permission) and then
- not ((File_Table(Key).Mode = Default_Mode) or else
- (File_Table(Key).Current_Status = Default_Status)))
- then
- return (True);
- else
- return (False);
- end if;
- end Final_Conditions_Valid;
-
-end CA11011_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11011_0.CA11011_1 is -- Package OS.File_Manager
-
- procedure Create_File (File_Key : in File_Descriptor_Type);
-
-end CA11011_0.CA11011_1; -- Package OS.File_Manager
-
- --=================================================================--
-
--- The Subprogram that performs the actual file operations is contained in a
--- private package so that it is not accessible to any client.
--- Default parameters are used in most cases in the subprogram calls, since
--- the caller does not have visibility to these private types.
-
- -- Package OS.File_Manager.Internals
-private package CA11011_0.CA11011_1.CA11011_2 is
-
- Private_File_Counter : Integer renames File_Counter; -- Grandparent
- -- object.
- procedure Create
- (Key : in File_Descriptor_Type;
- File_Name : in File_Name_Type := Get_File_Name; -- Grandparent
- -- prvt type,
- -- prvt functn.
- File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent
- -- prvt type,
- -- prvt const.
- File_Access : in Permission_Type := Init_Permission; -- Grandparent
- -- prvt type,
- -- prvt const.
- File_Status : in File_Status_Type := Init_Status); -- Grandparent
- -- prvt type,
- -- prvt const.
-
-end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals
-
- --=================================================================--
-
- -- Package Body OS.File_Manager.Internals
-package body CA11011_0.CA11011_1.CA11011_2 is
-
- procedure Create
- (Key : in File_Descriptor_Type;
- File_Name : in File_Name_Type := Get_File_Name;
- File_Mode : in File_Mode_Type := Init_Mode;
- File_Access : in Permission_Type := Init_Permission;
- File_Status : in File_Status_Type := Init_Status) is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- File_Table(Key).Descriptor := Key; -- Grandparent object.
- File_Table(Key).Name := File_Name;
- File_Table(Key).Mode := File_Mode;
- File_Table(Key).Acct_Access := File_Access;
- File_Table(Key).Current_Status := File_Status;
- end Create;
-
-end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals
-
- --=================================================================--
-
-with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals
-
-package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager
-
- package Internal renames CA11011_0.CA11011_1.CA11011_2;
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- procedure Create_File (File_Key : in File_Descriptor_Type) is
- begin
- Internal.Create (Key => File_Key); -- Other parameters are defaults,
- -- since they are of private types
- -- from the parent package.
- -- File_Descriptor_Type is private,
- -- but declared in visible part of
- -- parent spec.
- end Create_File;
-
-end CA11011_0.CA11011_1; -- Package body OS.File_Manager
-
- --=================================================================--
-
-with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager
-with Report;
-
-procedure CA11011 is
-
- package OS renames CA11011_0;
- package File_Manager renames CA11011_0.CA11011_1;
-
- Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File;
- TC_Status : Boolean := False;
-
-begin
-
- -- This test indicates one approach to file management operations.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a typical user situation.
-
- Report.Test ("CA11011", "Check that a private child package can use " &
- "entities declared in the private part of the " &
- "parent unit of its parent unit");
-
- OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status);
-
- if not TC_Status then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Perform file initializations.
-
- File_Manager.Create_File (File_Key => Data_Base_File_Key);
-
- TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key);
-
- if not TC_Status then
- Report.Failed ("Bad status return from Create_File");
- end if;
-
- Report.Result;
-
-end CA11011;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11012.a b/gcc/testsuite/ada/acats/tests/ca/ca11012.a
deleted file mode 100644
index 071b8f8..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11012.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CA11012.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 child package of a library level instantiation
--- of a generic can be the instantiation of a child package of
--- the generic. Check that the child instance can use its parent's
--- declarations and operations, including a formal type of the parent.
---
--- TEST DESCRIPTION:
--- Declare a generic package which simulates an integer complex
--- abstraction. Declare a generic child package of this package
--- which defines additional complex operations.
---
--- Instantiate the first generic package, then instantiate the child
--- generic package as a child unit of the first instance. In the main
--- program, check that the operations in both instances perform as
--- expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Corrected visibility errors for literals
--- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3
---!
-
-generic -- Complex number abstraction.
- type Int_Type is range <>;
-
-package CA11012_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- Real number (0,0).
-
- function Complex (Real, Imag : Int_Type) -- Create a complex
- return Complex_Type; -- number.
-
- function "-" (Right : Complex_Type) -- Invert a complex
- return Complex_Type; -- number.
-
- function "+" (Left, Right : Complex_Type) -- Add two complex
- return Complex_Type; -- numbers.
-
-private
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
-
-end CA11012_0;
-
- --==================================================================--
-
-package body CA11012_0 is
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
- ---------------------------------------------------------------
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return (-Right.Real, -Right.Imag);
- end "-";
- ---------------------------------------------------------------
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
-end CA11012_0;
-
- --==================================================================--
-
--- Generic child of complex number package. Child must be generic since
--- parent is generic.
-
-generic -- Complex additional operations
-
-package CA11012_0.CA11012_1 is
-
- -- More operations on complex number. This child adds a layer of
- -- functionality to the parent generic.
-
- function Real_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Imag_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type;
-
- function Vector_Magnitude (Complex_No : Complex_Type)
- return Int_Type;
-
-end CA11012_0.CA11012_1;
-
- --==================================================================--
-
-package body CA11012_0.CA11012_1 is
-
- function Real_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Real);
- end Real_Part;
- ---------------------------------------------------------------
- function Imag_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Imag);
- end Imag_Part;
- ---------------------------------------------------------------
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type is
- Result : Complex_Type := Zero; -- Zero is declared in parent,
- -- Complex_Number
- begin
- for I in 1 .. abs (Factor) loop
- Result := Result + C; -- Complex_Number "+"
- end loop;
-
- if Factor < 0 then
- Result := - Result; -- Complex_Number "-"
- end if;
-
- return Result;
- end "*";
- ---------------------------------------------------------------
- function Vector_Magnitude (Complex_No : Complex_Type)
- return Int_Type is -- Not a real vector magnitude.
- begin
- return (Complex_No.Real + Complex_No.Imag);
- end Vector_Magnitude;
-
-end CA11012_0.CA11012_1;
-
- --==================================================================--
-
-package CA11012_2 is
-
- subtype My_Integer is integer range -100 .. 100;
-
- -- ... Various other types used by the application.
-
-end CA11012_2;
-
--- No body for CA11012_2;
-
- --==================================================================--
-
--- Declare instances of the generic complex packages for integer type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11012_0; -- Complex number abstraction
-with CA11012_2; -- Package containing integer type
-pragma Elaborate (CA11012_0);
-package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer);
-
-with CA11012_0.CA11012_1; -- Complex additional operations
-with CA11012_3;
-package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1;
-
- --==================================================================--
-
-with CA11012_2; -- Package containing integer type
-with CA11012_3.CA11012_4; -- Complex abstraction + additional operations
-with Report;
-
-procedure CA11012 is
-
- package My_Complex_Pkg renames CA11012_3;
-
- package My_Complex_Operation renames CA11012_3.CA11012_4;
-
- use My_Complex_Pkg, -- All user-defined
- My_Complex_Operation; -- operators directly
- -- visible.
- Complex_One, Complex_Two : Complex_Type;
-
-begin
-
- Report.Test ("CA11012", "Check that child instance can use its parent's " &
- "declarations and operations, including a formal " &
- "type of the parent");
-
- Correct_Range_Test:
- declare
- My_Literal : CA11012_2.My_Integer := -3;
-
- begin
- Complex_One := Complex (-4, 7); -- Operation from the generic
- -- parent package.
-
- Complex_Two := My_Literal * Complex_One; -- Operation from the generic
- -- child package.
-
- if Real_Part (Complex_Two) /= 12 -- Operation from the generic
- or Imag_Part (Complex_Two) /= -21 -- child package.
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- end Correct_Range_Test;
-
- ---------------------------------------------------------------
-
- Out_Of_Range_Test:
- declare
- My_Vector : CA11012_2.My_Integer;
-
- begin
- Complex_One := Complex (70, 70); -- Operation from the generic
- -- parent package.
- My_Vector := Vector_Magnitude (Complex_One);
- -- Operation from the generic child package.
-
- Report.Failed ("Exception not raised in child package");
-
- exception
- when Constraint_Error =>
- Report.Comment ("Exception is raised as expected");
-
- when others =>
- Report.Failed ("Others exception is raised");
-
- end Out_Of_Range_Test;
-
- Report.Result;
-
-end CA11012;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11013.a b/gcc/testsuite/ada/acats/tests/ca/ca11013.a
deleted file mode 100644
index c7f4427..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11013.a
+++ /dev/null
@@ -1,201 +0,0 @@
--- CA11013.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 child function of a library level instantiation
--- of a generic can be the instantiation of a child function of
--- the generic. Check that the child instance can use its parent's
--- declarations and operations, including a formal subprogram of the
--- parent.
---
--- TEST DESCRIPTION:
--- Declare a generic package which simulates a real complex
--- abstraction. Declare a generic child function of this package
--- which builds a random complex number. Declare a second
--- package which defines a random complex number generator. This
--- package provides actual parameters for the generic parent package.
---
--- Instantiate the first generic package, then instantiate the child
--- generic function as a child unit of the first instance. In the main
--- program, check that the operations in both instances perform as
--- expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
--- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clause of CA11013_3.
--- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3
---!
-
-generic -- Complex number abstraction.
- type Real_Type is digits <>;
- with function Random_Generator (Seed : Real_Type) return Real_Type;
-
-package CA11013_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is
- record
- Real : Real_Type;
- Imag : Real_Type;
- end record;
-
- function Make (Real, Imag : Real_Type) -- Create a complex
- return Complex_Type; -- number.
-
- procedure Components (Complex_No : in Complex_Type;
- Real_Part, Imag_Part : out Real_Type);
-
-end CA11013_0;
-
- --==================================================================--
-
-package body CA11013_0 is
-
- function Make (Real, Imag : Real_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Make;
- -------------------------------------------------------------
- procedure Components (Complex_No : in Complex_Type;
- Real_Part, Imag_Part : out Real_Type) is
- begin
- Real_Part := Complex_No.Real;
- Imag_Part := Complex_No.Imag;
- end Components;
-
-end CA11013_0;
-
- --==================================================================--
-
--- Generic child of complex number package. This child adds a layer of
--- functionality to the parent generic.
-
-generic -- Random complex number operation.
-
-function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type;
-
- --==============================================--
-
-function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is
-
- Random_Real_Part : Real_Type := Random_Generator (Seed);
- -- parent's formal subprogram
- Random_Imag_Part : Real_Type
- := Random_Generator (Random_Generator (Seed));
- -- parent's formal subprogram
- Random_Complex_No : Complex_Type;
-
-begin -- CA11013_0.CA11013_1
-
- Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part);
- -- operation from parent
- return (Random_Complex_No);
-
-end CA11013_0.CA11013_1;
-
- --==================================================================--
-
-package CA11013_2 is
-
- -- To be used as actual parameters for random number generator
- -- in the parent package.
-
- type My_Float is digits 6 range -10.0 .. 100.0;
-
- function Random_Complex (Seed : My_float) return My_Float;
-
-end CA11013_2;
-
- --==================================================================--
-
-package body CA11013_2 is
-
- -- Not a real random number generator.
- function Random_Complex (Seed : My_float) return My_Float is
- begin
- return (Seed + 3.0);
- end Random_Complex;
-
-end CA11013_2;
-
- --==================================================================--
-
--- Declare instances of the generic complex packages for real type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11013_0; -- Complex number.
-with CA11013_2; -- Random number generator.
-pragma Elaborate (CA11013_0);
-package CA11013_3 is new
- CA11013_0 (Random_Generator => CA11013_2.Random_Complex,
- Real_Type => CA11013_2.My_Float);
-
-with CA11013_0.CA11013_1; -- Random complex number operation.
-with CA11013_3;
-pragma Elaborate (CA11013_3);
-function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1;
-
- --==================================================================--
-
-with Report;
-with CA11013_2; -- Random number generator.
-with CA11013_3.CA11013_4; -- Complex abstraction + Random complex
- -- number operation.
-procedure CA11013 is
-
- package My_Complex_Pkg renames CA11013_3;
- use type CA11013_2.My_Float;
-
- My_Complex : My_Complex_Pkg.Complex_Type;
- My_Literal : CA11013_2.My_Float := 3.0;
- My_Real_Part, My_Imag_Part : CA11013_2.My_Float;
-
-begin
-
- Report.Test ("CA11013", "Check that child instance can use its parent's " &
- "declarations and operations, including a formal " &
- "subprogram of the parent");
-
- My_Complex := CA11013_3.CA11013_4 (My_Literal);
- -- Operation from the generic child function.
-
- My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part);
- -- Operation from the generic parent package.
-
- if My_Real_Part /= 6.0 -- Operation from the generic
- or My_Imag_Part /= 9.0 -- parent package.
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Report.Result;
-
-end CA11013;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11014.a b/gcc/testsuite/ada/acats/tests/ca/ca11014.a
deleted file mode 100644
index 7847a50..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11014.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- CA11014.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 instantiation of a child package of a generic package
--- can use its parent's declarations and operations, including a formal
--- package of the parent.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any discrete type. Declare a generic package which
--- operates on lists of elements of integer types. Declare a generic
--- child of this package which defines additional list operations.
--- Use the formal discrete type as the generic formal actual part for the
--- parent formal package.
---
--- Declare an instance of parent, then declare an instance of the child
--- which is itself a child the parent's instance. In the main program,
--- check that the operations in both instances perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
--- 07 Sep 96 SAIC Change formal param E to be out only.
--- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clauses of CA11014_0, CA11014_1, and CA11014_5.
--- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4
---!
-
--- Actual package for the parent's formal.
-generic
-
- type Element_Type is (<>); -- List elems may be of any discrete types.
-
-package CA11014_0 is
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer := null;
- end record;
-
- type List_Type is record
- First : Node_Pointer := null;
- Current : Node_Pointer := null;
- Last : Node_Pointer := null;
- end record;
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-end CA11014_0;
-
- --==================================================================--
-
-package body CA11014_0 is
-
- function End_Of_List (L : List_Type) return boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
- -------------------------------------------------------
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end CA11014_0;
-
- --==================================================================--
-
-with CA11014_0; -- Generic list abstraction.
-pragma Elaborate (CA11014_0);
-generic
-
- -- Import the list abstraction defined in CA11014_0.
- with package List_Mgr is new CA11014_0 (<>);
-
-package CA11014_1 is
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type);
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Mgr.List_Type;
- E : out List_Mgr.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type);
-
-end CA11014_1;
-
- --==================================================================--
-
-package body CA11014_1 is
-
- procedure Write_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type) is
- begin
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
- -------------------------------------------------------
- procedure Read_Element (L : in out List_Mgr.List_Type;
- E : out List_Mgr.Element_Type) is
- begin
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
- -------------------------------------------------------
- procedure Add_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type) is
- New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null);
- use type List_Mgr.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-end CA11014_1;
-
- --==================================================================--
-
--- Generic child of list operation. This child adds a layer of
--- functionality to the parent generic.
-
-generic
-
-package CA11014_1.CA11014_2 is
-
- procedure Write_First_To_List (L : in out List_Mgr.List_Type);
-
- -- ... Various other operations used by the application.
-
-end CA11014_1.CA11014_2;
-
- --==================================================================--
-
-package body CA11014_1.CA11014_2 is
-
- procedure Write_First_To_List (L : in out List_Mgr.List_Type) is
- begin
- List_Mgr.Reset (L); -- Parent's formal package.
-
- while not List_Mgr.End_Of_List (L) loop -- Parent's formal package.
- Write_Element (L, List_Mgr.Element_Type'First);
- -- Parent's operation,
- end loop; -- parent's formal.
-
- end Write_First_To_List;
-
-end CA11014_1.CA11014_2;
-
- --==================================================================--
-
-package CA11014_3 is
-
- type Points is range 0 .. 100;
-
- -- ... Various other types used by the application.
-
-end CA11014_3;
-
-
--- No body for CA11014_3;
-
- --==================================================================--
-
--- Declare instances of the generic list packages for the discrete type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11014_0; -- Generic list abstraction.
-with CA11014_3; -- Package containing discrete type declaration.
-pragma Elaborate (CA11014_0);
-package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list.
-
-with CA11014_4; -- Points list.
-with CA11014_1; -- Generic list operation.
-pragma Elaborate (CA11014_1);
-package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list.
-
-with CA11014_1.CA11014_2; -- Additional generic list operation,
-with CA11014_5;
-pragma Elaborate (CA11014_5);
-package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2;
- -- Points list operation.
-
- --==================================================================--
-
-with CA11014_1.CA11014_2; -- Additional generic list operation,
- -- implicitly with list operation.
-with CA11014_3; -- Package containing discrete type declaration.
-with CA11014_4; -- Points list.
-with CA11014_5.CA11014_6; -- Points list operation.
-with Report;
-
-procedure CA11014 is
-
- package Lists_Of_Scores renames CA11014_4;
- package Score_Ops renames CA11014_5;
- package Point_Ops renames CA11014_5.CA11014_6;
-
- Scores : Lists_Of_Scores.List_Type; -- List of points.
-
- type TC_Score_Array is array (1 .. 3) of CA11014_3.Points;
-
- TC_Initial_Values : constant TC_Score_Array := (10, 21, 49);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Initial_Values_Are_Correct : boolean := false;
- TC_Final_Values_Are_Correct : boolean := false;
-
- --------------------------------------------------
-
- -- Initial list contains 3 scores with the values 10, 21, and 49.
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin
- for I in TC_Score_Array'range loop
- Score_Ops.Add_Element (L, TC_Initial_Values(I));
- -- Operation from generic parent.
- end loop;
- end TC_Initialize_List;
-
- --------------------------------------------------
-
- -- Verify that all scores have been set to zero.
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out boolean) is
- Actual : TC_Score_Array;
- begin
- Lists_of_Scores.Reset (L); -- Operation from parent's formal.
- for I in TC_Score_Array'range loop
- Score_Ops.Read_Element (L, Actual(I));
- -- Operation from generic parent.
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- --------------------------------------------------
-
-begin -- CA11014
-
- Report.Test ("CA11014", "Check that an instantiation of a child package " &
- "of a generic package can use its parent's " &
- "declarations and operations, including a " &
- "formal package of the parent");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct);
-
- if not TC_Initial_Values_Are_Correct then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Point_Ops.Write_First_To_List (Scores);
- -- Operation from generic child package.
-
- TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct);
-
- if not TC_Final_Values_Are_Correct then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-
-end CA11014;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11015.a b/gcc/testsuite/ada/acats/tests/ca/ca11015.a
deleted file mode 100644
index 79b99ed..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11015.a
+++ /dev/null
@@ -1,312 +0,0 @@
--- CA11015.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 generic child of a non-generic package can use its
--- parent's declarations and operations. Check that the instantiation
--- of the generic child can correctly use the operations.
---
--- TEST DESCRIPTION:
--- Declare a map abstraction in a package which manages basic physical
--- maps. Declare a generic child of this package which defines copies
--- of maps of any discrete type, i.e., population, density, or weather.
---
--- In the main program, declare an instance of the child. Check that
--- the operations in the parent and instance of the child package
--- perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates map of physical features, i.e., desert, forest, water,
--- or plains.
-
-package CA11015_0 is
- type Map_Type is private;
- subtype Latitude is integer range 1 .. 9;
- subtype Longitude is integer range 1 .. 7;
-
- type Physical_Features is (Desert, Forest, Water, Plains, Unexplored);
- type Page_Type is range 0 .. 80;
-
- Terra_Incognita : exception;
-
- -- Use geographic database to initialize the basic map.
-
- procedure Initialize_Basic_Map (Map : in out Map_Type);
-
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Physical_Features;
-
- function Next_Page return Page_Type;
-
-private
- type Map_Type is array (Latitude, Longitude) of Physical_Features;
- Basic_Map : Map_Type;
- Page : Page_Type := 0; -- Location for each copy of Map.
-
-end CA11015_0;
-
- --==================================================================--
-
-package body CA11015_0 is
-
- procedure Initialize_Basic_Map (Map : in out Map_Type) is
- -- Not a real initialization. Real application can use geographic
- -- database to create the basic map.
- begin
- for I in Latitude'first .. Latitude'last loop
- for J in 1 .. 2 loop
- Map (I, J) := Unexplored;
- end loop;
- for J in 3 .. 4 loop
- Map (I, J) := Desert;
- end loop;
- for J in 5 .. 7 loop
- Map (I, J) := Plains;
- end loop;
- end loop;
-
- end Initialize_Basic_Map;
- ---------------------------------------------------
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Physical_Features is
- begin
- return (Map (Lat, Long));
- end Get_Physical_Feature;
- ---------------------------------------------------
- function Next_Page return Page_Type is
- begin
- Page := Page + 1;
- return (Page);
- end Next_Page;
-
- ---------------------------------------------------
- begin -- CA11015_0
- -- Initialize a basic map.
- Initialize_Basic_Map (Basic_Map);
-
-end CA11015_0;
-
- --==================================================================--
-
--- Generic child package of physical map. Instantiate this package to
--- create map copy with a new geographic feature, i.e., population, density,
--- or weather.
-
-generic
-
- type Generic_Feature is (<>); -- Any geographic feature, i.e., population,
- -- density, or weather that can be
- -- characterized by a scalar value.
-
-package CA11015_0.CA11015_1 is
-
- type Feature_Map is private;
-
- function Get_Feature_Val (Lat : Latitude;
- Long : Longitude;
- Map : Feature_Map) return Generic_Feature;
-
- procedure Set_Feature_Val (Lat : in Latitude;
- Long : in Longitude;
- Fea : in Generic_Feature;
- Map : in out Feature_Map);
-
- function Check_Page (Map : Feature_Map;
- Page_No : Page_Type) return boolean;
-
-private
- type Feature_Type is array (Latitude, Longitude) of Generic_Feature;
-
- type Feature_Map is
- record
- Feature : Feature_Type;
- Page : Page_Type := Next_Page; -- Operation from parent.
- end record;
-
-end CA11015_0.CA11015_1;
-
- --==================================================================--
-
-package body CA11015_0.CA11015_1 is
-
- function Get_Feature_Val (Lat : Latitude;
- Long : Longitude;
- Map : Feature_Map) return Generic_Feature is
- begin
- return (Map.Feature (Lat, Long));
- end Get_Feature_Val;
- ---------------------------------------------------
- procedure Set_Feature_Val (Lat : in Latitude;
- Long : in Longitude;
- Fea : in Generic_Feature;
- Map : in out Feature_Map) is
- begin
- if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored
- -- Parent's operation,
- -- Parent's private object.
- then
- raise Terra_Incognita; -- Exception from parent.
- else
- Map.Feature (Lat, Long) := Fea;
- end if;
- end Set_Feature_Val;
- ---------------------------------------------------
- function Check_Page (Map : Feature_Map;
- Page_No : Page_Type) return boolean is
- begin
- return (Map.Page = Page_No);
- end Check_Page;
-
-end CA11015_0.CA11015_1;
-
- --==================================================================--
-
-with CA11015_0.CA11015_1; -- Generic map operation,
- -- implicitly withs parent, basic map
- -- application.
-with Report;
-
-procedure CA11015 is
-
-begin
-
- Report.Test ("CA11015", "Check that an instantiation of a child package " &
- "of a non-generic package can use its parent's " &
- "declarations and operations");
-
--- An application creates a population map using an integer type.
-
- Population_Map_Subtest:
- declare
- type Population_Type is range 0 .. 10_000;
-
- -- Declare instance of the child generic map package for one
- -- particular integer type.
-
- package Population is new CA11015_0.CA11015_1 (Population_Type);
-
- Population_Map_Latitude : CA11015_0.Latitude := 1;
- -- parent's type
- Population_Map_Longitude : CA11015_0.Longitude := 5;
- -- parent's type
- Pop_Map : Population.Feature_Map;
- Pop : Population_Type := 1000;
-
- begin
- Population.Set_Feature_Val (Population_Map_Latitude,
- Population_Map_Longitude,
- Pop,
- Pop_Map);
-
- If not ( (Population.Get_Feature_Val (Population_Map_Latitude,
- Population_Map_Longitude, Pop_Map) = Pop) or
- (Population.Check_Page (Pop_Map, 1)) ) then
- Report.Failed ("Population map contains incorrect values");
- end if;
-
- end Population_Map_Subtest;
-
--- An application creates a weather map using an enumeration type.
-
- Weather_Map_Subtest:
- declare
- type Weather_Type is (Hot, Cold, Mild);
-
- -- Declare instance of the child generic map package for one
- -- particular enumeration type.
-
- package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type);
-
- Weather_Map_Latitude : CA11015_0.Latitude := 2;
- -- parent's type
- Weather_Map_Longitude : CA11015_0.Longitude := 6;
- -- parent's type
- Weather_Map : Weather_Pkg.Feature_Map;
- Weather : Weather_Type := Mild;
-
- begin
- Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude,
- Weather_Map_Longitude,
- Weather,
- Weather_Map);
-
- if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude,
- Weather_Map_Longitude, Weather_Map) /= Weather) or
- not (Weather_Pkg.Check_Page (Weather_Map, 2)) )
- then
- Report.Failed ("Weather map contains incorrect values");
- end if;
-
- end Weather_Map_Subtest;
-
--- During processing, the application may erroneously attempts to create
--- a density map on an unexplored area. This would result in the raising
--- of an exception.
-
- Density_Map_Subtest:
- declare
- type Density_Type is (High, Medium, Low);
-
- -- Declare instance of the child generic map package for one
- -- particular enumeration type.
-
- package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type);
-
- Density_Map_Latitude : CA11015_0.Latitude := 7;
- -- parent's type
- Density_Map_Longitude : CA11015_0.Longitude := 2;
- -- parent's type
- Density : Density_Type := Low;
- Density_Map : Density_Pkg.Feature_Map;
-
- begin
- Density_Pkg.Set_Feature_Val (Density_Map_Latitude,
- Density_Map_Longitude,
- Density,
- Density_Map);
-
- Report.Failed ("Exception not raised in child generic package");
-
- exception
-
- when CA11015_0.Terra_Incognita => -- parent's exception,
- null; -- raised in child.
-
- when others =>
- Report.Failed ("Others exception is raised");
-
- end Density_Map_Subtest;
-
- Report.Result;
-
-end CA11015;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11016.a b/gcc/testsuite/ada/acats/tests/ca/ca11016.a
deleted file mode 100644
index d6d4089..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11016.a
+++ /dev/null
@@ -1,321 +0,0 @@
--- CA11016.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 child of a non-generic package can be a private generic
--- package. Check that the private child instance can use its parent's
--- declarations and operations. Check that the body of a public child
--- package can instantiate its sibling private generic package.
---
--- TEST DESCRIPTION:
--- Declare a map abstraction in a package which manages basic physical
--- map[s]. Declare a private generic child of this package which can be
--- instantiated for any display device which has display locations of
--- the physical map that can be characterized by any integer type, i.e.,
--- the intensity of the display point.
---
--- Declare a public child of the physical map which specifies the
--- display device. In the body of this child, declare an instance of
--- its generic sibling to display the geographic locations.
---
--- In the main program, check that the operations in the parent, public
--- child and instance of the private child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate.
---
---!
-
--- Simulates map of physical features, i.e., desert, forest, or water.
-
-package CA11016_0 is
- type Map_Type is private;
- subtype Latitude is integer range 1 .. 9;
- subtype Longitude is integer range 1 .. 7;
-
- type Physical_Features is (Desert, Forest, Water);
-
- -- Use geographic database to initialize the basic map.
-
- procedure Initialize_Basic_Map (Map : in out Map_Type);
-
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Physical_Features;
-
-private
- type Map_Type is array (Latitude, Longitude) of Physical_Features;
- Basic_Map : Map_Type;
-
-end CA11016_0;
-
- --==================================================================--
-
-package body CA11016_0 is
-
- procedure Initialize_Basic_Map (Map : in out Map_Type) is
- -- Not a real initialization. Real application can use geographic
- -- database to create the basic map.
-
- begin
- for I in Latitude'first .. Latitude'last loop
- for J in 1 .. 2 loop
- Map (I, J) := Desert;
- end loop;
- for J in 3 .. 4 loop
- Map (I, J) := Forest;
- end loop;
- for J in 5 .. 7 loop
- Map (I, J) := Water;
- end loop;
- end loop;
-
- end Initialize_Basic_Map;
- --------------------------------------------------------
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Physical_Features is
- begin
- return (Map (Lat, Long));
- end Get_Physical_Feature;
- --------------------------------------------------------
-
- begin
- -- Initialize a basic map.
- Initialize_Basic_Map (Basic_Map);
-
-end CA11016_0;
-
- --==================================================================--
-
--- Private generic child package of physical map. This generic package may
--- be instantiated for any display device which has display locations
--- (latitude, longitude) that can be characterized by an integer value.
--- For example, the intensity of the display point might be so characterized.
--- It can be instantiated for any desired range of values (which would
--- correspond to the range accepted by the display device).
-
-
-private
-
-generic
-
- type Display_Value is range <>; -- Any display feature that is
- -- represented by an integer.
-
-package CA11016_0.CA11016_1 is
-
- function Get_Display_Value (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Display_Value;
-
-end CA11016_0.CA11016_1;
-
-
- --==================================================================--
-
-
-package body CA11016_0.CA11016_1 is
-
- function Get_Display_Value (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Display_Value is
- begin
- case Get_Physical_Feature (Lat, Long, Map) is
- -- Parent's operation,
- when Forest => return (Display_Value'first);
- -- Parent's type.
- when Desert => return (Display_Value'last);
- -- Parent's type.
- when others => return
- ( (Display_Value'last - Display_Value'first) / 2 );
- -- NOTE: Results are truncated.
- end case;
-
- end Get_Display_Value;
-
-end CA11016_0.CA11016_1;
-
-
- --==================================================================--
-
--- Map display operation, public child of physical map.
-
-package CA11016_0.CA11016_2 is
-
- -- Super-duper Ultra Geographic Display Device (SDUGD) can display
- -- geographic locations with light intensity values ranging from 1 to 7.
-
- type Display_Val is range 1 .. 7;
-
- type Device_Color is (Brown, Blue, Green);
-
- type IO_Packet is
- record
- Lat : Latitude; -- Parent's type.
- Long : Longitude; -- Parent's type.
- Color : Device_Color;
- Intensity : Display_Val;
- end record;
-
- procedure Data_For_SDUGD (Lat : in Latitude;
- Long : in Longitude;
- Output_Packet : in out IO_Packet);
-
-end CA11016_0.CA11016_2;
-
- --==================================================================--
-
-
-with CA11016_0.CA11016_1; -- Private generic sibling.
-pragma Elaborate (CA11016_0.CA11016_1);
-
-package body CA11016_0.CA11016_2 is
-
- -- Declare instance of the private generic sibling for
- -- an integer type that represents color intensity.
-
- package SDUGD is new CA11016_0.CA11016_1 (Display_Val);
-
- procedure Data_For_SDUGD (Lat : in Latitude;
- Long : in Longitude;
- Output_Packet : in out IO_Packet) is
-
- -- Simulates sending control information to a display device.
- -- Control information consists of latitude, longitude, a
- -- color, and an intensity.
-
- begin
- case Get_Physical_Feature (Lat, Long, Basic_Map) is
- -- Parent's operation.
- when Water => Output_Packet.Color := Blue;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- when Forest => Output_Packet.Color := Green;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- when others => Output_Packet.Color := Brown;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- end case;
-
- end Data_For_SDUGD;
-
-end CA11016_0.CA11016_2;
-
- --==================================================================--
-
-with CA11016_0.CA11016_2; -- Map display device operation,
- -- implicitly withs parent, physical map
- -- application.
-
-use CA11016_0.CA11016_2; -- Allows direct visibility to the simple
- -- name of CA11016_0.CA11016_2.
-
-with Report;
-
-procedure CA11016 is
-
- TC_Packet : IO_Packet;
-
-begin
-
- Report.Test ("CA11016", "Check that body of a public child package can " &
- "use its sibling private generic package " &
- "declarations and operations");
-
--- Simulate control information at coordinates 3 and 7 of the
--- basic map for the SDUGD.
-
- Water_Display_Subtest:
- begin
- TC_Packet.Lat := 3;
- TC_Packet.Long := 7;
-
- -- Build color and light intensity of the basic map at
- -- latitude 3 and longitude 7.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Blue) or
- (TC_Packet.Intensity /= 3) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for water subtest");
- end if;
-
- end Water_Display_Subtest;
-
--- Simulate control information at coordinates 2 and 1 of the
--- basic map for the SDUGD.
-
- Desert_Display_Subtest:
- begin
- TC_Packet.Lat := 9;
- TC_Packet.Long := 2;
-
- -- Build color and light intensity of the basic map at
- -- latitude 9 and longitude 2.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Brown) or
- (TC_Packet.Intensity /= 7) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for desert subtest");
- end if;
-
- end Desert_Display_Subtest;
-
--- Simulate control information at coordinates 8 and 4 of the
--- basic map for the SDUGD.
-
- Forest_Display_Subtest:
- begin
- TC_Packet.Lat := 8;
- TC_Packet.Long := 4;
-
- -- Build color and light intensity of the basic map at
- -- latitude 8 and longitude 4.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Green) or
- (TC_Packet.Intensity /= 1) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for forest subtest");
- end if;
-
- end Forest_Display_Subtest;
-
- Report.Result;
-
-end CA11016;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11017.a b/gcc/testsuite/ada/acats/tests/ca/ca11017.a
deleted file mode 100644
index cbcce70..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11017.a
+++ /dev/null
@@ -1,246 +0,0 @@
--- CA11017.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 body of the parent package may depend on one of its own
--- public children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a string abstraction in a package which manipulates string
--- replacement. Define a parent package which provides operations for
--- a record type with discriminant. Declare a public child of this
--- package which adds functionality to the original subsystem. In the
--- parent body, call operations from the public child.
---
--- In the main program, check that operations in the parent and public
--- child perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates application which manipulates strings.
-
-package CA11017_0 is
-
- type String_Rec (The_Size : positive) is private;
-
- type Substring is new string;
-
- -- ... Various other types used by the application.
-
- procedure Replace (In_The_String : in out String_Rec;
- At_The_Position : in positive;
- With_The_String : in String_Rec);
-
- -- ... Various other operations used by the application.
-
-private
- -- Different size for each individual record.
-
- type String_Rec (The_Size : positive) is
- record
- The_Length : natural := 0;
- The_Content : Substring (1 .. The_Size);
- end record;
-
-end CA11017_0;
-
- --=================================================================--
-
--- Public child added during code maintenance without disturbing a
--- large system. This public child would add functionality to the
--- original system.
-
-package CA11017_0.CA11017_1 is
-
- Position_Error : exception;
-
- function Equal_Length (Left : in String_Rec;
- Right : in String_Rec) return boolean;
-
- function Same_Content (Left : in String_Rec;
- Right : in String_Rec) return boolean;
-
- procedure Copy (From_The_Substring : in Substring;
- To_The_String : in out String_Rec);
-
- -- ... Various other operations used by the application.
-
-end CA11017_0.CA11017_1;
-
- --=================================================================--
-
-package body CA11017_0.CA11017_1 is
-
- function Equal_Length (Left : in String_Rec;
- Right : in String_Rec) return boolean is
- -- Quick comparison between the lengths of the input strings.
-
- begin
- return (Left.The_Length = Right.The_Length); -- Parent's private
- -- type.
- end Equal_Length;
- --------------------------------------------------------------------
- function Same_Content (Left : in String_Rec;
- Right : in String_Rec) return boolean is
-
- begin
- for I in 1 .. Left.The_Length loop
- if Left.The_Content (I) = Right.The_Content (I) then
- return true;
- else
- return false;
- end if;
- end loop;
-
- end Same_Content;
- --------------------------------------------------------------------
- procedure Copy (From_The_Substring : in Substring;
- To_The_String : in out String_Rec) is
- begin
- To_The_String.The_Content -- Parent's private type.
- (1 .. From_The_Substring'length) := From_The_Substring;
-
- To_The_String.The_Length -- Parent's private type.
- := From_The_Substring'length;
- end Copy;
-
-end CA11017_0.CA11017_1;
-
- --=================================================================--
-
--- After child is added to the subsystem, a maintainer decides
--- to take advantage of the new functionality and rewrites the
--- parent's body.
-
-with CA11017_0.CA11017_1;
-
-package body CA11017_0 is
-
- -- Calls functions from public child for a quick comparison of the
- -- input strings. If their lengths are the same, do the replacement.
-
- procedure Replace (In_The_String : in out String_Rec;
- At_The_Position : in positive;
- With_The_String : in String_Rec) is
- End_Position : natural := At_The_Position +
- With_The_String.The_Length - 1;
-
- begin
- if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation.
- (With_The_String, In_The_String) then
- raise CA11017_0.CA11017_1.Position_Error;
- -- Public child's exception.
- else
- In_The_String.The_Content (At_The_Position .. End_Position) :=
- With_The_String.The_Content (1 .. With_The_String.The_Length);
- end if;
-
- end Replace;
-
-end CA11017_0;
-
- --=================================================================--
-
-with Report;
-
-with CA11017_0.CA11017_1; -- Explicit with public child package,
- -- implicit with parent package (CA11017_0).
-
-procedure CA11017 is
-
- package String_Pkg renames CA11017_0;
- use String_Pkg;
-
-begin
-
- Report.Test ("CA11017", "Check that body of the parent package can " &
- "depend on one of its own public children");
-
--- Both input strings have the same size. Replace the first string by the
--- second string.
-
- Replace_Subtest:
- declare
- The_First_String, The_Second_String : String_Rec (16);
- -- Parent's private type.
- The_Position : positive := 1;
- begin
- CA11017_1.Copy ("This is the time",
- To_The_String => The_First_String);
-
- CA11017_1.Copy ("For all good men", The_Second_String);
-
- Replace (The_First_String, The_Position, The_Second_String);
-
- -- Compare results using function from public child since
- -- the type is private.
-
- if not CA11017_1.Same_Content
- (The_First_String, The_Second_String) then
- Report.Failed ("Incorrect results");
- end if;
-
- end Replace_Subtest;
-
--- During processing, the application may erroneously attempt to replace
--- strings of different size. This would result in the raising of an
--- exception.
-
- Exception_Subtest:
- declare
- The_First_String : String_Rec (17);
- -- Parent's private type.
- The_Second_String : String_Rec (13);
- -- Parent's private type.
- The_Position : positive := 2;
- begin
- CA11017_1.Copy (" ACVC Version 2.0", The_First_String);
-
- CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic",
- To_The_String => The_Second_String);
-
- Replace (The_First_String, The_Position, The_Second_String);
-
- Report.Failed ("Exception was not raised");
-
- exception
- when CA11017_1.Position_Error =>
- Report.Comment ("Exception is raised as expected");
-
- end Exception_Subtest;
-
- Report.Result;
-
-end CA11017;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a
deleted file mode 100644
index a01ebfc..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11018.a
+++ /dev/null
@@ -1,366 +0,0 @@
--- CA11018.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 body of the parent package may depend on one of its own
--- public generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a message application in a package which highlights some
--- key words. Declare a public generic child of this package which adds
--- functionality to the original subsystem. In the parent body,
--- instantiate the child.
---
--- In the main program, check that the operations in the parent,
--- and instances of the public child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst.
--- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
--- Simulates application which displays messages.
-
-package CA11018_0 is
-
- type Designated_Num is new Integer range 0 .. 100;
-
- type Particularly_Designated_Num is new Integer range 0 .. 100;
-
- type Message is new String;
-
- type Message_Rec is tagged private;
-
- type Designated_Msg is new Message_Rec with private;
-
- type Particularly_Designated_Msg is new Message_Rec with private;
-
- -- Analyzes message for presence of word in the secret message. If found,
- -- word is highlighted.
-
- procedure Highlight_Designated (The_Word : in Message;
- In_The_Message : in out Designated_Msg);
-
-
- -- Analyzes message for presence of word in the secret message. If found,
- -- word is highlighted and do other actions.
-
- procedure Highlight_Particularly_Designated
- (The_Word : in Message;
- In_The_Message : in out Particularly_Designated_Msg);
-
-
- -- Begin test code declarations: -----------------------
-
- TC_Designated_Not_Zero : Boolean := false;
-
- TC_Particularly_Designated_Not_Zero : Boolean := false;
-
- -- The following two functions are used to check for function
- -- calls from the public generic child.
-
- function TC_Designated_Success return Boolean;
-
- function TC_Particularly_Designated_Success return Boolean;
-
- -- End test code declarations. -------------------------
-
-private
- type Message_Rec is tagged
- record
- The_Length : natural := 0;
- The_Content : Message (1 .. 60);
- end record;
-
- type Designated_Msg is new Message_Rec with null record;
- -- ... More components in real application.
-
- type Particularly_Designated_Msg is new Message_Rec with null record;
- -- ... More components in real application.
-
-end CA11018_0;
-
- --=================================================================--
-
-
--- Public generic child package of message display application. Imagine that
--- messages of one security level are associated with a type derived from
--- integer. For overall system security, messages of a different security
--- level are associated with a different type derived from integer. By
--- instantiating this package for each security level, the results of Count
--- applied to one kind of message cannot inadvertently be compared with the
--- results applied to a different kind.
-
-generic
- type Msg_Type is new Message_Rec with private;
- -- Derived from parent's type.
- type Count is range <>;
-
-package CA11018_0.CA11018_1 is
-
- TC_Function_Called : Boolean := false;
-
- function Find_Word (Wrd : in Message;
- Msg : in Msg_Type) return Count;
-
-end CA11018_0.CA11018_1;
-
- --=================================================================--
-
-package body CA11018_0.CA11018_1 is
-
- function Find_Word (Wrd : in Message;
- Msg : in Msg_Type) return Count is
-
- Num : Count := Count'first;
-
- -- Count how many time the word appears within the given message.
-
- begin
- -- ... Error-checking code omitted for brevity.
-
- for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop
- -- Parent's private type
- if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd
- -- Parent's private type
- then
- Num := Num + 1;
- end if;
-
- end loop;
-
- TC_Function_Called := true;
-
- return (Num);
-
- end Find_Word;
-
-end CA11018_0.CA11018_1;
-
- --=================================================================--
-
-with CA11018_0.CA11018_1; -- Public generic child.
-
-pragma Elaborate (CA11018_0.CA11018_1);
-package body CA11018_0 is
-
- ----------------------------------------------------
- -- Parent's body depends on public generic child. --
- ----------------------------------------------------
-
- -- Instantiate the public child for the secret message.
-
- package Designated_Pkg is new CA11018_0.CA11018_1
- (Msg_Type => Designated_Msg, Count => Designated_Num);
-
- -- Instantiate the public child for the top secret message.
-
- package Particularly_Designated_Pkg is new CA11018_0.CA11018_1
- (Particularly_Designated_Msg, Particularly_Designated_Num);
-
- -- End instantiations. -----------------------------
-
-
- function TC_Designated_Success return Boolean is
- -- Check to see if the function in the public generic child is called.
-
- begin
- return Designated_Pkg.TC_Function_Called;
- end TC_Designated_Success;
- --------------------------------------------------------------
- function TC_Particularly_Designated_Success return Boolean is
- -- Check to see if the function in the public generic child is called.
-
- begin
- return Particularly_Designated_Pkg.TC_Function_Called;
- end TC_Particularly_Designated_Success;
- --------------------------------------------------------------
- -- Calls functions from public child to search for a key word.
- -- If the word appears more than once in each message,
- -- highlight all of them.
-
- procedure Highlight_Designated (The_Word : in Message;
- In_The_Message : in out Designated_Msg) is
-
- -- Not a real highlight procedure. Real application can use graphic
- -- device to highlight all occurrences of words.
-
- begin
- --------------------------------------------------------------
- -- Parent's body uses function from instantiation of public --
- -- generic child. --
- --------------------------------------------------------------
-
- if Designated_Pkg.Find_Word -- Child's operation.
- (The_Word, In_The_Message) > 0 then
-
- -- Highlight all occurrences in lavender.
-
- TC_Designated_Not_Zero := true;
- end if;
-
- end Highlight_Designated;
- --------------------------------------------------------------
- procedure Highlight_Particularly_Designated
- (The_Word : in Message;
- In_The_Message : in out Particularly_Designated_Msg) is
-
- -- Not a real highlight procedure. Real application can use graphic
- -- device to highlight all occurrences of words.
-
- begin
- --------------------------------------------------------------
- -- Parent's body uses function from instantiation of public --
- -- generic child. --
- --------------------------------------------------------------
-
- if Particularly_Designated_Pkg.Find_Word -- Child's operation.
- (The_Word, In_The_Message) > 0 then
-
- -- Highlight all occurrences in chartreuse.
- -- Do other more secret stuff.
-
- TC_Particularly_Designated_Not_Zero := true;
- end if;
-
- end Highlight_Particularly_Designated;
-
-end CA11018_0;
-
- --=================================================================--
-
--- Public generic child to copy words to the messages.
-
-generic
- type Message_Type is new Message_Rec with private;
- -- Derived from parent's type.
-
-package CA11018_0.CA11018_2 is
-
- procedure Copy (From_The_Word : in Message;
- To_The_Message : in out Message_Type);
-
-end CA11018_0.CA11018_2;
-
- --=================================================================--
-
-package body CA11018_0.CA11018_2 is
-
- procedure Copy (From_The_Word : in Message;
- To_The_Message : in out Message_Type) is
-
- -- Copy words to the appropriate messages.
-
- begin
- To_The_Message.The_Content -- Parent's private type.
- (1 .. From_The_Word'length) := From_The_Word;
-
- To_The_Message.The_Length -- Parent's private type.
- := From_The_Word'length;
- end Copy;
-
-end CA11018_0.CA11018_2;
-
- --=================================================================--
-
-with Report;
-
-with CA11018_0.CA11018_2; -- Public generic child package, copy words
- -- to the message.
- -- Implicit with parent package (CA11018_0).
-
-procedure CA11018 is
-
- package Message_Pkg renames CA11018_0;
-
-begin
-
- Report.Test ("CA11018", "Check that body of the parent package can " &
- "depend on one of its own public generic children");
-
--- Highlight the word "Alert" from the secret message.
-
- Designated_Subtest:
- declare
- The_Message : Message_Pkg.Designated_Msg; -- Parent's private type.
-
- -- Instantiate the public child to copy words to the secret message.
-
- package Copy_Designated_Pkg is new CA11018_0.CA11018_2
- (Message_Pkg.Designated_Msg);
-
- begin
- Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard",
- To_The_Message => The_Message);
-
- Message_Pkg.Highlight_Designated ("Alert", The_Message);
-
- if not Message_Pkg.TC_Designated_Not_Zero and
- Message_Pkg.TC_Designated_Success then
- Report.Failed ("Alert should have been highlighted");
- end if;
-
- end Designated_Subtest;
-
--- Highlight the word "Push The Alarm" from the top secret message.
-
- Particularly_Designated_Subtest:
- declare
- The_Message : Message_Pkg.Particularly_Designated_Msg ;
- -- Parent's private type.
-
- -- Instantiate the public child to copy words to the top secret
- -- message.
-
- package Copy_Particularly_Designated_Pkg is new
- CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg);
-
- begin
- Copy_Particularly_Designated_Pkg.Copy
- ("Alert Level 10 : Alert The Guard and Push The Alarm",
- The_Message);
-
- Message_Pkg.Highlight_Particularly_Designated
- ("Push The Alarm", The_Message);
-
- if not Message_Pkg.TC_Particularly_Designated_Not_Zero and
- Message_Pkg.TC_Particularly_Designated_Success then
- Report.Failed ("Key words should have been highlighted");
- end if;
-
- end Particularly_Designated_Subtest;
-
- Report.Result;
-
-end CA11018;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11019.a b/gcc/testsuite/ada/acats/tests/ca/ca11019.a
deleted file mode 100644
index 92b3ba5..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11019.a
+++ /dev/null
@@ -1,306 +0,0 @@
--- CA11019.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 body of the parent package may depend on one of its own
--- private generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- generic private child during code maintenance without distubing a
--- large subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a data collection abstraction in a package. Declare a private
--- generic child of this package which provides parameterized code that
--- have been written once and will be used three times to implement the
--- services of the parent package. In the parent body, instantiate the
--- private child.
---
--- In the main program, check that the operations in the parent,
--- and instance of the private child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11019_0 is
- -- parent
-
- type Data_Record is tagged private;
- type Data_Collection is private;
- ---
- ---
- subtype Data_1 is integer range 0 .. 100;
- procedure Add_1 (Data : Data_1; To : in out Data_Collection);
- function Statistical_Op_1 (Data : Data_Collection) return Data_1;
- ---
- subtype Data_2 is integer range -100 .. 1000;
- procedure Add_2 (Data : Data_2; To : in out Data_Collection);
- function Statistical_Op_2 (Data : Data_Collection) return Data_2;
- ---
- subtype Data_3 is integer range -10_000 .. 10_000;
- procedure Add_3 (Data : Data_3; To : in out Data_Collection);
- function Statistical_Op_3 (Data : Data_Collection) return Data_3;
- ---
-
-private
-
- type Data_Ptr is access Data_Record'class;
- subtype Sequence_Number is positive range 1 .. 512;
-
- type Data_Record is tagged
- record
- Next : Data_Ptr := null;
- Seq : Sequence_Number;
- end record;
- ---
- type Data_Collection is
- record
- First : Data_Ptr := null;
- Last : Data_Ptr := null;
- end record;
-
-end CA11019_0;
- -- parent
-
- --=================================================================--
-
--- This generic package provides parameterized code that has been
--- written once and will be used three times to implement the services
--- of the parent package.
-
-private
-generic
- type Data_Type is range <>;
-
-package CA11019_0.CA11019_1 is
- -- parent.child
-
- type Data_Elem is new Data_Record with
- record
- Value : Data_Type;
- end record;
-
- Next_Avail_Seq_No : Sequence_Number := 1;
-
- procedure Sequence (Ptr : Data_Ptr);
- -- the child must be private for this procedure to know details of
- -- the implementation of data collections
-
- procedure Add (Datum : Data_Type; To : in out Data_Collection);
-
- function Op (Data : Data_Collection) return Data_Type;
- -- op models a complicated operation that whose code can be
- -- used for various data types
-
-
-end CA11019_0.CA11019_1;
- -- parent.child
-
- --=================================================================--
-
-
-package body CA11019_0.CA11019_1 is
- -- parent.child
-
- procedure Sequence (Ptr : Data_Ptr) is
- begin
- Ptr.Seq := Next_Avail_Seq_No;
- Next_Avail_Seq_No := Next_Avail_Seq_No + 1;
- end Sequence;
-
- ---------------------------------------------------------
-
- procedure Add (Datum : Data_Type; To : in out Data_Collection) is
- Ptr : Data_Ptr;
- begin
- if To.First = null then
- -- assign new record with data value to
- -- to.next <- null;
- To.First := new Data_Elem'(Next => null,
- Value => Datum,
- Seq => 1);
- Sequence (To.First);
- To.Last := To.First;
- else
- -- chase to end of list
- Ptr := To.First;
- while Ptr.Next /= null loop
- Ptr := Ptr.Next;
- end loop;
- -- and add element there
- Ptr.Next := new Data_Elem'(Next => null,
- Value => Datum,
- Seq => 1);
- Sequence (Ptr.Next);
- To.Last := Ptr.Next;
- end if;
-
- end Add;
-
- ---------------------------------------------------------
-
- function Op (Data : Data_Collection) return Data_Type is
- -- for simplicity, just return the maximum of the data set
- Max : Data_Type := Data_Elem( Data.First.all ).Value;
- -- assuming non-empty collection
- Ptr : Data_Ptr := Data.First;
-
- begin
- -- no error checking
- while Ptr.Next /= null loop
- if Data_Elem( Ptr.Next.all ).Value > Max then
- Max := Data_Elem( Ptr.Next.all ).Value;
- end if;
- Ptr := Ptr.Next;
- end loop;
- return Max;
- end Op;
-
-end CA11019_0.CA11019_1;
- -- parent.child
-
- --=================================================================--
-
--- parent body depends on private generic child
-with CA11019_0.CA11019_1; -- Private generic child.
-
-pragma Elaborate (CA11019_0.CA11019_1);
-package body CA11019_0 is
-
- -- instantiate the generic child with data types needed by the
- -- package interface services
- package Data_1_Ops is new CA11019_1
- (Data_Type => Data_1);
-
- package Data_2_Ops is new CA11019_1
- (Data_Type => Data_2);
-
- package Data_3_Ops is new CA11019_1
- (Data_Type => Data_3);
-
- ---------------------------------------------------------
-
- procedure Add_1 (Data : Data_1; To : in out Data_Collection) is
- begin
- -- maybe do other stuff here
- Data_1_Ops.Add (Data, To);
- -- and here
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_1 (Data : Data_Collection) return Data_1 is
- begin
- -- maybe use generic operation(s) in some complicated ways
- -- (but simplified out, for the sake of testing)
- return Data_1_Ops.Op (Data);
- end;
-
- ---------------------------------------------------------
-
- procedure Add_2 (Data : Data_2; To : in out Data_Collection) is
- begin
- Data_2_Ops.Add (Data, To);
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_2 (Data : Data_Collection) return Data_2 is
- begin
- return Data_2_Ops.Op (Data);
- end;
-
- ---------------------------------------------------------
-
- procedure Add_3 (Data : Data_3; To : in out Data_Collection) is
- begin
- Data_3_Ops.Add (Data, To);
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_3 (Data : Data_Collection) return Data_3 is
- begin
- return Data_3_Ops.Op (Data);
- end;
-
-end CA11019_0;
-
-
- --=================================================--
-
-with CA11019_0,
- -- Main,
- -- Main.Child is private
- Report;
-
-procedure CA11019 is
-
- package Main renames CA11019_0;
-
- Col_1,
- Col_2,
- Col_3 : Main.Data_Collection;
-
-begin
-
- Report.Test ("CA11019", "Check that body of a (non-generic) package " &
- "may depend on its private generic child");
-
- -- build a data collection
-
- for I in 1 .. 10 loop
- Main.Add_1 ( Main.Data_1(I), Col_1);
- end loop;
-
- if Main.Statistical_Op_1 (Col_1) /= 10 then
- Report.Failed ("Wrong data_1 value returned");
- end if;
-
- for I in reverse 10 .. 20 loop
- Main.Add_2 ( Main.Data_2(I * 10), Col_2);
- end loop;
-
- if Main.Statistical_Op_2 (Col_2) /= 200 then
- Report.Failed ("Wrong data_2 value returned");
- end if;
-
- for I in 0 .. 10 loop
- Main.Add_3 ( Main.Data_3(I + 5), Col_3);
- end loop;
-
- if Main.Statistical_Op_3 (Col_3) /= 15 then
- Report.Failed ("Wrong data_3 value returned");
- end if;
-
- Report.Result;
-
-end CA11019;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11020.a b/gcc/testsuite/ada/acats/tests/ca/ca11020.a
deleted file mode 100644
index 4949ce9..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11020.a
+++ /dev/null
@@ -1,238 +0,0 @@
--- CA11020.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 body of the generic parent package can depend on one of
--- its own public generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a bag abstraction in a generic package. Declare a public
--- generic child of this package which adds a generic procedure to the
--- original subsystem. In the parent body, instantiate the public
--- child. Then instantiate the procedure as a child instance of the
--- public child instance.
---
--- In the main program, declare an instance of parent. Check that the
--- operations in both parent and child packages perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates bag application.
-
-generic
- type Element is private;
- with function Image (E : Element) return String;
-
-package CA11020_0 is
-
- type Bag is limited private;
-
- procedure Add (E : in Element; To_The_Bag : in out Bag);
-
- function Bag_Image (B : Bag) return string;
-
-private
- type Node_Type;
- type Bag is access Node_Type;
-
- type Node_Type is
- record
- The_Element : Element;
-
- -- Other components in real application, i.e.,
- -- The_Count : positive;
-
- Next : Bag;
- end record;
-
-end CA11020_0;
-
- --==================================================================--
-
--- More operations on Bag.
-
-generic
-
--- Parameters go here.
-
-package CA11020_0.CA11020_1 is
-
- -- ... Other declarations.
-
- generic -- Generic iterator procedure.
- with procedure Use_Element (E : in Element);
-
- procedure Iterate (B : in Bag); -- Called once per element in the bag.
-
- -- ... Various other operations.
-
-end CA11020_0.CA11020_1;
-
- --==================================================================--
-
-package body CA11020_0.CA11020_1 is
-
- procedure Iterate (B : in Bag) is
-
- -- Traverse each element in the bag.
-
- Elem : Bag := B;
-
- begin
- while Elem /= null loop
- Use_Element (Elem.The_Element);
- Elem := Elem.Next;
- end loop;
-
- end Iterate;
-
-end CA11020_0.CA11020_1;
-
- --==================================================================--
-
-with CA11020_0.CA11020_1; -- Public generic child package.
-
-package body CA11020_0 is
-
- ----------------------------------------------------
- -- Parent's body depends on public generic child. --
- ----------------------------------------------------
-
- -- Instantiate the public child.
-
- package MS is new CA11020_1;
-
- function Bag_Image (B : Bag) return string is
-
- Buffer : String (1 .. 10_000);
- Last : Integer := 0;
-
- -----------------------------------------------------
-
- -- Will be called by the iterator.
-
- procedure Append_Image (E : in Element) is
- Im : constant String := Image (E);
-
- begin -- Append_Image
- if Last /= 0 then -- Insert a comma.
- Last := Last + 1;
- Buffer (Last) := ',';
- end if;
-
- Buffer (Last + 1 .. Last + Im'Length) := Im;
- Last := Last + Im'Length;
-
- end Append_Image;
-
- -----------------------------------------------------
-
- -- Instantiate procedure Iterate as a child of instance MS.
-
- procedure Append_All is new MS.Iterate (Use_Element => Append_Image);
-
- begin -- Bag_Image
-
- Append_All (B);
-
- return Buffer (1 .. Last);
-
- end Bag_Image;
-
- -----------------------------------------------------
-
- procedure Add (E : in Element; To_The_Bag : in out Bag) is
-
- -- Not a real bag addition.
-
- Index : Bag := To_The_Bag;
-
- begin
- -- ... Error-checking code omitted for brevity.
-
- if Index = null then
- To_The_Bag := new Node_Type' (The_Element => E,
- Next => null);
- else
- -- Goto the end of the list.
-
- while Index.Next /= null loop
- Index := Index.Next;
- end loop;
-
- -- Add element to the end of the list.
-
- Index.Next := new Node_Type' (The_Element => E,
- Next => null);
- end if;
-
- end Add;
-
-end CA11020_0;
-
- --==================================================================--
-
-with CA11020_0; -- Bag application.
-
-with Report;
-
-procedure CA11020 is
-
- -- Instantiate the bag application for integer type and attribute
- -- Image.
-
- package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);
-
- My_Bag : Bag_Of_Integers.Bag;
-
-begin
-
- Report.Test ("CA11020", "Check that body of the generic parent package " &
- "can depend on one of its own public generic children");
-
- -- Add 10 consecutive integers to the bag.
-
- for I in 1 .. 10 loop
- Bag_Of_Integers.Add (I, My_Bag);
- end loop;
-
- if Bag_Of_Integers.Bag_Image (My_Bag)
- /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then
- Report.Failed ("Incorrect results");
- end if;
-
- Report.Result;
-
-end CA11020;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11021.a b/gcc/testsuite/ada/acats/tests/ca/ca11021.a
deleted file mode 100644
index f4da2f9..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11021.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- CA11021.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 body of the generic parent package can depend on one of
--- its own private generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a generic package which declares high level operations for a
--- complex number abstraction. Declare a private generic child package
--- of this package which defines low level complex operations. In the
--- parent body, instantiate the private child. Use the low level
--- operation to complete the high level operation.
---
--- In the main program, instantiate the parent generic package.
--- Check that the operations in both packages perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Complex number abstraction.
- type Int_Type is range <>;
-
-package CA11021_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- Real number (0,0).
-
- function Real_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Imag_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Complex (Real, Imag : Int_Type)
- return Complex_Type;
-
- -- High level operation for complex number.
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type;
-
- -- ... and other complicated ones.
-
-private
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
-
-end CA11021_0;
-
- --==================================================================--
-
--- Private generic child of Complex_Number.
-
-private
-
-generic
-
--- No parameter.
-
-package CA11021_0.CA11021_1 is
-
- -- ... Other declarations.
-
- -- Low level operation on complex number.
- function "+" (Left, Right : Complex_Type)
- return Complex_Type;
-
- function "-" (Right : Complex_Type)
- return Complex_Type;
-
- -- ... Various other operations in real application.
-
-end CA11021_0.CA11021_1;
-
- --==================================================================--
-
-package body CA11021_0.CA11021_1 is
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type is
-
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
- --------------------------------------------------
-
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return (-Right.Real, -Right.Imag);
- end "-";
-
-end CA11021_0.CA11021_1;
-
- --==================================================================--
-
-with CA11021_0.CA11021_1; -- Private generic child package.
-
-package body CA11021_0 is
-
- -----------------------------------------------------
- -- Parent's body depends on private generic child. --
- -----------------------------------------------------
-
- -- Instantiate the private child.
-
- package Complex_Ops is new CA11021_1;
- use Complex_Ops; -- All user-defined operators
- -- directly visible.
-
- --------------------------------------------------
-
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type is
- Result : Complex_Type := Zero;
-
- begin
- for I in 1 .. abs (Factor) loop
- Result := Result + C; -- Private generic child "+".
- end loop;
-
- if Factor < 0 then
- Result := - Result; -- Private generic child "-".
- end if;
-
- return Result;
- end "*";
-
- --------------------------------------------------
-
- function Real_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Real);
- end Real_Part;
-
- --------------------------------------------------
-
- function Imag_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Imag);
- end Imag_Part;
-
- --------------------------------------------------
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
-
-end CA11021_0;
-
- --==================================================================--
-
-with CA11021_0; -- Complex number abstraction.
-
-with Report;
-
-procedure CA11021 is
-
- type My_Integer is range -100 .. 100;
-
- --------------------------------------------------
-
--- Declare instance of the generic complex package for one particular
--- integer type.
-
- package My_Complex_Pkg is new
- CA11021_0 (Int_Type => My_Integer);
-
- use My_Complex_Pkg; -- All user-defined operators
- -- directly visible.
-
- --------------------------------------------------
-
- Complex_One, Complex_Two : Complex_Type;
-
- My_Literal : My_Integer := -3;
-
-begin
-
- Report.Test ("CA11021", "Check that body of the generic parent package " &
- "can depend on its private generic child");
-
- Complex_One := Complex (11, 6);
-
- Complex_Two := 5 * Complex_One;
-
- if Real_Part (Complex_Two) /= 55
- and Imag_Part (Complex_Two) /= 30
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Complex_One := Complex (-4, 7);
-
- Complex_Two := My_Literal * Complex_One;
-
- if Real_Part (Complex_Two) /= 12
- and Imag_Part (Complex_Two) /= -21
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Report.Result;
-
-end CA11021;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11022.a b/gcc/testsuite/ada/acats/tests/ca/ca11022.a
deleted file mode 100644
index 60cbc08..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11022.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- CA11022.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 body of a child unit can instantiate its generic sibling.
---
--- TEST DESCRIPTION:
--- Declare a package that provides some types for the graphic
--- application. Add a generic child package with a subprogram parameter
--- to provide algorithms that can be used by different terminal types
--- but that have to be customized to the specific terminal. Add child
--- packages to take advantage of the parent types and to provide a
--- customized operation for each of the different terminals. The
--- customized operation will be passed as a generic subprogram parameter
--- to the child package's sibling.
---
--- The main program "with"s the child packages. Check that the
--- operations in child units perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11022_0 is -- Graphic Manager
-
- type Row is range 1 .. 66;
- type Column is range 1 .. 80;
- type Radius is range 1 .. 3;
- type Length is range 5 .. 10;
-
- -- Testing artifice.
- TC_Screen : array (Row, Column) of boolean := (others => (others => false));
- TC_Draw_Circle : boolean := false;
- TC_Draw_Square : boolean := false;
-
- -- ... and other complicated ones.
-
-end CA11022_0;
-
--- No bodies required for CA11022_0.
-
- --==================================================================--
-
--- Child package to provide general graphic functionalities.
-
-generic
-
- with procedure Put_Dot (X : in Column;
- Y : in Row);
-
-package CA11022_0.CA11022_1 is
-
- procedure Draw_Square (At_Col : in Column;
- At_Row : in Row;
- Len : in Length);
-
- procedure Draw_Circle (At_Col : in Column;
- At_Row : in Row;
- Rad : in Radius);
-
- -- procedure Draw_Ellipse ...
- -- and other drawings ...
-
-end CA11022_0.CA11022_1;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_1 is
-
- procedure Draw_Square (At_Col : in Column;
- At_Row : in Row;
- Len : in Length) is
- begin
- -- use square drawing algorithm
- -- call
- Put_Dot (At_Col + Column (Len), At_Row + Row(Len));
- -- as needed in the algorithm.
- TC_Draw_Square := true;
- end Draw_Square;
-
- -------------------------------------------------------
- procedure Draw_Circle (At_Col : in Column;
- At_Row : in Row;
- Rad : in Radius) is
- begin
- -- use circle drawing algorithm
- -- call
- for I in 1 .. Rad loop
- Put_Dot (At_Col + Column(I), At_Row + Row(I));
- end loop;
- -- as needed in the algorithm.
- TC_Draw_Circle := true;
- end Draw_Circle;
-
-end CA11022_0.CA11022_1;
-
- --==================================================================--
-
-with CA11022_0.CA11022_1; -- Generic sibling.
-
--- Child package to provide customized graphic functions for the
--- VT100.
-package CA11022_0.CA11022_2 is -- VT100 Graphic.
-
- X : Column := 8;
- Y : Row := 3;
- R : Radius := 2;
- L : Length := 6;
-
- procedure VT100_Graphic;
-
-end CA11022_0.CA11022_2;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_2 is
-
- procedure VT100_Graphic is
- procedure VT100_Putdot (X : in Column;
- Y : in Row) is
- begin
- -- Light a pixel at location (X, Y);
- TC_Screen (Y, X) := true;
- end VT100_Putdot;
-
- ------------------------------------
-
- -- Declare instance of the generic sibling package to draw a circle,
- -- a square, or an ellipse customized for the VT100.
- package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot);
-
- begin
- VT100_Graphic.Draw_Circle (X, Y, R);
- VT100_Graphic.Draw_Square (X, Y, L);
- end VT100_Graphic;
-
-end CA11022_0.CA11022_2;
-
- --==================================================================--
-
-with CA11022_0.CA11022_1; -- Generic sibling.
-
--- Child package to provide customized graphic functions for the
--- IBM3270.
-package CA11022_0.CA11022_3 is -- IBM3270 Graphic.
-
- X : Column := 39;
- Y : Row := 11;
- R : Radius := 3;
- L : Length := 7;
-
- procedure IBM3270_Graphic;
-
-end CA11022_0.CA11022_3;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_3 is
-
- procedure IBM3270_Graphic is
- procedure IBM3270_Putdot (X : in Column;
- Y : in Row) is
- begin
- -- Light a pixel at location (X + 2, Y);
- TC_Screen (Y, X + Column(2)) := true;
- end IBM3270_Putdot;
-
- ------------------------------------
-
- -- Declare instance of the generic sibling package to draw a circle,
- -- a square, or an ellipse customized for the IBM3270.
- package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot);
-
- begin
- IBM3270_Graphic.Draw_Circle (X, Y, R);
- IBM3270_Graphic.Draw_Square (X, Y, L);
- end IBM3270_Graphic;
-
-end CA11022_0.CA11022_3;
-
- --==================================================================--
-
-with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with
- -- CA11022_0, Graphic Manager.
-with CA11022_0.CA11022_3; -- IBM3270 Graphic.
-with Report;
-
-procedure CA11022 is
-
-begin
-
- Report.Test ("CA11022", "Check that body of a child unit can depend on " &
- "its generic sibling");
-
- -- Customized graphic functions for the VT100 terminal.
- CA11022_0.CA11022_2.VT100_Graphic;
-
- if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10)
- and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle
- and not CA11022_0.TC_Draw_Square then
- Report.Failed ("Wrong results for the VT100");
- end if;
-
- CA11022_0.TC_Draw_Circle := false;
- CA11022_0.TC_Draw_Square := false;
-
- -- Customized graphic functions for the IBM3270 terminal.
- CA11022_0.CA11022_3.IBM3270_Graphic;
-
- if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43)
- and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18)
- and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then
- Report.Failed ("Wrong results for the IBM3270");
- end if;
-
- Report.Result;
-
-end CA11022;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada
deleted file mode 100644
index 23f766f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada
+++ /dev/null
@@ -1,31 +0,0 @@
--- CA1102A0.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.
---*
--- WKB 6/12/81
-
-PACKAGE CA1102A0 IS -- BODY IS IN CA1102A1.
-
- PROCEDURE P (INVOKED : IN OUT BOOLEAN);
-
-END CA1102A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada
deleted file mode 100644
index e201a51..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA1102A1.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.
---*
--- WKB 6/12/81
-
-PACKAGE BODY CA1102A0 IS
-
- PROCEDURE P (INVOKED : IN OUT BOOLEAN) IS
- BEGIN
- INVOKED := TRUE;
- END P;
-
-BEGIN
- NULL;
-END CA1102A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada
deleted file mode 100644
index b4cffd1..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada
+++ /dev/null
@@ -1,58 +0,0 @@
--- CA1102A2M.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 MORE THAN ONE WITH_CLAUSE CAN APPEAR IN
--- A CONTEXT_SPECIFICATION.
--- CHECK THAT USE_CLAUSES CAN MENTION NAMES MADE
--- VISIBLE BY PRECEDING WITH_CLAUSES IN THE SAME
--- CONTEXT_SPECIFICATION.
--- CHECK THAT CONSECUTIVE USE_CLAUSES ARE ALLOWED.
-
--- SEPARATE FILES ARE:
--- CA1102A0 A LIBRARY PACKAGE DECLARATION.
--- CA1102A1 A LIBRARY PACKAGE BODY (CA1102A0).
--- CA1102A2M THE MAIN PROCEDURE.
-
--- WKB 6/12/81
--- BHS 7/19/84
-
-WITH CA1102A0;
-WITH REPORT; USE CA1102A0; USE REPORT;
-PROCEDURE CA1102A2M IS
-
-
- INVOKED : BOOLEAN := FALSE;
-
-BEGIN
- TEST ("CA1102A", "MORE THAN ONE WITH_CLAUSE; ALSO, A " &
- "USE_CLAUSE REFERING TO A PRECEDING WITH_CLAUSE " &
- "IN THE SAME CONTEXT_SPECIFICATION");
-
- P (INVOKED);
- IF NOT INVOKED THEN
- FAILED ("COMPILATION UNIT NOT MADE VISIBLE");
- END IF;
-
- RESULT;
-END CA1102A2M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada
deleted file mode 100644
index b3da9d1..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CA1106A.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 WITH CLAUSE FOR A PACKAGE BODY (GENERIC OR
--- NONGENERIC) OR FOR A GENERIC SUBPROGRAM BODY CAN NAME THE
--- CORRESPONDING SPECIFICATION, AND A USE CLAUSE CAN ALSO BE
--- GIVEN.
-
--- HISTORY:
--- JET 07/14/88 CREATED ORIGINAL TEST.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-PACKAGE CA1106A_1 IS
- I : INTEGER := 0;
- PROCEDURE REQUIRE_BODY;
-END CA1106A_1;
-
-GENERIC
- TYPE TG IS RANGE <>;
-PACKAGE CA1106A_2 IS
- J : TG := 0;
- PROCEDURE REQUIRE_BODY;
-END CA1106A_2;
-
-GENERIC
- TYPE TG IS RANGE <>;
-FUNCTION CA1106A_3 RETURN TG;
-
-WITH REPORT; USE REPORT;
-WITH CA1106A_1; USE CA1106A_1;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CA1106A_1 IS
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- I := IDENT_INT(1);
-END CA1106A_1;
-
-WITH REPORT; USE REPORT;
-WITH CA1106A_2;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CA1106A_2 IS
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- J := TG(IDENT_INT(2));
-END CA1106A_2;
-
-WITH REPORT; USE REPORT;
-WITH CA1106A_3;
-FUNCTION CA1106A_3 RETURN TG IS
-BEGIN
- RETURN TG(IDENT_INT(3));
-END CA1106A_3;
-
-WITH REPORT; USE REPORT;
-WITH CA1106A_1, CA1106A_2, CA1106A_3;
-USE CA1106A_1;
-PROCEDURE CA1106A IS
-
- PACKAGE CA1106A_2X IS NEW CA1106A_2 (INTEGER);
- FUNCTION CA1106A_3X IS NEW CA1106A_3 (INTEGER);
-
- USE CA1106A_2X;
-
-BEGIN
- TEST ("CA1106A", "CHECK THAT A WITH CLAUSE FOR A PACKAGE BODY " &
- "(GENERIC OR NONGENERIC) OR FOR A GENERIC " &
- "SUBPROGRAM BODY CAN NAME THE CORRESPONDING " &
- "SPECIFICATION, AND A USE CLAUSE CAN ALSO BE " &
- "GIVEN");
-
- IF I /= 1 THEN
- FAILED ("INCORRECT VALUE FROM NONGENERIC PACKAGE");
- END IF;
-
- IF J /= 2 THEN
- FAILED ("INCORRECT VALUE FROM GENERIC PACKAGE");
- END IF;
-
- IF CA1106A_3X /= 3 THEN
- FAILED ("INCORRECT VALUE FROM GENERIC SUBPROGRAM");
- END IF;
-
- RESULT;
-END CA1106A;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada
deleted file mode 100644
index 7059d26..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- CA1108A.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 WITH_CLAUSE AND USE_CLAUSE GIVEN FOR A PACKAGE
--- SPECIFICATION APPLIES TO THE BODY AND SUBUNITS OF THE BODY.
-
--- BHS 7/27/84
--- JBG 5/1/85
-
-PACKAGE OTHER_PKG IS
-
- I : INTEGER := 4;
- FUNCTION F (X : INTEGER) RETURN INTEGER;
-
-END OTHER_PKG;
-
-PACKAGE BODY OTHER_PKG IS
-
- FUNCTION F (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X + 1;
- END F;
-
-END OTHER_PKG;
-
-WITH REPORT, OTHER_PKG;
-USE REPORT, OTHER_PKG;
-PRAGMA ELABORATE (OTHER_PKG);
-PACKAGE CA1108A_PKG IS
-
- J : INTEGER := 2;
- PROCEDURE PROC;
- PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER);
-
-END CA1108A_PKG;
-
-PACKAGE BODY CA1108A_PKG IS
-
- PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE;
-
- PROCEDURE PROC IS
- Y : INTEGER := 2;
- BEGIN
- Y := OTHER_PKG.I;
- IF Y /= 4 THEN
- FAILED ("OTHER_PKG VARIABLE NOT VISIBLE " &
- "IN PACKAGE BODY PROCEDURE");
- END IF;
- END PROC;
-
- PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS
- BEGIN
- SUB (X, Y);
- END CALL_SUBS;
-
-BEGIN
-
- J := F(J); -- J => J + 1.
- IF J /= 3 THEN
- FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN " &
- "PACKAGE BODY");
- END IF;
-
-END CA1108A_PKG;
-
-
-WITH REPORT, CA1108A_PKG;
-USE REPORT, CA1108A_PKG;
-PROCEDURE CA1108A IS
-
- VAR1, VAR2 : INTEGER;
-
-BEGIN
-
- TEST ("CA1108A", "WITH_ AND USE_CLAUSES GIVEN FOR A PACKAGE " &
- "SPEC APPLY TO THE BODY AND ITS SUBUNITS");
-
- PROC;
-
- VAR1 := 1;
- VAR2 := 1;
- CALL_SUBS (VAR1, VAR2);
- IF VAR1 /= 4 THEN
- FAILED ("OTHER_PKG VARIABLE NOT VISIBLE IN SUBUNIT");
- END IF;
-
- IF VAR2 /= 6 THEN
- FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
- "OF SUBUNIT");
- END IF;
-
- RESULT;
-
-END CA1108A;
-
-
-SEPARATE (CA1108A_PKG)
-PROCEDURE SUB (X, Y : IN OUT INTEGER) IS
- PROCEDURE SUB2 (Z : IN OUT INTEGER) IS SEPARATE;
-BEGIN
-
- X := I;
- SUB2 (Y);
-
-END SUB;
-
-
-SEPARATE (CA1108A_PKG.SUB)
-PROCEDURE SUB2 (Z : IN OUT INTEGER) IS
- I : INTEGER := 5;
-BEGIN
-
- Z := OTHER_PKG.F(I); -- Z => I + 1.
-
-END SUB2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada b/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada
deleted file mode 100644
index 2877728..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- CA1108B.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 WITH_CLAUSES ARE GIVEN FOR BOTH A SPEC AND A BODY, AND
--- THE CLAUSES NAME DIFFERENT LIBRARY UNITS, THE UNITS NAMED IN ALL THE
--- CLAUSES ARE VISIBLE IN THE BODY AND IN SUBUNITS OF THE BODY.
-
--- BHS 7/31/84
--- JBG 5/1/85
-
-PACKAGE FIRST_PKG IS
-
- FUNCTION F (X : INTEGER := 1) RETURN INTEGER;
-
-END FIRST_PKG;
-
-PACKAGE BODY FIRST_PKG IS
-
- FUNCTION F (X : INTEGER := 1) RETURN INTEGER IS
- BEGIN
- RETURN X;
- END F;
-
-END FIRST_PKG;
-
-PACKAGE LATER_PKG IS
-
- FUNCTION F (Y : INTEGER := 2) RETURN INTEGER;
-
-END LATER_PKG;
-
-PACKAGE BODY LATER_PKG IS
-
- FUNCTION F (Y : INTEGER := 2) RETURN INTEGER IS
- BEGIN
- RETURN Y + 1;
- END F;
-
-END LATER_PKG;
-
-WITH REPORT, FIRST_PKG;
-USE REPORT;
-PRAGMA ELABORATE (FIRST_PKG);
-PACKAGE CA1108B_PKG IS
-
- I, J : INTEGER;
- PROCEDURE PROC;
- PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER);
-
-END CA1108B_PKG;
-
-WITH LATER_PKG;
-PRAGMA ELABORATE (LATER_PKG);
-PACKAGE BODY CA1108B_PKG IS
-
- PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE;
-
- PROCEDURE PROC IS
- I, J : INTEGER;
- BEGIN
- I := FIRST_PKG.F;
- IF I /= 1 THEN
- FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN " &
- "PACKAGE BODY PROCEDURE");
- END IF;
- J := LATER_PKG.F;
- IF J /= 3 THEN
- FAILED ("LATER_PKG FUNCITON NOT VISIBLE IN " &
- "PACKAGE BODY PROCEDURE");
- END IF;
- END PROC;
-
- PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS
- BEGIN
- SUB (X, Y);
- END CALL_SUBS;
-
-BEGIN
-
- I := FIRST_PKG.F;
- IF I /= 1 THEN
- FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY");
- END IF;
- J := LATER_PKG.F;
- IF J /= 3 THEN
- FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY");
- END IF;
-
-END CA1108B_PKG;
-
-WITH REPORT, CA1108B_PKG;
-USE REPORT, CA1108B_PKG;
-PROCEDURE CA1108B IS
-
- VAR1, VAR2 : INTEGER;
-
-BEGIN
-
- TEST ("CA1108B", "IF DIFFERENT WITH_CLAUSES GIVEN FOR PACKAGE " &
- "SPEC AND BODY, ALL NAMED UNITS ARE VISIBLE " &
- "IN THE BODY AND ITS SUBUNITS");
-
- PROC;
-
- VAR1 := 0;
- VAR2 := 1;
- CALL_SUBS (VAR1, VAR2);
- IF VAR1 /= 1 THEN
- FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT");
- END IF;
-
- IF VAR2 /= 3 THEN
- FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT");
- END IF;
-
- RESULT;
-
-END CA1108B;
-
-
-SEPARATE (CA1108B_PKG)
-PROCEDURE SUB (X, Y : IN OUT INTEGER) IS
- PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS SEPARATE;
-BEGIN
-
- SUB2 (Y, X);
- IF Y /= 1 THEN
- FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
- "OF SUBUNIT");
- END IF;
- IF X /= 3 THEN
- FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
- "OF SUBUNIT");
- END IF;
- X := FIRST_PKG.F;
- Y := LATER_PKG.F;
-
-END SUB;
-
-SEPARATE (CA1108B_PKG.SUB)
-PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS
-BEGIN
-
- A := FIRST_PKG.F;
- B := LATER_PKG.F;
-
-END SUB2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a
deleted file mode 100644
index a84c6b8..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CA11A01.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 type extended in a public child inherits primitive
--- operations from its ancestor.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type in a package specification. Declare two
--- primitive subprograms for the type (foundation code).
---
--- Add a public child to the above package. Extend the root type with
--- a record extension in the specification. Declare a new primitive
--- subprogram to write to the child extension.
---
--- Add a public grandchild to the above package. Extend the extension of
--- the parent type with a record extension in the private part of the
--- specification. Declare a new primitive subprogram for this grandchild
--- extension.
---
--- In the main program, "with" the grandchild. Access the primitive
--- operations from grandparent and parent package.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11A00.CA11A01_0 is -- Color_Widget_Pkg
--- This public child declares an extension from its parent. It
--- represents processing of widgets in a window system.
-
- type Widget_Color_Enum is (Black, Green, White);
-
- type Color_Widget is new Widget with -- Record extension of
- record -- parent tagged type.
- Color : Widget_Color_Enum;
- end record;
-
- -- Inherits procedure Set_Width from Widget.
- -- Inherits procedure Set_Height from Widget.
-
- -- To be inherited by its derivatives.
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum);
-
- procedure Set_Color_Widget (The_Widget : in out Color_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum);
-
-end FA11A00.CA11A01_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg
-
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
- ---------------------------------------------------------------
- procedure Set_Color_Widget (The_Widget : in out Color_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum) is
- begin
- Set_Width (The_Widget, The_Width); -- Inherited from parent.
- Set_Height (The_Widget, The_Height); -- Inherited from parent.
- Set_Color (The_Widget, The_Color);
- end Set_Color_Widget;
-
-end FA11A00.CA11A01_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
--- This public grandchild extends the extension from its parent. It
--- represents processing of widgets in a window system.
-
- -- Declaration used by private extension component.
- subtype Widget_Label_Str is string (1 .. 10);
-
- type Label_Widget is new Color_Widget with private;
- -- Record extension of parent tagged type.
-
- -- Inherits (inherited) procedure Set_Width from Color_Widget.
- -- Inherits (inherited) procedure Set_Height from Color_Widget.
- -- Inherits procedure Set_Color from Color_Widget.
- -- Inherits procedure Set_Color_Widget from Color_Widget.
-
- procedure Set_Label_Widget (The_Widget : in out Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum;
- The_Label : in Widget_Label_Str);
-
- -- The following function is needed to verify the value of the
- -- extension's private component.
-
- function Verify_Label (The_Widget : in Label_Widget;
- The_Label : in Widget_Label_Str) return Boolean;
-
-private
- type Label_Widget is new Color_Widget with
- record
- Label : Widget_Label_Str;
- end record;
-
-end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
-
- procedure Set_Label (The_Widget : in out Label_Widget;
- L : in Widget_Label_Str) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- --------------------------------------------------------------
- procedure Set_Label_Widget (The_Widget : in out Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum;
- The_Label : in Widget_Label_Str) is
- begin
- Set_Width (The_Widget, The_Width); -- Twice inherited.
- Set_Height (The_Widget, The_Height); -- Twice inherited.
- Set_Color (The_Widget, The_Color); -- Inherited from parent.
- Set_Label (The_Widget, The_Label);
- end Set_Label_Widget;
- --------------------------------------------------------------
- function Verify_Label (The_Widget : in Label_Widget;
- The_Label : in Widget_Label_Str) return Boolean is
- begin
- return (The_Widget.Label = The_Label);
- end Verify_Label;
-
-end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
-
---=======================================================================--
-
-with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg,
- -- implicitly with Widget_Pkg,
- -- implicitly with Color_Widget_Pkg
-with Report;
-
-procedure CA11A01 is
-
- package Widget_Pkg renames FA11A00;
- package Color_Widget_Pkg renames FA11A00.CA11A01_0;
- package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
-
- use Widget_Pkg; -- All user-defined operators directly visible.
-
- Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
-
- Default_Widget : Widget;
- Black_Widget : Color_Widget_Pkg.Color_Widget;
- Mail_Widget : Label_Widget_Pkg.Label_Widget;
-
-begin
-
- Report.Test ("CA11A01", "Check that type extended in a public " &
- "child inherits primitive operations from its " &
- "ancestor");
-
- Set_Width (Default_Widget, 9); -- Call from parent.
- Set_Height (Default_Widget, 10); -- Call from parent.
-
- If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
- Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
- Report.Failed ("Incorrect result for Default_Widget");
- end if;
-
- Color_Widget_Pkg.Set_Color_Widget
- (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared.
-
- If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
- Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
- Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
- Report.Failed ("Incorrect result for Black_Widget");
- end if;
-
- Label_Widget_Pkg.Set_Label_Widget
- (Mail_Widget, 15, 21, Color_Widget_Pkg.White,
- "Quick_Mail"); -- Explicitly declared.
-
- If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
- Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
- Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
- not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
- Report.Failed ("Incorrect result for Mail_Widget");
- end if;
-
- Report.Result;
-
-end CA11A01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a
deleted file mode 100644
index e7c1614..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a
+++ /dev/null
@@ -1,156 +0,0 @@
--- CA11A02.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 type extended in a client of a public child inherits
--- primitive operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type in a package specification. Declare two
--- primitive subprograms for the type (foundation code).
---
--- Add a public child to the above package. Extend the root type with
--- a record extension in the specification. Declare a new primitive
--- subprogram to write to the child extension.
---
--- In the main program, "with" the child. Declare an extension of
--- the child extension. Access the primitive operations from both
--- parent and child packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level
---
---!
-
-package FA11A00.CA11A02_0 is -- Color_Widget_Pkg
--- This public child declares an extension from its parent. It
--- represents processing of widgets in a window system.
-
- type Widget_Color_Enum is (Black, Green, White);
-
- type Color_Widget is new Widget with -- Record extension of
- record -- parent tagged type.
- Color : Widget_Color_Enum;
- end record;
-
- -- Inherits procedure Set_Width from parent.
- -- Inherits procedure Set_Height from parent.
-
- -- To be inherited by its derivatives.
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum);
-
-end FA11A00.CA11A02_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg
-
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
-
-end FA11A00.CA11A02_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-with FA11A00.CA11A02_0; -- Color_Widget_Pkg.
-
-package CA11A02_1 is
-
- type Label_Widget (Str_Disc : Integer) is new
- FA11A00.CA11A02_0.Color_Widget with
- record
- Label : String (1 .. Str_Disc);
- end record;
-
- -- Inherits (inherited) procedure Set_Width from Color_Widget.
- -- Inherits (inherited) procedure Set_Height from Color_Widget.
- -- Inherits procedure Set_Color from Color_Widget.
-
-end CA11A02_1;
-
---=======================================================================--
-
-with FA11A00.CA11A02_0; -- Color_Widget_Pkg,
- -- implicitly with Widget_Pkg
-with CA11A02_1;
-
-with Report;
-
-procedure CA11A02 is
-
- package Widget_Pkg renames FA11A00;
- package Color_Widget_Pkg renames FA11A00.CA11A02_0;
-
- use Widget_Pkg; -- All user-defined operators directly visible.
-
- procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget;
- L : in String) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- ---------------------------------------------------------
- procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in
- Color_Widget_Pkg.Widget_Color_Enum;
- The_Label : in String) is
- begin
- CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited.
- CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited.
- CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited.
- Set_Label (The_Widget, The_Label); -- Explicitly declared.
- end Set_Widget;
-
- White_Widget : CA11A02_1.Label_Widget (11);
-
-begin
-
- Report.Test ("CA11A02", "Check that a type extended in a client of " &
- "a public child inherits primitive operations from parent");
-
- Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock");
-
- If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
- White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
- Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or
- White_Widget.Label /= "Alarm_Clock" then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- Report.Result;
-
-end CA11A02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a
deleted file mode 100644
index 8d6de02..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a
+++ /dev/null
@@ -1,208 +0,0 @@
--- CA11B01.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 type derived in a public child inherits primitive
--- operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root record type with discriminant in a package
--- specification. Declare a primitive subprogram for the type
--- (foundation code).
---
--- Add a public child to the above package. Derive a new type
--- with constraint to the discriminant record type from the parent
--- package. Declare a new primitive subprogram to write to the child
--- derived type.
---
--- Add a new public child to the above package. This grandchild package
--- derives a new type using the record type from the above package.
--- Declare a new primitive subprogram to write to the grandchild derived
--- type.
---
--- In the main program, "with" the grandchild. Access the inherited
--- operations from grandparent, parent, and grandchild packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11B00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11B00.
-package FA11B00.CA11B01_0 is -- Application_Two_Widget
--- This public child declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- type App2_Widget is new App1_Widget (Maximum_Size => 5000);
- -- Inherits procedure Create_Widget from parent.
-
- -- Primitive operation of type App2_Widget.
- -- To be inherited by its children derivatives.
- procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget;
- Loc : in Widget_Location);
-
-end FA11B00.CA11B01_0; -- Application_Two_Widget
-
---=======================================================================--
-
-package body FA11B00.CA11B01_0 is -- Application_Two_Widget
-
- procedure App2_Widget_Specific_Oper
- (The_Widget : in out App2_Widget;
- Loc : in Widget_Location) is
- begin
- The_Widget.Location := Loc;
- end App2_Widget_Specific_Oper;
-
-end FA11B00.CA11B01_0; -- Application_Two_Widget
-
---=======================================================================--
-
--- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0.
-package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
--- This public grandchild declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- type App3_Widget is new App2_Widget; -- Derived record of App2_Widget.
-
- -- Inherits (inherited) procedure Create_Widget from Application_One_Widget.
- -- Inherits procedure App2_Widget_Specific_Oper from App2_Widget.
-
- -- Primitive operation of type App3_Widget.
- procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget;
- S : in Widget_Size);
-
-end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
-
---=======================================================================--
-
-package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
-
- procedure App3_Widget_Specific_Oper
- (The_Widget : in out App3_Widget;
- S : in Widget_Size) is
- begin
- The_Widget.Size := S;
- end App3_Widget_Specific_Oper;
-
-end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
-
---=======================================================================--
-
-with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget,
- -- implicitly with Application_Two_Widget,
- -- implicitly with Application_Three_Widget.
-with Report;
-
-procedure CA11B01 is
-
- package Application_One_Widget renames FA11B00;
- package Application_Two_Widget renames FA11B00.CA11B01_0;
- package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1;
-
- use Application_One_Widget;
- use Application_Two_Widget;
- use Application_Three_Widget;
-
-begin
-
- Report.Test ("CA11B01", "Check that a type derived in a public " &
- "child inherits primitive operations from parent");
-
- Application_One_Subtest:
- declare
- White_Widget : App1_Widget;
-
- begin
- -- perform an App1_Widget specific operation.
- App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
- The_Widget => White_Widget, I => 10);
-
- If White_Widget.Color /= White or
- White_Widget.Id /= Widget_ID
- (Report.Ident_Int (10)) or
- White_Widget.Label /= "Line Editor " then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- end Application_One_Subtest;
- ---------------------------------------------------------------
- Application_Two_Subtest:
- declare
- Amber_Widget : App2_Widget;
-
- begin
- App1_Widget_Specific_Oper (Amber_Widget, I => 11,
- C => Amber, L => "Alarm_Clock ");
- -- Inherited from Application_One_Widget.
-
- -- perform an App2_Widget specific operation.
- App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512));
-
- If Amber_Widget.Color /= Amber or
- Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or
- Amber_Widget.Label /= "Alarm_Clock " or
- Amber_Widget.Location /= (380,512) then
- Report.Failed ("Incorrect result for Amber_Widget");
- end if;
-
- end Application_Two_Subtest;
- ---------------------------------------------------------------
- Application_Three_Subtest:
- declare
- Green_Widget : App3_Widget;
-
- begin
- App1_Widget_Specific_Oper (Green_Widget, 100, Green,
- "Screen Editor ");
- -- Inherited (inherited) from Basic_Widget.
-
- -- perform an App2_Widget specific operation.
- App2_Widget_Specific_Oper (Loc => (1024,760),
- The_Widget => Green_Widget);
- -- Inherited from App_1_Widget.
-
- -- perform an App3_Widget specific operation.
- App3_Widget_Specific_Oper (Green_Widget, S => (100,100));
-
- If Green_Widget.Color /= Green or
- Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or
- Green_Widget.Label /= "Screen Editor " or
- Green_Widget.Location /= (1024,760) or
- Green_Widget.Size /= (100,100) then
- Report.Failed ("Incorrect result for Green_Widget");
- end if;
-
- end Application_Three_Subtest;
-
- Report.Result;
-
-end CA11B01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a
deleted file mode 100644
index 0743f73..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a
+++ /dev/null
@@ -1,169 +0,0 @@
--- CA11B02.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 type derived in a client of a public child inherits
--- primitive operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root record type with discriminant in a package
--- specification. Declare a primitive subprogram for the type
--- (foundation code).
---
--- Add a public child to the above package. Derive a new type
--- with constraint to the discriminant record type from the parent
--- package. Declare a new primitive subprogram to write to the child
--- derived type.
---
--- In the main program, "with" the child. Derive a new type using the
--- record type from the child package. Access the inherited operations
--- from both parent and child packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11B00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11B00.
-package FA11B00.CA11B02_0 is -- Application_Two_Widget
--- This public child declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- -- Dimension of app2_widget is limited to 5000 pixels.
-
- type App2_Widget is new App1_Widget (Maximum_Size => 5000);
- -- Derived record of parent type.
-
- -- Inherits procedure App1_Widget_Specific_Oper from parent.
-
-
- -- Primitive operation of type App2_Widget.
-
- procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
- S : in Widget_Size);
-
- -- Primitive operation of type App2_Widget.
-
- procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
- Loc : in Widget_Location);
-
-end FA11B00.CA11B02_0; -- Application_Two_Widget
-
-
---=======================================================================--
-
-
-package body FA11B00.CA11B02_0 is -- Application_Two_Widget
-
- procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
- S : in Widget_Size) is
- begin
- The_Widget.Size := S;
- end App2_Widget_Specific_Op1;
-
- --==============================================--
-
- procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
- Loc : in Widget_Location) is
- begin
- The_Widget.Location := Loc;
- end App2_Widget_Specific_Op2;
-
-end FA11B00.CA11B02_0; -- Application_Two_Widget
-
-
---=======================================================================--
-
-with FA11B00.CA11B02_0; -- Application_Two_Widget
- -- implicitly with Application_One_Widget.
-with Report;
-
-procedure CA11B02 is
-
- package Application_One_Widget renames FA11B00;
-
- package Application_Two_Widget renames FA11B00.CA11B02_0;
-
- use Application_One_Widget ;
- use Application_Two_Widget ;
-
- type Emulator_Widget is new App2_Widget; -- Derived record of
- -- parent type.
-
- White_Widget, Amber_Widget : Emulator_Widget;
-
-
-begin
-
- Report.Test ("CA11B02", "Check that a type derived in client of a " &
- "public child inherits primitive operations from parent");
-
- App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
- The_Widget => White_Widget, I => 10);
- -- Inherited from Application_One_Widget.
- If White_Widget.Color /= White or
- White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or
- White_Widget.Label /= "Line Editor "
- then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- -- perform an App2_Widget specific operation.
-
- App2_Widget_Specific_Op1 (White_Widget, S => (100, 200));
-
- If White_Widget.Size.X_Length /= 100 or
- White_Widget.Size.Y_Length /= 200
- then
- Report.Failed ("Incorrect size for White_Widget");
- end if;
-
- App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor ");
- -- Inherited from Application_One_Widget.
-
- -- perform an App2_Widget specific operations.
-
- App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget);
- App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760));
-
- If Amber_Widget.Color /= Amber or
- Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or
- Amber_Widget.Label /= "Screen Editor " or
- Amber_Widget.Size /= (1024,100) or
- Amber_Widget.Location.X_Location /= 1024 or
- Amber_Widget.Location.Y_Location /= 760
- then
- Report.Failed ("Incorrect result for Amber_Widget");
- end if;
-
- Report.Result;
-
-end CA11B02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a
deleted file mode 100644
index 195ec2d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- CA11C01.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 primitive operations declared in a child package
--- override operations declared in ancestor packages, a client of the
--- child package inherits the operations correctly.
---
--- TEST DESCRIPTION:
---
--- This test builds on the foundation code file (FA11C00) that contains
--- a parent package, child package, and grandchild package. The parent
--- package declares a tagged type and primitive operation. The child
--- package extends the type, and overrides the primitive operation. The
--- grandchild package does the same.
---
--- The test procedure "withs" the grandchild package, and receives
--- visibility to all of its ancestor packages, types and operations.
--- Three procedures, each with a formal parameter of a specific type are
--- defined. Each of these invokes a particular version of the overridden
--- primitive operation Image. Calls to these local procedures are made,
--- with objects of each of the tagged types as parameters, and the global
--- variable is finally examined to ensure that the correct version of
--- primitive operation was inherited by the client and invoked by the
--- call.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-with Report;
-
-procedure CA11C01 is
-
- package Animal_Package renames FA11C00_0;
- package Mammal_Package renames FA11C00_0.FA11C00_1;
- package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
-
- Max_Animals : constant := 3;
-
- subtype Data_String is String (1 .. 37);
- type Data_Base_Type is array (1 .. Max_Animals) of Data_String;
-
- Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
- -- Global variable.
-
- Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ",
- Weight => 10);
-
- Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ",
- Weight => 13,
- Hair_Color => Mammal_Package.Brown);
-
- Orangutan : Primate_Package.Primate :=
- (Common_Name => "Sumatran Orangutan ",
- Weight => 220,
- Hair_Color => Mammal_Package.Red,
- Habitat => Primate_Package.Arboreal);
-begin
-
- Report.Test ("CA11C01", "Check that when primitive operations declared " &
- "in a child package override operations declared " &
- "in ancestor packages, a client of the child " &
- "package inherits the operations correctly");
-
- declare
-
- use Animal_Package, Mammal_Package, Primate_Package;
-
- -- The function Image has been overridden in the child and grandchild
- -- packages, but the client has inherited all versions of the function,
- -- and can successfully use them to enter data into the database.
- -- Each of the following procedures updates the global variable
- -- Zoo_Data_Base.
-
- procedure Enter_Animal_Data (A : Animal; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (A);
- end Enter_Animal_Data;
-
- procedure Enter_Mammal_Data (M : Mammal; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (M);
- end Enter_Mammal_Data;
-
- procedure Enter_Primate_Data (P : Primate; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (P);
- end Enter_Primate_Data;
-
- begin
-
- -- Verify initial test conditions.
-
- if not (Zoo_Data_Base(1)(1..6) = " ")
- or else
- (Zoo_Data_Base(2)(1..6) /= " ")
- or else
- (Zoo_Data_Base(3)(1..6) /= " ")
- then
- Report.Failed ("Initial condition failure");
- end if;
-
-
- -- Enter data from all three animals into the zoo database.
-
- Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database.
- Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry.
- Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry.
-
- -- Verify the correct version of the overridden function Image was used
- -- for entering the specific data.
-
- if Zoo_Data_Base(1)(1 .. 6) /= "Animal"
- or else
- Zoo_Data_Base(1)(26 .. 31) /= "Salmon"
- then
- Report.Failed ("Incorrect version of Image for parent type");
- end if;
-
- if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal")
- or
- (Zoo_Data_Base(2)(28 .. 35) /= "Platypus")
- then
- Report.Failed ("Incorrect version of Image for child type");
- end if;
-
- if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate")
- or
- (Zoo_Data_Base(3)(27 .. 35) /= "Orangutan"))
- then
- Report.Failed ("Incorrect version of Image for grandchild type");
- end if;
-
- end;
-
-
- Report.Result;
-
-end CA11C01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a
deleted file mode 100644
index 7d87493..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- CA11C02.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 primitive operations declared in a child package
--- override operations declared in ancestor packages, and that
--- operations on class-wide types defined in the ancestor packages
--- dispatch as appropriate to these overriding implementations.
---
--- TEST DESCRIPTION:
---
--- This test builds on the foundation code file (FA11C00) that contains
--- a parent package, child package, and grandchild package. The parent
--- package declares a tagged type and primitive operation. The child
--- package extends the type, and overrides the primitive operation. The
--- grandchild package does the same.
---
--- The test procedure "withs" the grandchild package, and receives
--- visibility to all of its ancestor packages, types and operations.
--- A procedure with a formal class-wide parameter is defined that will
--- allow for dispatching calls to the overridden primitive operations,
--- based on the specific type of the actual parameter. The primitive
--- operations provide a string value to update a global string array
--- variable. Calls to the local procedure are made, with objects of each
--- of the tagged types as parameters, and the global variable is finally
--- examined to ensure that the correct version of primitive operation was
--- dispatched correctly.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-with Report;
-
-procedure CA11C02 is
-
- package Animal_Package renames FA11C00_0;
- package Mammal_Package renames FA11C00_0.FA11C00_1;
- package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
-
- Max_Animals : constant := 3;
-
- type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37);
-
- Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
- -- Global variable.
-
- Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ",
- Weight => 2);
-
- Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ",
- Weight => 230,
- Hair_Color => Mammal_Package.Brown);
-
- Lemur : Primate_Package.Primate :=
- (Common_Name => "Ring-Tailed Lemur ",
- Weight => 5,
- Hair_Color => Mammal_Package.Black,
- Habitat => Primate_Package.Arboreal);
-begin
-
- Report.Test ("CA11C02", "Check that primitive operations declared " &
- "in a child package override operations declared " &
- "in ancestor packages, and that operations " &
- "on class-wide types defined in the ancestor " &
- "packages dispatch as appropriate to these " &
- "overriding implementations");
-
- declare
-
- use Animal_Package, Mammal_Package, Primate_Package;
-
- -- The following procedure updates the global variable Zoo_Data_Base.
-
- procedure Enter_Data (A : Animal'Class; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (A);
- end Enter_Data;
-
- begin
-
- -- Verify initial test conditions.
-
- if not (Zoo_Data_Base(1)(1..6) = " ")
- or not
- (Zoo_Data_Base(2)(1..6) = " ")
- or not
- (Zoo_Data_Base(3)(1..6) = " ")
- then
- Report.Failed ("Initial condition failure");
- end if;
-
-
- -- Enter data from all three animals into the zoo database.
-
- Enter_Data (Macaw, 1); -- First entry in database.
- Enter_Data (A => Manatee, I => 2); -- Second entry.
- Enter_Data (Lemur, I => 3); -- Third entry.
-
- -- Verify the correct version of the overridden function Image was used
- -- for entering the specific data.
-
- if not (Zoo_Data_Base(1)(1 .. 6) = "Animal")
- or not
- (Zoo_Data_Base(1)(26 .. 30) = "Macaw")
- then
- Report.Failed ("Incorrect version of Image for parent type");
- end if;
-
- if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal"
- and
- Zoo_Data_Base(2)(27 .. 33) = "Manatee")
- then
- Report.Failed ("Incorrect version of Image for child type");
- end if;
-
- if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate")
- and
- (Zoo_Data_Base(3)(30 .. 34) = "Lemur"))
- then
- Report.Failed ("Incorrect version of Image for grandchild type");
- end if;
-
- end;
-
- Report.Result;
-
-end CA11C02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a
deleted file mode 100644
index b75a660..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- CA11C03.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 child unit is "withed", visibility is obtained to
--- all ancestor units named in the expanded name of the "withed" child
--- unit. Check that when the parent unit is "used", the simple name of
--- a "withed" child unit is made directly visible.
---
--- TEST DESCRIPTION:
--- To satisfy the first part of the objective, various references are
--- made to types and functions declared in the ancestor packages of the
--- foundation code package hierarchy. Since the grandchild library unit
--- package has been "withed" by this test, the visibility of these
--- components demonstrates that visibility of the ancestor package names
--- is provided when the expanded name of a child library unit is "withed".
---
--- The declare block in the test program includes a "use" clause of the
--- parent package (FA11C00_0.FA11C00_1) of the "withed" child package.
--- As a result, the simple name of the child package (FA11C00_2) is
--- directly visible. The type and function declared in the child
--- package are now visible when qualified with the simple name of the
--- "withed" package (FA11C00_2).
---
--- This test simulates the formatting of data strings, based on the
--- component fields of a "doubly-extended" tagged record type.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package
- -- Animal.Mammal.Primate.
- -- This will be used in conjunction with
- -- a "use" of FA11C00_0.FA11C00_1 below
- -- to verify a portion of the objective.
-with Report;
-
-procedure CA11C03 is
-
- Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' ');
- -- Visibility of grandparent package.
- -- The package FA11C00_0 is visible since
- -- it is an ancestor that is mentioned in
- -- the expanded name of its "withed"
- -- grandchild package.
-
- Blank_Hair_Color :
- String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' ');
- -- Visibility of parent package.
- -- The package FA11C00_0.FA11C00_1 is
- -- visible due to the "with" of its
- -- child package.
-
- subtype Data_String_Type is String (1 .. 60);
-
- TC_Result_String : Data_String_Type := (others => ' ');
-
- --
-
- function Format_Primate_Data (Name : String := Blank_Name_String;
- Hair : String := Blank_Hair_Color)
- return Data_String_Type is
-
- Pos : Integer := 1;
- Hair_Color_Field_Separator : constant String := " Hair Color: ";
-
- Result_String : Data_String_Type := (others => ' ');
-
- begin
- Result_String (Pos .. Name'Length) := Name; -- Enter name at start
- -- of string.
- Pos := Pos + Name'Length; -- Increment counter to
- -- next blank position.
- Result_String
- (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) :=
- Hair_Color_Field_Separator & Hair; -- Include hair color data
- -- in result string.
- return (Result_String);
- end Format_Primate_Data;
-
-
-begin
-
- Report.Test ("CA11C03", "Check that when a child unit is WITHED, " &
- "visibility is obtained to all ancestor units " &
- "named in the expanded name of the WITHED child " &
- "unit. Check that when the parent unit is USED, " &
- "the simple name of a WITHED child unit is made " &
- "directly visible" );
-
- declare
- use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct
- -- visibility to the simple name of
- -- package FA11C00_0.FA11C00_1.FA11C00_2,
- -- since this child package was "withed" by
- -- the main program.
-
- Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ",
- Weight => 7,
- Hair_Color => Brown,
- Habitat => FA11C00_2.Arboreal);
-
- -- Demonstrates visibility of package
- -- FA11C00_0.FA11C00_1.FA11C00_2.
- --
- -- Type Primate referenced with the simple
- -- name of package FA11C00_2 only.
- --
- -- Simple name of package FA11C00_2 is
- -- directly visible through "use" of parent.
-
- begin
-
- -- Verify that the Format_Primate_Data function will return a blank
- -- filled string when no parameters are provided in the call.
-
- TC_Result_String := Format_Primate_Data;
-
- if (TC_Result_String (1 .. 20) /= Blank_Name_String) then
- Report.Failed ("Incorrect initialization value from function");
- end if;
-
-
- -- Use function Format_Primate_Data to return a formatted data string.
-
- TC_Result_String :=
- Format_Primate_Data
- (Name => FA11C00_2.Image (Tarsier),
- -- Function returns a 37 character string
- -- value.
- Hair => Hair_Color_Type'Image(Tarsier.Hair_Color));
- -- The Hair_Color_Type is referenced
- -- directly, without package
- -- FA11C00_0.FA11C00_1 qualifier.
- -- No qualification of Hair_Color_Type is
- -- needed due to "use" clause.
-
- -- Note that the result of calling 'Image
- -- with an enumeration type argument
- -- results in an upper-case string.
- -- (See conditional statement below.)
-
- -- Verify the results of the function call.
-
- if not (TC_Result_String (1 .. 37) =
- "Primate Species: East-Indian Tarsier " and then
- TC_Result_String (38 .. 55) =
- " Hair Color: BROWN") then
- Report.Failed ("Incorrect result returned from function call");
- end if;
-
- end;
-
- Report.Result;
-
-end CA11C03;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a
deleted file mode 100644
index 7ea0e22..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a
+++ /dev/null
@@ -1,119 +0,0 @@
--- CA11D010.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:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- => CA11D010.A
--- CA11D011.A
--- CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
--- Child package of FA11D00.
-
-package FA11D00.CA11D010 is -- Add_Subtract_Complex
-
- procedure Add (Left, Right : in Complex_Type; -- Add two complex
- C : out Complex_Type); -- numbers.
-
- function Subtract (Left, Right : Complex_Type) -- Subtract two
- return Complex_Type; -- complex numbers.
-
-
-
-end FA11D00.CA11D010; -- Add_Subtract_Complex
-
---=======================================================================--
-
-with Report;
-
-package body FA11D00.CA11D010 is -- Add_Subtract_Complex
-
- procedure Add (Left, Right : in Complex_Type;
- C : out Complex_Type) is
- begin
- -- Zero is declared in parent package.
-
- if Left.Real < Zero.Real or else Right.Real < Zero.Real
- or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then
- raise Add_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "procedure Add");
- else
- C.Real := (Left.Real + Right.Real);
- C.Imag := (Left.Imag + Right.Imag);
- end if;
-
- exception
- when Add_Error =>
- TC_Handled_In_Child_Pkg_Proc := true;
- C := Check_Value; -- Reference to object in parent package.
- raise; -- Reraise the Add_Error exception in the subtest.
- Report.Failed ("Exception not reraised in handler");
-
- when others =>
- Report.Failed ("Unexpected exception raised in Add");
-
- end Add;
- -----------------------------------------------------------
- function Subtract (Left, Right : Complex_Type)
- return Complex_Type is
- begin
- -- Zero is declared in parent package.
- if Left.Real < Zero.Real or Right.Real < Zero.Real
- or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then
- raise Subtract_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "function Subtract");
- else
- return ( Real => (Left.Real - Right.Real),
- Imag => (Left.Imag - Right.Imag) );
- end if;
-
- exception
- when Subtract_Error =>
- Report.Comment ("Exception is properly handled in Subtract");
- TC_Handled_In_Child_Pkg_Func := true;
- return Check_Value;
-
- when others =>
- Report.Failed ("Unexpected exception raised in Subtract");
-
- end Subtract;
-
-end FA11D00.CA11D010; -- Add_Subtract_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a
deleted file mode 100644
index 014f74b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a
+++ /dev/null
@@ -1,79 +0,0 @@
--- CA11D011.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:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- CA11D010.A
--- => CA11D011.A
--- CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Declared child procedure specification
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-
--- Child procedure of FA11D00.
-
-procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
- C : out Complex_Type);
-
---=======================================================================--
-
-procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
- C : out Complex_Type) is
--- Multiply_Complex.
-
-begin
- -- Zero is declared in parent package.
-
- if Left.Real < Zero.Real or Right.Imag < Zero.Imag then
- raise Multiply_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "child procedure FA11D00.CA11D011");
- else
- C.Real := (Left.Real * Right.Real);
- C.Imag := (Left.Imag * Right.Imag);
- end if;
-
- exception
- when others =>
- TC_Handled_In_Child_Sub := true;
- C := Check_Value; -- Reference to object in parent package.
-
-end FA11D00.CA11D011; -- Multiply_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a
deleted file mode 100644
index 1bb3bd7..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a
+++ /dev/null
@@ -1,73 +0,0 @@
--- CA11D012.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:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- CA11D010.A
--- CA11D011.A
--- => CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Declared child function specification
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
--- Child function of FA11D00.
--- Does not divide zero complex numbers.
-
-function FA11D00.CA11D012 (Left, Right : Complex_Type)
- return Complex_Type;
-
---=======================================================================--
-
-function FA11D00.CA11D012 (Left, Right : Complex_Type)
- return Complex_Type is -- Divide_Complex
-
-begin
- -- Zero is declared in parent package.
-
- if Right.Real = Zero.Real or Right.Imag = Zero.Imag then
- raise Divide_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "child function FA11D00.CA11D012");
- else
- return ( Real => (Left.Real / Right.Real),
- Imag => (Left.Imag / Right.Imag) );
- end if;
-
-end FA11D00.CA11D012; -- Divide_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d013.am b/gcc/testsuite/ada/acats/tests/ca/ca11d013.am
deleted file mode 100644
index 6cbd3bb..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d013.am
+++ /dev/null
@@ -1,256 +0,0 @@
--- CA11D013.AM
---
--- 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 child unit can raise an exception that is declared in
--- parent.
---
--- TEST DESCRIPTION:
--- Declare a package which defines complex number abstraction with
--- user-defined exceptions (foundation code).
---
--- Add a public child package to the above package. Declare two
--- subprograms for the parent type. Each of the subprograms raises a
--- different exception, based on the value of an input parameter.
---
--- Add a public child procedure to the foundation package. This
--- procedure raises an exception based on the value of an input
--- parameter.
---
--- Add a public child function to the foundation package. This
--- function raises an exception based on the value of an input
--- parameter.
---
--- In the main program, "with" the child packages, then check that
--- the exceptions are raised and handled as expected. Ensure that
--- exceptions are:
--- 1) raised in the public child package and handled/reraised to
--- be handled by the main program.
--- 2) raised and handled locally in the public child package.
--- 3) raised and handled locally by "others" in the public child
--- procedure.
--- 4) raised in the public child function and propagated to the
--- main program.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- CA11D010.A
--- CA11D011.A
--- CA11D012.A
--- => CA11D013.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11D00.CA11D010; -- Add_Subtract_Complex
-with FA11D00.CA11D011; -- Multiply_Complex
-with FA11D00.CA11D012; -- Divide_Complex
-
-with Report;
-
-
-procedure CA11D013 is
-
- package Complex_Pkg renames FA11D00;
- package Add_Subtract_Complex_Pkg renames FA11D00.CA11D010;
- use Complex_Pkg;
-
-begin
-
- Report.Test ("CA11D013", "Check that a child unit can raise an " &
- "exception that is declared in parent");
-
-
- Add_Complex_Subtest:
- declare
- First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (7)));
- Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)),
- Int_Type (Report.Ident_Int (3)));
- Add_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (8)),
- Int_Type (Report.Ident_Int (10)));
- Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-100)),
- Int_Type (Report.Ident_Int (100)));
- Complex_Num : Complex_Type := Zero;
-
- begin
- Add_Subtract_Complex_Pkg.Add (First, Second, Complex_Num);
-
- if (Complex_Num /= Add_Result) then
- Report.Failed ("Incorrect results from addition");
- end if;
-
- -- Error is raised in child package and exception
- -- will be handled/reraised to caller.
-
- Add_Subtract_Complex_Pkg.Add (First, Third, Complex_Num);
-
- -- Error was not raised in child package.
- Report.Failed ("Exception was not reraised in addition");
-
- exception
- when Add_Error =>
- if not TC_Handled_In_Child_Pkg_Proc then
- Report.Failed ("Exception was not raised in addition");
- else
- TC_Handled_In_Caller := true; -- Exception is reraised from
- -- child package.
- end if;
-
- when others =>
- Report.Failed ("Unexpected exception in addition subtest");
- TC_Handled_In_Caller := false; -- Improper exception handling
- -- in caller.
-
- end Add_Complex_Subtest;
-
-
- Subtract_Complex_Subtest:
- declare
- First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (6)));
- Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)),
- Int_Type (Report.Ident_Int (7)));
- Sub_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (1)));
- Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-200)),
- Int_Type (Report.Ident_Int (1)));
- Complex_Num : Complex_Type;
-
- begin
- Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, First);
-
- if (Complex_Num /= Sub_Result) then
- Report.Failed ("Incorrect results from subtraction");
- end if;
-
- -- Error is raised and exception will be handled in child package.
- Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, Third);
-
- exception
- when Subtract_Error =>
- Report.Failed ("Exception raised in subtraction and " &
- "propagated to caller");
- TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling
- -- in caller.
-
- when others =>
- Report.Failed ("Unexpected exception in subtraction subtest");
- TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling
- -- in caller.
-
- end Subtract_Complex_Subtest;
-
-
- Multiply_Complex_Subtest:
- declare
- First : Complex_Type := Complex (Int_Type(Report.Ident_Int(3)),
- Int_Type (Report.Ident_Int (4)));
- Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)),
- Int_Type (Report.Ident_Int (3)));
- Mult_Result : Complex_Type := Complex(Int_Type(Report.Ident_Int(15)),
- Int_Type(Report.Ident_Int (12)));
- Third : Complex_Type := Complex(Int_Type(Report.Ident_Int(10)),
- Int_Type(Report.Ident_Int (-10)));
- Complex_Num : Complex_Type;
-
- begin
- CA11D011 (First, Second, Complex_Num);
-
- if (Complex_Num /= Mult_Result) then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled in child package.
- CA11D011 (First, Third, Complex_Num);
-
- exception
- when Multiply_Error =>
- Report.Failed ("Exception raised in multiplication and " &
- "propagated to caller");
- TC_Handled_In_Child_Sub := false; -- Improper exception handling
- -- in caller.
-
- when others =>
- Report.Failed ("Unexpected exception in multiplication subtest");
- TC_Handled_In_Child_Sub := false; -- Improper exception handling
- -- in caller.
- end Multiply_Complex_Subtest;
-
-
- Divide_Complex_Subtest:
- declare
- First : Complex_Type := Complex (Int_Type (Report.Ident_Int(10)),
- Int_Type (Report.Ident_Int (15)));
- Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)),
- Int_Type (Report.Ident_Int (3)));
- Div_Result : Complex_Type := Complex (Int_Type(Report.Ident_Int(2)),
- Int_Type (Report.Ident_Int (5)));
- Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-10)),
- Int_Type (Report.Ident_Int (0)));
- Complex_Num : Complex_Type := Zero;
-
- begin
- Complex_Num := CA11D012 (First, Second);
-
- if (Complex_Num /= Div_Result) then
- Report.Failed ("Incorrect results from division");
- end if;
-
- -- Error is raised in child package; exception will be
- -- propagated to caller.
- Complex_Num := CA11D012 (Second, Third);
-
- -- Error was not raised in child package.
- Report.Failed ("Exception was not raised in division subtest ");
-
- exception
- when Divide_Error =>
- TC_Propagated_To_Caller := true; -- Exception is propagated.
-
- when others =>
- Report.Failed ("Unexpected exception in division subtest");
- TC_Propagated_To_Caller := false; -- Improper exception handling
- -- in caller.
- end Divide_Complex_Subtest;
-
-
- if not (TC_Handled_In_Caller and -- Check to see that all
- TC_Handled_In_Child_Pkg_Proc and -- exceptions were handled in
- TC_Handled_In_Child_Pkg_Func and -- the proper locations.
- TC_Handled_In_Child_Sub and
- TC_Propagated_To_Caller)
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- Report.Result;
-
-end CA11D013;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a
deleted file mode 100644
index 7b4f488..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a
+++ /dev/null
@@ -1,393 +0,0 @@
--- CA11D02.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 exception declared in a package can be raised by a
--- child of a child package. Check that it can be renamed in the
--- child of the child package and raised with the correct effect.
---
--- TEST DESCRIPTION:
--- Declare a package which defines complex number abstraction with
--- user-defined exceptions (foundation code).
---
--- Add a public child package to the above package. Declare two
--- subprograms for the parent type.
---
--- Add a public grandchild package to the foundation package. Declare
--- subprograms to raise exceptions.
---
--- In the main program, "with" the grandchild package, then check that
--- the exceptions are raised and handled as expected. Ensure that
--- exceptions are:
--- 1) raised in the public grandchild package and handled/reraised to
--- be handled by the main program.
--- 2) raised and handled locally by the "others" handler in the
--- public grandchild package.
--- 3) raised in the public grandchild and propagated to the main
--- program.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11D00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11D00.
-
-package FA11D00.CA11D02_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type; -- Add two complex numbers.
-
- function "*" (Left, Right : Complex_Type)
- return Complex_Type; -- Multiply two complex numbers.
-
-end FA11D00.CA11D02_0; -- Basic_Complex
-
---=======================================================================--
-
-package body FA11D00.CA11D02_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
- --------------------------------------------------------------
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( Real => (Left.Real * Right.Real),
- Imag => (Left.Imag * Right.Imag) );
- end "*";
-
-end FA11D00.CA11D02_0; -- Basic_Complex
-
---=======================================================================--
-
--- Child package of FA11D00.CA11D02_0.
--- Grandchild package of FA11D00.
-
-package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
-
- Inverse_Error : exception renames Divide_Error; -- Reference to exception
- -- in grandparent package.
- Array_Size : constant := 2;
-
- type Complex_Array_Type is
- array (1 .. Array_Size) of Complex_Type; -- Reference to type
- -- in parent package.
-
- function Multiply (Left : Complex_Array_Type; -- Multiply two complex
- Right : Complex_Array_Type) -- arrays.
- return Complex_Array_Type;
-
- function Add (Left, Right : Complex_Array_Type) -- Add two complex
- return Complex_Array_Type; -- arrays.
-
- procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex
- Left : in out Complex_Array_Type); -- array.
-
-end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
-
---=======================================================================--
-
-with Report;
-
-
-package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
-
- function Multiply (Left : Complex_Array_Type;
- Right : Complex_Array_Type)
- return Complex_Array_Type is
-
- -- This procedure will raise an exception depending on the input
- -- parameter. The exception will be handled locally by the
- -- "others" handler.
-
- Result : Complex_Array_Type := (others => Zero);
-
- subtype Vector_Size is Positive range Left'Range;
-
- begin
- if Left = Result or else Right = Result then -- Do not multiply zero.
- raise Multiply_Error; -- Refence to exception in
- -- grandparent package.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in Vector_Size loop
- Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*".
- end loop;
- end if;
- return (Result);
-
- exception
- when others =>
- Report.Comment ("Exception is handled by others in Multiplication");
- TC_Handled_In_Grandchild_Pkg_Func := true;
- return (Zero, Zero);
-
- end Multiply;
- --------------------------------------------------------------
- function Add (Left, Right : Complex_Array_Type)
- return Complex_Array_Type is
-
- -- This function will raise an exception depending on the input
- -- parameter. The exception will be propagated and handled
- -- by the caller.
-
- Result : Complex_Array_Type := (others => Zero);
-
- subtype Vector_Size is Positive range Left'Range;
-
- begin
- if Left = Result or Right = Result then -- Do not add zero.
- raise Add_Error; -- Refence to exception in
- -- grandparent package.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in Vector_Size loop
- Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+".
- end loop;
- end if;
- return (Result);
-
- end Add;
- --------------------------------------------------------------
- procedure Inverse (Right : in Complex_Array_Type;
- Left : in out Complex_Array_Type) is
-
- -- This function will raise an exception depending on the input
- -- parameter. The exception will be handled/reraised to be
- -- handled by the caller.
-
- Result : Complex_Array_Type := (others => Zero);
-
- Array_With_Zero : boolean := false;
-
- begin
- for I in 1 .. Right'Length loop
- if Right(I) = Zero then -- Check for zero.
- Array_With_Zero := true;
- end if;
- end loop;
-
- If Array_With_Zero then
- raise Inverse_Error; -- Do not inverse zero.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in 1 .. Array_Size loop
- Left(I).Real := - Right(I).Real;
- Left(I).Imag := - Right(I).Imag;
- end loop;
- end if;
-
- exception
- when Inverse_Error =>
- TC_Handled_In_Grandchild_Pkg_Proc := true;
- Left := Result;
- raise; -- Reraise the Inverse_Error exception in the subtest.
- Report.Failed ("Exception not reraised in handler");
-
- when others =>
- Report.Failed ("Unexpected exception in procedure Inverse");
- end Inverse;
-
-end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
-
---=======================================================================--
-
-with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex,
- -- implicitly with Basic_Complex.
-with Report;
-
-procedure CA11D02 is
-
- package Complex_Pkg renames FA11D00;
- package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1;
-
- use Complex_Pkg;
- use Array_Complex_Pkg;
-
-begin
-
- Report.Test ("CA11D02", "Check that an exception declared in a package " &
- "can be raised by a child of a child package");
-
- Multiply_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (5))),
- Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (8))) );
- Operand_2 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (1)),
- Int_Type (Report.Ident_Int (2))),
- Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (6))) );
- Operand_3 : Complex_Array_Type := ( Zero, Zero);
- Mul_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (10))),
- Complex (Int_Type (Report.Ident_Int (6)),
- Int_Type (Report.Ident_Int (48))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- If (Multiply (Operand_1, Operand_2) /= Mul_Result) then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled in grandchild package.
-
- Complex_No := Multiply (Operand_1, Operand_3);
-
- if Complex_No /= (Zero, Zero) then
- Report.Failed ("Exception was not raised in multiplication");
- end if;
-
- exception
- when Multiply_Error =>
- Report.Failed ("Exception raised in multiplication and " &
- "propagated to caller");
- TC_Handled_In_Grandchild_Pkg_Func := false;
- -- Improper exception handling in caller.
-
- when others =>
- Report.Failed ("Unexpected exception in multiplication");
- TC_Handled_In_Grandchild_Pkg_Func := false;
- -- Improper exception handling in caller.
-
- end Multiply_Complex_Subtest;
-
-
- Add_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (7))),
- Complex (Int_Type (Report.Ident_Int (5)),
- Int_Type (Report.Ident_Int (8))) );
- Operand_2 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (4)),
- Int_Type (Report.Ident_Int (1))),
- Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (3))) );
- Operand_3 : Complex_Array_Type := ( Zero, Zero);
- Add_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (6)),
- Int_Type (Report.Ident_Int (8))),
- Complex (Int_Type (Report.Ident_Int (7)),
- Int_Type (Report.Ident_Int (11))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- Complex_No := Add (Operand_1, Operand_2);
-
- If (Complex_No /= Add_Result) then
- Report.Failed ("Incorrect results from addition");
- end if;
-
- -- Error is raised in grandchild package and exception
- -- will be propagated to caller.
-
- Complex_No := Add (Operand_1, Operand_3);
-
- if Complex_No = Add_Result then
- Report.Failed ("Exception was not raised in addition");
- end if;
-
- exception
- when Add_Error =>
- TC_Propagated_To_Caller := true; -- Exception is propagated.
-
- when others =>
- Report.Failed ("Unexpected exception in addition subtest");
- TC_Propagated_To_Caller := false; -- Improper exception handling
- -- in caller.
- end Add_Complex_Subtest;
-
- Inverse_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (1)),
- Int_Type (Report.Ident_Int (5))),
- Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (11))) );
- Operand_3 : Complex_Array_Type
- := ( Zero, Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (6))) );
- Inv_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (-1)),
- Int_Type (Report.Ident_Int (-5))),
- Complex (Int_Type (Report.Ident_Int (-3)),
- Int_Type (Report.Ident_Int (-11))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- Inverse (Operand_1, Complex_No);
-
- if (Complex_No /= Inv_Result) then
- Report.Failed ("Incorrect results from inverse");
- end if;
-
- -- Error is raised in grandchild package and exception
- -- will be handled/reraised to caller.
-
- Inverse (Operand_3, Complex_No);
-
- Report.Failed ("Exception was not handled in inverse");
-
- exception
- when Inverse_Error =>
- if not TC_Handled_In_Grandchild_Pkg_Proc then
- Report.Failed ("Exception was not raised in inverse");
- else
- TC_Handled_In_Caller := true; -- Exception is reraised from
- -- child package.
- end if;
-
- when others =>
- Report.Failed ("Unexpected exception in inverse");
- TC_Handled_In_Caller := false;
- -- Improper exception handling in caller.
-
- end Inverse_Complex_Subtest;
-
- if not (TC_Handled_In_Caller and -- Check to see that all
- TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled
- TC_Handled_In_Grandchild_Pkg_Func and -- in proper location.
- TC_Propagated_To_Caller)
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- Report.Result;
-
-end CA11D02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a
deleted file mode 100644
index 901b8d2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a
+++ /dev/null
@@ -1,174 +0,0 @@
--- CA11D03.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 exception declared in a package can be raised by a
--- client of a child of the package. Check that it can be renamed in
--- the client of the child of the package and raised with the correct
--- effect.
---
--- TEST DESCRIPTION:
--- Declare a package which defines complex number abstraction with
--- user-defined exceptions (foundation code).
---
--- Add a public child package to the above package. Declare two
--- subprograms for the parent type.
---
--- In the main program, "with" the child package, then check that
--- an exception can be raised and handled as expected.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11D00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11D00.
-package FA11D00.CA11D03_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type; -- Add two complex numbers.
-
- function "*" (Left, Right : Complex_Type)
- return Complex_Type; -- Multiply two complex numbers.
-
-end FA11D00.CA11D03_0; -- Basic_Complex
-
---=======================================================================--
-
-package body FA11D00.CA11D03_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
- --------------------------------------------------------------
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( Real => (Left.Real * Right.Real),
- Imag => (Left.Imag * Right.Imag) );
- end "*";
-
-end FA11D00.CA11D03_0; -- Basic_Complex
-
---=======================================================================--
-
-with FA11D00.CA11D03_0; -- Basic_Complex,
- -- implicitly with Complex_Definition.
-with Report;
-
-procedure CA11D03 is
-
- package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg
- package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex
-
- use Complex_Pkg;
- use Basic_Complex_Pkg;
-
- TC_Handled_In_Subtest_1,
- TC_Handled_In_Subtest_2 : boolean := false;
-
-begin
-
- Report.Test ("CA11D03", "Check that an exception declared in a package " &
- "can be raised by a client of a child of the package");
-
- Multiply_Complex_Subtest:
- declare
- Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (2)));
- -- Referenced to function in parent package.
- Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)),
- Int_Type (Report.Ident_Int (8)));
- Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)),
- Int_Type (Report.Ident_Int (16)));
- Complex_No : Complex_Type := Zero; -- Zero is declared in parent package.
- begin
- Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*".
- if Complex_No /= Mul_Res then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled.
- if Complex_No = Mul_Res then
- raise Multiply_Error; -- Reference to exception in
- end if; -- parent package.
-
- exception
- when Multiply_Error =>
- TC_Handled_In_Subtest_1 := true;
- when others =>
- TC_Handled_In_Subtest_1 := false; -- Improper exception handling.
-
- end Multiply_Complex_Subtest;
-
- Add_Complex_Subtest:
- declare
- Error_In_Client : exception renames Add_Error;
- -- Reference to exception in parent package.
- Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (7)));
- Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)),
- Int_Type (Report.Ident_Int (1)));
- Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)),
- Int_Type (Report.Ident_Int (8)));
- Complex_No : Complex_Type := One; -- One is declared in parent
- -- package.
- begin
- Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+".
-
- if Complex_No /= Add_Res then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled.
- if Complex_No = Add_Res then
- raise Error_In_Client;
- end if;
-
- exception
- when Error_In_Client =>
- TC_Handled_In_Subtest_2 := true;
-
- when others =>
- TC_Handled_In_Subtest_2 := false; -- Improper exception handling.
-
- end Add_Complex_Subtest;
-
- if not (TC_Handled_In_Subtest_1 and -- Check to see that all
- TC_Handled_In_Subtest_2) -- exceptions were handled
- -- in the proper location.
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- Report.Result;
-
-end CA11D03;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13001.a b/gcc/testsuite/ada/acats/tests/ca/ca13001.a
deleted file mode 100644
index 094bd7a..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13001.a
+++ /dev/null
@@ -1,370 +0,0 @@
--- CA13001.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 separate protected unit declared in a non-generic child
--- unit of a private parent have the same visibility into its parent,
--- its siblings, and packages on which its parent depends as is available
--- at the point of their declaration.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of having all
--- members of one family to take out a transportation. The restriction
--- is depend on each member to determine who can get a car, a clunker,
--- or a bicycle. If no transportation is available, that member has to
--- walk.
---
--- Declare a package with location for each family member. Declare
--- a public parent package. Declare a private child package. Declare a
--- public grandchild of this private package. Declare a protected unit
--- as a subunit in a public grandchild package. This subunit has
--- visibility into it's parent body ancestor and its sibling.
---
--- Declare another public parent package. The body of this package has
--- visibility into its private sibling's descendants.
---
--- In the main program, "with"s the parent package. Check that the
--- protected subunit performs as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA13001_0 is
-
- type Location is (School, Work, Beach, Home);
- type Family is (Father, Mother, Teen);
- Destination : array (Family) of Location;
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_0;
-
--- No bodies required for CA13001_0.
-
- --==================================================================--
-
--- Public parent.
-
-package CA13001_1 is
-
- type Transportation is (Bicycle, Clunker, New_Car);
- type Key_Type is private;
- Walking : boolean := false;
-
- -- Other type definitions and procedure declarations in real application.
-
-private
- type Key_Type
- is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car);
-
-end CA13001_1;
-
--- No bodies required for CA13001_1.
-
- --==================================================================--
-
--- Private child.
-
-private package CA13001_1.CA13001_2 is
-
- type Transport is
- record
- In_Use : boolean := false;
- end record;
- Vehicles : array (Transportation) of Transport;
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_1.CA13001_2;
-
--- No bodies required for CA13001_1.CA13001_2.
-
- --==================================================================--
-
--- Public grandchild of a private parent.
-
-package CA13001_1.CA13001_2.CA13001_3 is
-
- Flat_Tire : array (Transportation) of boolean := (others => false);
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_1.CA13001_2.CA13001_3;
-
--- No bodies required for CA13001_1.CA13001_2.CA13001_3.
-
- --==================================================================--
-
--- Context clauses required for visibility needed by a separate subunit.
-
-with CA13001_0;
-use CA13001_0;
-
--- Public grandchild of a private parent.
-
-package CA13001_1.CA13001_2.CA13001_4 is
-
- type Transit is
- record
- Available : boolean := false;
- end record;
- type Keys_Array is array (Transportation) of Transit;
- Fuel : array (Transportation) of boolean := (others => true);
-
- protected Family_Transportation is
-
- procedure Get_Vehicle (Who : in Family;
- Key : out Key_Type);
- procedure Return_Vehicle (Tr : in Transportation);
- function TC_Verify (What : Transportation) return boolean;
-
- private
- Keys : Keys_Array;
-
- end Family_Transportation;
-
-end CA13001_1.CA13001_2.CA13001_4;
-
- --==================================================================--
-
--- Context clause required for visibility needed by a separate subunit.
-
-with CA13001_1.CA13001_2.CA13001_3; -- Public sibling.
-
-package body CA13001_1.CA13001_2.CA13001_4 is
-
- protected body Family_Transportation is separate;
-
-end CA13001_1.CA13001_2.CA13001_4;
-
- --==================================================================--
-
-separate (CA13001_1.CA13001_2.CA13001_4)
-protected body Family_Transportation is
-
- procedure Get_Vehicle (Who : in Family;
- Key : out Key_Type) is
- begin
- case Who is
- when Father|Mother =>
- -- Drive new car to work
-
- -- Reference package with'ed by the subunit parent's body.
- if Destination(Who) = Work then
-
- -- Reference type declared in the private parent of the subunit
- -- parent's body.
- -- Reference type declared in the visible part of the
- -- subunit parent's body.
- if not Vehicles(New_Car).In_Use and Fuel(New_Car)
-
- -- Reference type declared in the public sibling of the
- -- subunit parent's body.
- and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then
- Vehicles(New_Car).In_Use := true;
-
- -- Reference type declared in the private part of the
- -- protected subunit.
- Keys(New_Car).Available := false;
- Key := Transportation'pos(New_Car);
- else
- -- Reference type declared in the grandparent of the subunit
- -- parent's body.
- Walking := true;
- end if;
-
- -- Drive clunker to other destinations.
- else
- if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
- CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
- Vehicles(Clunker).In_Use := true;
- Keys(Clunker).Available := false;
- Key := Transportation'pos(Clunker);
- else
- Walking := true;
- Key := Transportation'pos(Bicycle);
- end if;
- end if;
-
- -- Similar for Teen.
- when Teen =>
- if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
- CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
- Vehicles(Clunker).In_Use := true;
- Keys(Clunker).Available := false;
- Key := Transportation'pos(Clunker);
- else
- Walking := true;
- Key := Transportation'pos(Bicycle);
- end if;
- end case;
-
- end Get_Vehicle;
-
- ----------------------------------------------------------------
-
- -- Any family member can bring back the transportation with the key.
-
- procedure Return_Vehicle (Tr : in Transportation) is
- begin
- Vehicles(Tr).In_Use := false;
- Keys(Tr).Available := true;
- end Return_Vehicle;
-
- ----------------------------------------------------------------
-
- function TC_Verify (What : Transportation) return boolean is
- begin
- return Keys(What).Available;
- end TC_Verify;
-
-end Family_Transportation;
-
- --==================================================================--
-
-with CA13001_0;
-use CA13001_0;
-
--- Public child.
-
-package CA13001_1.CA13001_5 is
-
- -- In a real application, tasks could be used to demonstrate
- -- a family transportation scenario, i.e., each member of
- -- a family can take a vehicle out concurrently, then return
- -- them at the same time. For the purposes of the test, family
- -- transportation happens sequentially.
-
- procedure Provide_Transportation (Who : in Family;
- Get_Key : out Key_Type;
- Get_Veh : out boolean);
- procedure Return_Transportation (What : in Transportation;
- Rt_Veh : out boolean);
-
-end CA13001_1.CA13001_5;
-
- --==================================================================--
-
-with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent,
- -- implicitly with CA13001_1.CA13001_2.
-package body CA13001_1.CA13001_5 is
-
- package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4;
- use Transportation_Pkg;
-
- -- These two validation subprograms provide the capability to check the
- -- components defined in the private packages from within the client
- -- program.
-
- procedure Provide_Transportation (Who : in Family;
- Get_Key : out Key_Type;
- Get_Veh : out boolean) is
- begin
- -- Goto work, school, or to the beach.
- Family_Transportation.Get_Vehicle (Who, Get_Key);
- if not Family_Transportation.TC_Verify
- (Transportation'Val(Get_Key)) then
- Get_Veh := true;
- else
- Get_Veh := false;
- end if;
-
- end Provide_Transportation;
-
- ----------------------------------------------------------------
-
- procedure Return_Transportation (What : in Transportation;
- Rt_Veh : out boolean) is
- begin
- Family_Transportation.Return_Vehicle (What);
- if Family_Transportation.TC_Verify(What) and
- not CA13001_1.CA13001_2.Vehicles(What).In_Use then
- Rt_Veh := true;
- else
- Rt_Veh := false;
- end if;
-
- end Return_Transportation;
-
-end CA13001_1.CA13001_5;
-
- --==================================================================--
-
-with CA13001_0;
-with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1.
-with Report;
-
-procedure CA13001 is
-
- Mommy : CA13001_0.Family := CA13001_0.Mother;
- Daddy : CA13001_0.Family := CA13001_0.Father;
- BG : CA13001_0.Family := CA13001_0.Teen;
- BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker;
- Get_Key : CA13001_1.Key_Type;
- Get_Transit : boolean := false;
- Return_Transit : boolean := false;
-
-begin
- Report.Test ("CA13001", "Check that a protected subunit declared in " &
- "a child unit of a private parent have the same visibility " &
- "into its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
- -- Get transportation for mother to go to work.
- CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work;
- CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit);
- if not Get_Transit then
- Report.Failed ("Failed to get mother transportation");
- end if;
-
- -- Get transportation for teen to go to school.
- CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School;
- Get_Transit := false;
- CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit);
- if not Get_Transit then
- Report.Failed ("Failed to get teen transportation");
- end if;
-
- -- Get transportation for father to go to the beach.
- CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach;
- Get_Transit := false;
- CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit);
- if Get_Transit and not CA13001_1.Walking then
- Report.Failed ("Failed to make daddy to walk to the beach");
- end if;
-
- -- Return the clunker.
- CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit);
- if not Return_Transit then
- Report.Failed ("Failed to get back the clunker");
- end if;
-
- Report.Result;
-
-end CA13001;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13002.a b/gcc/testsuite/ada/acats/tests/ca/ca13002.a
deleted file mode 100644
index e985174..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13002.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CA13002.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 library child units and/or subunits may have the same
--- simple names if they have distinct expanded names.
---
--- TEST DESCRIPTION:
--- Declare a package that provides some primitive functionality (minimal
--- terminal driver operations in this case). Add child packages to
--- expand the functionality for different but related contexts (different
--- terminal kinds). Add child packages, or subunits, to the children to
--- provide the same high level operation for each of the different
--- contexts (terminals). Since the operations are the same, at the leaf
--- level they are likely to have the same names.
---
--- The main program "with"s the child packages. Check that the
--- child units and subunits perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Public parent.
-package CA13002_0 is -- Terminal_Driver.
-
- type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child);
- type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit,
- Second_Subunit);
- type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean;
- TC_Calls : TC_Calls_Arr := (others => (others => false));
-
- -- In real application, Send_Control_Sequence sends keystrokes from
- -- the terminal, i.e., space, escape, etc.
- procedure Send_Control_Sequence (Row : in TC_Name;
- Col : in TC_Call_From);
-
-end CA13002_0;
-
- --==================================================================--
-
--- First child.
-package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100
-
- -- Move cursor up, down, left, or right.
- procedure Move_Cursor (Col : in TC_Call_From);
-
-end CA13002_0.CA13002_1;
-
- --==================================================================--
-
--- First grandchild.
-procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up
-
- --==================================================================--
-
--- Second child.
-package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
-end CA13002_0.CA13002_2;
-
- --==================================================================--
-
--- Second grandchild.
-procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up
-
- --==================================================================--
-
--- Third child.
-package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
- procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up
- -- implementation will be as a
- -- separate subunit.
-end CA13002_0.CA13002_3;
-
- --==================================================================--
-
--- Fourth child.
-package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
- procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up
- -- implementation will be as a
- -- separate subunit.
-
-end CA13002_0.CA13002_4;
-
- --==================================================================--
-
--- Terminal_Driver.
-package body CA13002_0 is
-
- procedure Send_Control_Sequence (Row : in TC_Name;
- Col : in TC_Call_From) is
- begin
- -- Reads a key and takes action.
- TC_Calls (Row, Col) := true;
- end Send_Control_Sequence;
-
-end CA13002_0;
-
- --==================================================================--
-
--- Terminal_Driver.VT100.
-package body CA13002_0.CA13002_1 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (First_Child, Col);
- end Move_Cursor;
-
-end CA13002_0.CA13002_1;
-
- --==================================================================--
-
--- Terminal_Driver.VT100.Cursor_Up.
-procedure CA13002_0.CA13002_1.CA13002_5 is
-begin
- Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100.
-end CA13002_0.CA13002_1.CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.IBM3270.
-package body CA13002_0.CA13002_2 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Second_Child, Col);
- end Move_Cursor;
-
-end CA13002_0.CA13002_2;
-
- --==================================================================--
-
--- Terminal_Driver.IBM3270.Cursor_Up.
-procedure CA13002_0.CA13002_2.CA13002_5 is
-begin
- Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270.
-end CA13002_0.CA13002_2.CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.DOS_ANSI.
-package body CA13002_0.CA13002_3 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Third_Child, Col);
- end Move_Cursor;
-
- procedure CA13002_5 is separate;
-
-end CA13002_0.CA13002_3;
-
- --==================================================================--
-
--- Terminal_Driver.DOS_ANSI.Cursor_Up.
-separate (CA13002_0.CA13002_3)
-procedure CA13002_5 is
-begin
- Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI.
-end CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.WYSE.
-package body CA13002_0.CA13002_4 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Fourth_Child, Col);
- end Move_Cursor;
-
- procedure CA13002_5 is separate;
-
-end CA13002_0.CA13002_4;
-
- --==================================================================--
-
--- Terminal_Driver.WYSE.Cursor_Up.
-separate (CA13002_0.CA13002_4)
-procedure CA13002_5 is
-begin
- Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE.
-end CA13002_5;
-
- --==================================================================--
-
-with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up,
- -- implicitly with parent, CA13002_0.
-with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up.
-with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI.
-with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE.
-with Report;
-use CA13002_0; -- All primitive subprograms directly
- -- visible.
-
-procedure CA13002 is
- Expected_Calls : constant CA13002_0.TC_Calls_Arr
- := ((true, false, false, false),
- (false, true , false, false),
- (false, false, true , false),
- (false, false, false, true ));
-begin
- Report.Test ("CA13002", "Check that two library units and/or subunits " &
- "may have the same simple names if they have distinct " &
- "expanded names");
-
- -- Note that the leaves all have the same name.
- -- Call the first grandchild.
- CA13002_0.CA13002_1.CA13002_5;
-
- -- Call the second grandchild.
- CA13002_0.CA13002_2.CA13002_5;
-
- -- Call the first subunit.
- CA13002_0.CA13002_3.CA13002_5;
-
- -- Call the second subunit.
- CA13002_0.CA13002_4.CA13002_5;
-
- if TC_Calls /= Expected_Calls then
- Report.Failed ("Wrong result");
- end if;
-
- Report.Result;
-
-end CA13002;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13003.a b/gcc/testsuite/ada/acats/tests/ca/ca13003.a
deleted file mode 100644
index 607639e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13003.a
+++ /dev/null
@@ -1,256 +0,0 @@
--- CA13003.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 separate subunits which share an ancestor may have the
--- same name if they have different fully qualified names. Check
--- the case of separate subunits of separate subunits.
--- This test is a change in semantics from Ada 83 to Ada 9X.
---
--- TEST DESCRIPTION:
--- Declare a package that provides file processing operations. Declare
--- one separate package to do the file processing, and another to do the
--- auditing. These packages contain similar functions declared in
--- separate subunits. Verify that the main program can call the
--- separate subunits with the same name.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates a file processing application. The processing package opens
--- files, reads files, does file processing, and generates reports.
--- The auditing package opens files, read files, and generates reports.
-
-package CA13003_0 is
-
- type File_ID is range 1 .. 100;
- subtype File_Name is string (1 .. 10);
-
- TC_Open_For_Process : boolean := false;
- TC_Open_For_Audit : boolean := false;
- TC_Report_From_Process : boolean := false;
- TC_Report_From_Audit : boolean := false;
-
- type File_Rec is
- record
- Name : File_Name;
- ID : File_ID;
- end record;
-
- procedure Initialize_File_Rec (Name_In : in File_Name;
- ID_In : in File_ID;
- File_In : out File_Rec);
-
- ----------------------------------------------------------------------
-
- package CA13003_1 is -- File processing
-
- procedure CA13003_3; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name; -- Process files
- package CA13003_5 is -- Generate report
- procedure Generate_Report;
- end CA13003_5;
-
- end CA13003_1;
-
- ----------------------------------------------------------------------
-
- package CA13003_2 is -- File auditing
-
- procedure CA13003_3; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name; -- Process files
- package CA13003_5 is -- Generate report
- procedure Generate_Report;
- end CA13003_5;
-
- end CA13003_2;
-
-end CA13003_0;
-
- --==================================================================--
-
-package body CA13003_0 is
-
- procedure Initialize_File_Rec (Name_In : in File_Name;
- ID_In : in File_ID;
- File_In : out File_Rec) is
- -- Not a real initialization. Real application can use file
- -- database to create the file record.
- begin
- File_In.Name := Name_In;
- File_In.ID := ID_In;
- end Initialize_File_Rec;
-
- package body CA13003_1 is separate;
- package body CA13003_2 is separate;
-
-end CA13003_0;
-
- --==================================================================--
-
-separate (CA13003_0)
-package body CA13003_1 is
-
- procedure CA13003_3 is separate; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name is separate; -- Process files
- package body CA13003_5 is separate; -- Generate report
-
-end CA13003_1;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-procedure CA13003_3 is -- Open files
-begin
- -- In real file processing application, open file from database, setup
- -- data structure, etc.
- TC_Open_For_Process := true;
-end CA13003_3;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-function CA13003_4 (ID_In : File_ID; -- Process files
- File_In : File_Rec) return File_Name is
-begin
- -- In real file processing application, process files for more information.
- return File_In.Name;
-end CA13003_4;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-package body CA13003_5 is -- Generate report
- procedure Generate_Report is
- begin
- -- In real file processing application, generate various report from the
- -- file database.
- TC_Report_From_Process := true;
- end Generate_Report;
-
-end CA13003_5;
-
- --==================================================================--
-
-separate (CA13003_0)
-package body CA13003_2 is
-
- procedure CA13003_3 is separate; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name is separate; -- Process files
- package body CA13003_5 is separate; -- Generate report
-
-end CA13003_2;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-procedure CA13003_3 is -- Open files
-begin
- TC_Open_For_Audit := true;
-end CA13003_3;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-function CA13003_4 (ID_In : File_ID;
- File_In : File_Rec) return File_Name is
-begin
- return File_In.Name;
-end CA13003_4;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-package body CA13003_5 is -- Generate report
- procedure Generate_Report is
- begin
- TC_Report_From_Audit := true;
- end Generate_Report;
-
-end CA13003_5;
-
- --==================================================================--
-
-with CA13003_0;
-with Report;
-
-procedure CA13003 is
- First_File_Name : CA13003_0.File_Name := "Joe Smith ";
- First_File_Id : CA13003_0.File_ID := 11;
- Second_File_Name : CA13003_0.File_Name := "John Schep";
- Second_File_Id : CA13003_0.File_ID := 47;
- Expected_Name : CA13003_0.File_Name := " ";
- Student_File : CA13003_0.File_Rec;
-
- function Process_Input_Files (ID_In : CA13003_0.File_ID;
- File_In : CA13003_0.File_Rec) return
- CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4;
-
- function Process_Audit_Files (ID_In : CA13003_0.File_ID;
- File_In : CA13003_0.File_Rec) return
- CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4;
-begin
- Report.Test ("CA13003", "Check that separate subunits which share " &
- "an ancestor may have the same name if they have " &
- "different fully qualified names");
-
- Student_File := (ID => First_File_Id, Name => First_File_Name);
-
- -- Note that all subunits have the same simple name.
- -- Generate report from file processing.
- CA13003_0.CA13003_1.CA13003_3;
- Expected_Name := Process_Input_Files (First_File_Id, Student_File);
- CA13003_0.CA13003_1.CA13003_5.Generate_Report;
-
- if not CA13003_0.TC_Open_For_Process or
- not CA13003_0.TC_Report_From_Process or
- Expected_Name /= First_File_Name then
- Report.Failed ("Unexpected results in processing file");
- end if;
-
- CA13003_0.Initialize_File_Rec
- (Second_File_Name, Second_File_Id, Student_File);
-
- -- Generate report from file auditing.
- CA13003_0.CA13003_2.CA13003_3;
- Expected_Name := Process_Audit_Files (Second_File_Id, Student_File);
- CA13003_0.CA13003_2.CA13003_5.Generate_Report;
-
- if not CA13003_0.TC_Open_For_Audit or
- not CA13003_0.TC_Report_From_Audit or
- Expected_Name /= Second_File_Name then
- Report.Failed ("Unexpected results in auditing file");
- end if;
-
- Report.Result;
-
-end CA13003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a
deleted file mode 100644
index 3963bc6..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a
+++ /dev/null
@@ -1,320 +0,0 @@
--- CA13A01.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 subunits declared in non-generic child units of a public
--- parent have the same visibility into its parent, its siblings
--- (public and private), and packages on which its parent depends
--- as is available at the point of their declaration.
---
--- TEST DESCRIPTION:
--- Declare an check system procedure as a subunit in a private child
--- package of the basic operation package (FA13A00.A). This procedure
--- has visibility into its parent ancestor and its private sibling.
---
--- Declare an emergency procedure as a subunit in a public child package
--- of the basic operation package (FA13A00.A). This procedure has
--- visibility into its parent ancestor and its private sibling.
---
--- Declare an express procedure as a subunit in a public child subprogram
--- of the basic operation package (FA13A00.A). This procedure has
--- visibility into its parent ancestor and its public sibling.
---
--- In the main program, "with"s the child package and subprogram. Check
--- that subunits perform as expected.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA13A00.A
--- CA13A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Private child package of an elevator application. This package
--- provides maintenance operations.
-
-private package FA13A00_1.CA13A01_4 is -- Maintenance operation
-
- One_Floor : Floor_No := 1; -- Type declared in parent.
-
- procedure Check_System;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_1.CA13A01_4;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A01_4 is
-
- procedure Check_System is separate;
-
-end FA13A00_1.CA13A01_4;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_4)
-
--- Subunit Check_System declared in Maintenance Operation.
-
-procedure Check_System is
-begin
- -- See if regular power is on.
-
- if Power /= V120 then -- Reference package with'ed by
- TC_Operation := false; -- the subunit parent's body.
- end if;
-
- -- Test elevator function.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
- (Penthouse, Call_Waiting); -- the subunit parent's body.
-
- if not Call_Waiting (Penthouse) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit package's
- -- body.
- end if;
-
- FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of
- -- the subunit parent's body.
-
- if Current_Floor /= Floor'pred (Penthouse) then
- TC_Operation := false; -- Reference type declared in the
- end if; -- parent of the subunit parent's
- -- body.
-
-end Check_System;
-
- --==================================================================--
-
--- Public child package of an elevator application. This package provides
--- an emergency operation.
-
-package FA13A00_1.CA13A01_5 is -- Emergency Operation
-
- -- Other type definitions in real application.
-
- procedure Emergency;
-
-private
- type Bell_Type is (Inactive, Active);
-
-end FA13A00_1.CA13A01_5;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-with FA13A00_1.CA13A01_4; -- Maintenance Operation (private)
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A01_5 is
-
- procedure Emergency is separate;
-
-end FA13A00_1.CA13A01_5;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_5)
-
--- Subunit Emergency declared in Maintenance Operation.
-
-procedure Emergency is
- Bell : Bell_Type; -- Reference type declared in the
- -- subunit parent's body.
-
-begin
- -- Calls maintenance operation.
-
- FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the
- -- subunit parent 's body.
-
- -- Clear all calls to the elevator.
-
- Clear_Calls (Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- for I in Floor loop
- if Call_Waiting (I) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
- end loop;
-
- -- Move elevator to the basement.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
- (Basement, Call_Waiting); -- subunit parent's body.
-
- if Current_Floor /= Basement then -- Reference type declared in the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Shut off power.
-
- Power := Off; -- Reference package with'ed by
- -- the subunit parent's body.
-
- -- Activate bell.
-
- Bell := Active; -- Reference type declared in the
- -- subunit parent's body.
-
-end Emergency;
-
- --==================================================================--
-
--- Public child subprogram of an elevator application. This subprogram
--- provides an express operation.
-
-procedure FA13A00_1.CA13A01_6;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-procedure FA13A00_1.CA13A01_6 is -- Express Operation
-
- -- Other type definitions in real application.
-
- procedure GoTo_Penthouse is separate;
-
-begin
- GoTo_Penthouse;
-
-end FA13A00_1.CA13A01_6;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_6)
-
--- Subunit GoTo_Penthouse declared in Express Operation.
-
-procedure GoTo_Penthouse is
-begin
- -- Go faster.
-
- Power := V240; -- Reference package with'ed by
- -- the subunit parent's body.
-
- -- Call elevator.
-
- Call (Penthouse, Call_Waiting); -- Reference subprogram declared in
- -- the parent of the subunit
- -- parent's body.
-
- if not Call_Waiting (Penthouse) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Move elevator to Penthouse.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
- (Penthouse, Call_Waiting); -- subunit parent's body.
-
- if Current_Floor /= Penthouse then -- Reference type declared in the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Return slowly
-
- while Current_Floor /= Floor1 loop -- Reference type, subprogram
- FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the
- -- subunit parent's body.
- end loop;
-
- if Current_Floor /= Floor1 then -- Reference type declared in
- TC_Operation := false; -- the parent of the subunit
- end if; -- parent's body.
-
- -- Back to normal.
-
- Power := V120; -- Reference package with'ed by
- -- the subunit parent's body.
-
-end GoTo_Penthouse;
-
- --==================================================================--
-
-with FA13A00_1.CA13A01_5; -- Emergency Operation
- -- implicitly with Basic Elevator
- -- Operations
-
-with FA13A00_1.CA13A01_6; -- Express Operation
-
-with Report;
-
-procedure CA13A01 is
-
-begin
-
- Report.Test ("CA13A01", "Check that subunits declared in non-generic " &
- "child units of a public parent have the same visibility " &
- "into its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
- -- Go to Penthouse.
-
- FA13A00_1.CA13A01_6;
-
- -- Call emergency operation.
-
- FA13A00_1.CA13A01_5.Emergency;
-
- if not FA13A00_1.TC_Operation then
- Report.Failed ("Incorrect elevator operation");
- end if;
-
- Report.Result;
-
-end CA13A01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a
deleted file mode 100644
index 82d1b6e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a
+++ /dev/null
@@ -1,301 +0,0 @@
--- CA13A02.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 subunits declared in generic child units of a public
--- parent have the same visibility into its parent, its siblings
--- (public and private), and packages on which its parent depends
--- as is available at the point of their declaration.
---
--- TEST DESCRIPTION:
--- Declare an outside elevator button operation as a subunit in a
--- generic child package of the basic operation package (FA13A00.A).
--- This procedure has visibility into its parent ancestor and its
--- private sibling.
---
--- In the main program, instantiate the child package. Check that
--- subunits perform as expected.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA13A00.A
--- CA13A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Public generic child package of an elevator application. This package
--- provides outside elevator button operations.
-
-generic -- Instantiate once for each floor.
- Our_Floor : in Floor; -- Reference type declared in parent.
-
-package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations
-
- type Light is (Up, Down, Express, Off);
-
- type Direction is (Up, Down, Express);
-
- function Call_Elevator (D : Direction) return Light;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_1.CA13A02_4;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A02_4 is
-
- function Call_Elevator (D : Direction) return Light is separate;
-
-end FA13A00_1.CA13A02_4;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A02_4)
-
--- Subunit Call_Elevator declared in Outside Elevator Button Operations.
-
-function Call_Elevator (D : Direction) return Light is
- Elevator_Button : Light;
-
-begin
- -- See if power is on.
-
- if Power = Off then -- Reference package with'ed by
- Elevator_Button := Off; -- the subunit parent's body.
-
- else
- case D is
- when Express =>
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
- (Penthouse, Call_Waiting); -- the subunit parent's body.
-
- Elevator_Button := Express;
-
- when Up =>
- if Current_Floor < Our_Floor then
- FA13A00_1.FA13A00_2.Up -- Reference private sibling of
- (Floor'pos (Our_Floor) -- the subunit parent's body.
- - Floor'pos (Current_Floor));
- else
- FA13A00_1.FA13A00_2.Down -- Reference private sibling of
- (Floor'pos (Current_Floor) -- the subunit parent's body.
- - Floor'pos (Our_Floor));
- end if;
-
- -- Call elevator.
-
- Call
- (Current_Floor, Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- Elevator_Button := Up;
-
- when Down =>
- if Current_Floor > Our_Floor then
- FA13A00_1.FA13A00_2.Down -- Reference private sibling of
- (Floor'pos (Current_Floor) -- the subunit parent's body.
- - Floor'pos (Our_Floor));
- else
- FA13A00_1.FA13A00_2.Up -- Reference private sibling of
- (Floor'pos (Our_Floor) -- the subunit parent's body.
- - Floor'pos (Current_Floor));
- end if;
-
- Elevator_Button := Down;
-
- -- Call elevator.
-
- Call
- (Current_Floor, Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- end case;
-
- if not Call_Waiting (Current_Floor) -- Reference private part of the
- then -- parent of the subunit parent's
- -- body.
- TC_Operation := false;
- end if;
-
- end if;
-
- return Elevator_Button;
-
-end Call_Elevator;
-
- --==================================================================--
-
-with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations
- -- implicitly with Basic Elevator
- -- Operations
-with Report;
-
-procedure CA13A02 is
-
-begin
-
- Report.Test ("CA13A02", "Check that subunits declared in generic child " &
- "units of a public parent have the same visibility into " &
- "its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
--- Going from floor one to penthouse.
-
- Going_To_Penthouse:
- declare
- -- Declare instance of the child generic elevator package for penthouse.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Penthouse);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Express);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then
- Report.Failed ("Incorrect elevator operation going to penthouse");
- end if;
-
- end Going_To_Penthouse;
-
--- Going from penthouse to basement.
-
- Going_To_Basement:
- declare
- -- Declare instance of the child generic elevator package for basement.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Basement);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Down);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
- Report.Failed ("Incorrect elevator operation going to basement");
- end if;
-
- end Going_To_Basement;
-
--- Going from basement to floor three.
-
- Going_To_Floor3:
- declare
- -- Declare instance of the child generic elevator package for floor
- -- three.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor3);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Up);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
- Report.Failed ("Incorrect elevator operation going to floor 3");
- end if;
-
- end Going_To_Floor3;
-
--- Going from floor three to floor two.
-
- Going_To_Floor2:
- declare
- -- Declare instance of the child generic elevator package for floor two.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor2);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Up);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
- Report.Failed ("Incorrect elevator operation going to floor 2");
- end if;
-
- end Going_To_Floor2;
-
--- Going to floor one.
-
- Going_To_Floor1:
- declare
- -- Declare instance of the child generic elevator package for floor one.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor1);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
- -- Calling elevator from floor one.
-
- FA13A00_1.Current_Floor := FA13A00_1.Floor1;
-
- Call_Button_Light := Call_Elevator (Down);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
- Report.Failed ("Incorrect elevator operation going to floor 1");
- end if;
-
- end Going_To_Floor1;
-
- Report.Result;
-
-end CA13A02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140230.a b/gcc/testsuite/ada/acats/tests/ca/ca140230.a
deleted file mode 100644
index 95b72b1..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140230.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- CA140230.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:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA140230.A
--- CA140231.A
--- CA140232.AM
--- CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-package CA14023_0 is
- subtype Little_float is float digits 4 range 0.0..100.0;
- type Data_rec is tagged record
- Data : Little_float;
- end record;
-end CA14023_0;
-
---------------------------------------------------------
-
-generic
- type Data_type is digits <>;
- Floor : Data_type;
-function CA14023_1 (P1, P2 : Data_type) return Data_type;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140231.a b/gcc/testsuite/ada/acats/tests/ca/ca140231.a
deleted file mode 100644
index 32504b5..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140231.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- CA140231.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:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140230.A
--- -> CA140231.A
--- CA140232.AM
--- CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-function CA14023_1 (P1, P2 : Data_type) return Data_type is
-begin
- if Floor > P1 and Floor > P2 then
- return Floor;
- elsif P2 > P1 then
- return P2;
- else
- return P1;
- end if;
-end CA14023_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140232.am b/gcc/testsuite/ada/acats/tests/ca/ca140232.am
deleted file mode 100644
index d9ffba2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140232.am
+++ /dev/null
@@ -1,139 +0,0 @@
--- CA140232.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic instantiation depends on
--- a generic function that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic function, a generic
--- instantiation of the generic function, and a main
--- procedure that withs the instantiated generic
--- function. Then, a new version of the first generic
--- function is compiled (in a separate file, simulating
--- editing and modification to the unit). The test should
--- link the correct version of the withed function and
--- report "PASSED" at execution time.
---
--- Note that compilers are required by the standard to support
--- replacement of a generic body without recompilation of the
--- instantation. The ARG confirmed 10.1.4(10) with AI-00077.
---
--- To build this test:
--- 1) Compile the file CA140230 (and include the results in the
--- program library).
--- 2) Compile the file CA140231 (and include the results in the
--- program library).
--- 3) Compile the file CA140232 (and include the results in the
--- program library).
--- 4) Compile the file CA140233 (and include the results in the
--- program library).
--- 5) Build and run an executable image.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140230.A
--- CA140231.A
--- -> CA140232.AM
--- CA140233.A
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008T baseline version
--- 29 JUN 95 SAIC Initial version
--- 05 MAR 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved CA14023_1 to a separate file.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-with CA14023_0;
-use CA14023_0;
-
-generic
- Min : Little_float := 0.0;
- type Any_rec is new Data_rec with private;
-function CA14023_2 (R1, R2 : Any_rec) return Little_float;
-
---------------------------------------------------------
-
-with CA14023_1;
-
-function CA14023_2 (R1, R2 : Any_rec) return Little_float is
- function Max_val is new CA14023_1 (Little_float, Min);
-begin
- return max_val (R1.Data, R2.Data);
-end CA14023_2;
-
---------------------------------------------------------
-
-package CA14023_0.CA14023_3 is
- type New_data_rec is new Data_rec with record
- Other_val : integer := 100;
- end record;
-end CA14023_0.CA14023_3;
-
---------------------------------------------------------
-
-with Report; use Report;
-with CA14023_2;
-with CA14023_0;
-with CA14023_0.CA14023_3;
-
-procedure CA140232 is
-
- NDR1, NDR2 : CA14023_0.CA14023_3.New_data_rec;
- Min_value : constant CA14023_0.Little_float := 0.0;
- TC_result : CA14023_0.Little_float;
- function Max_Data_Val is new CA14023_2 (Min_value,
- CA14023_0.CA14023_3.New_data_rec);
-begin
- Test ("CA14023", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a generic " &
- "instantiation depends on a generic " &
- "function that is changed");
-
- NDR1.Data := 2.0;
- NDR2.Data := 5.0;
-
- TC_result := Max_Data_Val (NDR1, NDR2);
-
- if TC_result = 5.0 then
- Failed ("Revised generic not used");
- elsif TC_result /= 0.0 then -- the minimum, floor
- Failed ("Incorrect value returned"); -- value of 0.0 should
- end if; -- be returned rather
- -- than the min of the
- -- two actual parameters
-
- Result;
-end CA140232;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140233.a b/gcc/testsuite/ada/acats/tests/ca/ca140233.a
deleted file mode 100644
index a533437..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140233.a
+++ /dev/null
@@ -1,68 +0,0 @@
--- CA140233.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:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140230.A
--- CA140231.A
--- CA140232.AM
--- -> CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008T baseline version
--- 29 JUN 95 SAIC Initial version
--- 05 MAR 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---!
-
--- here is the replacement body, correcting "errors" in
--- the original
-
-function CA14023_1 (P1, P2 : Data_type) return Data_type is
-begin
- -- return min rather than max
- if Floor < P1 and Floor < P2 then
- return Floor;
- elsif P2 < P1 then
- return P2;
- else
- return P1;
- end if;
-end CA14023_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140280.a b/gcc/testsuite/ada/acats/tests/ca/ca140280.a
deleted file mode 100644
index 1ffe3cb..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140280.a
+++ /dev/null
@@ -1,77 +0,0 @@
--- CA140280.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:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA140280.A
--- CA140281.A
--- CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-GENERIC
- C : INTEGER;
-PROCEDURE GENPROC_CA14028 (X : OUT INTEGER);
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS
-BEGIN
- X := IDENT_INT(C);
-END GENPROC_CA14028;
-
-GENERIC
-FUNCTION GENFUNC_CA14028 RETURN INTEGER;
-
-FUNCTION GENFUNC_CA14028 RETURN INTEGER IS
-BEGIN
- RETURN 2;
-END GENFUNC_CA14028;
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028;
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140281.a b/gcc/testsuite/ada/acats/tests/ca/ca140281.a
deleted file mode 100644
index 57360c9..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140281.a
+++ /dev/null
@@ -1,67 +0,0 @@
--- CA140281.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:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140280.A
--- -> CA140281.A
--- CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS
-BEGIN
- X := 3;
-END CA14028_PROC1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA14028_FUNC2 RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END CA14028_FUNC2;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS
-BEGIN
- X := FALSE;
- Y := IDENT_INT(6);
-END CA14028_PROC3;
-
-FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS
-BEGIN
- RETURN FALSE;
-END CA14028_FUNC3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140282.a b/gcc/testsuite/ada/acats/tests/ca/ca140282.a
deleted file mode 100644
index 437f018..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140282.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- CA140282.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:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140280.A
--- CA140281.A
--- -> CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS
-BEGIN
- X := IDENT_INT(4);
-END CA14028_PROC3;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA14028_FUNC3 RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(7);
-END CA14028_FUNC3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140283.am b/gcc/testsuite/ada/acats/tests/ca/ca140283.am
deleted file mode 100644
index 9a74b8d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140283.am
+++ /dev/null
@@ -1,91 +0,0 @@
--- CA140283.AM
---
--- 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 subprogram body is compiled as a library unit
--- it is not interpreted as a completion for any previous library
--- subprogram created by generic instantiation, and it therefore
--- declares a new library subprogram.
---
--- TEST DESCRIPTION
--- A generic function and procedure plus their instantiations are
--- created. Then, subprogram bodies which ought to replace the
--- instantiations are compiled. Following that, additional instantiations
--- are compiled. Finally the main subprogram is compiled.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140280.A
--- CA140281.A
--- CA140282.A
--- -> CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- THS 09/24/90 REWORDED HEADER COMMENTS, ERROR MESSAGES, AND
--- CALL TO TEST. CALLED IDENT_INT CONSISTENTLY.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-WITH REPORT; USE REPORT;
-WITH CA14028_PROC1, CA14028_FUNC2, CA14028_PROC5, CA14028_FUNC22,
- CA14028_PROC3, CA14028_FUNC3;
-PROCEDURE CA140283 IS
- TEMP : INTEGER := 0;
-BEGIN
- TEST ("CA14028", "Check that library subprograms created by " &
- "generic instantiation are replaced " &
- "when new non-generic subprogram bodies are " &
- "compiled");
-
- CA14028_PROC1(TEMP);
- IF TEMP /= IDENT_INT(3) THEN
- FAILED ("CA14028_Proc1 instantiation not replaced");
- END IF;
-
- IF CA14028_FUNC2 /= IDENT_INT(4) THEN
- FAILED ("CA14028_Func2 instantiation not replaced");
- END IF;
-
- CA14028_PROC5(TEMP);
- IF TEMP /= IDENT_INT(5) THEN
- FAILED ("New CA14028_Proc5 instantiation not correct");
- END IF;
-
- IF CA14028_FUNC22 /= IDENT_INT(2) THEN
- FAILED ("New CA14028_Func22 instantiation not correct");
- END IF;
-
- CA14028_PROC3(TEMP);
- IF TEMP /= IDENT_INT(4) THEN
- FAILED ("CA14028_Proc3 not replaced by correct version");
- END IF;
-
- IF CA14028_FUNC3 /= IDENT_INT(7) THEN
- FAILED ("CA14028_Func3 not replaced by correct version");
- END IF;
-
- RESULT;
-END CA140283;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca15003.a b/gcc/testsuite/ada/acats/tests/ca/ca15003.a
deleted file mode 100644
index 08fe151..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca15003.a
+++ /dev/null
@@ -1,161 +0,0 @@
--- CA15003.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 the requirements of 10.1.5(4) and the modified 10.1.5(5)
--- from Technical Corrigendum 1. (Originally discussed as AI95-00136.)
--- Specifically:
--- Check that program unit pragma for a generic package are accepted
--- when given at the beginning of the package specification.
--- Check that a program unit pragma can be given for a generic
--- instantiation by placing the pragma immediately after the instantation.
---
--- TEST DESCRIPTION
--- This test checks the cases that are *not* forbidden by the RM,
--- and makes sure such legal cases actually work.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 08 JUL 1999 RLB Cleaned up and added to test suite.
--- 27 AUG 1999 RLB Repaired errors introduced by me.
---
---!
-
-with System;
-package CA15003A is
- pragma Pure;
-
- type Big_Int is range -System.Max_Int .. System.Max_Int;
- type Big_Positive is new Big_Int range 1..Big_Int'Last;
-end CA15003A;
-
-generic
- type Int is new Big_Int;
-package CA15003A.Pure is
- pragma Pure;
- function F(X: access Int) return Int;
-end CA15003A.Pure;
-
-with CA15003A.Pure;
-package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive);
- pragma Pure(CA15003A.Pure_Instance);
-
-package body CA15003A.Pure is
- function F(X: access Int) return Int is
- begin
- X.all := X.all + 1;
- return X.all;
- end F;
-end CA15003A.Pure;
-
-generic
-package CA15003A.Pure.Preelaborate is
- pragma Preelaborate;
- One: Int := 1;
- function F(X: access Int) return Int;
-end CA15003A.Pure.Preelaborate;
-
-package body CA15003A.Pure.Preelaborate is
- function F(X: access Int) return Int is
- begin
- X.all := X.all + One;
- return X.all;
- end F;
-end CA15003A.Pure.Preelaborate;
-
-with CA15003A.Pure_Instance;
-with CA15003A.Pure.Preelaborate;
-package CA15003A.Pure_Preelaborate_Instance is
- new CA15003A.Pure_Instance.Preelaborate;
- pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance);
-
-package CA15003A.Empty_Pure is
- pragma Pure;
- pragma Elaborate_Body;
-end CA15003A.Empty_Pure;
-
-package body CA15003A.Empty_Pure is
-end CA15003A.Empty_Pure;
-
-package CA15003A.Empty_Preelaborate is
- pragma Preelaborate;
- pragma Elaborate_Body;
- One: Big_Int := 1;
-end CA15003A.Empty_Preelaborate;
-
-package body CA15003A.Empty_Preelaborate is
- function F(X: access Big_Int) return Big_Int is
- begin
- X.all := X.all + One;
- return X.all;
- end F;
-end CA15003A.Empty_Preelaborate;
-
-package CA15003A.Empty_Elaborate_Body is
- pragma Elaborate_Body;
- Three: aliased Big_Positive := 1;
- Two, Tres: Big_Positive'Base := 0;
-end CA15003A.Empty_Elaborate_Body;
-
-with Report; use Report; pragma Elaborate_All(Report);
-with CA15003A.Pure_Instance;
-with CA15003A.Pure_Preelaborate_Instance;
-use CA15003A;
-package body CA15003A.Empty_Elaborate_Body is
-begin
- if Two /= Big_Positive'Base(Ident_Int(0)) then
- Failed ("Two should be zero now");
- end if;
- if Tres /= Big_Positive'Base(Ident_Int(0)) then
- Failed ("Tres should be zero now");
- end if;
- if Two /= Tres then
- Failed ("Tres should be zero now");
- end if;
- Two := Pure_Instance.F(Three'Access);
- Tres := Pure_Preelaborate_Instance.F(Three'Access);
- if Two /= Big_Positive(Ident_Int(2)) then
- Failed ("Two should be 2 now");
- end if;
- if Tres /= Big_Positive(Ident_Int(3)) then
- Failed ("Tres should be 3 now");
- end if;
-end CA15003A.Empty_Elaborate_Body;
-
-with Report; use Report;
-with CA15003A.Empty_Pure;
-with CA15003A.Empty_Preelaborate;
-with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body;
-use type CA15003A.Big_Positive'Base;
-procedure CA15003 is
-begin
- Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages");
- if Two /= 2 then
- Failed ("Two should be 2 now");
- end if;
- if Tres /= 3 then
- Failed ("Tres should be 3 now");
- end if;
- Result;
-end CA15003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200020.a b/gcc/testsuite/ada/acats/tests/ca/ca200020.a
deleted file mode 100644
index c9508f4..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca200020.a
+++ /dev/null
@@ -1,70 +0,0 @@
--- CA200020.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 a partition can be created even if the environment contains
--- two units with the same name. (This is rule 10.2(19)).
---
--- TEST DESCRIPTION:
--- Declare the a parent package (CA20002_0). Declare a child package
--- (CA20002_0.CA20002_1). Declare a subunit in the parent package body
--- (CA20002_1). Declare a main subprogram that does NOT include the
--- child package. Insure that this partition can be created.
---
--- This test is intended to test the effects of program maintenance.
--- After the programmer receives an error from creating a partition
--- like that tested in test LA20001, the programmer may then repair
--- the partition by eliminating the reference of the child unit. The
--- partition should be able to be created.
---
--- To build this test:
--- 1) Compile the file CA200020 (and include the results in the
--- program library).
--- 2) Compile the file CA200021 (and include the results in the
--- program library).
--- 3) Compile the file CA200022 (and include the results in the
--- program library).
--- 4) Build an executable image, and run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA200020.A
--- CA200021.A
--- CA200022.AM
---
--- CHANGE HISTORY:
--- 27 Jan 99 RLB Initial test.
--- 20 Mar 00 RLB Removed special requirements, because there
--- aren't any.
---!
-
-package CA20002_0 is
- procedure Do_a_Little (A : out Integer);
-
-end CA20002_0;
-
-package CA20002_0.CA20002_1 is
- My_Global : Integer;
-end CA20002_0.CA20002_1;
-
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200021.a b/gcc/testsuite/ada/acats/tests/ca/ca200021.a
deleted file mode 100644
index 0c5de38..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca200021.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- CA200021.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:
--- See CA200020.A.
---
--- TEST DESCRIPTION:
--- See CA200020.A.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA200020.A
--- -> CA200021.A
--- CA200022.AM
---
--- PASS/FAIL CRITERIA:
--- See CA200020.A.
---
--- CHANGE HISTORY:
--- 27 JAN 99 RLB Initial version.
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-package body CA20002_0 is
-
- function CA20002_1 return Integer is separate; -- Has the same expanded name
- -- as the child.
- -- Note: An implementation may produce a warning about the child
- -- unit at this point, but it must accept the subunit declaration.
-
- procedure Do_a_Little (A : out Integer) is
- begin
- A := CA20002_1;
- end Do_a_Little;
-
-end CA20002_0;
-
-with Report;
-separate (CA20002_0)
-function CA20002_1 return Integer is
-begin
- return Report.Ident_Int(5);
-end CA20002_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200022.am b/gcc/testsuite/ada/acats/tests/ca/ca200022.am
deleted file mode 100644
index 1e9b773..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca200022.am
+++ /dev/null
@@ -1,64 +0,0 @@
--- CA200022.AM
---
--- 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:
--- See CA200020.A.
---
--- TEST DESCRIPTION:
--- See CA200020.A.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA200020.A
--- CA200021.A
--- -> CA200022.AM
---
--- PASS/FAIL CRITERIA:
--- See CA200020.A.
---
--- CHANGE HISTORY:
--- 25 JAN 99 RLB Initial version.
--- 08 JUL 99 RLB Repaired comments.
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---!
-
-with Report;
-use Report;
-with CA20002_0; -- Child unit not included in the partition.
-procedure CA200022 is
- Value : Integer := 0;
-begin
- Test ("CA20002","Check that compiling multiple units with the same " &
- "name does not prevent the creation of a partition " &
- "using only one of the units.");
- CA20002_0.Do_a_Little (Value);
- if Report.Equal (Value, 5) then
- null; -- OK.
- else
- Failed ("Wrong result from subunit");
- end if;
-
- Result;
-end CA200022;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada
deleted file mode 100644
index f40744f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada
+++ /dev/null
@@ -1,40 +0,0 @@
--- CA2001H0.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.
---*
--- WKB 6/25/81
--- JBG 8/25/83
-
-FUNCTION CA2001H0 RETURN INTEGER IS
-
- PACKAGE CA2001H1 IS
- I : INTEGER := 0;
- END CA2001H1;
-
- PACKAGE BODY CA2001H1 IS SEPARATE;
-
-BEGIN
-
- RETURN CA2001H1.I;
-
-END CA2001H0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada
deleted file mode 100644
index db0797d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada
+++ /dev/null
@@ -1,39 +0,0 @@
--- CA2001H1.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.
---*
--- WKB 6/25/81
--- JBG 8/25/83
--- BHS 7/31/84
-
-SEPARATE (CA2001H0)
-
-PACKAGE BODY CA2001H1 IS
- PROCEDURE NOT_USED IS SEPARATE;
-
-BEGIN
-
- I := 1;
- NOT_USED;
-
-END CA2001H1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada
deleted file mode 100644
index c6f672b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada
+++ /dev/null
@@ -1,38 +0,0 @@
--- CA2001H2.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.
---*
--- WKB 6/25/81
--- JBG 8/25/83
-
-FUNCTION CA2001H0 RETURN INTEGER IS
-
- PACKAGE CA2001H1 IS
- I : INTEGER := 2;
- END CA2001H1;
-
-BEGIN
-
- RETURN CA2001H1.I;
-
-END CA2001H0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada
deleted file mode 100644
index 9da25ee..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CA2001H3M.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 BODY_STUB IS DELETED FROM A COMPILATION UNIT,
--- THE PREVIOUSLY EXISTING SUBUNIT CAN NO LONGER BE ACCESSED.
-
--- SEPARATE FILES ARE;
--- CA2001H0 A LIBRARY FUNCTION (CA2001H0).
--- CA2001H1 A SUBUNIT PACKAGE BODY.
--- CA2001H2 A LIBRARY FUNCTION (CA2001H0).
--- CA2001H3M THE MAIN PROCEDURE.
-
--- WKB 6/25/81
--- JRK 6/26/81
--- SPS 11/2/82
--- JBG 8/25/83
-
-
-WITH REPORT, CA2001H0;
-USE REPORT;
-PROCEDURE CA2001H3M IS
-
- I : INTEGER := -1;
-
-BEGIN
- TEST ("CA2001H", "IF A BODY_STUB IS DELETED FROM A COMPILATION " &
- "UNIT, THE PREVIOUSLY EXISTING SUBUNIT CAN NO " &
- "LONGER BE ACCESSED");
-
- I := CA2001H0;
-
- IF I = 1 THEN
- FAILED ("SUBUNIT ACCESSED");
- END IF;
-
- IF I = 0 THEN
- FAILED ("OLD LIBRARY UNIT ACCESSED");
- END IF;
-
- IF I /= 2 THEN
- FAILED ("NEW LIBRARY UNIT NOT ACCESSED");
- END IF;
-
- RESULT;
-END CA2001H3M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada
deleted file mode 100644
index f48f58b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada
+++ /dev/null
@@ -1,139 +0,0 @@
--- CA2002A0M.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 SUBUNITS HAVING DIFFERENT ANCESTOR LIBRARY UNITS CAN HAVE
--- THE SAME NAME.
-
--- SEPARATE FILES ARE:
--- CA2002A0M THE MAIN PROCEDURE, WITH SEPARATE LIBRARY
--- PACKAGES (CA2002A1) AND (CA2002A2).
--- CA2002A1 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A1.
--- CA2002A2 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A2.
-
--- BHS 8/02/84
-
-PACKAGE CA2002A1 IS
-
- PROCEDURE PROC (X : OUT INTEGER);
- FUNCTION FUN RETURN BOOLEAN;
-
- PACKAGE PKG IS
- I : INTEGER;
- PROCEDURE PKG_PROC (XX : IN OUT INTEGER);
- END PKG;
-
-END CA2002A1;
-
-PACKAGE BODY CA2002A1 IS
-
- PROCEDURE PROC (X : OUT INTEGER) IS SEPARATE;
- FUNCTION FUN RETURN BOOLEAN IS SEPARATE;
- PACKAGE BODY PKG IS SEPARATE;
-
-END CA2002A1;
-
-
-PACKAGE CA2002A2 IS
-
- PROCEDURE PROC (Y : OUT INTEGER);
- FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN;
-
- PACKAGE PKG IS
- I : INTEGER;
- PROCEDURE PKG_PROC (YY : IN OUT INTEGER);
- END PKG;
-
-END CA2002A2;
-
-PACKAGE BODY CA2002A2 IS
-
- PROCEDURE PROC (Y : OUT INTEGER) IS SEPARATE;
- FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS SEPARATE;
- PACKAGE BODY PKG IS SEPARATE;
-
-END CA2002A2;
-
-WITH CA2002A1, CA2002A2;
-WITH REPORT; USE REPORT;
-PROCEDURE CA2002A0M IS
-BEGIN
-
- TEST ("CA2002A", "SUBUNITS WITH DIFFERENT ANCESTORS " &
- "CAN HAVE THE SAME NAME");
-
- DECLARE
- VAR1 : INTEGER;
- USE CA2002A1;
- BEGIN
-
- PROC (VAR1);
- IF VAR1 /= 1 THEN
- FAILED ("CA2002A1 PROCEDURE NOT INVOKED CORRECTLY");
- END IF;
-
- IF NOT FUN THEN
- FAILED ("CA2002A1 FUNCTION NOT INVOKED CORRECTLY");
- END IF;
-
- IF PKG.I /= 1 THEN
- FAILED ("CA2202A1 PKG VARIABLE NOT ACCESSED CORRECTLY");
- END IF;
-
- VAR1 := 5;
- PKG.PKG_PROC (VAR1);
- IF VAR1 /= 4 THEN
- FAILED ("CA2002A1 PKG SUBUNIT NOT INVOKED CORRECTLY");
- END IF;
-
- END;
-
- DECLARE
- VAR2 : INTEGER;
- USE CA2002A2;
- BEGIN
-
- PROC (VAR2);
- IF VAR2 /= 2 THEN
- FAILED ("CA2002A2 PROCEDURE NOT INVOKED CORRECTLY");
- END IF;
-
- IF FUN THEN
- FAILED ("CA2002A2 FUNCTION NOT INVOKED CORRECTLY");
- END IF;
-
- IF PKG.I /= 2 THEN
- FAILED ("CA2002A2 PKG VARIABLE NOT ACCESSED CORRECTLY");
- END IF;
-
- VAR2 := 3;
- PKG.PKG_PROC (VAR2);
- IF VAR2 /= 4 THEN
- FAILED ("CA2002A2 PKG SUBUNIT NOT INVOKED CORRECTLY");
- END IF;
-
- END;
-
- RESULT;
-
-END CA2002A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada
deleted file mode 100644
index 064ec4d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- CA2002A1.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.
---*
--- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A1 IN FILE
--- CA2002A0M.
-
--- BHS 8/02/84
-
-SEPARATE (CA2002A1)
-PROCEDURE PROC (X : OUT INTEGER) IS
-BEGIN
- X := 1;
-END PROC;
-
-SEPARATE (CA2002A1)
-FUNCTION FUN RETURN BOOLEAN IS
-BEGIN
- RETURN TRUE;
-END FUN;
-
-SEPARATE (CA2002A1)
-PACKAGE BODY PKG IS
- PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS SEPARATE;
-BEGIN
- I := 1;
-END PKG;
-
-SEPARATE (CA2002A1.PKG)
-PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS
-BEGIN
- XX := XX - 1;
-END PKG_PROC;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada
deleted file mode 100644
index 6a1bc58..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- CA2002A2.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.
---*
--- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A2 IN FILE
--- CA2002A0M.
-
--- BHS 8/02/84
-
-SEPARATE (CA2002A2)
-PROCEDURE PROC (Y : OUT INTEGER) IS
-BEGIN
- Y := 2;
-END PROC;
-
-SEPARATE (CA2002A2)
-FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS
-BEGIN
- RETURN Z /= 3;
-END FUN;
-
-SEPARATE (CA2002A2)
-PACKAGE BODY PKG IS
- PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS SEPARATE;
-BEGIN
- I := 2;
-END PKG;
-
-SEPARATE (CA2002A2.PKG)
-PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS
-BEGIN
- YY := YY + 1;
-END PKG_PROC;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada
deleted file mode 100644
index d6e47b4..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- CA2003A0M.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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED
--- PRIOR TO ITS BODY_STUB.
-
--- SEPARATE FILES ARE:
--- CA2003A0M THE MAIN PROCEDURE.
--- CA2003A1 A SUBUNIT PROCEDURE BODY.
-
--- WKB 6/26/81
--- JRK 6/26/81
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2003A0M IS
-
- I : INTEGER := 1;
-
- PROCEDURE CA2003A1 IS SEPARATE;
-
- PACKAGE P IS
- I : INTEGER := 2;
- END P;
-
-BEGIN
- TEST ("CA2003A", "A SUBUNIT HAS VISIBILITY OF IDENTIFIERS " &
- "DECLARED BEFORE ITS BODY_STUB");
-
-
- CA2003A1;
-
- RESULT;
-END CA2003A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada
deleted file mode 100644
index ec09f13..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA2003A1.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.
---*
--- WKB 6/26/81
-
-SEPARATE (CA2003A0M)
-PROCEDURE CA2003A1 IS
-BEGIN
-
- IF I /= 1 THEN
- FAILED ("IDENTIFIER IN PARENT NOT VISIBLE");
- END IF;
-
-END CA2003A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada
deleted file mode 100644
index 4eae5e2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- CA2004A0M.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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED
--- IN ANCESTORS OTHER THAN THE PARENT.
-
--- SEPARATE FILES ARE:
--- CA2004A0M THE MAIN PROCEDURE.
--- CA2004A1 A SUBUNIT PACKAGE BODY.
--- CA2004A2 A SUBUNIT PROCEDURE BODY.
--- CA2004A3 A SUBUNIT PROCEDURE BODY.
--- CA2004A4 A SUBUNIT PROCEDURE BODY.
-
--- WKB 6/26/81
--- JRK 6/26/81
--- BHS 7/31/84
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2004A0M IS
-
- I : INTEGER := 1;
-
- PACKAGE CA2004A1 IS
- J : INTEGER := 2;
- PROCEDURE CA2004A2;
- END CA2004A1;
-
- USE CA2004A1;
- PACKAGE BODY CA2004A1 IS SEPARATE;
- PROCEDURE CA2004A3 IS SEPARATE;
-
-BEGIN
- TEST ("CA2004A", "CHECK THAT A SUBUNIT HAS VISIBILITY OF " &
- "IDENTIFIERS DECLARED IN ANCESTORS");
-
-
- CA2004A1.
- CA2004A2;
-
- CA2004A3;
-
- RESULT;
-END CA2004A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada
deleted file mode 100644
index 2dcfd45..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA2004A1.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.
---*
--- WKB 6/26/81
-
-SEPARATE (CA2004A0M)
-PACKAGE BODY CA2004A1 IS
-
- K : INTEGER := 3;
-
- PROCEDURE CA2004A2 IS SEPARATE;
-
-END CA2004A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada
deleted file mode 100644
index 739152f..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada
+++ /dev/null
@@ -1,43 +0,0 @@
--- CA2004A2.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.
---*
--- WKB 6/26/81
-
-SEPARATE (CA2004A0M.CA2004A1)
-PROCEDURE CA2004A2 IS
-BEGIN
-
- IF I /= 1 THEN
- FAILED ("IDENTIFIER NOT VISIBLE - 1");
- END IF;
-
- IF J /= 2 THEN
- FAILED ("IDENTIFIER NOT VISIBLE - 2");
- END IF;
-
- IF K /= 3 THEN
- FAILED ("IDENTIFIER NOT VISIBLE - 3");
- END IF;
-
-END CA2004A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada
deleted file mode 100644
index 528f4e2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada
+++ /dev/null
@@ -1,39 +0,0 @@
--- CA2004A3.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.
---*
--- BHS 7/31/84
-
-SEPARATE (CA2004A0M)
-PROCEDURE CA2004A3 IS
-
- PROCEDURE CA2004A4 IS SEPARATE;
-
-BEGIN
-
- IF I /= IDENT_INT(1) OR
- J /= IDENT_INT(2) THEN
- FAILED ("IDENTIFIER NOT VISIBLE - 4");
- END IF;
-
-END CA2004A3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada
deleted file mode 100644
index a71ca33..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA2004A4.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.
---*
--- BHS 7/31/84
-
-SEPARATE (CA2004A0M.CA2004A3)
-PROCEDURE CA2004A4 IS
-BEGIN
-
- IF I /= IDENT_INT(1) OR
- J /= IDENT_INT(2) THEN
- FAILED ("IDENTIFIER NOT VISIBLE - 5");
- END IF;
-
-END CA2004A4;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada
deleted file mode 100644
index fb9e0b4..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CA2007A0M.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 SUBUNIT PACKAGES ARE ELABORATED IN THE ORDER IN
--- WHICH THEIR BODY STUBS APPEAR, NOT (NECESSARILY) IN THE
--- ORDER IN WHICH THEY ARE COMPILED.
-
--- SEPARATE FILES ARE:
--- CA2007A0M THE MAIN PROCEDURE.
--- CA2007A1 A SUBUNIT PACKAGE BODY.
--- CA2007A2 A SUBUNIT PACKAGE BODY.
--- CA2007A3 A SUBUNIT PACKAGE BODY.
-
--- WKB 7/1/81
--- JRK 7/1/81
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2007A0M IS
-
- ELAB_ORDER : STRING (1..3) := " ";
- NEXT : NATURAL := 1;
-
- PACKAGE CALL_TEST IS
- END CALL_TEST;
-
- PACKAGE BODY CALL_TEST IS
- BEGIN
- TEST ("CA2007A", "CHECK THAT SUBUNIT PACKAGES ARE " &
- "ELABORATED IN THE ORDER IN WHICH THEIR " &
- "BODY STUBS APPEAR");
- END CALL_TEST;
-
- PACKAGE CA2007A3 IS
- END CA2007A3;
-
- PACKAGE BODY CA2007A3 IS SEPARATE;
-
- PACKAGE CA2007A2 IS
- END CA2007A2;
-
- PACKAGE BODY CA2007A2 IS SEPARATE;
-
- PACKAGE CA2007A1 IS
- END CA2007A1;
-
- PACKAGE BODY CA2007A1 IS SEPARATE;
-
-BEGIN
-
- IF ELAB_ORDER /= "321" THEN
- FAILED ("INCORRECT ELABORATION ORDER");
- END IF;
-
- RESULT;
-END CA2007A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada
deleted file mode 100644
index bef16f5..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA2007A1.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.
---*
--- WKB 7/1/81
-
-SEPARATE (CA2007A0M)
-
-PACKAGE BODY CA2007A1 IS
-
-BEGIN
-
- ELAB_ORDER (NEXT) := '1';
- NEXT := NEXT + 1;
-
-END CA2007A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada
deleted file mode 100644
index 9429ea4..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA2007A2.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.
---*
--- WKB 7/1/81
-
-SEPARATE (CA2007A0M)
-
-PACKAGE BODY CA2007A2 IS
-
-BEGIN
-
- ELAB_ORDER (NEXT) := '2';
- NEXT := NEXT + 1;
-
-END CA2007A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada
deleted file mode 100644
index 1d4886c..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada
+++ /dev/null
@@ -1,36 +0,0 @@
--- CA2007A3.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.
---*
--- WKB 7/1/81
-
-SEPARATE (CA2007A0M)
-
-PACKAGE BODY CA2007A3 IS
-
-BEGIN
-
- ELAB_ORDER (NEXT) := '3';
- NEXT := NEXT + 1;
-
-END CA2007A3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada
deleted file mode 100644
index 542591c..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- CA2008A0M.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 AN OVERLOADED SUBPROGRAM, ONE OF THE
--- SUBPROGRAM BODIES CAN BE SPECIFIED WITH A BODY_STUB AND
--- COMPILED SEPARATELY.
-
--- SEPARATE FILES ARE:
--- CA2008A0M THE MAIN PROCEDURE.
--- CA2008A1 A SUBUNIT PROCEDURE BODY.
--- CA2008A2 A SUBUNIT FUNCTION BODY.
-
--- WKB 6/26/81
--- SPS 11/2/82
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2008A0M IS
-
- I : INTEGER := 0;
- B : BOOLEAN := TRUE;
-
- PROCEDURE CA2008A1 (I : IN OUT INTEGER) IS
- BEGIN
- I := IDENT_INT (1);
- END CA2008A1;
-
- PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS SEPARATE;
-
- FUNCTION CA2008A2 RETURN INTEGER IS SEPARATE;
-
- FUNCTION CA2008A2 RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (FALSE);
- END CA2008A2;
-
-BEGIN
- TEST ("CA2008A", "CHECK THAT AN OVERLOADED SUBPROGRAM " &
- "CAN HAVE ONE OF ITS BODIES COMPILED SEPARATELY");
-
- CA2008A1 (I);
- IF I /= 1 THEN
- FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 1");
- END IF;
-
- CA2008A1 (B);
- IF B THEN
- FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 2");
- END IF;
-
- IF CA2008A2 /= 2 THEN
- FAILED ("OVERLOADED FUNCTION NOT INVOKED - 1");
- END IF;
-
- IF CA2008A2 THEN
- FAILED ("OVERLOADED FUNCTION NOT INVOKED - 2");
- END IF;
-
- RESULT;
-END CA2008A0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada
deleted file mode 100644
index 7154a8d..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA2008A1.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.
---*
--- WKB 6/26/81
-
-SEPARATE (CA2008A0M)
-
-PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS
-
-BEGIN
-
- B := FALSE;
-
-END CA2008A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada
deleted file mode 100644
index d8fd439..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA2008A2.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.
---*
--- WKB 6/26/81
-
-SEPARATE (CA2008A0M)
-
-FUNCTION CA2008A2 RETURN INTEGER IS
-
-BEGIN
-
- RETURN 2;
-
-END CA2008A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada
deleted file mode 100644
index 4953045..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CA2009A.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 GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND
--- INSTANTIATED.
-
--- BHS 8/01/84
--- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323.
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2009A IS
-
- INT1 : INTEGER := 1;
-
- SUBTYPE STR15 IS STRING (1..15);
- SVAR : STR15 := "ABCDEFGHIJKLMNO";
-
- GENERIC
- TYPE ITEM IS PRIVATE;
- CON1 : IN ITEM;
- VAR1 : IN OUT ITEM;
- PACKAGE PKG1 IS
- END PKG1;
-
- PACKAGE BODY PKG1 IS SEPARATE;
-
- PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1);
- PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"),
- SVAR);
-
-BEGIN
-
- TEST ("CA2009A", "SPECIFICATION AND INSTANTIATION " &
- "OF GENERIC PACKAGE SUBUNITS");
-
- IF INT1 /= 2 THEN
- FAILED ("INCORRECT INSTANTIATION - INTEGER");
- END IF;
-
- IF SVAR /= "REINSTANTIATION" THEN
- FAILED ("INCORRECT INSTANTIATION - STRING");
- END IF;
-
-
- RESULT;
-
-END CA2009A;
-
-
-SEPARATE (CA2009A)
-PACKAGE BODY PKG1 IS
-BEGIN
- VAR1 := CON1;
-END PKG1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada
deleted file mode 100644
index aedd31b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CA2009C0M.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 GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND
--- INSTANTIATED. IN THIS TEST, THE SUBUNIT BODY IS IN A
--- SEPARATE FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
-
--- SEPARATE FILES ARE:
--- CA2009C0M THE MAIN PROCEDURE.
--- CA2009C1 A SUBUNIT PACKAGE BODY (PKG1).
-
--- HISTORY:
--- BHS 08/01/84 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
--- RLB 09/15/99 REMOVED JUNK COMMENT.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2009C0M IS
-
- INT1 : INTEGER := 1;
-
- SUBTYPE STR15 IS STRING (1..15);
- SVAR : STR15 := "ABCDEFGHIJKLMNO";
-
- GENERIC
- TYPE ITEM IS PRIVATE;
- CON1 : IN ITEM;
- VAR1 : IN OUT ITEM;
- PACKAGE PKG1 IS
- END PKG1;
-
- PACKAGE BODY PKG1 IS SEPARATE;
-
- PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1);
- PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"),
- SVAR);
-
-BEGIN
-
- TEST ("CA2009C", "SPECIFICATION AND INSTANTIATION " &
- "OF GENERIC PACKAGE SUBUNITS " &
- " - SEPARATE FILES USED");
-
- IF INT1 /= 2 THEN
- FAILED ("INCORRECT INSTANTIATION - INTEGER");
- END IF;
-
- IF SVAR /= "REINSTANTIATION" THEN
- FAILED ("INCORRECT INSTANTIATION - STRING");
- END IF;
-
-
- RESULT;
-
-END CA2009C0M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada
deleted file mode 100644
index 6bf9a4b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada
+++ /dev/null
@@ -1,43 +0,0 @@
--- CA2009C1.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.
---*
--- A GENERIC PACKAGE BODY.
--- THE DECLARATION AND AN INSTANTIATION ARE IN CA2009C0M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- BHS 08/09/84 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED COMMENTS TO RELATE TO OTHER TEST FILES
--- AND TO DESCRIBE EXPECTED COMPILER ACTION.
--- BCB 01/05/88 MODIFIED HEADER.
--- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA2009C0M)
-PACKAGE BODY PKG1 IS
-BEGIN
- VAR1 := CON1;
-END PKG1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada
deleted file mode 100644
index 65b5d81..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- CA2009D.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 GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND
--- INSTANTIATED.
-
--- BHS 8/01/84
--- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323.
-
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2009D IS
-
- INT1 : INTEGER := 1;
- INT2 : INTEGER := 2;
-
-
- GENERIC
- TYPE ELEM IS PRIVATE;
- PCON1 : IN ELEM;
- PVAR1 : IN OUT ELEM;
- PROCEDURE PROC1;
-
-
- GENERIC
- TYPE OBJ IS PRIVATE;
- FCON1 : IN OBJ;
- FVAR1 : IN OUT OBJ;
- FUNCTION FUNC1 RETURN OBJ;
-
-
- PROCEDURE PROC1 IS SEPARATE;
- FUNCTION FUNC1 RETURN OBJ IS SEPARATE;
-
-
- PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1);
- FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 3, INT2);
-
-
-BEGIN
-
- TEST ("CA2009D", "SPECIFICATION AND INSTANTIATION " &
- "OF GENERIC SUBPROGRAM SUBUNITS");
-
- NI_PROC1;
- IF INT1 /= 2 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_PROC1");
- END IF;
-
-
- IF NI_FUNC1 /= 3 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_FUNC1");
- END IF;
-
-
- RESULT;
-
-END CA2009D;
-
-
-SEPARATE (CA2009D)
-PROCEDURE PROC1 IS
-BEGIN
- PVAR1 := PCON1;
-END PROC1;
-
-
-SEPARATE (CA2009D)
-FUNCTION FUNC1 RETURN OBJ IS
-BEGIN
- FVAR1 := FCON1;
- RETURN FVAR1;
-END FUNC1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada
deleted file mode 100644
index 8bc23c1..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CA2009F0M.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 GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND
--- INSTANTIATED. IN THIS TEST, SOME SUBUNIT BODIES ARE
--- IN SEPARATE FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
-
--- SEPARATE FILES ARE:
--- CA2009F0M THE MAIN PROCEDURE, WITH SUBUNIT BODIES FOR
--- PROC2 AND FUNC2.
--- CA2009F1 A SUBUNIT PROCEDURE BODY (PROC1).
--- CA2009F2 A SUBUNIT FUNCTION BODY (FUNC1).
-
--- HISTORY:
--- BHS 08/01/84 CREATED ORIGINAL TEST.
--- PWB 02/19/86 ADDED "SOME" TO FIRST COMMENT.
--- BCB 01/05/88 MODIFIED HEADER.
--- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
--- RLB 09/15/99 REMOVED JUNK COMMENT.
-
-WITH REPORT;
-USE REPORT;
-PROCEDURE CA2009F0M IS
-
- INT1 : INTEGER := 1;
- INT2 : INTEGER := 2;
- INT3 : INTEGER := 3;
- INT4 : INTEGER := 4;
-
-
- GENERIC
- TYPE ELEM IS PRIVATE;
- PCON1 : IN ELEM;
- PVAR1 : IN OUT ELEM;
- PROCEDURE PROC1;
-
- GENERIC
- TYPE ELEM IS PRIVATE;
- PCON2 : IN ELEM;
- PVAR2 : IN OUT ELEM;
- PROCEDURE PROC2;
-
- GENERIC
- TYPE OBJ IS PRIVATE;
- FCON1 : IN OBJ;
- FVAR1 : IN OUT OBJ;
- FUNCTION FUNC1 RETURN OBJ;
-
- GENERIC
- TYPE OBJ IS PRIVATE;
- FCON2 : IN OBJ;
- FVAR2 : IN OUT OBJ;
- FUNCTION FUNC2 RETURN OBJ;
-
-
- PROCEDURE PROC1 IS SEPARATE;
- PROCEDURE PROC2 IS SEPARATE;
- FUNCTION FUNC1 RETURN OBJ IS SEPARATE;
- FUNCTION FUNC2 RETURN OBJ IS SEPARATE;
-
-
- PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1);
- PROCEDURE NI_PROC2 IS NEW PROC2 (INTEGER, 3, INT2);
- FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 4, INT3);
- FUNCTION NI_FUNC2 IS NEW FUNC2 (INTEGER, 5, INT4);
-
-
-BEGIN
-
- TEST ("CA2009F", "SPECIFICATION AND INSTANTIATION " &
- "OF GENERIC SUBPROGRAM SUBUNITS");
-
- NI_PROC1;
- IF INT1 /= 2 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_PROC1");
- END IF;
-
- NI_PROC2;
- IF INT2 /= 3 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_PROC2");
- END IF;
-
- IF NI_FUNC1 /= 4 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_FUNC1");
- END IF;
-
- IF NI_FUNC2 /= 5 THEN
- FAILED ("INCORRECT INSTANTIATION - NI_FUNC2");
- END IF;
-
-
- RESULT;
-
-END CA2009F0M;
-
-
-SEPARATE (CA2009F0M)
-PROCEDURE PROC2 IS
-BEGIN
- PVAR2 := PCON2;
-END PROC2;
-
-SEPARATE (CA2009F0M)
-FUNCTION FUNC2 RETURN OBJ IS
-BEGIN
- FVAR2 := FCON2;
- RETURN FVAR2;
-END FUNC2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada
deleted file mode 100644
index e3e13ce..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada
+++ /dev/null
@@ -1,43 +0,0 @@
--- CA2009F1.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.
---*
--- SEPARATE GENERIC PROCEDURE BODY.
--- SPECIFICATION, BODY STUB, AND INSTANTIATION ARE IN A2009F0M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- BHS 08/01/84 CREATED ORIGINAL TEST.
--- PWB 02/19/86 MODIFIED COMMENTS TO SHOW RELATION TO OTHER FILES
--- AND TO CLARIFY NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA2009F0M)
-PROCEDURE PROC1 IS
-BEGIN
- PVAR1 := PCON1;
-END PROC1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada b/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada
deleted file mode 100644
index 201a438..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada
+++ /dev/null
@@ -1,45 +0,0 @@
--- CA2009F2.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.
---*
--- SEPARATE GENERIC FUNCTION BODY.
--- SPECIFICATION, BODY STUB, AND AN INSTANTIATION ARE
--- IN CA2009F0M.DEP.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- BHS 08/01/84 CREATED ORIGINAL TEST.
--- PWB 02/19/86 MODIFIED COMMENTS TO DESCRIBE RELATION TO OTHER
--- FILES AND POSSIBLE NON-APPLICABILITY.
--- BCB 01/05/88 MODIFIED HEADER.
--- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA2009F0M)
-FUNCTION FUNC1 RETURN OBJ IS
-BEGIN
- FVAR1 := FCON1;
- RETURN FVAR1;
-END FUNC1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada b/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada
deleted file mode 100644
index c1c3be5..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CA2011B.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 A SUBPROGRAM DECLARATION-STUB-BODY TRIPLE, THE
--- DECLARATION-STUB AND STUB-BODY SPECIFICATIONS CAN CONFORM, BUT
--- THE DECLARATION-BODY SPECIFICATIONS NEED NOT.
-
--- HISTORY:
--- JET 08/01/88 CREATED ORIGINAL TEST.
-
-PACKAGE CA2011B0 IS
- SUBTYPE T IS INTEGER RANGE -100 .. 100;
- I : T := 0;
-END CA2011B0;
-
-WITH CA2011B0; USE CA2011B0;
-PACKAGE CA2011B1 IS
- PROCEDURE P1 (X : CA2011B0.T);
- PROCEDURE P2 (X : T);
-END CA2011B1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CA2011B1 IS
- PACKAGE CA2011BX RENAMES CA2011B0;
- PROCEDURE P1 (X : T) IS SEPARATE;
- PROCEDURE P2 (X : CA2011BX.T) IS SEPARATE;
-END CA2011B1;
-
-SEPARATE (CA2011B1)
-PROCEDURE P1 (X : CA2011BX.T) IS
-BEGIN
- I := IDENT_INT(X);
-END P1;
-
-SEPARATE (CA2011B1)
-PROCEDURE P2 (X : CA2011BX.T) IS
-BEGIN
- I := IDENT_INT(X);
-END P2;
-
-WITH REPORT; USE REPORT;
-WITH CA2011B0, CA2011B1;
-PROCEDURE CA2011B IS
-
- PACKAGE P1 IS
- SUBTYPE T IS INTEGER RANGE -100 .. 100;
- END P1;
- USE P1;
-
- FUNCTION F1 RETURN P1.T;
- FUNCTION F2 RETURN T;
-
- PACKAGE P2 RENAMES P1;
-
- FUNCTION F1 RETURN T IS SEPARATE;
- FUNCTION F2 RETURN P2.T IS SEPARATE;
-
-BEGIN
- TEST ("CA2011B", "CHECK THAT FOR A SUBPROGRAM DECLARATION-STUB-" &
- "BODY TRIPLE, THE DECLARATION-STUB AND STUB-" &
- "BODY SPECIFICATIONS CAN CONFORM, BUT THE " &
- "DECLARATON-BODY SPECIFICATIONS NEED NOT");
-
- IF F1 /= IDENT_INT(100) THEN
- FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 1");
- END IF;
-
- IF F2 /= IDENT_INT(-100) THEN
- FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 2");
- END IF;
-
- CA2011B1.P1(3);
- IF CA2011B0.I /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 1");
- END IF;
-
- CA2011B1.P2(4);
- IF CA2011B0.I /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 2");
- END IF;
-
- RESULT;
-END CA2011B;
-
-SEPARATE (CA2011B)
-FUNCTION F1 RETURN P2.T IS
-BEGIN
- RETURN 100;
-END F1;
-
-SEPARATE (CA2011B)
-FUNCTION F2 RETURN P2.T IS
-BEGIN
- RETURN -100;
-END F2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca21001.a b/gcc/testsuite/ada/acats/tests/ca/ca21001.a
deleted file mode 100644
index 1056b65..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca21001.a
+++ /dev/null
@@ -1,152 +0,0 @@
--- CA21001.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 WHATSOVER, 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 the requirements of the revised 10.2.1(11) from Technical
--- Corrigendum 1 (originally discussed as AI95-00002).
--- A package subunit whose parent is a preelaborated subprogram need
--- not be preelaborable.
---
--- TEST DESCRIPTION
--- We create several preelaborated library procedures with
--- non-preelaborable package body subunits. We try various levels
--- of nesting of package and procedure subunits.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
---
---!
-
-procedure CA21001_1(X: out Integer);
- pragma Preelaborate(CA21001_1);
-
-procedure CA21001_1(X: out Integer) is
- function F return Integer is separate;
-
- package Sub is
- function G(X: Integer) return Integer;
- -- Returns X + 1.
- Not_Preelaborable: Integer := F; -- OK, by AI-2.
- end Sub;
-
- package body Sub is separate;
-
-begin
- X := -1;
- X := F;
- X := Sub.G(X);
-end CA21001_1;
-
-separate(CA21001_1)
-package body Sub is
- package Sub_Sub is
- -- Empty.
- end Sub_Sub;
- package body Sub_Sub is separate;
-
- function G(X: Integer) return Integer is separate;
-begin
- Not_Preelaborable := G(F); -- OK, by AI-2.
- if Not_Preelaborable /= 101 then
- raise Program_Error; -- Can't call Report.Failed, here,
- -- because Report is not preelaborated.
- end if;
-end Sub;
-
-separate(CA21001_1.Sub)
-package body Sub_Sub is
-begin
- X := X; -- OK by AI-2.
-end Sub_Sub;
-
-separate(CA21001_1.Sub)
-function G(X: Integer) return Integer is
-
- package G_Sub is
- function H(X: Integer) return Integer;
- -- Returns X + 1.
- Not_Preelaborable: Integer := F; -- OK, by AI-2.
- end G_Sub;
- package body G_Sub is separate;
-
-begin
- return G_Sub.H(X);
-end G;
-
-separate(CA21001_1.Sub.G)
-package body G_Sub is
- function H(X: Integer) return Integer is separate;
-begin
- Not_Preelaborable := H(F); -- OK, by AI-2.
- if Not_Preelaborable /= 101 then
- raise Program_Error; -- Can't call Report.Failed, here,
- -- because Report is not preelaborated.
- end if;
-end G_Sub;
-
-separate(CA21001_1.Sub.G.G_Sub)
-function H(X: Integer) return Integer is
-begin
- return X + 1;
-end H;
-
-separate(CA21001_1)
-function F return Integer is
-
- package F_Sub is
- -- Empty.
- end F_Sub;
-
- package body F_Sub is separate;
-begin
- return 100;
-end F;
-
-separate(CA21001_1.F)
-package body F_Sub is
- True_Var: Boolean;
-begin
- True_Var := True;
- if True_Var then -- OK by AI-2.
- X := X;
- else
- X := X + 2;
- end if;
-end F_Sub;
-
-with Report; use Report;
-with CA21001_1;
-procedure CA21001 is
- X: Integer := 0;
-begin
- Test("CA21001",
- "Test that a package subunit whose parent is a preelaborated"
- & " subprogram need not be preelaborable");
- CA21001_1(X);
- if X /= 101 then
- Failed("Bad value for X");
- end if;
- Result;
-end CA21001;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada
deleted file mode 100644
index fdbc141..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- CA3011A0.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.
---*
--- A GENERIC UNIT.
--- SUBUNITS ARE IN CA3011A1, CA3011A2, AND CA3011A3.
--- INSTANTIATION IS IN CA3011A4M.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- RJW 09/22/86 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-WITH REPORT; USE REPORT;
-
-GENERIC
- TYPE T IS (<>);
- X : T;
-PROCEDURE CA3011A0 (Z : OUT T);
-
-PROCEDURE CA3011A0 (Z : OUT T) IS
- T1 : T;
-
- FUNCTION CA3011A1 RETURN T IS SEPARATE;
-
- PROCEDURE CA3011A2 (Y : OUT T) IS SEPARATE;
-
- PACKAGE CA3011A3 IS
- FUNCTION CA3011A3F RETURN T;
- END CA3011A3;
-
- PACKAGE BODY CA3011A3 IS SEPARATE;
-
-BEGIN
- IF CA3011A1 /= X THEN
- FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A1" );
- END IF;
-
- CA3011A2 (T1);
-
- IF T1 /= X THEN
- FAILED ( "INCORRECT VALUE RETURNED BY PROCEDURE CA3011A2 " );
- END IF;
-
- IF CA3011A3.CA3011A3F /= X THEN
- FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A3F " );
- END IF;
-
- Z := X;
-
-END CA3011A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada
deleted file mode 100644
index 5c53cf3..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada
+++ /dev/null
@@ -1,42 +0,0 @@
--- CA3011A1.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.
---*
--- A SUBUNIT OF A GENERIC UNIT.
--- THE GENERIC UNIT IS IN CA3011A0.
--- INSTANTIATION IS IN CA0011A4M.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- RJW 09/22/86 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA3011A0)
-FUNCTION CA3011A1 RETURN T IS
-
-BEGIN
- RETURN X;
-END CA3011A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada
deleted file mode 100644
index 87aacfa..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada
+++ /dev/null
@@ -1,42 +0,0 @@
--- CA3011A2.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.
---*
--- A SUBUNIT OF A GENERIC UNIT.
--- THE GENERIC UNIT IS IN CA3011A0.
--- INSTANTIATION IS IN CA3011A4M.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- RJW 09/22/86 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA3011A0)
-PROCEDURE CA3011A2 (Y : OUT T) IS
-
-BEGIN
- Y := X;
-END CA3011A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada
deleted file mode 100644
index eb582b8..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada
+++ /dev/null
@@ -1,43 +0,0 @@
--- CA3011A3.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.
---*
--- A SUBUNIT OF A GENERIC UNIT.
--- THE GENERIC UNIT IS IN CA3011A0.
--- INSTANTIATION IS IN CA3011A4M.
-
--- APPLICABILITY CRITERIA:
--- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
-
--- HISTORY:
--- RJW 09/22/86 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-
-SEPARATE (CA3011A0)
-PACKAGE BODY CA3011A3 IS
- FUNCTION CA3011A3F RETURN T IS
- BEGIN
- RETURN X;
- END;
-END CA3011A3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada
deleted file mode 100644
index 70cad21..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- CA3011A4M.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 IMPLEMENTATION DOES NOT REQUIRE GENERIC UNIT BODIES AND
--- SUBUNITS TO BE COMPILED TOGETHER IN THE SAME FILE.
-
--- SEPARATE FILES ARE:
--- CA3011A0 - A GENERIC UNIT.
--- CA3011A1, CA3011A2, CA3011A3 - SUBUNITS OF GENERIC UNIT.
--- CA3011A4M - THE MAIN PROCEDURE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
--- THIS WAS NOT REQUIRED FOR ADA 83.
-
--- HISTORY:
--- RJW 09/22/86 CREATED ORIGINAL TEST.
--- BCB 01/05/88 MODIFIED HEADER.
--- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
--- RLB 09/15/99 REPAIRED OBJECTIVE FOR ADA 95.
-
-WITH REPORT; USE REPORT;
-WITH CA3011A0;
-PROCEDURE CA3011A4M IS
- I : INTEGER;
- PROCEDURE P IS NEW CA3011A0 (INTEGER, 22);
-
-BEGIN
- TEST ( "CA3011A", "CHECK THAT AN IMPLEMENTATION DOES NOT REQUIRE " &
- "GENERIC UNIT BODIES AND SUBUNITS TO BE " &
- "COMPILED TOGETHER IN THE SAME FILE" );
-
- P (I);
- IF I /= 22 THEN
- FAILED ( "INCORRECT INSTANTIATION" );
- END IF;
-
- RESULT;
-END CA3011A4M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada
deleted file mode 100644
index 302314b..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada
+++ /dev/null
@@ -1,50 +0,0 @@
--- CA5003A0.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-PACKAGE CA5003A0 IS
-
- ORDER : STRING (1..5) := " ";
-
- INDEX : NATURAL := 1;
-
- FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER;
-
-END CA5003A0;
-
-
-WITH REPORT;
-USE REPORT;
-PACKAGE BODY CA5003A0 IS
-
- FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS
- BEGIN
- ORDER (INDEX) := UNIT;
- INDEX := INDEX + 1;
- RETURN INDEX - 1;
- END SHOW_ELAB;
-
-END CA5003A0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada
deleted file mode 100644
index 7f9f3b2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA5003A1.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH CA5003A0;
-USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
-PACKAGE CA5003A1 IS
-
- A1 : INTEGER := SHOW_ELAB ('1');
-
-END CA5003A1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada
deleted file mode 100644
index 9d36ab2..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA5003A2.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH CA5003A0;
-USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
-PACKAGE CA5003A2 IS
-
- A2 : INTEGER := SHOW_ELAB ('2');
-
-END CA5003A2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada
deleted file mode 100644
index 9614567..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA5003A3.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH CA5003A0, CA5003A2;
-USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
-PACKAGE CA5003A3 IS
-
- A3 : INTEGER := SHOW_ELAB ('3');
-
-END CA5003A3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada
deleted file mode 100644
index 908b39e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA5003A4.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH CA5003A0, CA5003A2;
-USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
-PACKAGE CA5003A4 IS
-
- A4 : INTEGER := SHOW_ELAB ('4');
-
-END CA5003A4;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada
deleted file mode 100644
index a8e07fe..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada
+++ /dev/null
@@ -1,34 +0,0 @@
--- CA5003A5.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH CA5003A0, CA5003A3, CA5003A4;
-USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
-PACKAGE CA5003A5 IS
-
- A5 : INTEGER := SHOW_ELAB ('5');
-
-END CA5003A5;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada
deleted file mode 100644
index df12c4e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CA5003A6M.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 ELABORATION OF LIBRARY UNITS REQUIRED BY
--- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL
--- ORDERING DEFINED BY THE COMPILATION ORDER RULES.
-
--- SEPARATE FILES ARE:
--- CA5003A0 A LIBRARY PACKAGE.
--- CA5003A1 A LIBRARY PACKAGE SPECIFICATION.
--- CA5003A2 A LIBRARY PACKAGE SPECIFICATION.
--- CA5003A3 A LIBRARY PACKAGE SPECIFICATION.
--- CA5003A4 A LIBRARY PACKAGE SPECIFICATION.
--- CA5003A5 A LIBRARY PACKAGE SPECIFICATION.
--- CA5003A6M THE MAIN PROCEDURE.
-
--- PACKAGE A5 MUST BE ELABORATED AFTER A2, A3, AND A4.
--- PACKAGE A3 MUST BE ELABORATED AFTER A2.
--- PACKAGE A4 MUST BE ELABORATED AFTER A2.
-
--- WKB 7/22/81
--- JBG 10/6/83
-
-WITH REPORT, CA5003A0;
-USE REPORT, CA5003A0;
-WITH CA5003A1, CA5003A5;
-PROCEDURE CA5003A6M IS
-
-BEGIN
-
- TEST ("CA5003A", "CHECK THAT ELABORATION ORDER IS CONSISTENT " &
- "WITH PARTIAL ORDERING REQUIREMENTS");
-
- COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER);
-
- IF ORDER /= "12345" AND
- ORDER /= "12435" AND
- ORDER /= "21345" AND
- ORDER /= "21435" AND
- ORDER /= "23145" AND
- ORDER /= "24135" AND
- ORDER /= "23415" AND
- ORDER /= "24315" AND
- ORDER /= "23451" AND
- ORDER /= "24351" THEN
- FAILED ("ILLEGAL ELABORATION ORDER");
- END IF;
-
- RESULT;
-END CA5003A6M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada
deleted file mode 100644
index 9851ca3..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada
+++ /dev/null
@@ -1,51 +0,0 @@
--- CA5003B0.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
--- BHS 8/02/84
--- JRK 9/20/84
-
-
-PACKAGE CA5003B0 IS
-
- ORDER : STRING (1..4) := " ";
-
- INDEX : NATURAL := 1;
-
- FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER;
-
-END CA5003B0;
-
-
-PACKAGE BODY CA5003B0 IS
-
- FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS
- BEGIN
- ORDER (INDEX) := UNIT;
- INDEX := INDEX + 1;
- RETURN INDEX - 1;
- END SHOW_ELAB;
-
-END CA5003B0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada
deleted file mode 100644
index ba70ecc..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada
+++ /dev/null
@@ -1,46 +0,0 @@
--- CA5003B1.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
--- BHS 8/02/84
--- JRK 9/20/84
-
-
-WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
-PACKAGE CA5003B1 IS
-
- PACKAGE CA5003B2 IS
- PROCEDURE P1;
- END CA5003B2;
-
-END CA5003B1;
-
-
-PACKAGE BODY CA5003B1 IS
-
- A1 : INTEGER := SHOW_ELAB ('1');
- PACKAGE BODY CA5003B2 IS SEPARATE;
-
-END CA5003B1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada
deleted file mode 100644
index a524a00..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada
+++ /dev/null
@@ -1,45 +0,0 @@
--- CA5003B2.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.
---*
--- BHS 8/02/84
--- JRK 9/20/84
-
-WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
-SEPARATE (CA5003B1)
-PACKAGE BODY CA5003B2 IS
-
- A2 : INTEGER := SHOW_ELAB ('2');
-
- PROCEDURE P1 IS
- BEGIN
- NULL;
- END P1;
-
- PACKAGE CA5003B4 IS
- PROCEDURE P2;
- END CA5003B4;
-
- PACKAGE BODY CA5003B4 IS SEPARATE;
-
-END CA5003B2;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada
deleted file mode 100644
index 8706a06..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada
+++ /dev/null
@@ -1,35 +0,0 @@
--- CA5003B3.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.
---*
--- WKB 7/22/81
--- JBG 10/6/83
--- BHS 8/02/84
--- JRK 9/20/84
-
-WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
-PACKAGE CA5003B3 IS
-
- A3 : INTEGER := SHOW_ELAB ('3');
-
-END CA5003B3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada
deleted file mode 100644
index d3c2f7e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada
+++ /dev/null
@@ -1,40 +0,0 @@
--- CA5003B4.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.
---*
--- BHS 8/02/84
--- JRK 9/20/84
-
-WITH CA5003B3; -- MUST BE ELABORATED BEFORE CA5003B1.
-WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
-SEPARATE (CA5003B1.CA5003B2)
-PACKAGE BODY CA5003B4 IS
-
- A4 : INTEGER := SHOW_ELAB ('4');
-
- PROCEDURE P2 IS
- BEGIN
- NULL;
- END P2;
-
-END CA5003B4;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada b/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada
deleted file mode 100644
index 4beb61e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- CA5003B5M.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 ELABORATION OF LIBRARY UNITS REQUIRED BY
--- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL
--- ORDERING DEFINED BY THE COMPILATION ORDER RULES.
--- IN PARTICULAR, CHECK THAT A LIBRARY UNIT MENTIONED IN THE
--- WITH_CLAUSE OF A SUBUNIT IS ELABORATED PRIOR TO THE BODY OF
--- THE ANCESTOR UNIT.
-
--- SEPARATE FILES ARE:
--- CA5003B0 A LIBRARY PACKAGE.
--- CA5003B1 A LIBRARY PACKAGE.
--- CA5003B2 A SUBUNIT PACKAGE BODY (_B1._B2).
--- CA5003B3 A LIBRARY PACKAGE DECLARATION.
--- CA5003B4 A SUBUNIT PACKAGE BODY (_B1._B2._B4).
--- CA5003B5M THE MAIN PROCEDURE.
-
--- LIBRARY PACKAGES MUST BE ELABORATED IN ORDER: _B0, _B3, _B1.
--- PARENT UNITS MUST BE ELABORATED BEFORE THEIR SUBUNITS.
-
--- WKB 7/22/81
--- JBG 10/6/83
--- BHS 8/02/84
--- JRK 9/20/84
-
-WITH REPORT, CA5003B0;
-USE REPORT, CA5003B0;
-WITH CA5003B1;
-PROCEDURE CA5003B5M IS
-
-BEGIN
- TEST ("CA5003B", "CHECK THAT UNITS IN WITH_CLAUSES OF " &
- "SUBUNITS ARE ELABORATED PRIOR TO THE " &
- "BODY OF THE ANCESTOR UNIT");
-
- COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER);
-
- IF ORDER /= "3124" THEN
- FAILED ("ILLEGAL ELABORATION ORDER");
- END IF;
-
- RESULT;
-END CA5003B5M;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada
deleted file mode 100644
index 34a735e..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- CA5004A.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 PRAGMA ELABORATE IS APPLIED TO A PACKAGE THAT DECLARES
--- A TASK OBJECT, THE IMPLICIT PACKAGE BODY IS ELABORATED AND THE TASK
--- IS ACTIVATED.
-
--- BHS 8/03/84
--- JRK 9/20/84
--- PWN 01/31/95 ADDED A PROCEDURE TO REQUIRE A BODY FOR ADA 9X.
-
-
-PACKAGE CA5004A0 IS
-
- TASK TYPE TSK IS
- ENTRY E (VAR : OUT INTEGER);
- END TSK;
-
-END CA5004A0;
-
-
-PACKAGE BODY CA5004A0 IS
-
- TASK BODY TSK IS
- BEGIN
- ACCEPT E (VAR : OUT INTEGER) DO
- VAR := 4;
- END E;
- END TSK;
-
-END CA5004A0;
-
-
-WITH CA5004A0; USE CA5004A0; PRAGMA ELABORATE (CA5004A0);
-PACKAGE CA5004A1 IS
-
- T : TSK;
-
-END CA5004A1;
-
-
-PACKAGE CA5004A2 IS
- PROCEDURE REQUIRE_BODY;
-END CA5004A2;
-
-
-WITH REPORT; USE REPORT;
-WITH CA5004A1; USE CA5004A1;
-PRAGMA ELABORATE (CA5004A1, REPORT);
-PACKAGE BODY CA5004A2 IS
-
- I : INTEGER := 1;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
-
- TEST ("CA5004A", "APPLYING PRAGMA ELABORATE TO A PACKAGE " &
- "DECLARING A TASK OBJECT CAUSES IMPLICIT " &
- "BODY ELABORATION AND TASK ACTIVATION");
-
- SELECT
- T.E(I);
- IF I /= 4 THEN
- FAILED ("TASK NOT EXECUTED PROPERLY");
- END IF;
- OR
- DELAY 10.0;
- FAILED ("TASK NOT ACTIVATED AFTER 10 SECONDS");
- END SELECT;
-
-END CA5004A2;
-
-
-WITH CA5004A2;
-WITH REPORT; USE REPORT;
-PROCEDURE CA5004A IS
-BEGIN
-
- RESULT;
-
-END CA5004A;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada
deleted file mode 100644
index bb79470..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- CA5004B0.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: See CA5004B2M.ADA
---
--- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA
---
--- TEST FILES:
--- => CA5004B0.ADA
--- CA5004B1.ADA
--- CA5004B2M.ADA
-
--- PWN 05/31/96 Split test into files without duplicate unit names.
--- RLB 03/11/99 Split test into files so that units that will be replaced
--- and units that won't are not in the same source file.
-
--------------------------------------------------------------
-
-PACKAGE HEADER IS
-
- PROCEDURE WRONG (WHY : STRING);
-
-END HEADER;
-
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY HEADER IS
-
- PROCEDURE WRONG (WHY : STRING) IS
- BEGIN
- FAILED ("PACKAGE WITH " & WHY & " NOT ELABORATED " &
- "CORRECTLY");
- END WRONG;
-
-BEGIN
-
- TEST ("CA5004B", "PRAGMA ELABORATE IS ACCEPTED AND OBEYED " &
- "EVEN WHEN THE BODY OF THE UNIT NAMED IS " &
- "MISSING OR OBSOLETE");
-
-END HEADER;
-
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada
deleted file mode 100644
index 068ae88..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada
+++ /dev/null
@@ -1,56 +0,0 @@
--- CA5004B1.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: See CA5004B2M.ADA
---
--- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA
---
--- TEST FILES:
--- CA5004B0.ADA
--- => CA5004B1.ADA
--- CA5004B2M.ADA
-
--- PWN 05/31/96 Split test into files without duplicate unit names.
--- RLB 03/11/99 Split test into files so that units that will be replaced
--- and units that won't are not in the same source file.
-
-------------------------------------------------------------------
-
-PACKAGE CA5004B0 IS
-
- I : INTEGER := 1;
-
- FUNCTION F RETURN BOOLEAN;
-
-END CA5004B0;
-
-
-PACKAGE BODY CA5004B0 IS
-
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END F;
-
-END CA5004B0;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada b/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada
deleted file mode 100644
index bae6280..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- CA5004B2M.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 PRAGMA ELABORATE IS ACCEPTED AND OBEYED EVEN IF THE UNIT
--- NAMED IN THE PRAGMA DOES NOT YET HAVE A BODY IN THE LIBRARY OR IF
--- ITS BODY IS OBSOLETE.
--- CHECK THAT MORE THAN ONE NAME IS ALLOWED IN A PRAGMA ELABORATE.
---
--- SPECIAL INSTRUCTIONS:
--- 1. Compile CA5004B0.ADA
--- 2. Compile CA5004B1.ADA
--- 3. Compile CA5004B2M.ADA
--- 4. Bind/Link main unit CA5004B2M
--- 5. Execute the resulting file
---
--- TEST FILES:
--- CA5004B0.ADA
--- CA5004B1.ADA
--- => CA5004B2M.ADA
-
--- BHS 8/03/84
--- JRK 9/20/84
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
--- PWN 05/31/96 Split test into files without duplicate unit names.
--- TMB 11/20/96 ADDED PROCEDURE DECL TO CA5004B0 TO INSURE IT MAKES
--- THE OLD BODY OBSOLETE
--- TMB 12/2/96 MADE NAME OF MAIN PROCEDURE SAME AS FILE NAME
--- RLB 03/11/99 Split first test file in order to prevent good units
--- from being made obsolete.
-
--------------------------------------------------------------
-
-PACKAGE CA5004B0 IS -- OLD BODY NOW OBSOLETE.
-
- I : INTEGER := 2;
- B : BOOLEAN := TRUE;
-
- FUNCTION F RETURN BOOLEAN;
- PROCEDURE P;
-
-END CA5004B0;
-
----------------------------------------------------------
-
-PACKAGE CA5004B1 IS
-
- J : INTEGER := 3;
-
- PROCEDURE P (X : INTEGER);
-
-END CA5004B1; -- NO BODY GIVEN YET.
-
-----------------------------------------------------------
-
-WITH HEADER; USE HEADER;
-WITH CA5004B0, CA5004B1;
-USE CA5004B0, CA5004B1;
-PRAGMA ELABORATE (HEADER, CA5004B0, CA5004B1);
-PACKAGE CA5004B2 IS
-
- K1 : INTEGER := CA5004B0.I;
- K2 : INTEGER := CA5004B1.J;
-
- PROCEDURE REQUIRE_BODY;
-
-END CA5004B2;
-
-
-PACKAGE BODY CA5004B2 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
-BEGIN
-
- IF K1 /= 4 THEN
- WRONG ("OBSOLETE BODY");
- END IF;
-
- IF K2 /= 5 THEN
- WRONG ("NO BODY");
- END IF;
-
-END CA5004B2;
-
---------------------------------------------------
-
-WITH REPORT, CA5004B2;
-USE REPORT, CA5004B2;
-PROCEDURE CA5004B2M IS
-BEGIN
-
- RESULT;
-
-END CA5004B2M;
-
-----------------------------------------------------
-
-PACKAGE BODY CA5004B0 IS
-
- FUNCTION F RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END F;
-
- PROCEDURE P IS
- BEGIN
- RETURN;
- END P;
-
-BEGIN
-
- I := 4;
-
-END CA5004B0;
-
----------------------------------------------------
-
-PACKAGE BODY CA5004B1 IS
-
- PROCEDURE P (X : INTEGER) IS
- BEGIN
- NULL;
- END P;
-
-BEGIN
-
- J := 5;
-
-END CA5004B1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada b/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada
deleted file mode 100644
index cc4d3c9..0000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- CA5006A.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 PROGRAM IS NOT REJECTED JUST BECAUSE THERE IS NO WAY TO
--- ELABORATE SECONDARY UNITS SO PROGRAM_ERROR WILL BE AVOIDED.
-
--- R.WILLIAMS 9/22/86
-
------------------------------------------------------------------------
-
-PACKAGE CA5006A0 IS
- FUNCTION P_E_RAISED RETURN BOOLEAN;
- PROCEDURE SHOW_PE_RAISED;
-END CA5006A0;
-
------------------------------------------------------------------------
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CA5006A0 IS
- RAISED : BOOLEAN := FALSE;
-
- FUNCTION P_E_RAISED RETURN BOOLEAN IS
- BEGIN
- RETURN RAISED;
- END P_E_RAISED;
-
- PROCEDURE SHOW_PE_RAISED IS
- BEGIN
- RAISED := TRUE;
- END SHOW_PE_RAISED;
-
-BEGIN
- TEST ( "CA5006A", "CHECK THAT A PROGRAM IS NOT REJECTED JUST " &
- "BECAUSE THERE IS NO WAY TO ELABORATE " &
- "SECONDARY UNITS SO PROGRAM_ERROR WILL BE " &
- "AVOIDED" );
-
-
-END CA5006A0;
-
------------------------------------------------------------------------
-
-PACKAGE CA5006A1 IS
- FUNCTION F RETURN INTEGER;
-END CA5006A1;
-
------------------------------------------------------------------------
-
-PACKAGE CA5006A2 IS
- FUNCTION G RETURN INTEGER;
-END CA5006A2;
-
------------------------------------------------------------------------
-
-WITH REPORT; USE REPORT;
-WITH CA5006A0; USE CA5006A0;
-WITH CA5006A2; USE CA5006A2;
-PRAGMA ELABORATE(CA5006A0);
-
-PACKAGE BODY CA5006A1 IS
- X : INTEGER;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(0);
- END F;
-
-BEGIN
- X := G;
- IF NOT P_E_RAISED THEN
- FAILED ( "G CALLED" );
- END IF;
-EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A1" );
- SHOW_PE_RAISED;
- WHEN OTHERS =>
- FAILED ( "OTHER ERROR RAISED IN CA5006A1" );
-END CA5006A1;
-
------------------------------------------------------------------------
-
-WITH REPORT; USE REPORT;
-WITH CA5006A0; USE CA5006A0;
-WITH CA5006A1; USE CA5006A1;
-PRAGMA ELABORATE(CA5006A0);
-
-PACKAGE BODY CA5006A2 IS
- X : INTEGER;
-
- FUNCTION G RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END G;
-
-BEGIN
- X := F;
- IF NOT P_E_RAISED THEN
- FAILED ( "F CALLED" );
- END IF;
-EXCEPTION
- WHEN PROGRAM_ERROR =>
- COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A2" );
- SHOW_PE_RAISED;
- WHEN OTHERS =>
- FAILED ( "OTHER ERROR RAISED IN CA5006A2" );
-END CA5006A2;
-
------------------------------------------------------------------------
-
-WITH REPORT; USE REPORT;
-WITH CA5006A0; USE CA5006A0;
-WITH CA5006A1;
-WITH CA5006A2;
-
-PROCEDURE CA5006A IS
-BEGIN
- IF NOT P_E_RAISED THEN
- FAILED ( "PROGRAM_ERROR NEVER RAISED" );
- END IF;
-
- RESULT;
-END CA5006A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb10002.a b/gcc/testsuite/ada/acats/tests/cb/cb10002.a
deleted file mode 100644
index f3099d4..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb10002.a
+++ /dev/null
@@ -1,128 +0,0 @@
--- CB10002.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 Storage_Error is raised when storage for allocated objects
--- is exceeded.
---
--- TEST DESCRIPTION:
--- This test allocates a very large data structure.
---
--- In order to avoid running forever on virtual memory targets, the
--- data structure is bounded in size, and elements are larger the longer
--- the program runs.
---
--- The program attempts to allocate about 8,600,000 integers, or about
--- 32 Megabytes on a typical 32-bit machine.
---
--- If Storage_Error is raised, the data structure is deallocated.
--- (Otherwise, Report.Result may fail as memory is exhausted).
-
--- CHANGE HISTORY:
--- 30 Aug 85 JRK Ada 83 test created.
--- 14 Sep 99 RLB Created Ada 95 test.
-
-
-with Report;
-with Ada.Unchecked_Deallocation;
-procedure CB10002 is
-
- type Data_Space is array (Positive range <>) of Integer;
-
- type Element (Size : Positive);
-
- type Link is access Element;
-
- type Element (Size : Positive) is
- record
- Parent : Link;
- Child : Link;
- Sibling: Link;
- Data : Data_Space (1 .. Size);
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Element, Link);
-
- Holder : array (1 .. 430) of Link;
- Last_Allocated : Natural := 0;
-
- procedure Allocator (Count : in Positive) is
- begin
- -- Allocate various sized objects similar to what a real application
- -- would do.
- if Count in 1 .. 20 then
- Holder(Count) := new Element (Report.Ident_Int(10));
- elsif Count in 21 .. 40 then
- Holder(Count) := new Element (Report.Ident_Int(79));
- elsif Count in 41 .. 60 then
- Holder(Count) := new Element (Report.Ident_Int(250));
- elsif Count in 61 .. 80 then
- Holder(Count) := new Element (Report.Ident_Int(520));
- elsif Count in 81 .. 100 then
- Holder(Count) := new Element (Report.Ident_Int(1000));
- elsif Count in 101 .. 120 then
- Holder(Count) := new Element (Report.Ident_Int(2048));
- elsif Count in 121 .. 140 then
- Holder(Count) := new Element (Report.Ident_Int(4200));
- elsif Count in 141 .. 160 then
- Holder(Count) := new Element (Report.Ident_Int(7999));
- elsif Count in 161 .. 180 then
- Holder(Count) := new Element (Report.Ident_Int(15000));
- else -- 181..430
- Holder(Count) := new Element (Report.Ident_Int(32000));
- end if;
- Last_Allocated := Count;
- end Allocator;
-
-
-begin
- Report.Test ("CB10002", "Check that Storage_Error is raised when " &
- "storage for allocated objects is exceeded");
-
- begin
- for I in Holder'range loop
- Allocator (I);
- end loop;
- Report.Not_Applicable ("Unable to exhaust memory");
- for I in 1 .. Last_Allocated loop
- Free (Holder(I));
- end loop;
- exception
- when Storage_Error =>
- if Last_Allocated = 0 then
- Report.Failed ("Unable to allocate anything");
- else -- Clean up, so we have enough memory to report on the result.
- for I in 1 .. Last_Allocated loop
- Free (Holder(I));
- end loop;
- Report.Comment (Natural'Image(Last_Allocated) & " items allocated");
- end if;
- when others =>
- Report.Failed ("Wrong exception raised by heap overflow");
- end;
-
- Report.Result;
-
-end CB10002;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada b/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada
deleted file mode 100644
index 5cd5391..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- CB1001A.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 PREDEFINED EXCEPTIONS MAY BE RAISED EXPLICITLY
--- AND MAY HAVE HANDLERS WRITTEN FOR THEM.
-
--- *** 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
-
--- DCB 03/25/80
--- JRK 11/17/80
--- SPS 11/2/82
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE CB1001A IS
-
- USE REPORT;
-
- FLOW_COUNT : INTEGER := 0;
-
-BEGIN
- TEST("CB1001A", "CHECK THAT ALL PREDEFINED EXCEPTIONS MAY BE " &
- "RAISED EXPLICITLY AND MAY HAVE HANDLERS WRITTEN FOR THEM");
-
- BEGIN
- RAISE CONSTRAINT_ERROR;
- FAILED("NO EXCEPTION RAISED WHEN CONSTRAINT_ERROR EXPECTED");
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED WHEN CONSTRAINT_ERROR " &
- "EXPECTED");
- END;
-
-
- BEGIN
- RAISE PROGRAM_ERROR;
- FAILED("NO EXCEPTION RAISED WHEN PROGRAM_ERROR EXPECTED");
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED WHEN PROGRAM_ERROR " &
- "EXPECTED");
- END;
-
- BEGIN
- RAISE STORAGE_ERROR;
- FAILED("NO EXCEPTION RAISED WHEN STORAGE_ERROR EXPECTED");
-
- EXCEPTION
- WHEN STORAGE_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED WHEN STORAGE_ERROR " &
- "EXPECTED");
- END;
-
- BEGIN
- RAISE TASKING_ERROR;
- FAILED("NO EXCEPTION RAISED WHEN TASKING_ERROR EXPECTED");
-
- EXCEPTION
- WHEN TASKING_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED WHEN TASKING_ERROR " &
- "EXPECTED");
- END;
-
- IF FLOW_COUNT /= 4 THEN
- FAILED("WRONG FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END CB1001A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada b/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada
deleted file mode 100644
index d137d0e..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CB1004A.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 EXCEPTIONS DECLARED IN RECURSIVE PROCEDURES ARE NOT
--- REPLICATED ANEW FOR EACH RECURSIVE ACTIVATION OF THE PROCEDURE.
-
--- DCB 03/30/80
--- JRK 11/17/80
--- SPS 3/23/83
-
-WITH REPORT;
-PROCEDURE CB1004A IS
-
- USE REPORT;
-
- FLOW_COUNT : INTEGER := 0;
-
- PROCEDURE P1(SWITCH1 : IN INTEGER) IS
-
- E1 : EXCEPTION;
-
- PROCEDURE P2 IS
-
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1; -- 3
- P1(2);
- FAILED("EXCEPTION NOT PROPAGATED");
-
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1; -- 6
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED");
- END P2;
-
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1; -- 2 -- 4
- IF SWITCH1 = 1 THEN
- P2;
- ELSIF SWITCH1 = 2 THEN
- FLOW_COUNT := FLOW_COUNT + 1; -- 5
- RAISE E1;
- FAILED("EXCEPTION NOT RAISED");
- END IF;
- END P1;
-
-BEGIN
- TEST("CB1004A","CHECK THAT EXCEPTIONS ARE NOT RECURSIVELY " &
- "REPLICATED");
-
- FLOW_COUNT := FLOW_COUNT + 1; -- 1
- P1(1);
-
- IF FLOW_COUNT /= 6 THEN
- FAILED("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION HANDLED IN WRONG SCOPE");
- RESULT;
-END CB1004A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada b/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada
deleted file mode 100644
index 94e5383..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CB1005A.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 EXCEPTIONS DECLARED IN GENERIC PACKAGES AND PROCEDURES ARE
--- CONSIDERED DISTINCT FOR EACH INSTANTIATION.
-
--- CHECK THAT AN EXCEPTION NAME DECLARED IN A GENERIC PACKAGE
--- INSTANTIATION IN A RECURSIVE PROCEDURE DENOTES THE SAME ENTITY
--- EVEN WHEN THE INSTANTIATION IS ELABORATED MORE THAN ONCE BECAUSE
--- OF RECURSIVE CALLS.
-
--- *** 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
-
--- TBN 9/23/86
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-PROCEDURE CB1005A IS
-
- PROCEDURE PROP;
-
- GENERIC
- PACKAGE PAC IS
- EXC : EXCEPTION;
- END PAC;
-
- GENERIC
- PROCEDURE PROC (INST_AGAIN : BOOLEAN);
-
- PROCEDURE PROC (INST_AGAIN : BOOLEAN) IS
- EXC : EXCEPTION;
- BEGIN
- IF INST_AGAIN THEN
- BEGIN
- PROP;
- FAILED ("EXCEPTION WAS NOT PROPAGATED - 9");
- EXCEPTION
- WHEN EXC =>
- FAILED ("EXCEPTION NOT DISTINCT - 10");
- WHEN PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR | CONSTRAINT_ERROR =>
- FAILED ("WRONG EXCEPTION PROPAGATED - 11");
- WHEN OTHERS =>
- NULL;
- END;
- ELSE
- RAISE EXC;
- END IF;
- END PROC;
-
- PROCEDURE RAISE_EXC (CALL_AGAIN : BOOLEAN) IS
- PACKAGE PAC3 IS NEW PAC;
- BEGIN
- IF CALL_AGAIN THEN
- BEGIN
- RAISE_EXC (FALSE);
- FAILED ("EXCEPTION WAS NOT PROPAGATED - 12");
- EXCEPTION
- WHEN PAC3.EXC =>
- NULL;
- END;
- ELSE
- RAISE PAC3.EXC;
- END IF;
- END RAISE_EXC;
-
- PROCEDURE PROP IS
- PROCEDURE PROC2 IS NEW PROC;
- BEGIN
- PROC2 (FALSE);
- END PROP;
-
-BEGIN
- TEST ("CB1005A", "CHECK THAT EXCEPTIONS DECLARED IN GENERIC " &
- "PACKAGES AND PROCEDURES ARE CONSIDERED " &
- "DISTINCT FOR EACH INSTANTIATION");
-
- -------------------------------------------------------------------
- DECLARE
- PACKAGE PAC1 IS NEW PAC;
- PACKAGE PAC2 IS NEW PAC;
- PAC1_EXC_FOUND : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- IF EQUAL (3, 3) THEN
- RAISE PAC2.EXC;
- END IF;
- FAILED ("EXCEPTION WAS NOT RAISED - 1");
-
- EXCEPTION
- WHEN PAC1.EXC =>
- FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 2");
- PAC1_EXC_FOUND := TRUE;
- END;
- IF NOT PAC1_EXC_FOUND THEN
- FAILED ("EXCEPTION WAS NOT PROPAGATED - 3");
- END IF;
-
- EXCEPTION
- WHEN PAC1.EXC =>
- FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 4");
- WHEN PAC2.EXC =>
- BEGIN
- IF EQUAL (3, 3) THEN
- RAISE PAC1.EXC;
- END IF;
- FAILED ("EXCEPTION WAS NOT RAISED - 5");
-
- EXCEPTION
- WHEN PAC2.EXC =>
- FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 6");
- WHEN PAC1.EXC =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED - 7");
- END;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED - 8");
- END;
-
- -------------------------------------------------------------------
- DECLARE
- PROCEDURE PROC1 IS NEW PROC;
- BEGIN
- PROC1 (TRUE);
- END;
-
- -------------------------------------------------------------------
- BEGIN
- RAISE_EXC (TRUE);
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTIONS ARE DISTINCT FOR RECURSION - 13");
- END;
-
- -------------------------------------------------------------------
-
- RESULT;
-END CB1005A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada b/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada
deleted file mode 100644
index ac0a779..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada
+++ /dev/null
@@ -1,179 +0,0 @@
--- CB1010A.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 STORAGE_ERROR IS RAISED WHEN STORAGE ALLOCATED TO A TASK
--- IS EXCEEDED.
-
--- PNH 8/26/85
--- JRK 8/30/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB1010A IS
-
- N : INTEGER := IDENT_INT (1);
- M : INTEGER := IDENT_INT (0);
-
- PROCEDURE OVERFLOW_STACK IS
- A : ARRAY (1 .. 1000) OF INTEGER;
- BEGIN
- N := N + M;
- A (N) := M;
- IF N > M THEN -- ALWAYS TRUE.
- OVERFLOW_STACK;
- END IF;
- M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION.
- END OVERFLOW_STACK;
-
-BEGIN
- TEST ("CB1010A", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " &
- "STORAGE ALLOCATED TO A TASK IS EXCEEDED");
-
- --------------------------------------------------
-
- COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " &
- "PRIOR TO RENDEZVOUS");
-
- DECLARE
-
- TASK T1 IS
- ENTRY E1;
- END T1;
-
- TASK BODY T1 IS
- BEGIN
- OVERFLOW_STACK;
- FAILED ("TASK T1 NOT TERMINATED BY STACK OVERFLOW");
- END T1;
-
- BEGIN
-
- T1.E1;
- FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T1.E1");
-
- EXCEPTION
- WHEN TASKING_ERROR =>
- IF N /= 1 OR M /= 0 THEN
- FAILED ("VALUES OF VARIABLES N OR M ALTERED - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY CALL OF ENTRY E1 " &
- "OF TERMINATED TASK T1");
- END;
-
- --------------------------------------------------
-
- COMMENT ("CHECK TASKS THAT DO HANDLE STORAGE_ERROR PRIOR TO " &
- "RENDEZVOUS");
-
- N := IDENT_INT (1);
- M := IDENT_INT (0);
-
- DECLARE
-
- TASK T2 IS
- ENTRY E2;
- END T2;
-
- TASK BODY T2 IS
- BEGIN
- OVERFLOW_STACK;
- FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW IN " &
- "TASK T2");
- EXCEPTION
- WHEN STORAGE_ERROR =>
- ACCEPT E2;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED IN TASK T2 BY " &
- "STACK OVERFLOW");
- END T2;
-
- BEGIN
-
- T2.E2;
- IF N /= 1 OR M /= 0 THEN
- FAILED ("VALUES OF VARIABLES N OR M ALTERED - 2");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED BY ENTRY CALL T2.E2");
- ABORT T2;
- END;
-
- --------------------------------------------------
-
- COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " &
- "DURING RENDEZVOUS");
-
- N := IDENT_INT (1);
- M := IDENT_INT (0);
-
- DECLARE
-
- TASK T3 IS
- ENTRY E3A;
- ENTRY E3B;
- END T3;
-
- TASK BODY T3 IS
- BEGIN
- ACCEPT E3A DO
- OVERFLOW_STACK;
- FAILED ("EXCEPTION NOT RAISED IN ACCEPT E3A BY " &
- "STACK OVERFLOW");
- END E3A;
- FAILED ("EXCEPTION NOT PROPOGATED CORRECTLY IN TASK T3");
- EXCEPTION
- WHEN STORAGE_ERROR =>
- ACCEPT E3B;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED IN TASK T3 BY " &
- "STACK OVERFLOW");
- END T3;
-
- BEGIN
-
- T3.E3A;
- FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T3.E3A");
-
- EXCEPTION
- WHEN STORAGE_ERROR =>
- T3.E3B;
- IF N /= 1 OR M /= 0 THEN
- FAILED ("VALUES OF VARIABLES N OR M ALTERED - 3");
- END IF;
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED BY ENTRY CALL T3.E3A " &
- "INSTEAD OF STORAGE_ERROR");
- ABORT T3;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY ENTRY CALL T3.E3A");
- ABORT T3;
- END;
-
- --------------------------------------------------
-
- RESULT;
-END CB1010A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada b/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada
deleted file mode 100644
index bcd9504..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- CB1010C.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 STORAGE_ERROR IS RAISED WHEN STORAGE FOR A DECLARATIVE
--- ITEM IS INSUFFICIENT.
-
--- JRK 8/30/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB1010C IS
-
- N : INTEGER := IDENT_INT (1000);
- M : INTEGER := IDENT_INT (0);
-
- PROCEDURE OVERFLOW_STACK IS
- BEGIN
- N := N + M;
- DECLARE
- A : ARRAY (1 .. N) OF INTEGER;
- BEGIN
- A (N) := M;
- IF N > M THEN -- ALWAYS TRUE.
- OVERFLOW_STACK;
- END IF;
- M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION.
- END;
- END OVERFLOW_STACK;
-
-BEGIN
- TEST ("CB1010C", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " &
- "STORAGE FOR A DECLARATIVE ITEM IS INSUFFICIENT");
-
- BEGIN
-
- OVERFLOW_STACK;
- FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW");
-
- EXCEPTION
- WHEN STORAGE_ERROR =>
- IF N /= 1000 OR M /= 0 THEN
- FAILED ("VALUES OF VARIABLES N OR M WERE ALTERED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW");
- END;
-
- RESULT;
-END CB1010C;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada b/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada
deleted file mode 100644
index e58046c..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- CB1010D.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 STORAGE_ERROR IS RAISED WHEN STORAGE FOR THE EXECUTION OF
--- A SUBPROGRAM IS INSUFFICIENT.
-
--- PNH 8/26/85
--- JRK 8/30/85
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB1010D IS
-
- N : INTEGER := IDENT_INT (1);
- M : INTEGER := IDENT_INT (0);
-
- PROCEDURE OVERFLOW_STACK IS
- BEGIN
- N := N + M;
- IF N > M THEN -- ALWAYS TRUE.
- OVERFLOW_STACK;
- END IF;
- N := N - M; -- TO PREVENT TAIL RECURSION OPTIMIZATION.
- END OVERFLOW_STACK;
-
-BEGIN
- TEST ("CB1010D", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " &
- "STORAGE FOR THE EXECUTION OF A SUBPROGRAM " &
- "IS INSUFFICIENT");
-
- -- CHECK HANDLING OF STORAGE_ERROR IN MAIN PROGRAM.
-
- BEGIN
- OVERFLOW_STACK;
- FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 1");
- EXCEPTION
- WHEN STORAGE_ERROR =>
- IF N /= 1 THEN
- FAILED ("VALUE OF VARIABLE N ALTERED - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW - 1");
- END;
-
- -- CHECK HANDLING OF STORAGE_ERROR IN SUBPROGRAM.
-
- DECLARE
-
- PROCEDURE P IS
- BEGIN
- OVERFLOW_STACK;
- FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 2");
- EXCEPTION
- WHEN STORAGE_ERROR =>
- IF N /= 1 THEN
- FAILED ("VALUE OF VARIABLE N ALTERED - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED BY STACK " &
- "OVERFLOW - 2");
- END P;
-
- BEGIN
-
- N := IDENT_INT (1);
- P;
-
- END;
-
- RESULT;
-END CB1010D;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20001.a b/gcc/testsuite/ada/acats/tests/cb/cb20001.a
deleted file mode 100644
index ccfad52..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20001.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CB20001.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 exceptions can be handled in accept bodies, and that a
--- task object that has an exception handled in an accept body is still
--- viable for future use.
---
--- TEST DESCRIPTION:
--- Declare a task that has exception handlers within an accept
--- statement in the task body. Declare a task object, and make entry
--- calls with data that will cause various exceptions to be raised
--- by the accept statement. Ensure that the exceptions are:
--- 1) raised and handled locally in the accept body
--- 2) raised in the accept body and handled/reraised to be handled
--- by the task body
--- 3) raised in the accept body and propagated to the calling
--- procedure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-
-package CB20001_0 is
-
- Incorrect_Data,
- Location_Error,
- Off_Screen_Data : exception;
-
- TC_Handled_In_Accept,
- TC_Reraised_In_Accept,
- TC_Handled_In_Task_Block,
- TC_Handled_In_Caller : boolean := False;
-
- type Location_Type is range 0 .. 2000;
-
- task type Submarine_Type is
- entry Contact (Location : in Location_Type);
- end Submarine_Type;
-
- Current_Position : Location_Type := 0;
-
-end CB20001_0;
-
-
- --=================================================================--
-
-
-package body CB20001_0 is
-
-
- task body Submarine_Type is
- begin
- loop
-
- Task_Block:
- begin
- select
- accept Contact (Location : in Location_Type) do
- if Location > 1000 then
- raise Off_Screen_Data;
- elsif (Location > 500) and (Location <= 1000) then
- raise Location_Error;
- elsif (Location > 100) and (Location <= 500) then
- raise Incorrect_Data;
- else
- Current_Position := Location;
- end if;
- exception
- when Off_Screen_Data =>
- TC_Handled_In_Accept := True;
- when Location_Error =>
- TC_Reraised_In_Accept := True;
- raise; -- Reraise the Location_Error exception
- -- in the task block.
- end Contact;
- or
- terminate;
- end select;
-
- exception
-
- when Off_Screen_Data =>
- TC_Handled_In_Accept := False;
- Report.Failed ("Off_Screen_Data exception " &
- "improperly handled in task block");
-
- when Location_Error =>
- TC_Handled_In_Task_Block := True;
- end Task_Block;
-
- end loop;
-
- exception
-
- when Location_Error | Off_Screen_Data =>
- TC_Handled_In_Accept := False;
- TC_Handled_In_Task_Block := False;
- Report.Failed ("Exception improperly propagated out to task body");
- when others =>
- null;
- end Submarine_Type;
-
-end CB20001_0;
-
-
- --=================================================================--
-
-
-with CB20001_0;
-with Report;
-with ImpDef;
-
-procedure CB20001 is
-
- package Submarine_Tracking renames CB20001_0;
-
- Trident : Submarine_Tracking.Submarine_Type; -- Declare task
- Sonar_Contact : Submarine_Tracking.Location_Type;
-
- TC_LEB_Error,
- TC_Main_Handler_Used : Boolean := False;
-
-begin
-
- Report.Test ("CB20001", "Check that exceptions can be handled " &
- "in accept bodies");
-
-
- Off_Screen_Block:
- begin
- Sonar_Contact := 1500;
- Trident.Contact (Sonar_Contact); -- Cause Off_Screen_Data exception
- -- to be raised and handled in a task
- -- accept body.
- exception
- when Submarine_Tracking.Off_Screen_Data =>
- TC_Main_Handler_Used := True;
- Report.Failed ("Off_Screen_Data exception improperly handled " &
- "in calling procedure");
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Off_Screen_Block");
- end Off_Screen_Block;
-
-
- Location_Error_Block:
- begin
- Sonar_Contact := 700;
- Trident.Contact (Sonar_Contact); -- Cause Location_Error exception
- -- to be raised in task accept body,
- -- propogated to a task block, and
- -- handled there. Corresponding
- -- exception propagated here also.
- Report.Failed ("Expected exception not raised");
- exception
- when Submarine_Tracking.Location_Error =>
- TC_LEB_Error := True;
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Location_Error_Block");
- end Location_Error_Block;
-
-
- Incorrect_Data_Block:
- begin
- Sonar_Contact := 200;
- Trident.Contact (Sonar_Contact); -- Cause Incorrect_Data exception
- -- to be raised in task accept body,
- -- propogated to calling procedure.
- Report.Failed ("Expected exception not raised");
- exception
- when Submarine_Tracking.Incorrect_Data =>
- Submarine_Tracking.TC_Handled_In_Caller := True;
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Incorrect_Data_Block");
- end Incorrect_Data_Block;
-
-
- if TC_Main_Handler_Used or
- not (Submarine_Tracking.TC_Handled_In_Caller and -- Check to see that
- Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions
- Submarine_Tracking.TC_Handled_In_Accept and -- were handled in
- Submarine_Tracking.TC_Reraised_In_Accept and -- proper locations.
- TC_LEB_Error)
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- if Integer(Submarine_Tracking.Current_Position) /= 0 then
- Report.Failed ("Variable incorrectly written in task processing");
- end if;
-
- delay ImpDef.Minimum_Task_Switch;
- if Trident'Callable then
- Report.Failed ("Task didn't terminate with exception propagation");
- end if;
-
- Report.Result;
-
-end CB20001;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20003.a b/gcc/testsuite/ada/acats/tests/cb/cb20003.a
deleted file mode 100644
index daaf9ff..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20003.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- CB20003.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 exceptions can be raised, reraised, and handled in an
--- accessed subprogram.
---
---
--- TEST DESCRIPTION:
--- Declare a record type, with one component being an access to
--- subprogram type. Various subprograms are defined to fit the profile
--- of this access type, such that the record component can refer to
--- any of the subprograms.
---
--- Each of the subprograms raises a different exception, based on the
--- value of an input parameter. Exceptions are 1) raised, handled with
--- an others handler, reraised and propagated to main to be handled in
--- a specific handler; 2) raised, handled in a specific handler, reraised
--- and propagated to the main to be handled in an others handler there,
--- and 3) raised and propagated directly to the caller by the subprogram.
---
--- Boolean variables are set throughout the test to ensure that correct
--- exception processing has occurred, and these variables are verified at
--- the conclusion of the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20003_0 is -- package Push_Buttons
-
-
- Non_Default_Priority,
- Non_Alert_Priority,
- Non_Emergency_Priority : exception;
-
- Handled_With_Others,
- Reraised_In_Subprogram,
- Handled_In_Caller : Boolean := False;
-
- subtype Priority_Type is Integer range 1 .. 10;
-
- Default_Priority : Priority_Type := 1;
- Alert_Priority : Priority_Type := 3;
- Emergency_Priority : Priority_Type := 5;
-
-
- type Button is tagged private; -- Private tagged type.
-
- type Button_Response_Ptr is access procedure (P : in Priority_Type;
- B : in out Button);
-
-
- -- Procedures accessible with Button_Response_Ptr type.
-
- procedure Default_Response (P : in Priority_Type;
- B : in out Button);
-
- procedure Alert_Response (P : in Priority_Type;
- B : in out Button);
-
- procedure Emergency_Response (P : in Priority_Type;
- B : in out Button);
-
-
-
- procedure Push (B : in out Button;
- P : in Priority_Type);
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr);
-
-private
-
- type Button is tagged
- record
- Priority : Priority_Type := Default_Priority;
- Response : Button_Response_Ptr := Default_Response'Access;
- end record;
-
-
-end CB20003_0; -- package Push_Buttons
-
-
- --=================================================================--
-
-
-with Report;
-
-package body CB20003_0 is -- package Push_Buttons
-
-
- procedure Push (B : in out Button;
- P : in Priority_Type) is
- begin -- Invoking subprogram designated
- B.Response (P, B); -- by access value.
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- B.Response := R; -- Set procedure value in record
- end Set_Response;
-
-
- procedure Default_Response (P : in Priority_Type;
- B : in out Button) is
- begin
- if (P > Default_Priority) then
- raise Non_Default_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- exception
- when others => -- Catch exception with others handler
- Handled_With_Others := True; -- Successfully caught with "others"
- raise;
- Report.Failed ("Exception not reraised in handler");
- end Default_Response;
-
-
-
- procedure Alert_Response (P : in Priority_Type;
- B : in out Button) is
- begin
- if (P > Alert_Priority) then
- raise Non_Alert_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- exception
- when Non_Alert_Priority =>
- Reraised_In_Subprogram := True;
- raise; -- Propagate to caller.
- Report.Failed ("Exception not reraised in procedure excpt handler");
- when others =>
- Report.Failed ("Incorrect exception raised/handled");
- end Alert_Response;
-
-
-
- procedure Emergency_Response (P : in Priority_type;
- B : in out Button) is
- begin
- if (P > Emergency_Priority) then
- raise Non_Emergency_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- -- No exception handler here, exception will be propagated to caller.
- end Emergency_Response;
-
-
-end CB20003_0; -- package Push_Buttons
-
-
- --=================================================================--
-
-
-with Report;
-with CB20003_0; -- package Push_Buttons
-
-procedure CB20003 is
-
- package Push_Buttons renames CB20003_0;
-
- Console_Button : Push_Buttons.Button;
-
-begin
-
- Report.Test ("CB20003", "Check that exceptions can be raised, " &
- "reraised, and handled in a subprogram " &
- "referenced by an access to subprogram value");
-
-
- Default_Response_Processing: -- The exception
- -- Handled_With_Others is to
- -- be caught with an others
- -- handler in Default_Resp.,
- -- reraised, and handled with
- -- a specific handler here.
- begin
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(2)); -- be handled in procedure.
- exception
- when Push_Buttons.Non_Default_Priority =>
- if not Push_Buttons.Handled_With_Others then -- Not reraised in
- -- procedure.
- Report.Failed
- ("Exception not handled/reraised in procedure");
- end if;
- when others =>
- Report.Failed ("Exception handled in " &
- " Default_Response_Processing block");
- end Default_Response_Processing;
-
-
-
- Alert_Response_Processing:
- begin
-
- Push_Buttons.Set_Response (Console_Button,
- Push_Buttons.Alert_Response'access);
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(4)); -- be handled in procedure,
- -- reraised, and propagated
- -- to caller.
- Report.Failed ("Exception not propagated to caller " &
- "in Alert_Response_Processing block");
-
- exception
- when Push_Buttons.Non_Alert_Priority =>
- if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in
- -- procedure.
- Report.Failed ("Exception not reraised in procedure");
- end if;
- when others =>
- Report.Failed ("Exception handled in " &
- " Alert_Response_Processing block");
- end Alert_Response_Processing;
-
-
-
- Emergency_Response_Processing:
- begin
-
- Push_Buttons.Set_Response (Console_Button,
- Push_Buttons.Emergency_Response'access);
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(6)); -- be propagated directly to
- -- caller.
- Report.Failed ("Exception not propagated to caller " &
- "in Emergency_Response_Processing block");
-
- exception
- when Push_Buttons.Non_Emergency_Priority =>
- Push_Buttons.Handled_In_Caller := True;
- when others =>
- Report.Failed ("Exception handled in " &
- " Emergency_Response_Processing block");
- end Emergency_Response_Processing;
-
-
-
- if not (Push_Buttons.Handled_With_Others and
- Push_Buttons.Reraised_In_Subprogram and
- Push_Buttons.Handled_In_Caller )
- then
- Report.Failed ("Incorrect exception handling in referenced subprograms");
- end if;
-
-
- Report.Result;
-
-end CB20003;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20004.a b/gcc/testsuite/ada/acats/tests/cb/cb20004.a
deleted file mode 100644
index 42c0d76..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20004.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CB20004.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 exceptions propagate correctly from objects of
--- protected types. Check propagation from protected entry bodies.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including entries and private
--- data, simulating a bounded buffer abstraction. In the main procedure,
--- perform entry calls on an object of the protected type that raises
--- exceptions.
--- Ensure that the exceptions are:
--- 1) raised and handled locally in the entry body
--- 2) raised in the entry body and handled/reraised to be handled
--- by the caller.
--- 3) raised in the entry body and propagated directly to the calling
--- procedure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20004_0 is -- Package Buffer.
-
- Max_Buffer_Size : constant := 2;
-
- Handled_In_Body,
- Propagated_To_Caller,
- Handled_In_Caller : Boolean := False;
-
- Data_Over_5,
- Data_Degradation : exception;
-
- type Data_Item is range 0 .. 100;
-
- type Item_Array_Type is array (1 .. Max_Buffer_Size) of Data_Item;
-
- protected type Bounded_Buffer is
- entry Put (Item : in Data_Item);
- entry Get (Item : out Data_Item);
- private
- Item_Array : Item_Array_Type;
- I, J : Integer range 1 .. Max_Buffer_Size := 1;
- Count : Integer range 0 .. Max_Buffer_Size := 0;
- end Bounded_Buffer;
-
-end CB20004_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20004_0 is -- Package Buffer.
-
- protected body Bounded_Buffer is
-
- entry Put (Item : in Data_Item) when Count < Max_Buffer_Size is
- begin
- if Item > 10 then
- Item_Array (I) := Item * 8; -- Constraint_Error will be raised
- elsif Item > 5 then -- and handled in entry body.
- raise Data_Over_5; -- Exception handled/reraised in
- else -- entry body, propagated to caller.
- Item_Array (I) := Item; -- Store data item in buffer.
- I := (I mod Max_Buffer_Size) + 1;
- Count := Count + 1;
- end if;
- exception
- when Constraint_Error =>
- Handled_In_Body := True;
- when Data_Over_5 =>
- Propagated_To_Caller := True;
- raise; -- Propagate the exception to the caller.
- end Put;
-
-
- entry Get (Item : out Data_Item) when Count > 0 is
- begin
- Item := Item_Array(J);
- J := (J mod Max_Buffer_Size) + 1;
- Count := Count - 1;
- if Count = 0 then
- raise Data_Degradation; -- Exception to propagate to caller.
- end if;
- end Get;
-
- end Bounded_Buffer;
-
-end CB20004_0;
-
-
- --=================================================================--
-
-
-with CB20004_0; -- Package Buffer.
-with Report;
-
-procedure CB20004 is
-
- package Buffer renames CB20004_0;
-
- Data : Buffer.Data_Item := Buffer.Data_Item'First;
- Data_Buffer : Buffer.Bounded_Buffer; -- an object of protected type.
-
- Handled_In_Caller : Boolean := False; -- same name as boolean declared
- -- in package Buffer.
-begin
-
- Report.Test ("CB20004", "Check that exceptions propagate correctly " &
- "from objects of protected types" );
-
- Initial_Data_Block:
- begin -- Data causes Constraint_Error.
- Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(51)));
-
- exception
- when Constraint_Error =>
- Buffer.Handled_In_Body := False; -- Improper exception handling
- -- in entry body.
- Report.Failed ("Exception propagated to caller " &
- " from Initial_Data_Block");
- when others =>
- Report.Failed ("Exception raised in processing and " &
- "propagated to caller from Initial_Data_Block");
- end Initial_Data_Block;
-
-
- Data_Entry_Block:
- begin
- -- Valid data. No exception.
- Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(3)));
-
- -- Data will cause exception.
- Data_Buffer.Put (7); -- Call protected object entry,
- -- exception to be handled/
- -- reraised in entry body.
- Report.Failed ("Data_Over_5 Exception not raised in processing");
- exception
- when Buffer.Data_Over_5 =>
- if Buffer.Propagated_To_Caller then -- Reraised in entry body?
- Buffer.Handled_In_Caller := True;
- else
- Report.Failed ("Exception not reraised in entry body");
- end if;
- when others =>
- Report.Failed ("Exception raised in processing and propagated " &
- "to caller from Data_Entry_Block");
- end Data_Entry_Block;
-
-
- Data_Retrieval_Block:
- begin
-
- Data_Buffer.Get (Data); -- Retrieval of buffer data, buffer now empty.
- -- Exception will be raised in entry body, with
- -- propagation to caller.
- Report.Failed ("Data_Degradation Exception not raised in processing");
- exception
- when Buffer.Data_Degradation =>
- Handled_In_Caller := True; -- Local Boolean used here.
- when others =>
- Report.Failed ("Exception raised in processing and propagated " &
- "to caller from Data_Retrieval_Block");
- end Data_Retrieval_Block;
-
-
- if not (Buffer.Handled_In_Body and -- Validate proper exception
- Buffer.Propagated_To_Caller and -- handling in entry bodies.
- Buffer.Handled_In_Caller and
- Handled_In_Caller)
- then
- Report.Failed ("Improper exception handling by entry bodies");
- end if;
-
-
- Report.Result;
-
-end CB20004;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20005.a b/gcc/testsuite/ada/acats/tests/cb/cb20005.a
deleted file mode 100644
index 898d2a2..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20005.a
+++ /dev/null
@@ -1,210 +0,0 @@
--- CB20005.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 exceptions are raised and properly handled locally in
--- protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- Ensure that the exceptions are raised and handled locally in a
--- protected procedures and functions, and that in this case the
--- exceptions will not propagate to the calling unit. Use specific
--- exception handlers in the protected functions.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20005_0 is -- Package Semaphore.
-
- Handled_In_Function,
- Handled_In_Procedure : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20005_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20005_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed
- ("Program control not transferred by raise in Secure");
- else
- Count := Count - 1; -- Avail resources decremented.
- end if;
- exception
- when Resource_Underflow => -- Exception handled locally in
- Handled_In_Procedure := True; -- this protected operation.
- when others =>
- Report.Failed ("Unexpected exception raised in Secure");
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed
- ("Program control not transferred by raise in " &
- "Resource_Limit_Exceeded");
- else
- return (False);
- end if;
- exception
- when Resource_Overflow => -- Handle its own raised
- Handled_In_Function := True; -- exception.
- return (True);
- when others =>
- Report.Failed
- ("Unexpected exception raised in Resource_Limit_Exceeded");
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises/handles
- end if; -- an exception.
- exception
- when Resource_Overflow =>
- Handled_In_Function := False;
- Report.Failed ("Exception propagated to Function Release");
- when others =>
- Report.Failed ("Unexpected exception raised in Function Release");
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20005_0;
-
-
- --=================================================================--
-
-
-with CB20005_0; -- Package Semaphore.
-with Report;
-
-procedure CB20005 is
-begin
-
- Report.Test ("CB20005", "Check that exceptions are raised and handled " &
- "correctly in protected operations" );
-
- Test_Block:
- declare
-
- package Semaphore renames CB20005_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore(Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception.
- Resources.Secure;
- end loop;
- exception
- when Semaphore.Resource_Underflow =>
- Semaphore.Handled_In_Procedure := False; -- Excptn not handled
- Report.Failed -- in prot. operation.
- ("Resource_Underflow exception not handled " &
- "in Allocate_Resources");
- when others =>
- Report.Failed
- ("Exception unexpectedly raised during resource allocation");
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force excptn.
- Resources.Release;
- end loop;
- exception
- when Semaphore.Resource_Overflow =>
- Semaphore.Handled_In_Function := False; -- Exception not handled
- Report.Failed -- in prot. operation.
- ("Resource overflow not handled by function");
- when others =>
- Report.Failed
- ("Exception raised during resource deallocation");
- end Deallocate_Resources;
-
-
- if not (Semaphore.Handled_In_Procedure and -- Incorrect excpt. handling
- Semaphore.Handled_In_Function) -- in protected operations.
- then
- Report.Failed
- ("Improper exception handling by protected operations");
- end if;
-
-
- exception
- when others =>
- Report.Failed ("Exception raised and propagated in test");
-
- end Test_Block;
-
- Report.Result;
-
-end CB20005;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20006.a b/gcc/testsuite/ada/acats/tests/cb/cb20006.a
deleted file mode 100644
index f2b3c70..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20006.a
+++ /dev/null
@@ -1,217 +0,0 @@
--- CB20006.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 exceptions are raised and properly handled (including
--- propagation by reraise) in protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- The exceptions raised are to be initially handled in the protected
--- operations, but this handling involves the reraise of the exception
--- and the propagation of the exception to the caller.
---
--- Ensure that the exceptions are raised, handled / reraised successfully
--- in protected procedures and functions. Use "others" handlers in the
--- protected operations.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20006_0 is -- Package Semaphore.
-
- Reraised_In_Function,
- Reraised_In_Procedure,
- Handled_In_Function_Caller,
- Handled_In_Procedure_Caller : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20006_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20006_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed
- ("Program control not transferred by raise in Procedure Secure");
- else
- Count := Count - 1; -- Available resources decremented.
- end if;
- exception
- when Resource_Underflow =>
- Reraised_In_Procedure := True;
- raise; -- Exception propagated to caller.
- Report.Failed ("Exception not propagated to caller from Secure");
- when others =>
- Report.Failed ("Unexpected exception raised in Secure");
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed
- ("Specific raise did not alter program control" &
- " from Resource_Limit_Exceeded");
- else
- return (False);
- end if;
- exception
- when others =>
- Reraised_In_Function := True;
- raise; -- Exception propagated to caller.
- Report.Failed ("Exception not propagated to caller" &
- " from Resource_Limit_Exceeded");
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises/reraises
- -- an exception.
- Report.Failed("Resource limit exceeded");
- end if;
-
- exception
- when others =>
- raise; -- Reraised and propagated again.
- Report.Failed ("Exception not reraised by procedure Release");
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20006_0;
-
-
- --=================================================================--
-
-
-with CB20006_0; -- Package Semaphore.
-with Report;
-
-procedure CB20006 is
-begin
-
- Report.Test ("CB20006", "Check that exceptions are raised and " &
- "handled / reraised and propagated " &
- "correctly by protected operations" );
-
- Test_Block:
- declare
-
- package Semaphore renames CB20006_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception
- Resources.Secure;
- end loop;
- Report.Failed
- ("Exception not propagated from protected operation Secure");
- exception
- when Semaphore.Resource_Underflow => -- Exception propagated
- Semaphore.Handled_In_Procedure_Caller := True; -- from protected
- when others => -- procedure.
- Semaphore.Handled_In_Procedure_Caller := False;
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception
- Resources.Release;
- end loop;
- Report.Failed
- ("Exception not propagated from protected operation Release");
- exception
- when Semaphore.Resource_Overflow => -- Exception propagated
- Semaphore.Handled_In_Function_Caller := True; -- from protected
- when others => -- function.
- Semaphore.Handled_In_Function_Caller := False;
- end Deallocate_Resources;
-
-
- if not (Semaphore.Reraised_In_Procedure and
- Semaphore.Reraised_In_Function and
- Semaphore.Handled_In_Procedure_Caller and
- Semaphore.Handled_In_Function_Caller)
- then -- Incorrect excpt. handling
- Report.Failed -- in protected operations.
- ("Improper exception handling/reraising by protected operations");
- end if;
-
- exception
-
- when others =>
- Report.Failed ("Unexpected exception " &
- " raised and propagated in test");
- end Test_Block;
-
- Report.Result;
-
-
-end CB20006;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20007.a b/gcc/testsuite/ada/acats/tests/cb/cb20007.a
deleted file mode 100644
index 6d05251..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20007.a
+++ /dev/null
@@ -1,196 +0,0 @@
--- CB20007.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 exceptions are raised and can be directly propagated to
--- the calling unit by protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- The exceptions raised are to be propagated directly from the protected
--- operations to the calling unit.
---
--- Ensure that the exceptions are raised and correctly propagated directly
--- to the calling unit from protected procedures and functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20007_0 is -- Package Semaphore.
-
- Handled_In_Function_Caller,
- Handled_In_Procedure_Caller : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20007_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20007_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed ("Program control not transferred by raise");
- else
- Count := Count - 1; -- Available resources decremented.
- end if;
- -- No exception handlers here, direct propagation to calling unit.
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed ("Program control not transferred by raise");
- else
- return (False);
- end if;
- -- No exception handlers here, direct propagation to calling unit.
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises an
- -- exception.
- Report.Failed("Resource limit exceeded");
- end if;
- -- No exception handler here for exception raised in function.
- -- Exception will propagate directly to calling unit.
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20007_0;
-
-
- --=================================================================--
-
-
-with CB20007_0; -- Package Semaphore.
-with Report;
-
-procedure CB20007 is
-begin
-
- Test_Block:
- declare
-
- package Semaphore renames CB20007_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Report.Test ("CB20007", "Check that exceptions are raised and can " &
- "be directly propagated to the calling unit " &
- "by protected operations" );
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin -- Force exception.
- for I in 1..Loop_Count loop
- Resources.Secure;
- end loop;
- Report.Failed ("Exception not propagated from protected " &
- " operation in Allocate_Resources");
- exception
- when Semaphore.Resource_Underflow => -- Exception prop.
- Semaphore.Handled_In_Procedure_Caller := True; -- from protected
- -- procedure.
- when others =>
- Report.Failed ("Unknown exception during resource allocation");
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin -- Force exception.
- for I in 1..Loop_Count loop
- Resources.Release;
- end loop;
- Report.Failed ("Exception not propagated from protected " &
- "operation in Deallocate_Resources");
- exception
- when Semaphore.Resource_Overflow => -- Exception prop
- Semaphore.Handled_In_Function_Caller := True; -- from protected
- -- function.
- when others =>
- Report.Failed ("Exception raised during resource deallocation");
- end Deallocate_Resources;
-
-
- if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception
- Semaphore.Handled_In_Function_Caller) -- handling in
- then -- protected ops.
- Report.Failed
- ("Improper exception propagation by protected operations");
- end if;
-
- exception
-
- when others =>
- Report.Failed ("Unexpected exception " &
- " raised and propagated in test");
- end Test_Block;
-
-
- Report.Result;
-
-end CB20007;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada b/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada
deleted file mode 100644
index e16aeb5..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada
+++ /dev/null
@@ -1,245 +0,0 @@
--- CB2004A.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 PREDEFINED OR A PROGRAMMER DEFINED EXCEPTION
--- RAISED SEVERAL LEVELS INSIDE A HIERARCHY OF NESTED BLOCKS
--- CAN BE SUCCESSFULLY HANDLED IN AN OUTER BLOCK.
-
--- *** 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
-
--- DCB 5/12/80
--- JRK 11/17/80
--- SPS 11/2/82
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE CB2004A IS
-
- USE REPORT;
-
- FLOW_COUNT : INTEGER := 0;
-
- E1, E2, E3 : EXCEPTION;
-
-BEGIN
- TEST("CB2004A","CHECK THAT EXCEPTIONS RAISED INSIDE NESTED " &
- "BLOCKS CAN BE HANDLED IN OUTER BLOCKS");
-
- BEGIN
-
- -- PROGRAMMER-DEFINED EXCEPTION, SINGLE EXCEPTON_CHOICE.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("PROGRAMMER-DEFINED EXCEPTION " &
- "NOT RAISED #1");
-
- EXCEPTION
- WHEN E2 | E3 =>
- FAILED("WRONG PROGRAMMER-" &
- "DEFINED EXCEPTION HANDLED #1");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR |
- PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR | E2 | E3 =>
- FAILED("WRONG " &
- "EXCEPTION HANDLED #1");
- END;
-
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- -- PROGRAMMER-DEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E2;
- FAILED("PROGRAMMER-DEFINED EXCEPTION " &
- "NOT RAISED #2");
-
- EXCEPTION
- WHEN E1 | E3 =>
- FAILED("WRONG PROGRAMMER-" &
- "DEFINED EXCEPTION HANDLED #2");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR |
- PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR | E1 | E3 =>
- FAILED("WRONG " &
- "EXCEPTION HANDLED #2");
- END;
-
- EXCEPTION
- WHEN E3 =>
- FAILED("WRONG EXCEPTION HANDLED #2A");
- WHEN E1 | E2 | CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- -- PROGRAMMER-DEFINED EXCEPTION, 'OTHERS' CHOICE.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("PROGRAMMER-DEFINED EXCEPTION " &
- "NOT RAISED #3");
-
- EXCEPTION
- WHEN E2 | E3 =>
- FAILED("WRONG PROGRAMMER-" &
- "DEFINED EXCEPTION HANDLED #3");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR |
- PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR | E2 | E3 =>
- FAILED("WRONG " &
- "EXCEPTION HANDLED #3");
- END;
-
- EXCEPTION
- WHEN E2 | CONSTRAINT_ERROR =>
- FAILED("WRONG EXCEPTION HANDLED #3A");
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- -- PREDEFINED EXCEPTION, SINGLE EXCEPTION_CHOICE.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE CONSTRAINT_ERROR;
- FAILED("PREDEFINED EXCEPTION NOT RAISED #4");
-
- EXCEPTION
- WHEN E1 | E2 | E3 =>
- FAILED("WRONG " &
- "EXCEPTION HANDLED #4");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR =>
- FAILED("WRONG PREDEFINED " &
- "EXCEPTION HANDLED #4");
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- -- PREDEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE CONSTRAINT_ERROR;
- FAILED("PREDEFINED EXCEPTION NOT RAISED #5");
-
- EXCEPTION
- WHEN E1 | E2 | E3 =>
- FAILED("WRONG " &
- "EXCEPTION HANDLED #5");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR |
- STORAGE_ERROR | TASKING_ERROR =>
- FAILED("WRONG PREDEFINED " &
- "EXCEPTION HANDLED #5");
- END;
-
- EXCEPTION
- WHEN E1 | E2 =>
- FAILED("WRONG EXCEPTION HANDLED #5A");
- WHEN CONSTRAINT_ERROR | E3 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- -- PREDEFINED EXCEPTION, 'OTHERS' CHOICE.
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE CONSTRAINT_ERROR;
- FAILED("PREDEFINED EXCEPTION NOT RAISED #6");
-
- EXCEPTION
- WHEN E1 | E2 | E3 =>
- FAILED("WRONG " &
- " EXCEPTION HANDLED #6");
- END;
-
- EXCEPTION
- WHEN PROGRAM_ERROR | STORAGE_ERROR |
- TASKING_ERROR =>
- FAILED("WRONG PREDEFINED " &
- "EXCEPTION HANDLED #6");
- END;
-
- EXCEPTION
- WHEN E1 =>
- FAILED("WRONG EXCEPTION HANDLED #6A");
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- END;
-
- EXCEPTION
- WHEN E1 | E2 | E3 =>
- FAILED("PROGRAMMER-DEFINED EXCEPTION HANDLED IN" &
- "WRONG SCOPE");
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR HANDLED IN WRONG SCOPE");
- WHEN OTHERS =>
- FAILED("OTHER EXCEPTIONS HANDLED IN WRONG SCOPE");
- END;
-
- IF FLOW_COUNT /= 12 THEN
- FAILED("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END CB2004A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada b/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada
deleted file mode 100644
index 64ac5a7..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CB2005A.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 RETURN STATEMENT CAN APPEAR IN AN EXCEPTION HANDLER
--- AND IT CAUSES CONTROL TO LEAVE THE SUBPROGRAM, FOR BOTH
--- FUNCTIONS AND PROCEDURES.
-
--- DAT 4/13/81
--- JRK 4/24/81
--- SPS 10/26/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB2005A IS
-
- I : INTEGER RANGE 0 .. 1;
-
- FUNCTION SETI RETURN INTEGER IS
- BEGIN
- I := I + 1;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 1");
- RETURN 0;
- EXCEPTION
- WHEN OTHERS =>
- RETURN I;
- FAILED ("FUNCTION RETURN STMT DID NOT RETURN");
- RETURN 0;
- END SETI;
-
- PROCEDURE ISET IS
- BEGIN
- I := 2;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 2");
- I := 0;
- EXCEPTION
- WHEN OTHERS =>
- RETURN;
- FAILED ("PROCEDURE RETURN STMT DID NOT RETURN");
- END ISET;
-
-BEGIN
- TEST ("CB2005A", "RETURN IN EXCEPTION HANDLERS");
-
- I := 1;
- IF SETI /= 1 THEN
- FAILED ("WRONG VALUE RETURNED 1");
- END IF;
-
- I := 1;
- ISET;
- IF I /= 1 THEN
- FAILED ("WRONG VALUE RETURNED 2");
- END IF;
-
- RESULT;
-END CB2005A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada b/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada
deleted file mode 100644
index b4da0e2..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- CB2006A.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 LOCAL VARIABLES AND PARAMETERS OF A SUBPROGRAM,
--- OR PACKAGE ARE ACCESSIBLE WITHIN A HANDLER.
-
--- DAT 4/13/81
--- SPS 3/23/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB2006A IS
-
- I : INTEGER RANGE 0 .. 1;
-
- PACKAGE P IS
- V2 : INTEGER := 2;
- END P;
-
- PROCEDURE PR (J : IN OUT INTEGER) IS
- K : INTEGER := J;
- BEGIN
- I := K;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 1");
- EXCEPTION
- WHEN OTHERS =>
- J := K + 1;
- END PR;
-
- PACKAGE BODY P IS
- L : INTEGER := 2;
- BEGIN
- TEST ("CB2006A", "LOCAL VARIABLES ARE ACCESSIBLE IN"
- & " HANDLERS");
-
- I := 1;
- I := I + 1;
- FAILED ("CONSTRAINT_ERROR NOT RAISED 2");
- EXCEPTION
- WHEN OTHERS =>
- PR (L);
- IF L /= V2 + 1 THEN
- FAILED ("WRONG VALUE IN LOCAL VARIABLE");
- END IF;
- END P;
-BEGIN
-
- RESULT;
-END CB2006A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada b/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada
deleted file mode 100644
index 01e12d8..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CB2007A.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 EXIT STATEMENT IN A HANDLER CAN TRANSFER CONTROL
--- OUT OF A LOOP.
-
--- DAT 4/13/81
--- RM 4/30/81
--- SPS 3/23/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB2007A IS
-BEGIN
- TEST ("CB2007A", "EXIT STATEMENTS IN EXCEPTION HANDLERS");
-
- DECLARE
- FLOW_INDEX : INTEGER := 0 ;
- BEGIN
-
- FOR I IN 1 .. 10 LOOP
- BEGIN
- IF I = 1 THEN
- RAISE CONSTRAINT_ERROR;
- END IF;
- FAILED ("WRONG CONTROL FLOW 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => EXIT;
- END;
- FAILED ("WRONG CONTROL FLOW 2");
- EXIT;
- END LOOP;
-
- FOR AAA IN 1..1 LOOP
- FOR BBB IN 1..1 LOOP
- FOR I IN 1 .. 10 LOOP
- BEGIN
- IF I = 1 THEN
- RAISE CONSTRAINT_ERROR;
- END IF;
- FAILED ("WRONG CONTROL FLOW A1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => EXIT;
- END;
- FAILED ("WRONG CONTROL FLOW A2");
- EXIT;
- END LOOP;
-
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END LOOP;
- END LOOP;
-
- LOOP1 :
- FOR AAA IN 1..1 LOOP
- LOOP2 :
- FOR BBB IN 1..1 LOOP
- LOOP3 :
- FOR I IN 1 .. 10 LOOP
- BEGIN
- IF I = 1 THEN
- RAISE CONSTRAINT_ERROR;
- END IF;
- FAILED ("WRONG CONTROL FLOW B1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => EXIT LOOP2 ;
- END;
- FAILED ("WRONG CONTROL FLOW B2");
- EXIT LOOP2 ;
- END LOOP LOOP3 ;
-
- FAILED ("WRONG CONTROL FLOW B3");
- END LOOP LOOP2 ;
-
- FLOW_INDEX := FLOW_INDEX + 1 ;
- END LOOP LOOP1 ;
-
- IF FLOW_INDEX /= 2 THEN FAILED( "WRONG FLOW OF CONTROL" );
- END IF;
-
- END ;
-
- RESULT;
-END CB2007A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a b/gcc/testsuite/ada/acats/tests/cb/cb20a02.a
deleted file mode 100644
index 4c85370..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a
+++ /dev/null
@@ -1,155 +0,0 @@
--- CB20A02.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 name and pertinent information about a user defined
--- exception are available to an enclosing program unit even when the
--- enclosing unit has no visibility into the scope where the exception
--- is declared and raised.
---
--- TEST DESCRIPTION:
--- Declare a subprogram nested within the test subprogram. The enclosing
--- subprogram does not have visibility into the nested subprogram.
--- Declare and raise an exception in the nested subprogram, and allow
--- the exception to propagate to the enclosing scope. Use the function
--- Exception_Name in the enclosing subprogram to produce exception
--- specific information when the exception is handled in an others
--- handler.
---
--- TEST FILES:
---
--- This test depends on the following foundation code file:
--- FB20A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FB20A00; -- Package containing Function Find
-with Ada.Exceptions;
-with Report;
-
-procedure CB20A02 is
-
- Seed_Number : Integer;
- Random_Number : Integer := 0;
-
- --=================================================================--
-
- function Random_Number_Generator (Seed : Integer) return Integer is
-
- Result : Integer := 0;
-
- HighSeedError,
- Mid_Seed_Error,
- L_o_w_S_e_e_d_E_r_r_o_r : exception;
-
- begin -- Random_Number_Generator
-
-
- if (Report.Ident_Int (Seed) > 1000) then
- raise HighSeedError;
- elsif (Report.Ident_Int (Seed) > 100) then
- raise Mid_Seed_Error;
- elsif (Report.Ident_Int (Seed) > 10) then
- raise L_o_w_S_e_e_d_E_r_r_o_r;
- else
- Seed_Number := ((Seed_Number * 417) + 231) mod 53;
- Result := Seed_Number / 52;
- end if;
-
- return Result;
-
- end Random_Number_Generator;
-
- --=================================================================--
-
-begin
-
- Report.Test ("CB20A02", "Check that the name " &
- "of a user defined exception is available " &
- "to an enclosing program unit even when the " &
- "enclosing unit has no visibility into the " &
- "scope where the exception is declared and " &
- "raised" );
-
- High_Seed:
- begin
- -- This seed value will result in the raising of a HighSeedError
- -- exception.
- Seed_Number := 1001;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in High_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "HighSeedError")
- then
- Report.Failed ("Expected HighSeedError, but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end High_Seed;
-
-
- Mid_Seed:
- begin
- -- This seed value will generate a Mid_Seed_Error exception.
- Seed_Number := 101;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in Mid_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "Mid_Seed_Error")
- then
- Report.Failed ("Expected Mid_Seed_Error, but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end Mid_Seed;
-
-
- Low_Seed:
- begin
- -- This seed value will result in the raising of a
- -- L_o_w_S_e_e_d_E_r_r_o_r exception.
- Seed_Number := 11;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in Low_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "L_o_w_S_e_e_d_E_r_r_o_r")
- then
- Report.Failed ("Expected L_o_w_S_e_e_d_E_r_r_o_r but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end Low_Seed;
-
-
- Report.Result;
-
-end CB20A02;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada b/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada
deleted file mode 100644
index 3acdd2e..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CB3003A.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 NON-SPECIFIC RAISE STATEMENT PROPAGATES THE EXCEPTION
--- FOR FURTHER PROCESSING(HANDLING) IN ANOTHER HANDLER.
-
--- *** 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
-
--- DCB 04/01/80
--- JRK 11/19/80
--- SPS 11/2/82
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE CB3003A IS
-
- USE REPORT;
-
- FLOW_COUNT : INTEGER := 0;
- E1,E2 : EXCEPTION;
-
-BEGIN
- TEST("CB3003A","CHECK THAT THE NON-SPECIFIC RAISE STATEMENT" &
- " PROPAGATES THE ERROR FOR FURTHER HANDLING IN ANOTHER" &
- " HANDLER");
-
- -------------------------------------------------------
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("EXCEPTION NOT RAISED (CASE 1)");
- EXCEPTION
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 1; " &
- "INNER)");
- END;
-
- EXCEPTION
- -- A HANDLER SPECIFIC TO THE RAISED EXCEPTION (E1).
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 1; OUTER)");
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED (CASE 1)");
- END;
-
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION PASSED (CASE 1)");
- END;
-
- -------------------------------------------------------
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("EXCEPTION NOT RAISED (CASE 2)");
- EXCEPTION
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 2; " &
- "INNER)");
- END;
-
- EXCEPTION
- -- A HANDLER FOR SEVERAL EXCEPTIONS INCLUDING THE ONE RAISED.
- WHEN CONSTRAINT_ERROR =>
- FAILED("WRONG EXCEPTION RAISED (CONSTRAINT_ERROR)");
- WHEN E2 =>
- FAILED("WRONG EXCEPTION RAISED (E2)");
- WHEN PROGRAM_ERROR | E1 | TASKING_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 2; OUTER)");
- WHEN STORAGE_ERROR =>
- FAILED("WRONG EXCEPTION RAISED (STORAGE_ERROR)");
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED (OTHERS)");
- END;
-
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION PASSED (CASE 2)");
- END;
-
- -------------------------------------------------------
-
- BEGIN
- BEGIN
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("EXCEPTION NOT RAISED (CASE 3)");
- EXCEPTION
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 3; " &
- "INNER)");
- END;
-
- EXCEPTION
- -- A NON-SPECIFIC HANDLER.
- WHEN CONSTRAINT_ERROR | E2 =>
- FAILED("WRONG EXCEPTION RAISED " &
- "(CONSTRAINT_ERROR | E2)");
- WHEN OTHERS =>
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE;
- FAILED("EXCEPTION NOT RERAISED (CASE 3; OUTER)");
- END;
-
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION PASSED (CASE 3)");
- END;
-
- -------------------------------------------------------
-
- IF FLOW_COUNT /= 12 THEN
- FAILED("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END CB3003A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada b/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada
deleted file mode 100644
index 460670f..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- CB3003B.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-EXPLICIT RAISE STATEMENT MAY APPEAR IN A BLOCK
--- STATEMENT WITHIN AN EXCEPTION HANDLER; IF THE BLOCK STATEMENT
--- INCLUDES A HANDLER FOR THE CURRENT EXCEPTION, THEN THE INNER
--- HANDLER RECEIVES CONTROL.
-
--- *** 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
-
--- L.BROWN 10/08/86
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB3003B IS
-
- MY_ERROR : EXCEPTION;
-
-BEGIN
- TEST("CB3003B","A NON-EXPLICIT RAISE STATEMENT MAY APPEAR IN A "&
- "BLOCK STATEMENT WITHIN AN EXCEPTION HANDLER");
-
- BEGIN
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE MY_ERROR;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 1");
- EXCEPTION
- WHEN MY_ERROR =>
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 2");
- EXCEPTION
- WHEN MY_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED 1");
- END;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED 2");
- END;
- EXCEPTION
- WHEN MY_ERROR =>
- FAILED("CONTROL PASSED TO OUTER HANDLER 1");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED 1");
- END;
-
- BEGIN
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE MY_ERROR;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR | MY_ERROR | TASKING_ERROR =>
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 4");
- EXCEPTION
- WHEN MY_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED 3");
- END;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED 4");
- END;
- EXCEPTION
- WHEN MY_ERROR =>
- FAILED("CONTROL PASSED TO OUTER HANDLER 2");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED 2");
- END;
-
- BEGIN
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE MY_ERROR;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 5");
- EXCEPTION
- WHEN OTHERS =>
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE;
- END IF;
- FAILED("MY_ERROR WAS NOT RAISED 6");
- EXCEPTION
- WHEN MY_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED 5");
- END;
- END;
- EXCEPTION
- WHEN MY_ERROR =>
- FAILED("CONTROL PASSED TO OUTER HANDLER 3");
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED 3");
- END;
-
- RESULT;
-
-END CB3003B;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada b/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada
deleted file mode 100644
index b089bc2..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- CB3004A.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 INNER UNIT REDECLARES AN EXCEPTION NAME
--- THE HIDDEN DEFINITION IS STILL AVAILABLE FOR USE.
-
--- NOTE : WE ASSUME FUNCTIONS ACT LIKE PROCEDURES AND
--- THAT UNITS, BLOCKS, AND PROCEDURES ACT THE SAME
--- IN OTHER CONTEXTS (E.G. TASKS AND PACKAGES).
-
--- DCB 6/2/80
--- JRK 11/19/80
--- SPS 3/24/83
-
-WITH REPORT;
-PROCEDURE CB3004A IS
-
- USE REPORT;
-
- E1 : EXCEPTION;
- FLOW_COUNT : INTEGER := 0;
-
- PROCEDURE P1 IS
- E1, E2 : EXCEPTION;
-
- PROCEDURE P2 IS
- E1 : EXCEPTION;
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE E1;
- FAILED("E1 EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN P1.E1 =>
- FAILED("P1.E1 EXCEPTION RAISED WHEN " &
- "(P2)E1 EXPECTED");
- WHEN E1 =>
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE P1.E1;
- FAILED("P1.E1 EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN E1 =>
- FAILED("(P2)E1 EXCEPTION RAISED WHEN" &
- " P1.E1 EXPECTED");
- WHEN P1.E1 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("OTHERS RAISED WHEN P1.E1 " &
- "EXPECTED");
- END;
- WHEN OTHERS =>
- FAILED("OTHERS RAISED WHEN (P2)E1 EXPECTED");
- END P2;
-
- PROCEDURE P3 IS
- CONSTRAINT_ERROR : EXCEPTION;
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE CONSTRAINT_ERROR;
- FAILED("CONSTRAINT_ERROR EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN STANDARD.CONSTRAINT_ERROR =>
- FAILED("STANDARD.CONSTRAINT_ERROR EXCEPTION " &
- "RAISED WHEN " &
- "(P3)CONSTRAINT_ERROR EXPECTED");
- WHEN CONSTRAINT_ERROR =>
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE STANDARD.CONSTRAINT_ERROR;
- FAILED("STANDARD.CONSTRAINT_ERROR " &
- "EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED("(P3)CONSTRAINT_ERROR " &
- "EXCEPTION RAISED WHEN " &
- "STANDARD.CONSTRAINT_ERROR " &
- "EXPECTED");
- WHEN STANDARD.CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("OTHERS RAISED WHEN " &
- "STANDARD.CONSTRAINT_ERROR " &
- "EXPECTED");
- END;
- WHEN OTHERS =>
- FAILED("OTHERS RAISED WHEN " &
- "(P3)CONSTRAINT_ERROR EXPECTED");
- END P3;
-
- PROCEDURE P4 IS
- E2 : EXCEPTION;
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1;
- RAISE P1.E2;
- FAILED("P1.E2 EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN E2 =>
- FAILED("(P4).E2 RAISED WHEN P1.E2 EXPECTED");
- END P4;
-
- BEGIN -- P1
- P2;
- P3;
- P4;
- FAILED("P1.E2 EXCEPTION NOT PROPAGATED FROM P4");
- EXCEPTION
- WHEN E2 =>
- FLOW_COUNT := FLOW_COUNT + 1;
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED WHERE NONE EXPECTED");
- END P1;
-
-BEGIN
- TEST("CB3004A","CHECK THAT WHEN EXCEPTION NAMES" &
- " ARE REDECLARED THE HIDDEN DEFINITION IS STILL AVAILABLE");
-
- P1;
-
- IF FLOW_COUNT /= 8 THEN
- FAILED("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END CB3004A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40005.a b/gcc/testsuite/ada/acats/tests/cb/cb40005.a
deleted file mode 100644
index 681ec18..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40005.a
+++ /dev/null
@@ -1,339 +0,0 @@
--- CB40005.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 exceptions raised in non-generic code can be handled by
--- a procedure in a generic package. Check that the exception identity
--- can be properly retrieved from the generic code and used by the
--- non-generic code.
---
--- TEST DESCRIPTION:
--- This test models a possible usage paradigm for the type:
--- Ada.Exceptions.Exception_Occurrence.
---
--- A generic package takes access to procedure types (allowing it to
--- be used at any accessibility level) and defines a "fail soft"
--- procedure that takes designators to a procedure to call, a
--- procedure to call in the event that it fails, and a function to
--- call to determine the next action.
---
--- In the event an exception occurs on the call to the first procedure,
--- the exception is stored in a stack; along with the designator to the
--- procedure that caused it; allowing the procedure to be called again,
--- or the exception to be re-raised.
---
--- A full implementation of such a tool would use a more robust storage
--- mechanism, and would provide a more flexible interface.
---
---
--- CHANGE HISTORY:
--- 29 MAR 96 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1 release
---
---!
-
------------------------------------------------------------------ CB40005_0
-
-with Ada.Exceptions;
-generic
- type Proc_Pointer is access procedure;
- type Func_Pointer is access function return Proc_Pointer;
-package CB40005_0 is -- Fail_Soft
-
-
- procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
- Proc_To_Call_On_Exception : Proc_Pointer := null;
- Retry_Routine : Func_Pointer := null );
-
- function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence;
-
- function Top_Event_Procedure return Proc_Pointer;
-
- procedure Pop_Event;
-
- function Event_Stack_Size return Natural;
-
-end CB40005_0; -- Fail_Soft
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0
-
-with Report;
-package body CB40005_0 is
-
- type History_Event is record
- Exception_Event : Ada.Exceptions.Exception_Occurrence_Access;
- Procedure_Called : Proc_Pointer;
- end record;
-
- procedure Store_Event( Proc_Called : Proc_Pointer;
- Error : Ada.Exceptions.Exception_Occurrence );
-
- procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
- Proc_To_Call_On_Exception : Proc_Pointer := null;
- Retry_Routine : Func_Pointer := null ) is
-
- Current_Proc_To_Call : Proc_Pointer := Proc_To_Call;
-
- begin
- while Current_Proc_To_Call /= null loop
- begin
- Current_Proc_To_Call.all; -- call procedure through pointer
- Current_Proc_To_Call := null;
- exception
- when Capture: others =>
- Store_Event( Current_Proc_To_Call, Capture );
- if Proc_To_Call_On_Exception /= null then
- Proc_To_Call_On_Exception.all;
- end if;
- if Retry_Routine /= null then
- Current_Proc_To_Call := Retry_Routine.all;
- else
- Current_Proc_To_Call := null;
- end if;
- end;
- end loop;
- end Fail_Soft_Call;
-
- Stack : array(1..10) of History_Event; -- minimal, sufficient for testing
-
- Stack_Top : Natural := 0;
-
- procedure Store_Event( Proc_Called : Proc_Pointer;
- Error : Ada.Exceptions.Exception_Occurrence )
- is
- begin
- Stack_Top := Stack_Top +1;
- Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error),
- Proc_Called );
- end Store_Event;
-
- function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is
- begin
- if Stack_Top > 0 then
- return Stack(Stack_Top).Exception_Event.all;
- else
- return Ada.Exceptions.Null_Occurrence;
- end if;
- end Top_Event_Exception;
-
- function Top_Event_Procedure return Proc_Pointer is
- begin
- if Stack_Top > 0 then
- return Stack(Stack_Top).Procedure_Called;
- else
- return null;
- end if;
- end Top_Event_Procedure;
-
- procedure Pop_Event is
- begin
- if Stack_Top > 0 then
- Stack_Top := Stack_Top -1;
- else
- Report.Failed("Stack Error");
- end if;
- end Pop_Event;
-
- function Event_Stack_Size return Natural is
- begin
- return Stack_Top;
- end Event_Stack_Size;
-
-end CB40005_0;
-
-------------------------------------------------------------------- CB40005
-
-with Report;
-with TCTouch;
-with CB40005_0;
-with Ada.Exceptions;
-procedure CB40005 is
-
- type Proc_Pointer is access procedure;
- type Func_Pointer is access function return Proc_Pointer;
-
- package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer);
-
- procedure Cause_Standard_Exception;
-
- procedure Cause_Visible_Exception;
-
- procedure Cause_Invisible_Exception;
-
- Exception_Procedure_Pointer : Proc_Pointer;
-
- Visible_Exception : exception;
-
- procedure Action_On_Exception;
-
- function Retry_Procedure return Proc_Pointer;
-
- Raise_Error : Boolean;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- procedure Cause_Standard_Exception is
- begin
- TCTouch.Touch('S'); --------------------------------------------------- S
- if Raise_Error then
- raise Constraint_Error;
- end if;
- end Cause_Standard_Exception;
-
- procedure Cause_Visible_Exception is
- begin
- TCTouch.Touch('V'); --------------------------------------------------- V
- if Raise_Error then
- raise Visible_Exception;
- end if;
- end Cause_Visible_Exception;
-
- procedure Cause_Invisible_Exception is
- Invisible_Exception : exception;
- begin
- TCTouch.Touch('I'); --------------------------------------------------- I
- if Raise_Error then
- raise Invisible_Exception;
- end if;
- end Cause_Invisible_Exception;
-
- procedure Action_On_Exception is
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
- end Action_On_Exception;
-
- function Retry_Procedure return Proc_Pointer is
- begin
- TCTouch.Touch('R'); --------------------------------------------------- R
- return Action_On_Exception'Access;
- end Retry_Procedure;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("CB40005", "Check that exceptions raised in non-generic " &
- "code can be handled by a procedure in a generic " &
- "package. Check that the exception identity can " &
- "be properly retrieved from the generic code and " &
- "used by the non-generic code" );
-
- -- first, check that the no exception cases cause no action on the stack
- Raise_Error := False;
-
- Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S
-
- Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V
- Action_On_Exception'Access,
- Retry_Procedure'Access );
-
- Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I
- null,
- Retry_Procedure'Access );
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack");
-
- TCTouch.Validate( "SVI", "Non error case check" );
-
- -- second, check that error cases add to the stack
- Raise_Error := True;
-
- Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S
-
- Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V
- Action_On_Exception'Access, -- A
- Retry_Procedure'Access ); -- RA
-
- Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I
- null,
- Retry_Procedure'Access ); -- RA
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3");
-
- TCTouch.Validate( "SVARAIRA", "Error case check" );
-
- -- check that the exceptions and procedure were stored correctly
- -- on the stack
- Raise_Error := False;
-
- -- return procedure pointer from top of stack and call the procedure
- -- through that pointer:
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "I", "Invisible case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("1: Exception not raised");
- exception
- when Constraint_Error => Report.Failed("1: Raised Constraint_Error");
- when Visible_Exception => Report.Failed("1: Raised Visible_Exception");
- when others => null; -- expected case
- end;
-
- Fail_Soft.Pop_Event;
-
- -- return procedure pointer from top of stack and call the procedure
- -- through that pointer:
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "V", "Visible case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("2: Exception not raised");
- exception
- when Constraint_Error => Report.Failed("2: Raised Constraint_Error");
- when Visible_Exception => null; -- expected case
- when others => Report.Failed("2: Raised Invisible_Exception");
- end;
-
- Fail_Soft.Pop_Event;
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "S", "Standard case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("3: Exception not raised");
- exception
- when Constraint_Error => null; -- expected case
- when Visible_Exception => Report.Failed("3: Raised Visible_Exception");
- when others => Report.Failed("3: Raised Invisible_Exception");
- end;
-
- Fail_Soft.Pop_Event;
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops");
-
- Report.Result;
-
-end CB40005;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada
deleted file mode 100644
index 010add1..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- CB4001A.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 ANY EXCEPTION RAISED IN THE STATEMENT SEQUENCE OF A
--- SUBPROGRAM IS PROPAGATED TO THE CALLER OF THE SUBPROGRAM, NOT TO THE
--- STATICALLY ENCLOSING LEXICAL ENVIRONMENT.
-
--- RM 05/30/80
--- JRK 11/19/80
--- SPS 03/28/83
--- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
-
-WITH REPORT;
-PROCEDURE CB4001A IS
-
- USE REPORT;
-
- E1 : EXCEPTION;
- I9 : INTEGER RANGE 1..10 ;
- FLOW_COUNT : INTEGER := 0 ;
-
-BEGIN
- TEST("CB4001A","CHECK THAT ANY EXCEPTION RAISED IN THE " &
- "STATEMENT SEQUENCE OF A SUBPROGRAM IS " &
- "PROPAGATED TO THE CALLER, NOT TO THE STATICALLY ENCLOSING" &
- " LEXICAL ENVIRONMENT");
-
- BEGIN -- BLOCK WITH HANDLERS; LEX. ENVIRONMT FOR ALL PROC.DEFS
-
- DECLARE -- BLOCK WITH PROCEDURE DEFINITIONS
-
- PROCEDURE CALLEE1 ;
- PROCEDURE CALLEE2 ;
- PROCEDURE CALLEE3 ;
- PROCEDURE R ;
- PROCEDURE S ;
-
- PROCEDURE CALLER1 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- CALLEE1 ;
- FAILED("EXCEPTION NOT RAISED (CALLER1)");
- EXCEPTION
- WHEN E1 =>
- FLOW_COUNT := FLOW_COUNT + 1 ;
- END ;
-
- PROCEDURE CALLER2 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- CALLEE2 ;
- FAILED("EXCEPTION NOT RAISED (CALLER2)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1 ;
- END ;
-
- PROCEDURE CALLER3 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- CALLEE3 ;
- FAILED("EXCEPTION NOT RAISED (CALLER3)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FLOW_COUNT := FLOW_COUNT + 1 ;
- END ;
-
- PROCEDURE CALLEE1 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- R ;
- FAILED("EXCEPTION NOT RAISED (CALLEE1)");
- END ;
-
- PROCEDURE CALLEE2 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- RAISE CONSTRAINT_ERROR ;
- FAILED("EXCEPTION NOT RAISED (CALLEE2)");
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- FAILED("WRONG EXCEPTION RAISED (CALLEE2)");
- END ;
-
- PROCEDURE CALLEE3 IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 1 ;
- I9 := IDENT_INT(20) ;
- FAILED("EXCEPTION NOT RAISED (CALLEE3)");
- END ;
-
- PROCEDURE R IS
- E2 : EXCEPTION;
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 10 ;
- S ;
- FAILED("EXCEPTION E1 NOT RAISED (PROC R)");
- EXCEPTION
- WHEN E2 =>
- FAILED("WRONG EXCEPTION RAISED (PROC R)");
- END ;
-
- PROCEDURE S IS
- BEGIN
- FLOW_COUNT := FLOW_COUNT + 10 ;
- RAISE E1 ;
- FAILED("EXCEPTION E1 NOT RAISED (PROC S)");
- END ;
-
- BEGIN -- (THE BLOCK WITH PROC. DEFS)
-
- CALLER1;
- CALLER2;
- CALLER3;
-
- END ; -- (THE BLOCK WITH PROC. DEFS)
-
- EXCEPTION
-
- WHEN OTHERS =>
- FAILED("EXCEPTION PROPAGATED STATICALLY");
-
- END ;
-
- IF FLOW_COUNT /= 29 THEN
- FAILED("INCORRECT FLOW_COUNT VALUE");
- END IF;
-
- RESULT;
-END CB4001A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada
deleted file mode 100644
index e3752576..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- CB4002A.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 EXCEPTIONS RAISED DURING ELABORATION OF THE
--- DECLARATIVE PART OF A SUBPROGRAM ARE PROPAGATED TO THE
--- CALLER, FOR CONSTRAINT_ERROR CAUSED BY INITIALIZATION,
--- AND CONSTRAINT ELABORATION, AND FOR FUNCTION EVALUATIONS
--- RAISING CONSTRAINT_ERROR AND A PROGRAMMER-DEFINED EXCEPTION.
-
--- DAT 4/13/81
--- SPS 3/28/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4002A IS
-BEGIN
- TEST("CB4002A", "EXCEPTIONS IN SUBPROGRAM DECLARATIVE_PARTS"
- & " ARE PROPAGATED TO CALLER");
-
- DECLARE
- SUBTYPE I5 IS INTEGER RANGE -5 .. 5;
-
- E : EXCEPTION;
-
- FUNCTION RAISE_IT (I : I5) RETURN INTEGER IS
- J : INTEGER RANGE 0 .. 1 := I;
- BEGIN
- IF I = 0 THEN
- RAISE CONSTRAINT_ERROR;
- ELSIF I = 1 THEN
- RAISE E;
- END IF;
- FAILED ("EXCEPTION NOT RAISED 0");
- RETURN J;
- EXCEPTION
- WHEN OTHERS =>
- IF I NOT IN 0 .. 1 THEN
- FAILED ("WRONG HANDLER 0");
- RETURN 0;
- ELSE
- RAISE;
- END IF;
- END RAISE_IT;
-
- PROCEDURE P1 (P : INTEGER) IS
- Q : INTEGER := RAISE_IT (P);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 1");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER 1");
- END P1;
-
- PROCEDURE P2 (P : INTEGER) IS
- Q : I5 RANGE 0 .. P := 1;
- BEGIN
- IF P = 0 OR P > 5 THEN
- FAILED ("EXCEPTION NOT RAISED 2");
- END IF;
- END P2;
-
- BEGIN
-
- BEGIN
- P1(-1);
- FAILED ("EXCEPTION NOT RAISED 2A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
-
- BEGIN
- P1(0);
- FAILED ("EXCEPTION NOT RAISED 3");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
-
- BEGIN
- P1(1);
- FAILED ("EXCEPTION NOT RAISED 4");
- EXCEPTION
- WHEN E => NULL;
- END;
-
- BEGIN
- P2(0);
- FAILED ("EXCEPTION NOT RAISED 5");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
-
- BEGIN
- P2(6);
- FAILED ("EXCEPTION NOT RAISED 6");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
-
- EXCEPTION
- WHEN OTHERS => FAILED ("WRONG EXCEPTION OR HANDLER");
- END;
-
- RESULT;
-EXCEPTION
- WHEN OTHERS => FAILED ("WRONG HANDLER FOR SURE"); RESULT;
-END CB4002A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada
deleted file mode 100644
index 7f1aaf5..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- CB4003A.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 EXCEPTIONS RAISED DURING ELABORATION OF PACKAGE
--- SPECIFICATIONS, OR DECLARATIVE_PARTS OF BLOCKS AND PACKAGE
--- BODIES, ARE PROPAGATED TO THE STATIC ENVIRONMENT. EXCEPTIONS
--- ARE CAUSED BY INITIALIZATIONS AND FUNCTION CALLS.
-
--- HISTORY:
--- DAT 04/14/81 CREATED ORIGINAL TEST.
--- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4003A IS
-
- E : EXCEPTION;
-
- FUNCTION F (B : BOOLEAN) RETURN INTEGER IS
- BEGIN
- IF B THEN
- RAISE E;
- ELSE
- RETURN 1;
- END IF;
- END F;
-
-BEGIN
- TEST ("CB4003A", "CHECK THAT EXCEPTIONS DURING ELABORATION"
- & " OF DECLARATIVE PARTS"
- & " IN BLOCKS, PACKAGE SPECS, AND PACKAGE BODIES ARE"
- & " PROPAGATED TO STATIC ENCLOSING ENVIRONMENT");
-
- BEGIN
- DECLARE
- PACKAGE P1 IS
- I : INTEGER RANGE 1 .. 1 := 2;
- END P1;
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 1");
- IF NOT EQUAL(P1.I,P1.I) THEN
- COMMENT ("NO EXCEPTION RAISED");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("WRONG HANDLER 1");
- END;
- FAILED ("EXCEPTION NOT RAISED 1A");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION 1");
- END;
-
- FOR L IN IDENT_INT(1) .. IDENT_INT(4) LOOP
- BEGIN
- DECLARE
- PACKAGE P2 IS
- PRIVATE
- J : INTEGER RANGE 2 .. 4 := L;
- END P2;
-
- Q : INTEGER := F(L = 3);
-
- PACKAGE BODY P2 IS
- K : INTEGER := F(L = 2);
-
- BEGIN
- IF NOT (EQUAL(J,J) OR EQUAL(K,K)) THEN
- COMMENT("CAN'T OPTIMIZE THIS");
- END IF;
- END P2;
- BEGIN
- IF L /= 4 THEN
- FAILED ("EXCEPTION NOT RAISED 2");
- END IF;
-
- IF NOT EQUAL(Q,Q) THEN
- COMMENT("CAN'T OPTIMIZE THIS");
- END IF;
-
- EXIT;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION HANDLER 2");
- EXIT;
- END;
- FAILED ("EXCEPTION NOT RAISED 2A");
- EXCEPTION
- WHEN E | CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2");
- END;
- END LOOP;
-
- RESULT;
-
-END CB4003A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada
deleted file mode 100644
index 228d0a4..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CB4004A.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 VARIOUS EXCEPTIONS IN THE BODY OF A SUBPROGRAM WITH
--- AN APPLICABLE HANDLER ARE HANDLED LOCALLY.
-
--- DAT 04/15/81
--- JRK 04/24/81
--- SPS 11/02/82
--- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4004A IS
-
- E, F : EXCEPTION;
- STORAGE_ERROR: EXCEPTION;
-
- I1 : INTEGER RANGE 1 .. 1;
-
- FUNCTION F1 (I : INTEGER) RETURN BOOLEAN IS
- BEGIN
- CASE I IS
- WHEN 1 => RAISE E;
- WHEN 2 => RAISE STORAGE_ERROR;
- WHEN 3 => I1 := 4;
- WHEN 4 => RAISE TASKING_ERROR;
- WHEN OTHERS => NULL;
- END CASE;
- RETURN FALSE;
- EXCEPTION
- WHEN E | F => RETURN I = 1;
- WHEN STORAGE_ERROR => RETURN I = 2;
- WHEN PROGRAM_ERROR | CONSTRAINT_ERROR =>
- RETURN I = 3;
- WHEN OTHERS => RETURN I = 4;
- END F1;
-
-BEGIN
- TEST ("CB4004A", "EXCEPTIONS WITH LOCAL HANDLERS ARE HANDLED"
- & " THERE");
-
- BEGIN
- FOR L IN 1 .. 4 LOOP
- IF F1(L) /= TRUE THEN
- FAILED ("LOCAL EXCEPTIONS DON'T WORK");
- EXIT;
- END IF;
- END LOOP;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG HANDLER");
- END;
-
- RESULT;
-END CB4004A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada
deleted file mode 100644
index 5b68ac3..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CB4005A.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 EXCEPTIONS PROPAGATED OUT OF A HANDLER ARE PROPAGATED
--- OUTSIDE THE ENCLOSING UNIT.
-
--- DAT 4/15/81
--- SPS 3/28/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4005A IS
-
- E , F : EXCEPTION;
-
- B : BOOLEAN := FALSE;
-
- PROCEDURE P IS
- BEGIN
- RAISE E;
- EXCEPTION
- WHEN F => FAILED ("WRONG HANDLER 1");
- WHEN E =>
- IF B THEN
- FAILED ("WRONG HANDLER 2");
- ELSE
- B := TRUE;
- RAISE F;
- END IF;
- END P;
-
-BEGIN
- TEST ("CB4005A", "EXCEPTIONS FROM HANDLERS ARE PROPAGATED " &
- "OUTSIDE");
-
- BEGIN
- P;
- FAILED ("EXCEPTION NOT PROPAGATED 1");
- EXCEPTION
- WHEN F => NULL;
- WHEN OTHERS => FAILED ("WRONG HANDLER 3");
- END;
-
- RESULT;
-END CB4005A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada
deleted file mode 100644
index b0ddfc5..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- CB4006A.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 EXCEPTIONS IN A BLOCK IN A HANDLER
--- ARE HANDLED CORRECTLY.
-
--- HISTORY:
--- DAT 04/15/81
--- SPS 11/02/82
--- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
--- JRL 05/28/92 CHANGED CODE IN PROGRAM_ERROR BLOCK TO
--- PREVENT OPTIMIZATION.
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CB4006A IS
-
- I1 : INTEGER RANGE 1 .. 2 := 1;
-
- PROCEDURE P IS
- BEGIN
- IF EQUAL(3,3) THEN
- RAISE PROGRAM_ERROR;
- END IF;
- EXCEPTION
- WHEN PROGRAM_ERROR =>
- DECLARE
- I : INTEGER RANGE 1 .. 1 := I1;
- BEGIN
- IF EQUAL(I,I) THEN
- I := I1 + 1;
- END IF ;
- FAILED ("EXCEPTION NOT RAISED 1");
-
- IF NOT EQUAL(I,I) THEN
- COMMENT ("CAN'T OPTIMIZE THIS");
- END IF;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I1 /= 1 THEN
- FAILED ("WRONG HANDLER 1");
- ELSE
- I1 := I1 + 1;
- END IF;
- END;
- WHEN CONSTRAINT_ERROR =>
- FAILED ("WRONG HANDLER 3");
- END P;
-
-BEGIN
- TEST ("CB4006A", "CHECK THAT EXCEPTIONS IN BLOCKS IN " &
- "HANDLERS WORK");
-
- P;
- IF IDENT_INT(I1) /= 2 THEN
- FAILED ("EXCEPTION NOT HANDLED CORRECTLY");
- ELSE
- BEGIN
- P;
- FAILED ("EXCEPTION NOT RAISED CORRECTLY 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- END;
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS => FAILED ("WRONG HANDLER 2");
- RESULT;
-
-END CB4006A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada
deleted file mode 100644
index 789d1b3..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CB4007A.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 STATEMENT PART OF A PACKAGE CAN RAISE, PROPAGATE,
--- AND HANDLE EXCEPTIONS. IF THE BODY'S HANDLERS HANDLE ALL
--- EXCEPTIONS RAISED AND DO NOT RAISE ANY UNHANDLED EXCEPTIONS,
--- NO EXCEPTION IS PROPAGATED.
-
--- HISTORY:
--- DHH 03/28/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CB4007A IS
-BEGIN
-
- TEST("CB4007A", "CHECK THAT THE STATEMENT PART OF A PACKAGE " &
- "CAN RAISE, PROPAGATE, AND HANDLE EXCEPTIONS. " &
- "IF THE BODY'S HANDLERS HANDLE ALL EXCEPTIONS " &
- "RAISED AND DO NOT RAISE ANY UNHANDLED " &
- "EXCEPTIONS, NO EXCEPTION IS PROPAGATED");
- DECLARE
-
- PACKAGE OUTSIDE IS
- END OUTSIDE;
-
- PACKAGE BODY OUTSIDE IS
-
- BEGIN
- DECLARE
- PACKAGE HANDLER IS
- END HANDLER;
-
- PACKAGE BODY HANDLER IS
- BEGIN
- DECLARE
- PACKAGE PROPAGATE IS
- END PROPAGATE;
-
- PACKAGE BODY PROPAGATE IS
- BEGIN
- DECLARE
- PACKAGE RISE IS
- END RISE;
-
- PACKAGE BODY RISE IS
- BEGIN
- RAISE CONSTRAINT_ERROR;
- FAILED("EXCEPTION " &
- "NOT RAISED");
- END RISE;
-
- BEGIN
- NULL;
- END; -- PACKAGE PROPAGATE DECLARE.
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- RAISE CONSTRAINT_ERROR;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION " &
- "RAISED IN PROPAGATE " &
- "PACKAGE");
- END PROPAGATE;
-
- BEGIN
- NULL;
- END; -- PACKAGE HANDLER DECLARE.
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN " &
- "HANDLER PACKAGE");
- END HANDLER;
-
- BEGIN
- NULL;
- END; -- PACKAGE OUTSIDE DECLARE.
- EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED IN OUTSIDE " &
- "PACKAGE");
- END OUTSIDE;
- BEGIN
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED");
- RESULT;
-END CB4007A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada
deleted file mode 100644
index 741a7a8..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- CB4008A.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 NESTED LAST WISHES EXCEPTION HANDLERS WORK
--- (FOR PROCEDURES).
-
--- DAT 4/15/81
--- SPS 3/28/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4008A IS
-
- C : INTEGER := 0;
-
- E : EXCEPTION;
-
- DEPTH : CONSTANT := 99;
-
- PROCEDURE F;
-
- PROCEDURE I IS
- BEGIN
- C := C + 1;
- IF C >= DEPTH THEN
- RAISE E;
- END IF;
- END I;
-
- PROCEDURE O IS
- BEGIN
- C := C - 1;
- END O;
-
- PROCEDURE X IS
- PROCEDURE X1 IS
- PROCEDURE X2 IS
- BEGIN
- F;
- END X2;
-
- PROCEDURE X3 IS
- BEGIN
- I;
- X2;
- EXCEPTION
- WHEN E => O; RAISE;
- END X3;
- BEGIN
- I;
- X3;
- EXCEPTION
- WHEN E => O; RAISE;
- END X1;
-
- PROCEDURE X1A IS
- BEGIN
- I;
- X1;
- FAILED ("INCORRECT EXECUTION SEQUENCE");
- EXCEPTION
- WHEN E => O; RAISE;
- END X1A;
- BEGIN
- I;
- X1A;
- EXCEPTION
- WHEN E => O; RAISE;
- END X;
-
- PROCEDURE Y IS
- BEGIN
- I;
- X;
- EXCEPTION WHEN E => O; RAISE;
- END Y;
-
- PROCEDURE F IS
- PROCEDURE F2;
-
- PROCEDURE F1 IS
- BEGIN
- I;
- F2;
- EXCEPTION WHEN E => O; RAISE;
- END F1;
-
- PROCEDURE F2 IS
- BEGIN
- I;
- Y;
- EXCEPTION WHEN E => O; RAISE;
- END F2;
- BEGIN
- I;
- F1;
- EXCEPTION WHEN E => O; RAISE;
- END F;
-
-BEGIN
- TEST ("CB4008A", "(PROCEDURE) LAST WISHES UNWIND PROPERLY");
-
- BEGIN
- I;
- Y;
- FAILED ("INCORRECT EXECUTION SEQUENCE 2");
- EXCEPTION
- WHEN E =>
- O;
- IF C /= 0 THEN
- FAILED ("EXCEPTION HANDLER MISSED SOMEWHERE");
- END IF;
- END;
-
- RESULT;
-END CB4008A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada
deleted file mode 100644
index 98f009e..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada
+++ /dev/null
@@ -1,114 +0,0 @@
--- CB4009A.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 PROGRAMMER DEFINED EXCEPTION AND A REDECLARED
--- PREDEFINED EXCEPTION MAY BE PROPAGATED OUT OF SCOPE AND BACK IN,
--- WITH OUT-OF-SCOPE 'OTHERS' HANDLERS HANDLING THE EXCEPTION
--- INSTEAD OF OTHER HANDLERS. SEPARATELY COMPILED UNITS ARE NOT TESTED.
-
--- DAT 4/15/81
--- SPS 1/14/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CB4009A IS
-
- E : EXCEPTION;
-
- I : INTEGER := 0;
-
- PROCEDURE P1 (C : INTEGER);
- PROCEDURE P2 (C : INTEGER);
- PROCEDURE P3 (C : INTEGER);
-
- F : BOOLEAN := FALSE;
- T : CONSTANT BOOLEAN := TRUE;
-
- PROCEDURE P1 (C : INTEGER) IS
- BEGIN
- P3(C);
- EXCEPTION
- WHEN E => F := T;
- WHEN CONSTRAINT_ERROR => F := T;
- WHEN OTHERS => I := I + 1; RAISE;
- END P1;
-
- PROCEDURE P2 (C : INTEGER) IS
- E : EXCEPTION;
- CONSTRAINT_ERROR : EXCEPTION;
- BEGIN
- CASE C IS
- WHEN 0 => FAILED ("WRONG CASE");
- WHEN 1 => RAISE E;
- WHEN -1 => RAISE CONSTRAINT_ERROR;
- WHEN OTHERS => P1 (C - C/ABS(C));
- END CASE;
- EXCEPTION
- WHEN E =>
- I := I + 100; RAISE;
- WHEN CONSTRAINT_ERROR =>
- I := I + 101; RAISE;
- WHEN OTHERS =>
- F := T;
- END P2;
-
- PROCEDURE P3 (C : INTEGER) IS
- BEGIN
- P2(C);
- EXCEPTION
- WHEN E => F := T;
- WHEN CONSTRAINT_ERROR => F := T;
- END P3;
-
-BEGIN
- TEST ("CB4009A", "EXCEPTIONS PROPAGATED OUT OF SCOPE");
-
- I := 0;
- BEGIN
- P3 (-2);
- FAILED ("EXCEPTION NOT RAISED 1");
- EXCEPTION
- WHEN OTHERS => NULL;
- END;
- IF I /= 203 THEN
- FAILED ("INCORRECT HANDLER SOMEWHERE 1");
- END IF;
-
- I := 0;
- BEGIN
- P3(3);
- FAILED ("EXCEPTION NOT RAISED 2");
- EXCEPTION
- WHEN OTHERS => NULL;
- END;
- IF I /= 302 THEN
- FAILED ("INCORRECT HANDLER SOMEWHERE 2");
- END IF;
-
- IF F = T THEN
- FAILED ("WRONG HANDLER SOMEWHERE");
- END IF;
-
- RESULT;
-END CB4009A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada b/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada
deleted file mode 100644
index 655b800..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- CB4013A.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 UNHANDLED EXCEPTION RAISED IN A TASK BODY, BUT
--- OUTSIDE AN ACCEPT STATEMENT, RAISES NO EXCEPTION OUTSIDE THE
--- TASK.
-
--- HISTORY:
--- DHH 03/29/88 CREATED ORIGINAL TEST.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CB4013A IS
-
- TASK TYPE CHOICE IS
- ENTRY E1;
- ENTRY STOP;
- END CHOICE;
-
- T : CHOICE;
-
- TASK BODY CHOICE IS
- BEGIN
- ACCEPT E1;
- IF EQUAL(3,3) THEN
- RAISE CONSTRAINT_ERROR;
- END IF;
- ACCEPT STOP;
- END CHOICE;
-
-BEGIN
-
- TEST("CB4013A", "CHECK THAT AN UNHANDLED EXCEPTION RAISED IN " &
- "A TASK BODY, BUT OUTSIDE AN ACCEPT STATEMENT, " &
- "RAISES NO EXCEPTION OUTSIDE THE TASK");
-
- T.E1;
- DELAY 1.0;
- IF T'CALLABLE THEN
- FAILED("TASK NOT COMPLETED ON RAISING CONSTRAINT_ERROR");
- T.STOP;
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN TASKING_ERROR =>
- FAILED("TASKING_ERROR RAISED OUTSIDE TASK");
- RESULT;
-
- WHEN CONSTRAINT_ERROR =>
- FAILED("CONSTRAINT_ERROR PROPAGATED OUTSIDE TASK");
- RESULT;
-
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED");
- RESULT;
-END CB4013A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a b/gcc/testsuite/ada/acats/tests/cb/cb40a01.a
deleted file mode 100644
index 1c56911..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a
+++ /dev/null
@@ -1,135 +0,0 @@
--- CB40A01.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 user defined exception is correctly propagated out of
--- a public child package.
---
--- TEST DESCRIPTION:
--- Declare a public child package containing a procedure used to
--- analyze the alphanumeric content of a particular text string.
--- The procedure contains a processing loop that continues until the
--- range of the text string is exceeded, at which time a user defined
--- exception is raised. This exception propagates out of the procedure
--- through the parent package, to the main test program.
---
--- Exception Type Raised:
--- * User Defined
--- Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- * Public Child Package
--- Private Child Package
--- Public Child Subprogram
--- Private Child Subprogram
---
--- TEST FILES:
--- This test depends on the following foundation code:
--- FB40A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package FB40A00.CB40A01_0 is -- package Text_Parser.Processing
-
- procedure Process_Text (Text : in String_Pointer_Type);
-
-end FB40A00.CB40A01_0;
-
-
- --=================================================================--
-
-
-with Report;
-
-package body FB40A00.CB40A01_0 is
-
- procedure Process_Text (Text : in String_Pointer_Type) is
- Pos : Natural := Text'First - 1;
- begin
- loop -- Process string, raise exception upon completion.
- Pos := Pos + 1;
- if Pos > Text.all'Last then
- raise Completed_Text_Processing;
- elsif (Text.all (Pos) in 'A' .. 'Z') or
- (Text.all (Pos) in 'a' .. 'z') or
- (Text.all (Pos) in '0' .. '9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
- -- No exception handler here, exception propagates.
- Report.Failed ("No exception raised in child package subprogram");
- end Process_Text;
-
-end FB40A00.CB40A01_0;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A01_0;
-with Report;
-
-procedure CB40A01 is
-
- String_Pointer : FB40A00.String_Pointer_Type :=
- new String'("'Twas the night before Christmas, " &
- "and all through the house...");
-
-begin
-
- Process_Block:
- begin
-
- Report.Test ("CB40A01", "Check that a user defined exception " &
- "is correctly propagated out of a " &
- "public child package");
-
- FB40A00.CB40A01_0.Process_Text (String_Pointer);
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when FB40A00.Completed_Text_Processing => -- Correct exception
- if FB40A00.AlphaNumeric_Count /= 48 then -- propagation.
- Report.Failed ("Incorrect string processing");
- end if;
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A01;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a b/gcc/testsuite/ada/acats/tests/cb/cb40a020.a
deleted file mode 100644
index 09830b8..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a
+++ /dev/null
@@ -1,95 +0,0 @@
--- CB40A020.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:
--- See CB40A021.AM.
---
--- TEST DESCRIPTION:
--- See CB40A021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- => CB40A020.A
--- CB40A021.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-
-package FB40A00.CB40A020_0 is -- package Text_Parser.Processing
-
- function Count_AlphaNumerics (Text : in String) return Natural;
-
-end FB40A00.CB40A020_0;
-
-
- --=================================================================--
-
-
--- Text_Parser.Processing.Process_Text
-with Report;
-private procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String);
-
-procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String) is
- Pos : Natural := Text'First - 1;
-begin
- loop -- Process string, raise exception upon completion.
- Pos := Pos + 1;
- if Pos > Text'Last then
- raise Completed_Text_Processing;
- elsif (Text (Pos) in 'A' .. 'Z') or
- (Text (Pos) in 'a' .. 'z') or
- (Text (Pos) in '0' .. '9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
- -- No exception handler here, exception propagates.
- Report.Failed ("No exception raised in child package subprogram");
-end FB40A00.CB40A020_0.CB40A020_1;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A020_0.CB40A020_1; -- "with" of private child subprogram
- -- Text_Parser.Processing.Process_Text
-package body FB40A00.CB40A020_0 is
-
- function Count_AlphaNumerics (Text : in String) return Natural is
- begin
- FB40A00.CB40A020_0.CB40A020_1 (Text); -- Call prvt child proc.
- return (AlphaNumeric_Count); -- Global maintained in parent.
- -- No exception handler here, exception propagates.
- end Count_AlphaNumerics;
-
-end FB40A00.CB40A020_0;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a021.am b/gcc/testsuite/ada/acats/tests/cb/cb40a021.am
deleted file mode 100644
index 027b7da..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a021.am
+++ /dev/null
@@ -1,103 +0,0 @@
--- CB40A021.AM
---
--- 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 user defined exception is correctly propagated from a
--- private child subprogram to its parent and then to a client of the
--- parent.
---
--- TEST DESCRIPTION:
--- Declare a child package containing a function. The body of the
--- function contains a call to a private child subprogram (child of
--- the child). The private child subprogram raises an exception
--- defined in the root ancestor package, and it is propagated to the
--- test program.
---
--- Exception Type Raised:
--- * User Defined
--- Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- * Visible Child Package
--- Private Child Package
--- Visible Child Subprogram
--- * Private Child Subprogram
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- CB40A020.A
--- => CB40A021.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-
-with Report;
-with FB40A00.CB40A020_0; -- Explicit "with" of Text_Parser.Processing
- -- Implicit "with" of Text_Parser (FB40A00)
-
-procedure CB40A021 is
-
- String_Constant : constant String :=
- "ACVC Version 2.0 will incorporate Ada 9X feature tests.";
-
- Number_Of_AlphaNumeric_Characters : Natural := 0;
-
-begin
-
- Process_Block:
- begin
-
- Report.Test ("CB40A021", "Check that a user defined exception " &
- "is correctly propagated across " &
- "package and subprogram boundaries");
-
- Number_Of_AlphaNumeric_Characters :=
- FB40A00.CB40A020_0.Count_AlphaNumerics (String_Constant);
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when FB40A00.Completed_Text_Processing => -- Correct exception
- if FB40A00.AlphaNumeric_Count /= 45 then -- propagation.
- Report.Failed ("Incorrect string processing");
- end if;
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A021;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a b/gcc/testsuite/ada/acats/tests/cb/cb40a030.a
deleted file mode 100644
index 8b053e2..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a
+++ /dev/null
@@ -1,105 +0,0 @@
--- CB40A030.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:
--- See CB40A031.AM.
---
--- TEST DESCRIPTION:
--- See CB40A031.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- => CB40A030.A
--- CB40A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-
-package FB40A00.CB40A030_0 is -- package Text_Parser.Character_Counting
-
- function Count_AlphaNumerics (Text : in String) return Natural;
-
-end FB40A00.CB40A030_0;
-
-
- --=================================================================--
-
-
-private package FB40A00.CB40A030_1 is -- package Text_Parser.Processing
-
- procedure Process_Text (Text : in String);
-
-end FB40A00.CB40A030_1;
-
-
- --=================================================================--
-
-
-package body FB40A00.CB40A030_1 is
-
- procedure Process_Text (Text : in String) is
- Loop_Count : Integer := Text'Length + 1;
- begin
- for Pos in 1..Loop_Count loop -- Process string, force the
- -- raise of Constraint_Error.
- if (Text (Pos) in 'a'..'z') or
- (Text (Pos) in 'A'..'Z') or
- (Text (Pos) in '0'..'9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
-
- end loop;
- -- No exception handler here, exception propagates.
- end Process_Text;
-
-end FB40A00.CB40A030_1;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A030_1; -- private sibling package Text_Parser.Processing;
-
-package body FB40A00.CB40A030_0 is
-
- function Count_AlphaNumerics (Text : in String) return Natural is
- begin
- FB40A00.CB40A030_1.Process_Text (Text); -- Call proc in prvt child
- -- package that is a
- -- sibling of this package.
- return (AlphaNumeric_Count);
- -- No exception handler here, exception propagates.
- end Count_AlphaNumerics;
-
-end FB40A00.CB40A030_0;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a031.am b/gcc/testsuite/ada/acats/tests/cb/cb40a031.am
deleted file mode 100644
index 6f2f2aa..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a031.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- CB40A031.AM
---
--- 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 predefined exception is correctly propagated from
--- a private child package through a visible child package to a client.
---
--- TEST DESCRIPTION:
--- Declare two child packages from a root package, one visible, one
--- private. The visible child package contains a function, whose
--- body makes a call to a procedure contained in the private sibling
--- package. A predefined exception occurring in the subprogram within the
--- private package is propagated through the visible sibling and ancestor
--- to the test program.
---
--- Exception Type Raised:
--- User Defined
--- * Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- * Visible Child Package
--- * Private Child Package
--- Visible Child Subprogram
--- Private Child Subprogram
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- CB40A030.A
--- => CB40A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-with FB40A00.CB40A030_0; -- Explicit "with" of Text_Parser.Character_Counting
- -- Implicit "with" of Text_Parser
-
-procedure CB40A031 is
-
- String_Constant : constant String :=
- "The San Diego Padres will win the World Series in 1999.";
-
- Number_Of_AlphaNumeric_Characters : Natural := 0;
-
-begin
-
- Process_Block:
- begin
-
- Report.Test ("CB40A031", "Check that a predefined exception " &
- "is correctly propagated across " &
- "package boundaries");
-
- Number_Of_AlphaNumeric_Characters :=
- FB40A00.CB40A030_0.Count_AlphaNumerics (String_Constant);
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when Constraint_Error => -- Correct exception
- if FB40A00.AlphaNumeric_Count /= 44 then -- propagation.
- Report.Failed ("Incorrect string processing");
- end if;
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A031;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a b/gcc/testsuite/ada/acats/tests/cb/cb40a04.a
deleted file mode 100644
index 45209b9..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a
+++ /dev/null
@@ -1,119 +0,0 @@
--- CB40A04.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 predefined exception is correctly propagated out of a
--- public child function to a client.
---
--- TEST DESCRIPTION:
--- Declare a public child subprogram. Define the processing loop
--- inside the subprogram to expect a string with index starting at 1.
--- From the test procedure, call the child subprogram with a slice
--- from the middle of a string variable. This will cause an exception
--- to be raised in the child and propagated to the caller.
---
--- Exception Type Raised:
--- User Defined
--- * Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- Public Child Package
--- Private Child Package
--- * Public Child Subprogram
--- Private Child Subprogram
---
--- TEST FILES:
--- This test depends on the following foundation code:
--- FB40A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
--- Child subprogram Text_Parser.Count_AlphaNumerics
-
-function FB40A00.CB40A04_0 (Text : string) return Natural is
-begin
-
- for I in 1 .. Text'Last loop -- Raise immediate Constraint_Error
- if (Text (I) in 'a'..'z') or -- with String slice passed from
- (Text (I) in 'A'..'Z') or -- caller. (Slice'first /= 1)
- (Text (I) in '0'..'9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
-
- return (AlphaNumeric_Count); -- Global in parent package.
-
- -- No exception handler here, exception propagates.
-
-end FB40A00.CB40A04_0;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A04_0; -- Explicit "with" of Text_Parser.Count_AlphaNumerics
-with Report; -- Implicit "with" of Text_Parser.
-
-procedure CB40A04 is
-
- String_Var : String (1..19) := "The quick brown fox";
-
- Number_Of_AlphaNumeric_Characters : Natural := 0;
-
-begin
-
- Report.Test ("CB40A04", "Check that a predefined exception is " &
- "correctly propagated out of a public " &
- "child function to a client");
-
- Process_Block:
- begin
-
- Number_Of_AlphaNumeric_Characters := -- Provide slice of string
- FB40A00.CB40A04_0 (String_Var (5..10)); -- to subprogram.
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when Constraint_Error => -- Correct exception
- null; -- propagation.
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A04;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41001.a b/gcc/testsuite/ada/acats/tests/cb/cb41001.a
deleted file mode 100644
index 95ad868..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41001.a
+++ /dev/null
@@ -1,213 +0,0 @@
--- CB41001.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 'Identity attribute returns the unique identity of an
--- exception. Check that the Raise_Exception procedure can raise an
--- exception that is specified through the use of the 'Identity attribute,
--- and that Reraise_Occurrence can re-raise an exception occurrence
--- using an exception choice parameter.
---
--- TEST DESCRIPTION:
--- This test uses the capability of the 'Identity attribute, which
--- returns the unique identity of an exception, as an Exception_Id
--- result. This result is used as an input parameter to the procedure
--- Raise_Exception. The exception that results is handled, propagated
--- using the Reraise_Occurrence procedure, and handled again.
--- The above actions are performed for both a user-defined and a
--- predefined exception.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Nov 96 SAIC ACVC 2.1: Modified Propagate_User_Exception.
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41001 is
-
-begin
-
- Report.Test ("CB41001", "Check that the 'Identity attribute returns " &
- "the unique identity of an exception. Check " &
- "that the 'Identity attribute is of type " &
- "Exception_Id. Check that the " &
- "Raise_Exception procedure can raise an " &
- "exception that is specified through the " &
- "use of the 'Identity attribute");
- Test_Block:
- declare
-
- Check_Points : constant := 5;
-
- type Check_Point_Array_Type is array (1..Check_Points) of Boolean;
-
- -- Global array used to track the processing path through the test.
- TC_Check_Points : Check_Point_Array_Type := (others => False);
-
- A_User_Defined_Exception : Exception;
- An_Exception_ID : Ada.Exceptions.Exception_Id :=
- Ada.Exceptions.Null_Id;
-
- procedure Propagate_User_Exception is
- Hidden_Exception : Exception;
- begin
- -- Use the 'Identity function to store the unique identity of a
- -- user defined exception into a variable of type Exception_Id.
-
- An_Exception_ID := A_User_Defined_Exception'Identity;
-
- -- Raise this user defined exception using the result of the
- -- 'Identity attribute.
-
- Ada.Exceptions.Raise_Exception(E => An_Exception_Id);
-
- Report.Failed("User defined exception not raised by " &
- "procedure Propagate_User_Exception");
-
- exception
- when Proc_Excpt : A_User_Defined_Exception => -- Expected exception.
- begin
-
- -- By raising a different exception at this point, the
- -- information associated with A_User_Defined_Exception must
- -- be correctly stacked internally.
-
- Ada.Exceptions.Raise_Exception(Hidden_Exception'Identity);
- Report.Failed("Hidden_Exception not raised by " &
- "procedure Propagate_User_Exception");
- exception
- when others =>
- TC_Check_Points(1) := True;
-
- -- Reraise the original exception, which will be propagated
- -- outside the scope of this procedure.
-
- Ada.Exceptions.Reraise_Occurrence(Proc_Excpt);
- Report.Failed("User defined exception not reraised");
-
- end;
-
- when others =>
- Report.Failed("Unexpected exception raised by " &
- "Procedure Propagate_User_Exception");
- end Propagate_User_Exception;
-
- begin
-
- User_Exception_Block:
- begin
- -- Call procedure to raise, handle, and reraise a user defined
- -- exception.
- Propagate_User_Exception;
-
- Report.Failed("User defined exception not propagated from " &
- "procedure Propagate_User_Exception");
-
- exception
- when A_User_Defined_Exception => -- Expected exception.
- TC_Check_Points(2) := True;
- when others =>
- Report.Failed
- ("Unexpected exception handled in User_Exception_Block");
- end User_Exception_Block;
-
-
- Predefined_Exception_Block:
- begin
-
- Inner_Block:
- begin
-
- begin
- -- Use the 'Identity attribute as an input parameter to the
- -- Raise_Exception procedure.
-
- Ada.Exceptions.Raise_Exception(Constraint_Error'Identity);
- Report.Failed("Constraint_Error not raised in Inner_Block");
-
- exception
- when Excpt : Constraint_Error => -- Expected exception.
- TC_Check_Points(3) := True;
-
- -- Reraise the exception.
- Ada.Exceptions.Reraise_Occurrence(X => Excpt);
- Report.Failed("Predefined exception not raised from " &
- "within the exception handler - 1");
- when others =>
- Report.Failed("Incorrect result from attempt to raise " &
- "Constraint_Error using the 'Identity " &
- "attribute - 1");
- end;
-
- Report.Failed("Constraint_Error not reraised in Inner_Block");
-
- exception
- when Block_Excpt : Constraint_Error => -- Expected exception.
- TC_Check_Points(4) := True;
-
- -- Reraise the exception in a scope where the exception
- -- was not originally raised.
-
- Ada.Exceptions.Reraise_Occurrence(X => Block_Excpt);
- Report.Failed("Predefined exception not raised from " &
- "within the exception handler - 2");
-
- when others =>
- Report.Failed("Incorrect result from attempt to raise " &
- "Constraint_Error using the 'Identity " &
- "attribute - 2");
- end Inner_Block;
-
- Report.Failed("Exception not propagated from Inner_Block");
-
- exception
- when Constraint_Error => -- Expected exception.
- TC_Check_Points(5) := True;
- when others =>
- Report.Failed("Unexpected exception handled after second " &
- "reraise of Constraint_Error");
- end Predefined_Exception_Block;
-
-
- -- Verify the processing path taken through the test.
-
- for i in 1..Check_Points loop
- if not TC_Check_Points(i) then
- Report.Failed("Incorrect processing path taken through test, " &
- "didn't pass check point #" & Integer'Image(i));
- end if;
- end loop;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41001;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41002.a b/gcc/testsuite/ada/acats/tests/cb/cb41002.a
deleted file mode 100644
index 1b38981..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41002.a
+++ /dev/null
@@ -1,283 +0,0 @@
--- CB41002.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 message string input parameter in a call to the
--- Raise_Exception procedure is associated with the raised exception
--- occurrence, and that the message string can be obtained using the
--- Exception_Message function with the associated Exception_Occurrence
--- object. Check that Function Exception_Information is available
--- to provide implementation-defined information about the exception
--- occurrence.
---
--- TEST DESCRIPTION:
--- This test checks that a message associated with a raised exception
--- is propagated with the exception, and can be retrieved using the
--- Exception_Message function. The exception will be raised using the
--- 'Identity attribute as a parameter to the Raise_Exception procedure,
--- and an associated message string will be provided. The exception
--- will be handled, and the message associated with the occurrence will
--- be compared to the original source message (non-default).
---
--- The test also includes a simulated logging procedure
--- (Check_Exception_Information) that checks that Exception_Information
--- can be called.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Jun 00 RLB Added a check at Exception_Information can be
--- called.
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41002 is
-begin
-
- Report.Test ("CB41002", "Check that the message string input parameter " &
- "in a call to the Raise_Exception procedure is " &
- "associated with the raised exception " &
- "occurrence, and that the message string can " &
- "be obtained using the Exception_Message " &
- "function with the associated " &
- "Exception_Occurrence object. Also check that " &
- "the Exception_Information function can be called");
-
- Test_Block:
- declare
-
- Number_Of_Exceptions : constant := 3;
-
- User_Exception_1,
- User_Exception_2,
- User_Exception_3 : exception;
-
- type String_Ptr is access String;
-
- User_Messages : constant array (1..Number_Of_Exceptions)
- of String_Ptr :=
- (new String'("Msg"),
- new String'("This message will override the default " &
- "message provided by the implementation"),
- new String'("The message can be captured by procedure" & -- 200 chars
- " Exception_Message. It is designed to b" &
- "e exactly 200 characters in length, sinc" &
- "e there is a permission concerning the " &
- "truncation of a message over 200 chars. "));
-
- procedure Check_Exception_Information (
- Occur : in Ada.Exceptions.Exception_Occurrence) is
- -- Simulates an error logging routine.
- Info : constant String :=
- Ada.Exceptions.Exception_Information (Occur);
- function Is_Substring_of (Target, Search : in String) return Boolean is
- -- Returns True if Search is a substring of Target, and False
- -- otherwise.
- begin
- for I in Report.Ident_Int(Target'First) ..
- Target'Last - Search'Length + 1 loop
- if Target(I .. I+Search'Length-1) = Search then
- return True;
- end if;
- end loop;
- return False;
- end Is_Substring_of;
- begin
- -- We can't display Info, as it often contains line breaks
- -- (confusing Report), and might look much like the failure of a test
- -- with an unhandled exception (thus confusing grading tools).
- --
- -- We don't particular care if the implementation advice is followed,
- -- but we make these checks to insure that a compiler cannot optimize
- -- away Info or the rest of this routine.
- if not Is_Substring_of (Info,
- Ada.Exceptions.Exception_Name (Occur)) then
- Report.Comment ("Exception_Information does not contain " &
- "Exception_Name - see 11.4.1(19)");
- elsif not Is_Substring_of (Info,
- Ada.Exceptions.Exception_Message (Occur)) then
- Report.Comment ("Exception_Information does not contain " &
- "Exception_Message - see 11.4.1(19)");
- end if;
- end Check_Exception_Information;
-
- begin
-
- for i in 1..Number_Of_Exceptions loop
- begin
-
- -- Raise a user-defined exception with a specific message string.
- case i is
- when 1 =>
- Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
- User_Messages(i).all);
- when 2 =>
- Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
- User_Messages(i).all);
- when 3 =>
- Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
- User_Messages(i).all);
- when others =>
- Report.Failed("Incorrect result from Case statement");
- end case;
-
- Report.Failed
- ("Exception not raised by procedure Exception_With_Message " &
- "for User_Exception #" & Integer'Image(i));
-
- exception
- when Excptn : others =>
-
- begin
- -- The message that is associated with the raising of each
- -- exception is captured here using the Exception_Message
- -- function.
-
- if User_Messages(i).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed
- ("Message captured from exception is not the " &
- "message provided when the exception was raised, " &
- "User_Exception #" & Integer'Image(i));
- end if;
-
- Check_Exception_Information(Excptn);
- end;
- end;
- end loop;
-
-
-
- -- Verify that the exception specific message is carried across
- -- various boundaries:
-
- begin
-
- begin
- Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
- User_Messages(1).all);
- Report.Failed("User_Exception_1 not raised");
- end;
- Report.Failed("User_Exception_1 not propagated");
- exception
- when Excptn : User_Exception_1 =>
-
- if User_Messages(1).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_1 not found");
- end if;
- Check_Exception_Information(Excptn);
-
- when others => Report.Failed("Unexpected exception handled - 1");
- end;
-
-
-
- begin
-
- begin
- Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
- User_Messages(2).all);
- Report.Failed("User_Exception_2 not raised");
- exception
- when Exc : User_Exception_2 =>
-
- -- The exception is reraised here; message should propagate
- -- with exception occurrence.
-
- Ada.Exceptions.Reraise_Occurrence(Exc);
- when others => Report.Failed("User_Exception_2 not handled");
- end;
- Report.Failed("User_Exception_2 not propagated");
- exception
- when Excptn : User_Exception_2 =>
-
- if User_Messages(2).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_2 not found");
- end if;
- Check_Exception_Information(Excptn);
-
- when others => Report.Failed("Unexpected exception handled - 2");
- end;
-
-
- -- Check exception and message propagation across task boundaries.
-
- declare
-
- task Raise_An_Exception is -- single task
- entry Raise_It;
- end Raise_An_Exception;
-
- task body Raise_An_Exception is
- begin
- accept Raise_It do
- Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
- User_Messages(3).all);
- end Raise_It;
- Report.Failed("User_Exception_3 not raised");
- exception
- when Excptn : User_Exception_3 =>
- if User_Messages(3).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed
- ("User_Message_3 not returned inside task body");
- end if;
- Check_Exception_Information(Excptn);
- when others =>
- Report.Failed("Incorrect exception raised in task body");
- end Raise_An_Exception;
-
- begin
- Raise_An_Exception.Raise_It; -- Exception will be propagated here.
- Report.Failed("User_Exception_3 not propagated to caller");
- exception
- when Excptn : User_Exception_3 =>
- if User_Messages(3).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_3 not returned to caller of task");
- end if;
- Check_Exception_Information(Excptn);
- when others =>
- Report.Failed("Incorrect exception raised by task");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41002;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41003.a b/gcc/testsuite/ada/acats/tests/cb/cb41003.a
deleted file mode 100644
index aee0b09..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41003.a
+++ /dev/null
@@ -1,358 +0,0 @@
--- CB41003.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 exception occurrence can be saved into an object of
--- type Exception_Occurrence using the procedure Save_Occurrence.
--- Check that a saved exception occurrence can be used to reraise
--- another occurrence of the same exception using the procedure
--- Reraise_Occurrence. Check that the function Save_Occurrence will
--- allocate a new object of type Exception_Occurrence_Access, and saves
--- the source exception to the new object which is returned as the
--- function result.
---
--- TEST DESCRIPTION:
--- This test verifies that an occurrence of an exception can be saved,
--- using either of two overloaded versions of Save_Occurrence. The
--- procedure version of Save_Occurrence is used to save an occurrence
--- of a user defined exception into an object of type
--- Exception_Occurrence. This object is then used as an input
--- parameter to procedure Reraise_Occurrence, the expected exception is
--- handled, and the exception id of the handled exception is compared
--- to the id of the originally raised exception.
--- The function version of Save_Occurrence returns a result of
--- Exception_Occurrence_Access, and is used to store the value of another
--- occurrence of the user defined exception. The resulting access value
--- is dereferenced and used as an input to Reraise_Occurrence. The
--- resulting exception is handled, and the exception id of the handled
--- exception is compared to the id of the originally raised exception.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41003 is
-
-begin
-
- Report.Test ("CB41003", "Check that an exception occurrence can " &
- "be saved into an object of type " &
- "Exception_Occurrence using the procedure " &
- "Save_Occurrence");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- User_Exception_1,
- User_Exception_2 : Exception;
-
- Saved_Occurrence : Exception_Occurrence;
- Occurrence_Ptr : Exception_Occurrence_Access;
-
- User_Message : constant String := -- 200 character string.
- "The string returned by Exception_Message may be tr" &
- "uncated (to no less then 200 characters) by the Sa" &
- "ve_Occurrence procedure (not the function), the Re" &
- "raise_Occurrence proc, and the re-raise statement.";
-
- begin
-
- Raise_And_Save_Block_1 :
- begin
-
- -- This nested exception structure is designed to ensure that the
- -- appropriate exception occurrence is saved using the
- -- Save_Occurrence procedure.
-
- raise Program_Error;
- Report.Failed("Program_Error not raised");
-
- exception
- when Program_Error =>
-
- begin
- -- Use the procedure Raise_Exception, along with the 'Identity
- -- attribute to raise the first user defined exception. Note
- -- that a 200 character message is included in the call.
-
- Raise_Exception(User_Exception_1'Identity, User_Message);
- Report.Failed("User_Exception_1 not raised");
-
- exception
- when Exc : User_Exception_1 =>
-
- -- This exception occurrence is saved into a variable using
- -- procedure Save_Occurrence. This saved occurrence should
- -- not be confused with the raised occurrence of
- -- Program_Error above.
-
- Save_Occurrence(Target => Saved_Occurrence, Source => Exc);
-
- when others =>
- Report.Failed("Unexpected exception handled, expecting " &
- "User_Exception_1");
- end;
-
- when others =>
- Report.Failed("Incorrect exception generated by raise statement");
-
- end Raise_And_Save_Block_1;
-
-
- Reraise_And_Handle_Saved_Exception_1 :
- begin
- -- Reraise the exception that was saved in the previous block.
-
- Reraise_Occurrence(X => Saved_Occurrence);
-
- exception
- when Exc : User_Exception_1 => -- Expected exception.
- -- Check the exception id of the handled id by using the
- -- Exception_Identity function, and compare with the id of the
- -- originally raised exception.
-
- if User_Exception_1'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_Ids do not match - 1");
- end if;
-
- -- Check that the message associated with this exception occurrence
- -- has not been truncated (it was originally 200 characters).
-
- if User_Message /= Exception_Message(Exc) then
- Report.Failed("Exception messages do not match - 1");
- end if;
-
- when others =>
- Report.Failed
- ("Incorrect exception raised by Reraise_Occurrence - 1");
- end Reraise_And_Handle_Saved_Exception_1;
-
-
- Raise_And_Save_Block_2 :
- begin
-
- Raise_Exception(User_Exception_2'Identity, User_Message);
- Report.Failed("User_Exception_2 not raised");
-
- exception
- when Exc : User_Exception_2 =>
-
- -- This exception occurrence is saved into an access object
- -- using function Save_Occurrence.
-
- Occurrence_Ptr := Save_Occurrence(Source => Exc);
-
- when others =>
- Report.Failed("Unexpected exception handled, expecting " &
- "User_Exception_2");
- end Raise_And_Save_Block_2;
-
-
- Reraise_And_Handle_Saved_Exception_2 :
- begin
- -- Reraise the exception that was saved in the previous block.
- -- Dereference the access object for use as input parameter.
-
- Reraise_Occurrence(X => Occurrence_Ptr.all);
-
- exception
- when Exc : User_Exception_2 => -- Expected exception.
- -- Check the exception id of the handled id by using the
- -- Exception_Identity function, and compare with the id of the
- -- originally raised exception.
-
- if User_Exception_2'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_Ids do not match - 2");
- end if;
-
- -- Check that the message associated with this exception occurrence
- -- has not been truncated (it was originally 200 characters).
-
- if User_Message /= Exception_Message(Exc) then
- Report.Failed("Exception messages do not match - 2");
- end if;
-
- when others =>
- Report.Failed
- ("Incorrect exception raised by Reraise_Occurrence - 2");
- end Reraise_And_Handle_Saved_Exception_2;
-
-
- -- Another example of the use of saving an exception occurrence
- -- is demonstrated in the following block, where the ability to
- -- save an occurrence into a data structure, for later processing,
- -- is modeled.
-
- Store_And_Handle_Block:
- declare
-
- Exc_Number : constant := 3;
- Exception_1,
- Exception_2,
- Exception_3 : exception;
-
- Exception_Storage : array (1..Exc_Number) of Exception_Occurrence;
- Messages : array (1..Exc_Number) of String(1..9) :=
- ("Message 1", "Message 2", "Message 3");
-
- begin
-
- Outer_Block:
- begin
-
- Inner_Block:
- begin
-
- for i in 1..Exc_Number loop
- begin
-
- begin
- -- Exceptions all raised in a deep scope.
- if i = 1 then
- Raise_Exception(Exception_1'Identity, Messages(i));
- elsif i = 2 then
- Raise_Exception(Exception_2'Identity, Messages(i));
- elsif i = 3 then
- Raise_Exception(Exception_3'Identity, Messages(i));
- end if;
- Report.Failed("Exception not raised on loop #" &
- Integer'Image(i));
- end;
- Report.Failed("Exception not propagated on loop #" &
- Integer'Image(i));
- exception
- when Exc : others =>
-
- -- Save each occurrence into a storage array for
- -- later processing.
-
- Save_Occurrence(Exception_Storage(i), Exc);
- end;
- end loop;
-
- end Inner_Block;
- end Outer_Block;
-
- -- Raise the exceptions from the stored occurrences, and handle.
-
- for i in 1..Exc_Number loop
- begin
- Reraise_Occurrence(Exception_Storage(i));
- Report.Failed("No exception reraised for " &
- "exception #" & Integer'Image(i));
- exception
- when Exc : others =>
- -- The following sequence of checks ensures that the
- -- correct occurrence was stored, and the associated
- -- exception was raised and handled in the proper order.
- if i = 1 then
- if Exception_1'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_1 not raised");
- end if;
- elsif i = 2 then
- if Exception_2'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_2 not raised");
- end if;
- elsif i = 3 then
- if Exception_3'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_3 not raised");
- end if;
- end if;
-
- if Exception_Message(Exc) /= Messages(i) then
- Report.Failed("Incorrect message associated with " &
- "exception #" & Integer'Image(i));
- end if;
- end;
- end loop;
- exception
- when others =>
- Report.Failed("Unexpected exception in Store_And_Handle_Block");
- end Store_And_Handle_Block;
-
-
- Reraise_Out_Of_Scope:
- declare
-
- TC_Value : constant := 5;
- The_Exception : exception;
- Saved_Exc_Occ : Exception_Occurrence;
-
- procedure Handle_It (Exc_Occ : in Exception_Occurrence) is
- Must_Be_Raised : exception;
- begin
- if Exception_Identity(Exc_Occ) = The_Exception'Identity then
- raise Must_Be_Raised;
- Report.Failed("Exception Must_Be_Raised was not raised");
- else
- Report.Failed("Incorrect exception handled in " &
- "Procedure Handle_It");
- end if;
- end Handle_It;
-
- begin
-
- if Report.Ident_Int(5) = TC_Value then
- raise The_Exception;
- end if;
-
- exception
- when Exc : others =>
- Save_Occurrence (Saved_Exc_Occ, Exc);
- begin
- Handle_It(Saved_Exc_Occ); -- Raise another exception, in a
- exception -- different scope.
- when others => -- Handle this new exception.
- begin
- Reraise_Occurrence (Saved_Exc_Occ); -- Reraise the
- -- original excptn.
- Report.Failed("Saved Exception was not raised");
- exception
- when Exc_2 : others =>
- if Exception_Identity (Exc_2) /=
- The_Exception'Identity
- then
- Report.Failed
- ("Incorrect exception occurrence reraised");
- end if;
- end;
- end;
- end Reraise_Out_Of_Scope;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41003;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41004.a b/gcc/testsuite/ada/acats/tests/cb/cb41004.a
deleted file mode 100644
index b73ed8f..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41004.a
+++ /dev/null
@@ -1,324 +0,0 @@
--- CB41004.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 Raise_Exception and Reraise_Occurrence have no effect in
--- the case of Null_Id or Null_Occurrence. Check that Exception_Message,
--- Exception_Identity, Exception_Name, and Exception_Information raise
--- Constraint_Error for a Null_Occurrence input parameter.
--- Check that calling the Save_Occurrence subprograms with the
--- Null_Occurrence input parameter saves the Null_Occurrence to the
--- appropriate target object, and does not raise Constraint_Error.
--- Check that Null_Id is the default initial value of type Exception_Id.
---
--- TEST DESCRIPTION:
--- This test performs a series of calls to many of the subprograms
--- defined in package Ada.Exceptions, using either Null_Id or
--- Null_Occurrence (based on their parameter profile). In the cases of
--- Raise_Exception and Reraise_Occurrence, these null input values
--- should result in no exceptions being raised, and Constraint_Error
--- should not be raised in response to these calls. Test failure will
--- result if any exception is raised in these cases.
--- For the Save_Occurrence subprograms, calling them with the
--- Null_Occurrence input parameter does not raise Constraint_Error, but
--- simply results in the Null_Occurrence being saved into the appropriate
--- target (either a Exception_Occurrence out parameter, or as an
--- Exception_Occurrence_Access value).
--- In the cases of the other mentioned subprograms, calls performed with
--- a Null_Occurrence input parameter must result in Constraint_Error
--- being raised. This exception will be handled, with test failure the
--- result if the exception is not raised.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Dec 00 RLB Removed Exception_Identity subtest, pending
--- resolution of AI95-00241.
--- 29 Mar 07 RLB Replaced Exception_Identity subtest, repaired
--- Raise_Exception subtest for AI95-00446.
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41004 is
-begin
-
- Report.Test ("CB41004", "Check that Null_Id and Null_Occurrence input " &
- "parameters have the appropriate effect when " &
- "used in calls of the subprograms found in " &
- "package Ada.Exceptions");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- -- No initial values given for these two declarations; they default
- -- to Null_Id and Null_Occurrence respectively.
- A_Null_Exception_Id : Ada.Exceptions.Exception_Id;
- A_Null_Exception_Occurrence : Ada.Exceptions.Exception_Occurrence;
-
- TC_Flag : Boolean := False;
-
- begin
-
- -- Verify that Null_Id is the default initial value of type
- -- Exception_Id.
-
- if not (A_Null_Exception_Id = Ada.Exceptions.Null_Id) then
- Report.Failed("The default initial value of an object of type " &
- "Exception_Id was not Null_Id");
- end if;
-
-
- -- Verify that Raise_Exception has no effect in the case of Null_Id.
- -- Modified by AI-446.
- begin
- Ada.Exceptions.Raise_Exception(A_Null_Exception_Id);
- Report.Comment(
- "No exception raised by procedure Raise_Exception " &
- "when called with a Null_Id input parameter - compatible with " &
- "original Ada95");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- Report.Comment(
- "Constraint_Error exception raised by procedure Raise_Exception " &
- "when called with a Null_Id input parameter - compatible with " &
- "AI95-00446");
- when others =>
- Report.Failed(
- "Unexpected exception raised by procedure Raise_Exception " &
- "when called with a Null_Id input parameter");
- end;
-
- TC_Flag := False;
-
-
- -- Verify that Reraise_Occurrence has no effect in the case of
- -- Null_Occurrence.
- begin
- Ada.Exceptions.Reraise_Occurrence(A_Null_Exception_Occurrence);
- TC_Flag := True;
- exception
- when others =>
- Report.Failed
- ("Exception raised by procedure Reraise_Occurrence " &
- "when called with a Null_Occurrence input parameter");
- end;
-
- if not TC_Flag then
- Report.Failed("Incorrect processing following the call to " &
- "Reraise_Occurrence with a Null_Occurrence " &
- "input parameter");
- end if;
-
-
- -- Verify that function Exception_Message raises Constraint_Error for
- -- a Null_Occurrence input parameter.
- begin
- declare
- Msg : constant String :=
- Ada.Exceptions.Exception_Message(A_Null_Exception_Occurrence);
- begin
- Report.Failed
- ("Constraint_Error not raised by Function Exception_Message " &
- "when called with a Null_Occurrence input parameter");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Function Exception_Message " &
- "when called with a Null_Occurrence input parameter");
- end;
-
-
- -- Verify that function Exception_Identity raises Constraint_Error for
- -- a Null_Occurrence input parameter.
- -- Modified by AI-241.
- begin
- declare
- Id : Ada.Exceptions.Exception_Id :=
- Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence);
- begin
- Report.Comment
- ("No exception raised by Function Exception_Identity " &
- "when called with a Null_Occurrence input parameter - " &
- "compatible with AI95-00241.");
- end;
- exception
- when Constraint_Error =>
- Report.Comment
- ("Constraint_Error raised by Function Exception_Identity " &
- "when called with a Null_Occurrence input parameter - " &
- "compatible with original Ada95.");
- when others =>
- Report.Failed
- ("Unexpected exception raised by Function Exception_Identity " &
- "when called with a Null_Occurrence input parameter");
- end;
-
-
- -- Verify that function Exception_Name raises Constraint_Error for
- -- a Null_Occurrence input parameter.
- begin
- declare
- Name : constant String :=
- Ada.Exceptions.Exception_Name(A_Null_Exception_Occurrence);
- begin
- Report.Failed
- ("Constraint_Error not raised by Function Exception_Name " &
- "when called with a Null_Occurrence input parameter");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Function Exception_Null " &
- "when called with a Null_Occurrence input parameter");
- end;
-
-
- -- Verify that function Exception_Information raises Constraint_Error
- -- for a Null_Occurrence input parameter.
- begin
- declare
- Info : constant String :=
- Ada.Exceptions.Exception_Information
- (A_Null_Exception_Occurrence);
- begin
- Report.Failed
- ("Constraint_Error not raised by Function " &
- "Exception_Information when called with a " &
- "Null_Occurrence input parameter");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Function Exception_Null " &
- "when called with a Null_Occurrence input parameter");
- end;
-
-
- -- Verify that calling the Save_Occurrence procedure with a
- -- Null_Occurrence input parameter saves the Null_Occurrence to the
- -- target object, and does not raise Constraint_Error.
- declare
- use Ada.Exceptions;
- Saved_Occurrence : Exception_Occurrence;
- begin
-
- -- Initialize the Saved_Occurrence variable with a value other than
- -- Null_Occurrence (default).
- begin
- raise Program_Error;
- exception
- when Exc : others => Save_Occurrence(Saved_Occurrence, Exc);
- end;
-
- -- Save a Null_Occurrence input parameter.
- begin
- Save_Occurrence(Target => Saved_Occurrence,
- Source => Ada.Exceptions.Null_Occurrence);
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised by procedure " &
- "Save_Occurrence when called with a Null_Occurrence " &
- "input parameter");
- end;
-
- -- Verify that the occurrence that was saved above is a
- -- Null_Occurrence value.
-
- begin
- Reraise_Occurrence(Saved_Occurrence);
- exception
- when others =>
- Report.Failed("Value saved from Procedure Save_Occurrence " &
- "resulted in an exception, i.e., was not a " &
- "value of Null_Occurrence");
- end;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during evaluation " &
- "of Procedure Save_Occurrence");
- end;
-
-
- -- Verify that calling the Save_Occurrence function with a
- -- Null_Occurrence input parameter returns the Null_Occurrence as the
- -- function result, and does not raise Constraint_Error.
- declare
- Occurrence_Ptr : Ada.Exceptions.Exception_Occurrence_Access;
- begin
- -- Save a Null_Occurrence input parameter.
- begin
- Occurrence_Ptr :=
- Ada.Exceptions.Save_Occurrence(Ada.Exceptions.Null_Occurrence);
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised by function " &
- "Save_Occurrence when called with a Null_Occurrence " &
- "input parameter");
- end;
-
- -- Verify that the occurrence that was saved above is a
- -- Null_Occurrence value.
-
- begin
- -- Dereferenced value of type Exception_Occurrence_Access
- -- should be a Null_Occurrence value, based on the action
- -- of Function Save_Occurrence above. Providing this as an
- -- input parameter to Reraise_Exception should not result in
- -- any exception being raised.
-
- Ada.Exceptions.Reraise_Occurrence(Occurrence_Ptr.all);
-
- exception
- when others =>
- Report.Failed("Value saved from Function Save_Occurrence " &
- "resulted in an exception, i.e., was not a " &
- "value of Null_Occurrence");
- end;
- exception
- when others =>
- Report.Failed("Unexpected exception raised during evaluation " &
- "of Function Save_Occurrence");
- end;
-
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41004;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada b/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada
deleted file mode 100644
index 5cf563f..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CB5001A.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 EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO
--- THE CALLER AND TO THE CALLED TASK.
-
--- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH ONE
--- LEVEL OF RENDEVOUS.
-
--- *** 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
-
--- JEAN-PIERRE ROSEN 09 MARCH 1984
--- JBG 6/1/84
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CB5001A IS
-
-BEGIN
-
- TEST("CB5001A", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " &
- "PROPAGATED TO CALLER AND CALLED TASKS -- ONE " &
- "LEVEL");
-
- DECLARE
- TASK T2 IS
- ENTRY E2;
- END T2;
-
- TASK BODY T2 IS
- MY_EXCEPTION: EXCEPTION;
- BEGIN
- ACCEPT E2 DO
- IF EQUAL (1,1) THEN
- RAISE MY_EXCEPTION;
- END IF;
- END E2;
- FAILED ("T2: EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN MY_EXCEPTION =>
- NULL;
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED IN T2");
- WHEN OTHERS =>
- FAILED ("T2 RECEIVED ABNORMAL EXCEPTION");
- END T2;
-
- BEGIN
- T2.E2;
- FAILED ("MAIN: EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR | PROGRAM_ERROR | STORAGE_ERROR =>
- FAILED ("PREDEFINED ERROR RAISED IN MAIN");
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED IN MAIN");
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-
-END CB5001A;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada b/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada
deleted file mode 100644
index 35dff52..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CB5001B.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 EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO
--- THE CALLER AND TO THE CALLED TASK.
-
--- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH TWO
--- LEVELS OF RENDEVOUS.
-
--- *** 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
-
--- JEAN-PIERRE ROSEN 09 MARCH 1984
--- JBG 6/1/84
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CB5001B IS
-
-BEGIN
-
- TEST("CB5001B", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " &
- "PROPAGATED TO CALLER AND CALLED TASKS -- TWO " &
- "LEVELS");
-
- DECLARE
- TASK T1 IS
- ENTRY E1;
- END T1;
-
- TASK T2 IS
- ENTRY E2;
- END T2;
-
- TASK BODY T1 IS
- BEGIN
- ACCEPT E1 DO
- T2.E2;
- END E1;
- FAILED ("T1: EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR | PROGRAM_ERROR =>
- FAILED ("PREDEFINED EXCEPTION RAISED IN T1");
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED IN T1");
- WHEN OTHERS =>
- NULL;
- END T1;
-
- TASK BODY T2 IS
- MY_EXCEPTION: EXCEPTION;
- BEGIN
- ACCEPT E2 DO
- IF EQUAL (1,1) THEN
- RAISE MY_EXCEPTION;
- END IF;
- END E2;
- FAILED ("T2: EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN MY_EXCEPTION =>
- NULL;
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED IN T2");
- WHEN OTHERS =>
- FAILED ("T2 RECEIVED ABNORMAL EXCEPTION");
- END T2;
-
- BEGIN
- T1.E1;
- FAILED ("MAIN: EXCEPTION NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR | PROGRAM_ERROR =>
- FAILED ("PREDEFINED ERROR RAISED IN MAIN");
- WHEN TASKING_ERROR =>
- FAILED ("TASKING_ERROR RAISED IN MAIN");
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-
-END CB5001B;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada b/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada
deleted file mode 100644
index f4484bc..0000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- CB5002A.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 WHEN "TASKING_ERROR" IS RAISED EXPLICITLY OR BY
--- PROPAGATION WITHIN AN ACCEPT STATEMENT, THEN "TASKING_ERROR"
--- IS RAISED IN BOTH THE CALLING AND THE CALLED TASK.
-
--- HISTORY:
--- DHH 03/31/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CB5002A IS
-
-BEGIN
- TEST("CB5002A", "CHECK THAT WHEN ""TASKING_ERROR"" IS RAISED " &
- "EXPLICITLY OR BY PROPAGATION WITHIN AN ACCEPT " &
- "STATEMENT, THEN ""TASKING_ERROR"" IS RAISED " &
- "IN BOTH THE CALLING AND THE CALLED TASK");
-
- DECLARE
- TASK CALLING_EXP IS
- ENTRY A;
- END CALLING_EXP;
-
- TASK CALLED_EXP IS
- ENTRY B;
- ENTRY STOP;
- END CALLED_EXP;
-
- TASK CALLING_PROP IS
- ENTRY C;
- END CALLING_PROP;
-
- TASK CALLED_PROP IS
- ENTRY D;
- ENTRY STOP;
- END CALLED_PROP;
-
- TASK PROP IS
- ENTRY E;
- ENTRY STOP;
- END PROP;
------------------------------------------------------------------------
- TASK BODY CALLING_EXP IS
- BEGIN
- ACCEPT A DO
- BEGIN
- CALLED_EXP.B;
- FAILED("EXCEPTION NOT RAISED IN CALLING " &
- "TASK - EXPLICIT RAISE");
- EXCEPTION
- WHEN TASKING_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED IN " &
- "CALLING TASK - EXPLICIT RAISE");
- END; -- EXCEPTION
- END A;
- END CALLING_EXP;
-
- TASK BODY CALLED_EXP IS
- BEGIN
- BEGIN
- ACCEPT B DO
- RAISE TASKING_ERROR;
- FAILED("EXCEPTION NOT RAISED IN CALLED " &
- "TASK - EXPLICIT RAISE");
- END B;
- EXCEPTION
- WHEN TASKING_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED IN CALLED " &
- "TASK - EXPLICIT RAISE");
- END; -- EXCEPTION BLOCK
-
- ACCEPT STOP;
- END CALLED_EXP;
-
------------------------------------------------------------------------
- TASK BODY CALLING_PROP IS
- BEGIN
- ACCEPT C DO
- BEGIN
- CALLED_PROP.D;
- FAILED("EXCEPTION NOT RAISED IN CALLING " &
- "TASK - PROPAGATED RAISE");
- EXCEPTION
- WHEN TASKING_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED IN " &
- "CALLING TASK - PROPAGATED RAISE");
- END; -- EXCEPTION
- END C;
- END CALLING_PROP;
-
- TASK BODY CALLED_PROP IS
- BEGIN
- BEGIN
- ACCEPT D DO
- PROP.E;
- FAILED("EXCEPTION NOT RAISED IN CALLED " &
- "TASK - PROPAGATED RAISE");
- END D;
- EXCEPTION
- WHEN TASKING_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED IN CALLED " &
- "TASK - PROPAGATED RAISE");
- END; -- EXCEPTION BLOCK;
-
- ACCEPT STOP;
- END CALLED_PROP;
-
- TASK BODY PROP IS
- BEGIN
- BEGIN
- ACCEPT E DO
- RAISE TASKING_ERROR;
- FAILED("EXCEPTION NOT RAISED IN PROPAGATE " &
- "TASK - ACCEPT E");
- END E;
- EXCEPTION
- WHEN TASKING_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED IN PROP. TASK");
- END; -- EXCEPTION BLOCK
-
- ACCEPT STOP;
-
- END PROP;
------------------------------------------------------------------------
- BEGIN
- CALLING_EXP.A;
- CALLING_PROP.C;
- CALLED_EXP.STOP;
- CALLED_PROP.STOP;
- PROP.STOP;
-
- END; -- DECLARE
-
- RESULT;
-END CB5002A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada
deleted file mode 100644
index f5a1481..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- CC1004A.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 ELABORATION OF A GENERIC DECLARATION
--- DOES NOT ELABORATE THE SUBPROGRAM OR PACKAGE SPECIFICATION.
-
--- HISTORY:
--- DAT 07/31/81 CREATED ORIGINAL TEST.
--- SPS 10/18/82
--- SPS 02/09/83
--- JET 01/07/88 UPDATED HEADER FORMAT AND ADDED CODE TO
--- PREVENT OPTIMIZATION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1004A IS
-BEGIN
- TEST ("CC1004A", "THE SPECIFICATION PART OF A GENERIC " &
- "SUBPROGRAM IS NOT ELABORATED AT THE " &
- "ELABORATION OF THE DECLARATION");
-
- BEGIN
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE 1 .. 1;
-
- GENERIC
- PROCEDURE PROC (P1: I1 := IDENT_INT(2));
-
- PROCEDURE PROC (P1: I1 := IDENT_INT(2)) IS
- BEGIN
- IF NOT EQUAL (P1,P1) THEN
- COMMENT ("DON'T OPTIMIZE THIS");
- END IF;
- END PROC;
- BEGIN
- BEGIN
- DECLARE
- PROCEDURE P IS NEW PROC;
- BEGIN
- IF NOT EQUAL(3,3) THEN
- P(1);
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("INSTANTIATION ELABORATES SPEC");
- END;
-
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DECL ELABORATED SPEC PART - 1");
- END;
-
- BEGIN
- DECLARE
- SUBTYPE I1 IS INTEGER RANGE 1 .. 1;
-
- GENERIC
- PACKAGE PKG IS
- X : INTEGER := I1(IDENT_INT(2));
- END PKG;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE P IS NEW PKG;
- BEGIN
- FAILED ("PACKAGE INSTANTIATION FAILED");
- IF NOT EQUAL(P.X,P.X) THEN
- COMMENT("DON'T OPTIMIZE THIS");
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2");
- END;
-
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DECL ELABORATED SPEC PART - 2");
- END;
-
- RESULT;
-
-END CC1004A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada
deleted file mode 100644
index 484227f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- CC1005B.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 GENERIC UNIT'S IDENTIFIER CAN BE USED IN ITS
--- FORMAL PART:
---
--- (A) AS THE SELECTOR IN AN EXPANDED NAME TO DENOTE AN ENTITY IN THE
--- VISIBLE PART OF A PACKAGE, OR TO DENOTE AN ENTITY IMMEDIATELY
--- ENCLOSED IN A CONSTRUCT OTHER THAN THE CONSTRUCT IMMEDIATELY
--- ENCLOSING THE GENERIC UNIT.
---
--- (B) AS A SELECTOR TO DENOTE A COMPONENT OF A RECORD OBJECT,
--- AS THE NAME OF A RECORD OR DISCRIMINANT COMPONENT IN A RECORD
--- AGGREGATE, AND AS THE NAME OF A FORMAL PARAMETER IN A
--- FUNCTION CALL.
-
--- HISTORY:
--- BCB 08/03/88 CREATED ORIGINAL TEST.
--- JRL 03/20/92 DELETED TEST IN BLOCK STATEMENT; CONSOLIDATED
--- WITH CC1005C.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1005B IS
-
- S : INTEGER := IDENT_INT(0);
-
- PACKAGE CC1005B IS
- I : INTEGER;
- S : INTEGER := IDENT_INT(5);
- GENERIC
- S : INTEGER := IDENT_INT(10);
- V : INTEGER := STANDARD.CC1005B.S;
- W : INTEGER := STANDARD.CC1005B.CC1005B.S;
- FUNCTION CC1005B RETURN INTEGER;
- END CC1005B;
-
- PACKAGE BODY CC1005B IS
- FUNCTION CC1005B RETURN INTEGER IS
- BEGIN
- IF NOT EQUAL(V,0) THEN
- FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF V");
- END IF;
-
- IF NOT EQUAL(W,5) THEN
- FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF W");
- END IF;
-
- RETURN 0;
- END CC1005B;
-
- FUNCTION NEW_CC IS NEW CC1005B;
-
- BEGIN
- TEST ("CC1005B", "CHECK THAT A GENERIC UNIT'S IDENTIFIER " &
- "CAN BE USED IN ITS FORMAL PART: AS THE " &
- "SELECTOR IN AN EXPANDED NAME TO DENOTE " &
- "AN ENTITY IN THE VISIBLE PART OF A " &
- "PACKAGE, OR TO DENOTE AN ENTITY " &
- "IMMEDIATELY ENCLOSED IN A CONSTRUCT " &
- "OTHER THAN THE CONSTRUCT IMMEDIATELY " &
- "ENCLOSING THE GENERIC UNIT; AND AS A " &
- "SELECTOR TO DENOTE A COMPONENT OF A " &
- "RECORD OBJECT, AS THE NAME OF A RECORD " &
- "OR DISCRIMINANT COMPONENT IN A RECORD " &
- "AGGREGATE, AND AS THE NAME OF A FORMAL " &
- "PARAMETER IN A FUNCTION CALL");
-
- I := NEW_CC;
- END CC1005B;
-
- FUNCTION F (P : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN P;
- END F;
-
-BEGIN
-
- BLOCK1:
- DECLARE
- TYPE REC IS RECORD
- P : INTEGER := IDENT_INT(0);
- END RECORD;
-
- TYPE REC2 (P : INTEGER) IS RECORD
- NULL;
- END RECORD;
-
- R : REC;
-
- J : INTEGER;
-
- GENERIC
- V : INTEGER := R.P;
- X : REC := (P => IDENT_INT(10));
- Y : REC2 := (P => IDENT_INT(15));
- Z : INTEGER := F(P => IDENT_INT(20));
- FUNCTION P RETURN INTEGER;
-
- FUNCTION P RETURN INTEGER IS
- BEGIN
- IF NOT EQUAL(V,0) THEN
- FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " &
- "OF V");
- END IF;
-
- IF NOT EQUAL(X.P,10) THEN
- FAILED ("WRONG VALUE USED IN ASSIGNMENT OF X.P");
- END IF;
-
- IF NOT EQUAL(Y.P,15) THEN
- FAILED ("WRONG VALUE USED IN ASSIGNMENT OF Y.P");
- END IF;
-
- IF NOT EQUAL(Z,20) THEN
- FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " &
- "OF Z");
- END IF;
-
- RETURN 0;
- END P;
-
- FUNCTION NEW_P IS NEW P;
- BEGIN
- J := NEW_P;
- END BLOCK1;
-
- RESULT;
-END CC1005B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada
deleted file mode 100644
index c04a325..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CC1010A.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 NAMES IN A GENERIC SUBPROGRAM DECLARATION ARE
--- STATICALLY IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE
--- GENERIC DECLARATION TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY
--- BOUND AT THE POINT OF INSTANTIATION.
-
--- ASL 8/12/81
-
-WITH REPORT;
-PROCEDURE CC1010A IS
- USE REPORT;
-BEGIN
- TEST ("CC1010A","PROPER VISIBILITY OF FREE IDENTIFIERS IN " &
- "GENERIC DECLARATIONS, BODIES AND INSTANTIATIONS");
-
- OUTER:
- DECLARE
- FREE : CONSTANT INTEGER := 5;
- BEGIN
- DECLARE
- GENERIC
- GFP : INTEGER := FREE;
- PROCEDURE P(PFP : IN INTEGER := FREE);
-
- FREE : CONSTANT INTEGER := 6;
-
- PROCEDURE P(PFP : IN INTEGER := OUTER.FREE) IS
- BEGIN
- IF FREE /= 6 OR GFP /= 5 OR PFP /= 5 THEN
- FAILED ("BINDINGS INCORRECT");
- END IF;
- END P;
- BEGIN
- DECLARE
- FREE : CONSTANT INTEGER := 7;
- PROCEDURE INST IS NEW P;
- BEGIN
- INST;
- END;
- END;
- END OUTER;
- RESULT;
-END CC1010A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada
deleted file mode 100644
index 74ef437..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada
+++ /dev/null
@@ -1,67 +0,0 @@
--- CC1010B.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 NAMES IN A GENERIC PACKAGE BODY ARE STATICALLY
--- IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE GENERIC BODY
--- TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY BOUND AT THE POINT
--- OF INSTANTIATION.
-
--- ASL 8/13/81
-
-WITH REPORT;
-PROCEDURE CC1010B IS
-
- USE REPORT;
- FREE : CONSTANT INTEGER := 5;
-BEGIN
- TEST("CC1010B","PROPER VISIBILITY OF FREE IDENTIFIERS IN " &
- "GENERIC PACKAGE DECLARATIONS, BODIES AND INSTANTIATIONS");
-
- DECLARE
- GENERIC
- GFP : INTEGER := FREE;
- PACKAGE P IS
- SPECITEM : CONSTANT INTEGER := FREE;
- END P;
-
- FREE : CONSTANT INTEGER := 6;
-
- PACKAGE BODY P IS
- BODYITEM : INTEGER := FREE;
- BEGIN
- IF GFP /= 5 OR SPECITEM /= 5 OR BODYITEM /= 6 THEN
- FAILED ("BINDINGS INCORRECT");
- END IF;
- END P;
- BEGIN
- DECLARE
- FREE : CONSTANT INTEGER := 7;
- PACKAGE INST IS NEW P;
- BEGIN
- NULL;
- END;
- END;
-
- RESULT;
-END CC1010B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada
deleted file mode 100644
index 2ea39a9..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CC1018A.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 OUT PARAMETER OF A GENERIC FORMAL SUBPROGRAM CAN
--- HAVE A FORMAL LIMITED TYPE AND AN ARRAY TYPE WITH LIMITED COMPONENTS.
-
--- AH 10/3/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC1018A IS
- TYPE INT IS RANGE 1..10;
- TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INT;
- INT_OBJ : INT := 4;
- ARR_OBJ : ARR(1..5) := (2, 8, 2, 8, 2);
-
- GENERIC
- TYPE GLP IS LIMITED PRIVATE;
- TYPE GARR IS ARRAY (INTEGER RANGE <>) OF GLP;
- LP_OBJ : IN OUT GLP;
- GA_OBJ : IN OUT GARR;
- WITH PROCEDURE P (X : OUT GLP; Y : OUT GARR);
- WITH FUNCTION SAME (LEFT, RIGHT : GLP) RETURN BOOLEAN;
- PROCEDURE GEN_PROC;
-
- PROCEDURE GET_VALUES (X1 : OUT INT; Y1 : OUT ARR) IS
- BEGIN
- X1 := 4;
- Y1 := (2, 8, 2, 8, 2);
- END GET_VALUES;
-
- FUNCTION SAME_VALUE (LEFT, RIGHT : INT) RETURN BOOLEAN IS
- BEGIN
- RETURN LEFT = RIGHT;
- END SAME_VALUE;
-
- PROCEDURE GEN_PROC IS
- LP : GLP;
- A : GARR(1..5);
- BEGIN
- P(LP, A);
- IF NOT SAME(LP, LP_OBJ) THEN
- FAILED ("LIMITED PRIVATE TYPE HAS INCORRECT VALUE");
- END IF;
-
- FOR INDEX IN A'RANGE LOOP
- IF NOT SAME(A(INDEX), GA_OBJ(INDEX)) THEN
- FAILED ("LIMITED PRIVATE TYPE COMPONENT " &
- "HAS INCORRECT VALUE");
- END IF;
- END LOOP;
- END GEN_PROC;
-
- PROCEDURE TEST_LP IS NEW GEN_PROC(INT, ARR, INT_OBJ, ARR_OBJ,
- GET_VALUES, SAME_VALUE);
-
-BEGIN
- TEST ("CC1018A", "A GENERIC FORMAL SUBPROGRAM OUT PRARAMETER " &
- "CAN HAVE A LIMITED TYPE");
- TEST_LP;
-
- RESULT;
-END CC1018A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada b/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada
deleted file mode 100644
index a97e7a0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- CC1104C.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 GENERIC FORMAL IN OUT PARAMETER CAN HAVE A
--- LIMITED TYPE.
-
--- HISTORY:
--- BCB 08/03/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1104C IS
-
- TASK TYPE TSK IS
- ENTRY E;
- END TSK;
-
- VAR : INTEGER := IDENT_INT(0);
- NEW_VAL : INTEGER := IDENT_INT(5);
-
- TSK_VAR : TSK;
-
- PACKAGE PP IS
- TYPE LP IS LIMITED PRIVATE;
- PROCEDURE INIT (ONE : OUT LP; TWO : INTEGER);
- FUNCTION EQUAL (ONE : LP; TWO : INTEGER) RETURN BOOLEAN;
- PRIVATE
- TYPE LP IS RANGE 1 .. 100;
- END PP;
-
- USE PP;
-
- TYPE REC IS RECORD
- COMP : LP;
- END RECORD;
-
- C : LP;
-
- REC_VAR : REC;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- IN_OUT_VAR : IN OUT T;
- IN_OUT_TSK : IN OUT TSK;
- VAL : IN OUT T;
- WITH PROCEDURE INIT (L : IN OUT T; R : T);
- PROCEDURE P;
-
- GENERIC
- VAL : IN OUT LP;
- PROCEDURE Q;
-
- GENERIC
- VAL : IN OUT REC;
- PROCEDURE R;
-
- PACKAGE BODY PP IS
- PROCEDURE INIT(ONE : OUT LP; TWO : INTEGER) IS
- BEGIN
- ONE := LP(TWO);
- END INIT;
-
- FUNCTION EQUAL(ONE : LP; TWO : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = LP(TWO);
- END EQUAL;
- END PP;
-
- TASK BODY TSK IS
- BEGIN
- ACCEPT E;
- END TSK;
-
- PROCEDURE P IS
- BEGIN
- INIT(IN_OUT_VAR,VAL);
- IN_OUT_TSK.E;
- INIT(C,50);
- END P;
-
- PROCEDURE Q IS
- BEGIN
- INIT(VAL,75);
- INIT(REC_VAR.COMP,50);
- END Q;
-
- PROCEDURE R IS
- BEGIN
- INIT(VAL.COMP,75);
- END R;
-
- PROCEDURE I (ONE : IN OUT INTEGER; TWO : INTEGER) IS
- BEGIN
- ONE := TWO;
- END I;
-
- PROCEDURE NEW_P IS NEW P(INTEGER,VAR,TSK_VAR,NEW_VAL,I);
-
- PROCEDURE NEW_Q IS NEW Q(C);
-
- PROCEDURE NEW_R IS NEW R(REC_VAR);
-
-BEGIN
- TEST ("CC1104C", "CHECK THAT A GENERIC FORMAL IN OUT PARAMETER " &
- "CAN HAVE A LIMITED TYPE");
-
- NEW_P;
-
- IF NOT EQUAL(VAR,5) THEN
- FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " &
- "GENERIC PACKAGE - 1");
- END IF;
-
- NEW_Q;
-
- IF NOT EQUAL(C,75) THEN
- FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " &
- "GENERIC PACKAGE - 2");
- END IF;
-
- NEW_R;
-
- IF NOT EQUAL(REC_VAR.COMP,75) THEN
- FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " &
- "GENERIC PACKAGE - 3");
- END IF;
-
- RESULT;
-END CC1104C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada
deleted file mode 100644
index 94a1776..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CC1107B.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 DEFAULT EXPRESSION MAY REFER TO AN EARLIER FORMAL
--- PARAMETER OF THE SAME GENERIC FORMAL PART.
-
--- HISTORY:
--- BCB 08/03/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1107B IS
-
- J, I : INTEGER;
-
- X : INTEGER := IDENT_INT(0);
-
- VAL : INTEGER := IDENT_INT(10);
-
- GENERIC
- X : INTEGER := IDENT_INT(5);
- Y : INTEGER := X;
- FUNCTION F RETURN INTEGER;
-
- GENERIC
- X : INTEGER;
- Y : INTEGER := X;
- FUNCTION G RETURN INTEGER;
-
- FUNCTION F RETURN INTEGER IS
- BEGIN
- IF NOT EQUAL(X,Y) THEN
- FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 1");
- END IF;
-
- RETURN 0;
- END F;
-
- FUNCTION G RETURN INTEGER IS
- BEGIN
- IF NOT EQUAL(X,Y) THEN
- FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 2");
- END IF;
-
- RETURN 0;
- END G;
-
- FUNCTION NEW_F IS NEW F;
-
- FUNCTION NEW_G IS NEW G(VAL);
-
-BEGIN
- TEST ("CC1107B", "CHECK THAT A DEFAULT EXPRESSION MAY REFER " &
- "TO AN EARLIER FORMAL PARAMETER OF THE SAME " &
- "GENERIC FORMAL PART");
-
- J := NEW_F;
-
- I := NEW_G;
-
- RESULT;
-END CC1107B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada
deleted file mode 100644
index 709307d..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada
+++ /dev/null
@@ -1,322 +0,0 @@
--- CC1111A.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 AFTER A GENERIC UNIT IS INSTANTIATED, THE SUBTYPE OF
--- AN IN OUT OBJECT PARAMETER IS DETERMINED BY THE ACTUAL PARAMETER
--- (TESTS INTEGER, ENUMERATION, FLOATING POINT, FIXED POINT, ARRAY,
--- ACCESS, AND DISCRIMINATED TYPES).
-
--- HISTORY:
--- BCB 03/28/88 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1111A IS
-
- SUBTYPE INT IS INTEGER RANGE 0..5;
- INTVAR : INTEGER RANGE 1..3;
-
- TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT);
- SUBTYPE SUBENUM IS ENUM RANGE ONE .. FIVE;
- ENUMVAR : ENUM RANGE TWO .. THREE;
-
- TYPE FLT IS DIGITS 5 RANGE -5.0 .. 5.0;
- SUBTYPE SUBFLT IS FLT RANGE -1.0 .. 1.0;
- FLTVAR : FLT RANGE 0.0 .. 1.0;
-
- TYPE FIX IS DELTA 0.5 RANGE -5.0 .. 5.0;
- SUBTYPE SUBFIX IS FIX RANGE -1.0 .. 1.0;
- FIXVAR : FIX RANGE 0.0 .. 1.0;
-
- SUBTYPE STR IS STRING (1..10);
- STRVAR : STRING (1..5);
-
- TYPE REC (DISC : INTEGER := 5) IS RECORD
- NULL;
- END RECORD;
- SUBTYPE SUBREC IS REC (6);
- RECVAR : REC(5);
- SUBRECVAR : SUBREC;
-
- TYPE ACCREC IS ACCESS REC;
- SUBTYPE A1 IS ACCREC(1);
- SUBTYPE A2 IS ACCREC(2);
- A1VAR : A1 := NEW REC(1);
- A2VAR : A2 := NEW REC(2);
-
- PACKAGE P IS
- TYPE PRIV IS PRIVATE;
- PRIVATE
- TYPE PRIV IS RANGE 1 .. 100;
- SUBTYPE SUBPRIV IS PRIV RANGE 5 .. 10;
- PRIVVAR : PRIV RANGE 8 .. 10;
- END P;
-
- PACKAGE BODY P IS
- FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN;
-
- FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = TWO;
- END PRIVEQUAL;
-
- GENERIC
- INPUT : SUBPRIV;
- OUTPUT : IN OUT SUBPRIV;
- PROCEDURE I;
-
- PROCEDURE I IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "PRIVATE TYPE");
- IF PRIVEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END I;
-
- PROCEDURE I1 IS NEW I (5, PRIVVAR);
- PROCEDURE I2 IS NEW I (SUBPRIV'FIRST, PRIVVAR);
-
- BEGIN
- TEST ("CC1111A", "CHECK THAT AFTER A GENERIC UNIT IS " &
- "INSTANTIATED, THE SUBTYPE OF AN IN OUT " &
- "OBJECT PARAMETER IS DETERMINED BY THE " &
- "ACTUAL PARAMETER (TESTS INTEGER, " &
- "ENUMERATION, FLOATING POINT, FIXED POINT " &
- ", ARRAY, ACCESS, AND DISCRIMINATED TYPES)");
-
- I1;
- I2;
- END P;
-
- USE P;
-
- GENERIC
- TYPE GP IS PRIVATE;
- FUNCTION GEN_IDENT (X : GP) RETURN GP;
-
- GENERIC
- INPUT : INT;
- OUTPUT : IN OUT INT;
- PROCEDURE B;
-
- GENERIC
- INPUT : SUBENUM;
- OUTPUT : IN OUT SUBENUM;
- PROCEDURE C;
-
- GENERIC
- INPUT : SUBFLT;
- OUTPUT : IN OUT SUBFLT;
- PROCEDURE D;
-
- GENERIC
- INPUT : SUBFIX;
- OUTPUT : IN OUT SUBFIX;
- PROCEDURE E;
-
- GENERIC
- INPUT : STR;
- OUTPUT : IN OUT STR;
- PROCEDURE F;
-
- GENERIC
- INPUT : A1;
- OUTPUT : IN OUT A1;
- PROCEDURE G;
-
- GENERIC
- INPUT : SUBREC;
- OUTPUT : IN OUT SUBREC;
- PROCEDURE H;
-
- GENERIC
- TYPE GP IS PRIVATE;
- FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN;
-
- FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN IS
- BEGIN
- RETURN ONE = TWO;
- END GENEQUAL;
-
- FUNCTION GEN_IDENT (X : GP) RETURN GP IS
- BEGIN
- RETURN X;
- END GEN_IDENT;
-
- FUNCTION INT_IDENT IS NEW GEN_IDENT (INT);
- FUNCTION SUBENUM_IDENT IS NEW GEN_IDENT (SUBENUM);
- FUNCTION SUBFLT_IDENT IS NEW GEN_IDENT (SUBFLT);
- FUNCTION SUBFIX_IDENT IS NEW GEN_IDENT (SUBFIX);
-
- FUNCTION ENUMEQUAL IS NEW GENEQUAL (SUBENUM);
- FUNCTION FLTEQUAL IS NEW GENEQUAL (SUBFLT);
- FUNCTION FIXEQUAL IS NEW GENEQUAL (SUBFIX);
- FUNCTION STREQUAL IS NEW GENEQUAL (STR);
- FUNCTION ACCEQUAL IS NEW GENEQUAL (A2);
- FUNCTION RECEQUAL IS NEW GENEQUAL (REC);
-
- PROCEDURE B IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "INTEGER TYPE");
- IF EQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END B;
-
- PROCEDURE C IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "ENUMERATION TYPE");
- IF ENUMEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END C;
-
- PROCEDURE D IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "FLOATING POINT TYPE");
- IF FLTEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END D;
-
- PROCEDURE E IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "FIXED POINT TYPE");
- IF FIXEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END E;
-
- PROCEDURE F IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "ARRAY TYPE");
- IF STREQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END F;
-
- PROCEDURE G IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "ACCESS TYPE");
- IF ACCEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END G;
-
- PROCEDURE H IS
- BEGIN
- OUTPUT := INPUT;
- FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " &
- "DISCRIMINATED RECORD TYPE");
- IF RECEQUAL (OUTPUT, OUTPUT) THEN
- COMMENT ("DON'T OPTIMIZE OUTPUT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END H;
-
- PROCEDURE B1 IS NEW B (4, INTVAR);
- PROCEDURE C1 IS NEW C (FOUR, ENUMVAR);
- PROCEDURE D1 IS NEW D (-1.0, FLTVAR);
- PROCEDURE E1 IS NEW E (-1.0, FIXVAR);
- PROCEDURE F1 IS NEW F ("9876543210", STRVAR);
- PROCEDURE G1 IS NEW G (A1VAR, A2VAR);
- PROCEDURE H1 IS NEW H (SUBRECVAR, RECVAR);
-
- PROCEDURE B2 IS NEW B (INT_IDENT(INT'FIRST), INTVAR);
- PROCEDURE C2 IS NEW C (SUBENUM_IDENT(SUBENUM'FIRST), ENUMVAR);
- PROCEDURE D2 IS NEW D (SUBFLT_IDENT(SUBFLT'FIRST), FLTVAR);
- PROCEDURE E2 IS NEW E (SUBFIX_IDENT(SUBFIX'FIRST), FIXVAR);
-
-BEGIN
-
- B1;
- C1;
- D1;
- E1;
- F1;
- G1;
- H1;
-
- B2;
- C2;
- D2;
- E2;
-
- RESULT;
-END CC1111A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada
deleted file mode 100644
index 17e3d7f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CC1204A.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 GENERIC FORMAL TYPES MAY HAVE A DISCRIMINANT PART,
--- WHICH MAY BE OF A GENERIC FORMAL TYPE.
-
--- DAT 8/14/81
--- SPS 5/12/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1204A IS
-BEGIN
- TEST ("CC1204A", "DISCRIMINANT PARTS FOR GENERIC FORMAL TYPES");
-
- DECLARE
- GENERIC
- TYPE T IS ( <> );
- TYPE I IS RANGE <> ;
- TYPE R1 (C : BOOLEAN) IS PRIVATE;
- TYPE R2 (C : T) IS PRIVATE;
- TYPE R3 (C : I) IS LIMITED PRIVATE;
- P1 : IN R1;
- P2 : IN R2;
- V1 : IN OUT R1;
- V2 : IN OUT R2;
- V3 : IN OUT R3;
- PROCEDURE PROC;
-
- TYPE DD IS NEW INTEGER RANGE 1 .. 10;
- TYPE ARR IS ARRAY (DD RANGE <>) OF CHARACTER;
- TYPE RECD (C : DD := DD (IDENT_INT (1))) IS
- RECORD
- C1 : ARR (1..C);
- END RECORD;
-
- X1 : RECD;
- X2 : RECD := (1, "Y");
-
- TYPE RECB (C : BOOLEAN) IS
- RECORD
- V : INTEGER := 6;
- END RECORD;
- RB : RECB (IDENT_BOOL (TRUE));
- RB1 : RECB (IDENT_BOOL (TRUE));
-
- PROCEDURE PROC IS
- BEGIN
- IF P1.C /= TRUE
- OR P2.C /= T'FIRST
- OR V1.C /= TRUE
- OR V2.C /= T'FIRST
- OR V3.C /= I'FIRST
- THEN
- FAILED ("WRONG GENERIC PARAMETER VALUE");
- END IF;
-
- V1 := P1;
- V2 := P2;
-
- IF V1 /= P1
- OR V2 /= P2
- THEN
- FAILED ("BAD ASSIGNMENT TO GENERIC PARAMETERS");
- END IF;
- END PROC;
-
- BEGIN
- RB1.V := IDENT_INT (1);
- X1.C1 := "X";
-
- DECLARE
-
- PROCEDURE PR IS NEW PROC
- (T => DD,
- I => DD,
- R1 => RECB,
- R2 => RECD,
- R3 => RECD,
- P1 => RB1,
- P2 => X1,
- V1 => RB,
- V2 => X2,
- V3 => X2);
- BEGIN
- PR;
- IF RB /= (TRUE, 1) OR X2.C1 /= "X" THEN
- FAILED ("PR NOT CALLED CORRECTLY");
- END IF;
- END;
- END;
-
- RESULT;
-END CC1204A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada
deleted file mode 100644
index b8eeae4..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- CC1207B.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 UNCONSTRAINED FORMAL TYPE WITH DISCRIMINANTS IS
--- ALLOWED AS THE TYPE OF A SUBPROGRAM OR AN ENTRY FORMAL
--- PARAMETER, AND AS THE TYPE OF A GENERIC FORMAL OBJECT PARAMETER,
--- AS A GENERIC ACTUAL PARAMETER, AND IN A MEMBERSHIP TEST, IN A
--- SUBTYPE DECLARATION, IN AN ACCESS TYPE DEFINITION, AND IN A
--- DERIVED TYPE DEFINITION.
-
--- HISTORY:
--- BCB 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1207B IS
-
- GENERIC
- TYPE X (L : INTEGER) IS PRIVATE;
- PACKAGE PACK IS
- END PACK;
-
-BEGIN
- TEST ("CC1207B", "CHECK THAT AN UNCONSTRAINED FORMAL TYPE WITH " &
- "DISCRIMINANTS IS ALLOWED AS THE TYPE OF A " &
- "SUBPROGRAM OR AN ENTRY FORMAL PARAMETER, AND " &
- "AS THE TYPE OF A GENERIC FORMAL OBJECT " &
- "PARAMETER, AS A GENERIC ACTUAL PARAMETER, AND " &
- "IN A MEMBERSHIP TEST, IN A SUBTYPE " &
- "DECLARATION, IN AN ACCESS TYPE DEFINITION, " &
- "AND IN A DERIVED TYPE DEFINITION");
-
- DECLARE
- TYPE REC (D : INTEGER := 3) IS RECORD
- NULL;
- END RECORD;
-
- GENERIC
- TYPE R (D : INTEGER) IS PRIVATE;
- OBJ : R;
- PACKAGE P IS
- PROCEDURE S (X : R);
-
- TASK T IS
- ENTRY E (Y : R);
- END T;
-
- SUBTYPE SUB_R IS R;
-
- TYPE ACC_R IS ACCESS R;
-
- TYPE NEW_R IS NEW R;
-
- BOOL : BOOLEAN := (OBJ IN R);
-
- SUB_VAR : SUB_R(5);
-
- ACC_VAR : ACC_R := NEW R(5);
-
- NEW_VAR : NEW_R(5);
-
- PACKAGE NEW_PACK IS NEW PACK (R);
- END P;
-
- REC_VAR : REC(5) := (D => 5);
-
- PACKAGE BODY P IS
- PROCEDURE S (X : R) IS
- BEGIN
- IF NOT EQUAL(X.D,5) THEN
- FAILED ("WRONG DISCRIMINANT VALUE - S");
- END IF;
- END S;
-
- TASK BODY T IS
- BEGIN
- ACCEPT E (Y : R) DO
- IF NOT EQUAL(Y.D,5) THEN
- FAILED ("WRONG DISCRIMINANT VALUE - T");
- END IF;
- END E;
- END T;
- BEGIN
- IF NOT EQUAL(OBJ.D,5) THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE");
- END IF;
-
- S (OBJ);
-
- T.E (OBJ);
-
- IF NOT EQUAL(SUB_VAR.D,5) THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE - SUBTYPE");
- END IF;
-
- IF NOT EQUAL(ACC_VAR.D,5) THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE - ACCESS");
- END IF;
-
- IF NOT EQUAL(NEW_VAR.D,5) THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE - DERIVED");
- END IF;
-
- IF NOT BOOL THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
- END IF;
- END P;
-
- PACKAGE NEW_P IS NEW P (REC,REC_VAR);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC1207B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada
deleted file mode 100644
index cabd591..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada
+++ /dev/null
@@ -1,174 +0,0 @@
--- CC1220A.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 GENERIC UNIT CAN REFER TO AN IMPLICITLY
--- DECLARED PREDEFINED OPERATOR.
-
--- HISTORY:
--- DAT 08/20/81 CREATED ORIGINAL TEST.
--- SPS 05/03/82
--- BCB 08/04/88 MODIFIED HEADER FORMAT AND ADDED CHECKS FOR OTHER
--- OPERATIONS OF A DISCRETE TYPE.
--- RJW 03/27/90 REVISED TEST TO CHECK FOR A GENERIC FORMAL
--- DISCRETE TYPE.
--- CJJ 10/14/90 ADDED CHECKS FOR RELATIONAL OPERATOR (<, <=, >, >=);
--- MADE FAILED MESSAGES IN PROCEDURE BODY MORE SPECIFIC.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CC1220A IS
-
-BEGIN
- TEST ("CC1220A", "GENERIC UNIT CAN REFER TO IMPLICITLY " &
- "DECLARED OPERATORS");
-
-
- DECLARE
-
- GENERIC
- TYPE T IS (<>);
- STR : STRING;
- P1 : T := T'FIRST;
- P2 : T := T(T'SUCC (P1));
- P3 : T := T'(T'PRED (P2));
- P4 : INTEGER := IDENT_INT(T'WIDTH);
- P5 : BOOLEAN := (P1 < P2) AND (P2 > P3);
- P6: BOOLEAN := (P1 <= P3) AND (P2 >= P1);
- P7 : BOOLEAN := (P3 = P1);
- P8 : T := T'BASE'FIRST;
- P10 : T := T'LAST;
- P11 : INTEGER := T'SIZE;
- P12 : ADDRESS := P10'ADDRESS;
- P13 : INTEGER := T'WIDTH;
- P14 : INTEGER := T'POS(T'LAST);
- P15 : T := T'VAL(1);
- P16 : INTEGER := T'POS(P15);
- P17 : STRING := T'IMAGE(T'BASE'LAST);
- P18 : T := T'VALUE(P17);
- P19 : BOOLEAN := (P15 IN T);
- WITH FUNCTION IDENT (X : T) RETURN T;
- PACKAGE PKG IS
- ARR : ARRAY (1 .. 3) OF T := (P1,P2,P3);
- B1 : BOOLEAN := P7 AND P19;
- B2 : BOOLEAN := P5 AND P6;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF P1 /= T(T'FIRST) THEN
- FAILED ("IMPROPER VALUE FOR 'FIRST - " & STR);
- END IF;
-
- IF T'SUCC (P1) /= IDENT (P2) OR
- T'PRED (P2) /= IDENT (P1) THEN
- FAILED ("IMPROPER VALUE FOR 'SUCC, PRED - " & STR);
- END IF;
-
- IF P10 /= T(T'LAST) THEN
- FAILED ("IMPROPER VALUE FOR 'LAST - " & STR);
- END IF;
-
- IF NOT EQUAL(P11,T'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR 'SIZE - " & STR);
- END IF;
-
- IF NOT EQUAL(P13,T'WIDTH) THEN
- FAILED ("IMPROPER VALUE FOR 'WIDTH - " & STR);
- END IF;
-
- IF NOT EQUAL (P16, T'POS (P15)) OR
- T'VAL (P16) /= T(IDENT (P15)) THEN
- FAILED ("IMPROPER VALUE FOR 'POS, 'VAL - " & STR);
- END IF;
-
- IF T'VALUE (P17) /= T'BASE'LAST OR
- T'IMAGE (P18) /= T'IMAGE (T'BASE'LAST) THEN
- FAILED ("IMPROPER VALUE FOR 'VALUE, 'IMAGE - " &
- STR);
- END IF;
- END PKG;
-
- BEGIN
- DECLARE
- TYPE CHAR IS ('A', 'B', 'C', 'D', 'E');
-
- FUNCTION IDENT (C : CHAR) RETURN CHAR IS
- BEGIN
- RETURN CHAR'VAL (IDENT_INT (CHAR'POS (C)));
- END IDENT;
-
- PACKAGE N_CHAR IS NEW PKG (T => CHAR, STR => "CHAR",
- IDENT => IDENT);
- BEGIN
- IF N_CHAR.ARR (1) /= IDENT ('A') OR
- N_CHAR.ARR (2) /= IDENT ('B') OR
- N_CHAR.ARR (3) /= 'A' OR
- N_CHAR.B1 /= TRUE OR
- N_CHAR.B2 /= TRUE THEN
- FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
- " IN INSTANTIATION OF N_CHAR.");
- END IF;
- END;
-
- DECLARE
- TYPE ENUM IS (JOVIAL, ADA, FORTRAN, BASIC);
-
- FUNCTION IDENT (C : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'VAL (IDENT_INT (ENUM'POS (C)));
- END IDENT;
-
- PACKAGE N_ENUM IS NEW PKG (T => ENUM, STR => "ENUM",
- IDENT => IDENT);
-
- BEGIN
- IF N_ENUM.ARR (1) /= IDENT (JOVIAL) OR
- N_ENUM.ARR (2) /= IDENT (ADA) OR
- N_ENUM.ARR (3) /= JOVIAL OR
- N_ENUM.B1 /= TRUE OR
- N_ENUM.B2 /= TRUE THEN
- FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
- " IN INSTANTIATION OF N_ENUM.");
- END IF;
- END;
-
- DECLARE
-
- PACKAGE N_INT IS NEW PKG (T => INTEGER, STR => "INTEGER",
- IDENT => IDENT_INT);
- BEGIN
- IF N_INT.ARR (1) /= IDENT_INT (INTEGER'FIRST) OR
- N_INT.ARR (2) /= IDENT_INT (INTEGER'FIRST + 1) OR
- N_INT.ARR (3) /= INTEGER'FIRST OR
- N_INT.B1 /= TRUE OR
- N_INT.B2 /= TRUE THEN
- FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
- " IN INSTANTIATION OF N_INT.");
- END IF;
- END;
- END;
- RESULT;
-END CC1220A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada
deleted file mode 100644
index 0749e86..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- CC1221A.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:
--- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP, QUALIFICATION,
--- AND EXPLICIT CONVERSION TO AND FROM OTHER INTEGER TYPES.
-
--- HISTORY:
--- RJW 09/26/86 CREATED ORIGINAL TEST.
--- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. SPLIT TEST
--- INTO PARTS A, B, C, AND D.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CC1221A IS
-
- SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
- TYPE NEWINT IS NEW INTEGER;
- TYPE INT IS RANGE -300 .. 300;
-
-BEGIN
- TEST ( "CC1221A", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
- "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
- "DECLARED AND ARE THEREFORE AVAILABLE " &
- "WITHIN THE GENERIC UNIT: ASSIGNMENT, " &
- "MEMBERSHIP, QUALIFICATION, AND EXPLICIT " &
- "CONVERSION TO AND FROM OTHER INTEGER TYPES");
-
- DECLARE -- (A) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
- -- PART I.
-
- GENERIC
- TYPE T IS RANGE <>;
- TYPE T1 IS RANGE <>;
- I : T;
- I1 : T1;
- PROCEDURE P (J : T; STR : STRING);
-
- PROCEDURE P (J : T; STR : STRING) IS
- SUBTYPE ST IS T RANGE T'VAL (-1) .. T'VAL (1);
- K, L : T;
-
- FUNCTION F (X : T) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (TRUE);
- END F;
-
- FUNCTION F (X : T1) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (FALSE);
- END F;
-
- BEGIN
- K := I;
- L := J;
- K := L;
-
- IF K /= J THEN
- FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " &
- "WITH TYPE - " & STR);
- END IF;
-
- IF I IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF J NOT IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF T'(I) /= I THEN
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 1" );
- END IF;
-
- IF F (T'(1)) THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 2" );
- END IF;
-
- IF T (I1) /= I THEN
- FAILED ( "INCORRECT RESULTS FOR EXPLICIT " &
- "CONVERSION WITH TYPE - " & STR &
- " - 1" );
- END IF;
-
- IF F (T (I1)) THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR EXPLICIT " &
- "CONVERSION WITH TYPE - " & STR &
- " - 2" );
- END IF;
-
- END P;
-
- PROCEDURE NP1 IS NEW P (SUBINT, SUBINT, 0, 0);
- PROCEDURE NP2 IS NEW P (NEWINT, NEWINT, 0, 0);
- PROCEDURE NP3 IS NEW P (INT, INT, 0, 0);
- PROCEDURE NP4 IS NEW P (INTEGER, INTEGER, 0, 0);
-
- BEGIN
- NP1 (2, "SUBINT");
- NP2 (2, "NEWINT");
- NP3 (2, "INT");
- NP4 (2, "INTEGER");
- END; -- (A).
-
- RESULT;
-END CC1221A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada
deleted file mode 100644
index 2e4d816..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- CC1221B.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:
--- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, 'LAST, 'WIDTH,
--- 'ADDRESS, AND 'SIZE.
-
--- HISTORY:
--- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CC1221B IS
-
- SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
- SUBTYPE NOINT IS INTEGER RANGE 1 .. -1;
- TYPE NEWINT IS NEW INTEGER;
- TYPE INT IS RANGE -300 .. 300;
- SUBTYPE SINT1 IS INT
- RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
- SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#;
- TYPE INT2 IS RANGE 0E8 .. 1E3;
-
-BEGIN
- TEST ( "CC1221B", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
- "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
- "DECLARED AND ARE THEREFORE AVAILABLE " &
- "WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, " &
- "'LAST, 'WIDTH, 'ADDRESS, AND 'SIZE");
-
- DECLARE -- (B) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
- -- PART II.
-
- GENERIC
- TYPE T IS RANGE <>;
- F, L : T;
- W : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- I : INTEGER := F'SIZE;
- T1 : T;
- A : ADDRESS := T1'ADDRESS;
-
- BEGIN
- IF T'FIRST /= F THEN
- FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" );
- END IF;
-
- IF T'LAST /= L THEN
- FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" );
- END IF;
-
- IF T'BASE'FIRST > T'FIRST THEN
- FAILED ( "INCORRECT RESULTS WITH " & STR &
- "'BASE'FIRST" );
- END IF;
-
- IF T'BASE'LAST < T'LAST THEN
- FAILED ( "INCORRECT RESULTS WITH " & STR &
- "'BASE'LAST" );
- END IF;
-
- IF T'WIDTH /= W THEN
- FAILED ( "INCORRECT VALUE FOR " & STR &
- "'WIDTH" );
- END IF;
-
- IF T'BASE'WIDTH < T'WIDTH THEN
- FAILED ( "INCORRECT RESULTS WITH " & STR &
- "'BASE'WIDTH" );
- END IF;
-
- END P;
-
- GENERIC
- TYPE T IS RANGE <>;
- PROCEDURE Q;
-
- PROCEDURE Q IS
- BEGIN
- IF T'FIRST /= 1 THEN
- FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" );
- END IF;
-
- IF T'LAST /= -1 THEN
- FAILED ( "INCORRECT VALUE FOR NOINT'LAST" );
- END IF;
-
- IF T'BASE'FIRST > T'FIRST THEN
- FAILED ( "INCORRECT RESULTS WITH " &
- "NOINT'BASE'FIRST" );
- END IF;
-
- IF T'BASE'LAST < T'LAST THEN
- FAILED ( "INCORRECT RESULTS WITH " &
- "NOINT'BASE'LAST" );
- END IF;
-
- IF T'WIDTH /= 0 THEN
- FAILED ( "INCORRECT VALUE FOR " &
- "NOINT'WIDTH" );
- END IF;
-
- IF T'BASE'WIDTH < T'WIDTH THEN
- FAILED ( "INCORRECT RESULTS WITH " &
- "NOINT'BASE'WIDTH" );
- END IF;
-
- END Q;
-
- PROCEDURE P1 IS NEW P (INTEGER, INTEGER'FIRST, INTEGER'LAST,
- INTEGER'WIDTH);
- PROCEDURE P2 IS NEW P (SUBINT, -100, 100, 4);
- PROCEDURE P3 IS NEW P (NEWINT, NEWINT'FIRST, NEWINT'LAST,
- NEWINT'WIDTH);
- PROCEDURE P4 IS NEW P (SINT1, -4, 4, 2);
- PROCEDURE P5 IS NEW P (SINT2, 224, 255, 4);
- PROCEDURE P6 IS NEW P (INT2 , 0, 1000, 5);
-
- PROCEDURE Q1 IS NEW Q (NOINT);
-
- BEGIN
- P1 ( "INTEGER" );
- P2 ( "SUBINT" );
- P3 ( "NEWINT" );
- P4 ( "SINT1" );
- P5 ( "SINT2" );
- P6 ( "INT2" );
-
- Q1;
-
- END; -- (B).
-
- RESULT;
-END CC1221B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada
deleted file mode 100644
index 2173885..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada
+++ /dev/null
@@ -1,195 +0,0 @@
--- CC1221C.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:
--- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC,
--- 'IMAGE, AND 'VALUE.
-
--- HISTORY:
--- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CC1221C IS
-
- SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
- TYPE NEWINT IS NEW INTEGER;
- TYPE INT IS RANGE -300 .. 300;
- SUBTYPE SINT1 IS INT
- RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
- TYPE INT1 IS RANGE -6 .. 6;
-
-BEGIN
- TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
- "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
- "DECLARED AND ARE THEREFORE AVAILABLE " &
- "WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " &
- "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE");
-
- DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
- -- PART III.
-
- GENERIC
- TYPE T IS RANGE <>;
- F : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
- I : INTEGER;
- Y : T;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN T'SUCC (T'FIRST);
- END IF;
- END IDENT;
-
- BEGIN
- I := F;
- FOR X IN T LOOP
- IF T'VAL (I) /= X THEN
- FAILED ( "WRONG VALUE FOR " & STR &
- "'VAL OF " & INTEGER'IMAGE (I));
- END IF;
-
- IF T'POS (X) /= I THEN
- FAILED ( "WRONG VALUE FOR " & STR &
- "'POS OF " & T'IMAGE (X));
- END IF;
-
- I := I + 1;
- END LOOP;
-
- FOR X IN T LOOP
- IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN
- FAILED ( "WRONG VALUE FOR " & STR &
- "'SUCC OF " & T'IMAGE (X));
- END IF;
-
- IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN
- FAILED ( "WRONG VALUE FOR " & STR &
- "'PRED OF " & T'IMAGE (X));
- END IF;
- END LOOP;
-
- BEGIN
- Y := T'SUCC (IDENT (T'BASE'LAST));
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'SUCC (IDENT (" & STR &
- "'BASE'LAST))" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'SUCC (IDENT (" & STR &
- "'BASE'LAST))" );
- END;
-
- BEGIN
- Y := T'PRED (IDENT (T'BASE'FIRST));
- FAILED ( "NO EXCEPTION RAISED FOR " &
- STR & "'PRED (IDENT (" & STR &
- "'BASE'FIRST))" );
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED FOR " &
- STR & "'PRED (IDENT (" & STR &
- "'BASE'FIRST))" );
- END;
-
- END P;
-
- PROCEDURE P1 IS NEW P (SUBINT, -100);
- PROCEDURE P2 IS NEW P (SINT1, -4);
- PROCEDURE P3 IS NEW P (INT1, -6);
-
- BEGIN
- P1 ( "SUBINT" );
- P2 ( "SINT" );
- P3 ( "INT1" );
- END; -- (C1).
-
- DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
- -- PART IV.
-
- GENERIC
- TYPE T IS RANGE <>;
- STR : STRING;
- PACKAGE PKG IS END PKG;
-
- PACKAGE BODY PKG IS
- PROCEDURE P (IM : STRING; VA : T) IS
- BEGIN
- IF T'IMAGE (VA) /= IM THEN
- FAILED ( "INCORRECT RESULTS FOR " & STR &
- "'IMAGE OF " &
- INTEGER'IMAGE (INTEGER (VA)));
- END IF;
- END P;
-
- PROCEDURE Q (IM : STRING; VA : T) IS
- BEGIN
- IF T'VALUE (IM) /= VA THEN
- FAILED ( "INCORRECT RESULTS FOR " & STR &
- "'VALUE OF " & IM);
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
- STR &"'VALUE OF " & IM);
- WHEN OTHERS =>
- FAILED ( "OTHER EXCEPTION RAISED FOR " &
- STR &"'VALUE OF " & IM);
-
- END Q;
-
- BEGIN
- P (" 2", 2);
- P ("-1", -1);
-
- Q (" 2", 2);
- Q ("-1", -1);
- Q (" 2", 2);
- Q ("-1 ", -1);
- END PKG;
-
- PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT");
- PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1");
- PACKAGE PKG3 IS NEW PKG (INT1, "INT1");
- PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT");
-
- BEGIN
- NULL;
- END; -- (C2).
-
- RESULT;
-END CC1221C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada
deleted file mode 100644
index 931d016..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- CC1221D.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:
--- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: EXPLICIT CONVERSION TO AND FROM REAL
--- TYPES AND IMPLICIT CONVERSION FROM INTEGER LITERALS.
-
--- HISTORY:
--- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CC1221D IS
-
- SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
- TYPE INT IS RANGE -300 .. 300;
- SUBTYPE SINT1 IS INT
- RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
- TYPE INT1 IS RANGE -6 .. 6;
-
-BEGIN
- TEST ( "CC1221D", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
- "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
- "DECLARED AND ARE THEREFORE AVAILABLE " &
- "WITHIN THE GENERIC UNIT: EXPLICIT " &
- "CONVERSION TO AND FROM REAL TYPES AND " &
- "IMPLICIT CONVERSION FROM INTEGER LITERALS");
-
- DECLARE -- (D) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER
- -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM
- -- INTEGER LITERALS.
-
- GENERIC
- TYPE T IS RANGE <>;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0;
- FI0 : FIXED := 0.0;
- FI2 : FIXED := 2.0;
- FIN2 : FIXED := -2.0;
-
- FL0 : FLOAT := 0.0;
- FL2 : FLOAT := 2.0;
- FLN2 : FLOAT := -2.0;
-
- T0 : T := 0;
- T2 : T := 2;
- TN2 : T := -2;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN T'FIRST;
- END IF;
- END IDENT;
-
- BEGIN
- IF T0 + 1 /= 1 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 1" );
- END IF;
-
- IF T2 + 1 /= 3 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 2" );
- END IF;
-
- IF TN2 + 1 /= -1 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 3" );
- END IF;
-
- IF T (FI0) /= T0 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FI2) /= IDENT (T2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FIN2) /= TN2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FL0) /= IDENT (T0) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FL2) /= T2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FLN2) /= IDENT (TN2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (T0) /= FI0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (IDENT (T2)) /= FI2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (TN2) /= FIN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (IDENT (T0)) /= FL0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (T2) /= FL2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (IDENT (TN2)) /= FLN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- END P;
-
- PROCEDURE P1 IS NEW P (SUBINT);
- PROCEDURE P2 IS NEW P (SINT1);
- PROCEDURE P3 IS NEW P (INT1);
-
- BEGIN
- P1 ( "SUBINT" );
- P2 ( "SINT" );
- P3 ( "INT1" );
- END; -- (D).
-
- RESULT;
-END CC1221D;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada
deleted file mode 100644
index f6f6589..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada
+++ /dev/null
@@ -1,290 +0,0 @@
--- CC1222A.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.
---*
--- FOR A FORMAL FLOATING POINT TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS,
--- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC TYPES,
--- AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL TO THE
--- FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DIGITS, 'MACHINE_RADIX,
--- 'MACHINE_MANTISSA, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_ROUNDS,
--- 'MACHINE_OVERFLOWS.
-
--- R.WILLIAMS 9/30/86
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-PROCEDURE CC1222A IS
-
- TYPE NEWFLT IS NEW FLOAT;
-
-BEGIN
- TEST ( "CC1222A", "FOR A FORMAL FLOATING POINT TYPE, CHECK " &
- "THAT THE BASIC OPERATIONS ARE " &
- "IMPLICITLY DECLARED AND ARE THEREFORE " &
- "AVAILABLE WITHIN THE GENERIC UNIT" );
-
- DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND
- -- QUALIFICATION.
-
- GENERIC
- TYPE T IS DIGITS <>;
- TYPE T1 IS DIGITS <>;
- F : T;
- F1 : T1;
- PROCEDURE P (F2 : T; STR : STRING);
-
- PROCEDURE P (F2 : T; STR : STRING) IS
- SUBTYPE ST IS T RANGE -1.0 .. 1.0;
- F3, F4 : T;
-
- FUNCTION FUN (X : T) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (TRUE);
- END FUN;
-
- FUNCTION FUN (X : T1) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (FALSE);
- END FUN;
-
- BEGIN
- F3 := F;
- F4 := F2;
- F3 := F4;
-
- IF F3 /= F2 THEN
- FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " &
- "WITH TYPE - " & STR);
- END IF;
-
- IF F IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF F2 NOT IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF T'(F) /= F THEN
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 1" );
- END IF;
-
- IF FUN (T'(1.0)) THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 2" );
- END IF;
-
- END P;
-
- PROCEDURE P1 IS NEW P (FLOAT, FLOAT, 0.0, 0.0);
- PROCEDURE P2 IS NEW P (NEWFLT, NEWFLT, 0.0, 0.0);
-
- BEGIN
- P1 (2.0, "FLOAT");
- P2 (2.0, "NEWFLT");
- END; -- (A).
-
- DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER
- -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM
- -- REAL LITERAL.
-
- GENERIC
- TYPE T IS DIGITS <>;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0;
- FI0 : FIXED := 0.0;
- FI2 : FIXED := 2.0;
- FIN2 : FIXED := -2.0;
-
- I0 : INTEGER := 0;
- I2 : INTEGER := 2;
- IN2 : INTEGER := -2;
-
- T0 : T := 0.0;
- T2 : T := 2.0;
- TN2 : T := -2.0;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN T'FIRST;
- END IF;
- END IDENT;
-
- BEGIN
- IF T0 + 1.0 /= 1.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 1" );
- END IF;
-
- IF T2 + 1.0 /= 3.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 2" );
- END IF;
-
- IF TN2 + 1.0 /= -1.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 3" );
- END IF;
-
- IF T (FI0) /= T0 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FI2) /= IDENT (T2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FIN2) /= TN2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FIXED VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (I0) /= IDENT (T0) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE 0 WITH TYPE " & STR);
- END IF;
-
- IF T (I2) /= T2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE 2 WITH TYPE " & STR);
- END IF;
-
- IF T (IN2) /= IDENT (TN2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE -2 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (T0) /= FI0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (IDENT (T2)) /= FI2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF FIXED (TN2) /= FIN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FIXED VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (IDENT (T0)) /= I0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE 0 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (T2) /= I2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE 2 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (IDENT (TN2)) /= IN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE -2 WITH TYPE " & STR);
- END IF;
-
- END P;
-
- PROCEDURE P1 IS NEW P (FLOAT);
- PROCEDURE P2 IS NEW P (NEWFLT);
-
- BEGIN
- P1 ( "FLOAT" );
- P2 ( "NEWFLT" );
- END; -- (B).
-
- DECLARE -- (C) CHECKS FOR ATTRIBUTES.
-
- GENERIC
- TYPE T IS DIGITS <>;
- F, L : T;
- D : INTEGER;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- F1 : T;
- A : ADDRESS := F'ADDRESS;
- S : INTEGER := F'SIZE;
-
- I : INTEGER;
- I1 : INTEGER := T'MACHINE_RADIX;
- I2 : INTEGER := T'MACHINE_MANTISSA;
- I3 : INTEGER := T'MACHINE_EMAX;
- I4 : INTEGER := T'MACHINE_EMIN;
-
- B1 : BOOLEAN := T'MACHINE_ROUNDS;
- B2 : BOOLEAN := T'MACHINE_OVERFLOWS;
-
- BEGIN
- IF T'DIGITS /= D THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'DIGITS" );
- END IF;
-
- IF T'FIRST /= F THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'FIRST" );
- END IF;
-
- IF T'LAST /= L THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'LAST" );
- END IF;
-
- END P;
-
- PROCEDURE P1 IS
- NEW P (FLOAT, FLOAT'FIRST, FLOAT'LAST, FLOAT'DIGITS);
- PROCEDURE P2 IS
- NEW P (NEWFLT, NEWFLT'FIRST, NEWFLT'LAST,
- NEWFLT'DIGITS);
-
- BEGIN
- P1 ( "FLOAT" );
- P2 ( "NEWFLT" );
- END; -- (C).
-
- RESULT;
-END CC1222A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada
deleted file mode 100644
index 1f9b005..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada
+++ /dev/null
@@ -1,297 +0,0 @@
--- CC1223A.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:
--- FOR A FORMAL FIXED POINT TYPE, CHECK THAT THE FOLLOWING BASIC
--- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
--- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS,
--- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC
--- TYPES, AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL
--- TO THE FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DELTA, 'FORE,
--- 'AFT, 'MACHINE_ROUNDS, 'MACHINE_OVERFLOWS.
-
--- HISTORY:
--- RJW 09/30/86 CREATED ORIGINAL TEST.
--- JLH 09/25/87 REFORMATTED HEADER.
--- RJW 08/21/89 MODIFIED CHECKS FOR 'MANTISSA AND 'AFT.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1223A IS
-
- TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0;
-
-BEGIN
- TEST ( "CC1223A", "FOR A FORMAL FIXED POINT TYPE, CHECK " &
- "THAT THE BASIC OPERATIONS ARE " &
- "IMPLICITLY DECLARED AND ARE THEREFORE " &
- "AVAILABLE WITHIN THE GENERIC UNIT" );
-
- DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND
- -- QUALIFICATION.
-
- GENERIC
- TYPE T IS DELTA <>;
- TYPE T1 IS DELTA <>;
- F : T;
- F1 : T1;
- PROCEDURE P (F2 : T; STR : STRING);
-
- PROCEDURE P (F2 : T; STR : STRING) IS
- SUBTYPE ST IS T RANGE -1.0 .. 1.0;
- F3, F4 : T;
-
- FUNCTION FUN (X : T) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (TRUE);
- END FUN;
-
- FUNCTION FUN (X : T1) RETURN BOOLEAN IS
- BEGIN
- RETURN IDENT_BOOL (FALSE);
- END FUN;
-
- BEGIN
- F3 := F;
- F4 := F2;
- F3 := F4;
-
- IF F3 /= F2 THEN
- FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " &
- "WITH TYPE - " & STR);
- END IF;
-
- IF F IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF F2 NOT IN ST THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " &
- "TYPE - " & STR);
- END IF;
-
- IF T'(F) /= F THEN
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 1" );
- END IF;
-
- IF FUN (T'(1.0)) THEN
- NULL;
- ELSE
- FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " &
- "WITH TYPE - " & STR & " - 2" );
- END IF;
-
- END P;
-
- PROCEDURE P1 IS NEW P (FIXED, FIXED, 0.0, 0.0);
- PROCEDURE P2 IS NEW P (DURATION, DURATION, 0.0, 0.0);
-
- BEGIN
- P1 (2.0, "FIXED");
- P2 (2.0, "DURATION");
- END; -- (A).
-
- DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER
- -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM
- -- REAL LITERAL.
-
- GENERIC
- TYPE T IS DELTA <>;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- FL0 : FLOAT := 0.0;
- FL2 : FLOAT := 2.0;
- FLN2 : FLOAT := -2.0;
-
- I0 : INTEGER := 0;
- I2 : INTEGER := 2;
- IN2 : INTEGER := -2;
-
- T0 : T := 0.0;
- T2 : T := 2.0;
- TN2 : T := -2.0;
-
- FUNCTION IDENT (X : T) RETURN T IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN T'FIRST;
- END IF;
- END IDENT;
-
- BEGIN
- IF T0 + 1.0 /= 1.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 1" );
- END IF;
-
- IF T2 + 1.0 /= 3.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 2" );
- END IF;
-
- IF TN2 + 1.0 /= -1.0 THEN
- FAILED ( "INCORRECT RESULTS FOR IMPLICIT " &
- "CONVERSION WITH TYPE " & STR & " - 3" );
- END IF;
-
- IF T (FL0) /= T0 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FL2) /= IDENT (T2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (FLN2) /= TN2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "FLOAT VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF T (I0) /= IDENT (T0) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE 0 WITH TYPE " & STR);
- END IF;
-
- IF T (I2) /= T2 THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE 2 WITH TYPE " & STR);
- END IF;
-
- IF T (IN2) /= IDENT (TN2) THEN
- FAILED ( "INCORRECT CONVERSION FROM " &
- "INTEGER VALUE -2 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (T0) /= FL0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE 0.0 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (IDENT (T2)) /= FL2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE 2.0 WITH TYPE " & STR);
- END IF;
-
- IF FLOAT (TN2) /= FLN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "FLOAT VALUE -2.0 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (IDENT (T0)) /= I0 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE 0 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (T2) /= I2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE 2 WITH TYPE " & STR);
- END IF;
-
- IF INTEGER (IDENT (TN2)) /= IN2 THEN
- FAILED ( "INCORRECT CONVERSION TO " &
- "INTEGER VALUE -2 WITH TYPE " & STR);
- END IF;
-
- END P;
-
- PROCEDURE P1 IS NEW P (FIXED);
- PROCEDURE P2 IS NEW P (DURATION);
-
- BEGIN
- P1 ( "FIXED" );
- P2 ( "DURATION" );
- END; -- (B).
-
- DECLARE -- (C) CHECKS FOR ATTRIBUTES.
-
- GENERIC
- TYPE T IS DELTA <>;
- F, L, D : T;
- PROCEDURE P (STR : STRING);
-
- PROCEDURE P (STR : STRING) IS
-
- F1 : T;
- A : ADDRESS := F'ADDRESS;
- S : INTEGER := F'SIZE;
-
- I : INTEGER;
-
- B1 : BOOLEAN := T'MACHINE_ROUNDS;
- B2 : BOOLEAN := T'MACHINE_OVERFLOWS;
-
- BEGIN
- IF T'DELTA /= D THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'DELTA" );
- END IF;
-
- IF T'FIRST /= F THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'FIRST" );
- END IF;
-
- IF T'LAST /= L THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'LAST" );
- END IF;
-
- IF T'FORE < 2 THEN
- FAILED ( "INCORRECT VALUE FOR " &
- STR & "'FORE" );
- END IF;
-
- IF T'AFT <= 0 THEN
- FAILED ( "INCORRECT VALUE FOR " & STR & "'AFT" );
- END IF;
-
- END P;
-
- PROCEDURE P1 IS
- NEW P (FIXED, FIXED'FIRST, FIXED'LAST, FIXED'DELTA);
- PROCEDURE P2 IS
- NEW P (DURATION, DURATION'FIRST, DURATION'LAST,
- DURATION'DELTA);
-
- BEGIN
- P1 ( "FIXED" );
- P2 ( "DURATION" );
- END; -- (C).
-
- RESULT;
-END CC1223A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada
deleted file mode 100644
index c419fb7..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada
+++ /dev/null
@@ -1,558 +0,0 @@
--- CC1224A.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:
--- FOR ARRAY TYPES WITH A NONLIMITED COMPONENT TYPE (OF A FORMAL
--- AND NONFORMAL GENERIC TYPE), CHECK THAT THE FOLLOWING OPERATIONS
--- ARE IMPLICITY DECLARED AND ARE, THEREFORE, AVAILABLE WITHIN THE
--- GENERIC UNIT: ASSIGNMENT, THE OPERATION ASSOCIATED WITH
--- AGGREGATE NOTATION, MEMBERSHIP TESTS, THE OPERATION ASSOCIATED
--- WITH INDEXED COMPONENTS, QUALIFICATION, EXPLICIT CONVERSION,
--- 'SIZE, 'ADDRESS, 'FIRST, 'FIRST (N), 'LAST, 'LAST (N),
--- 'RANGE, 'RANGE (N), 'LENGTH, 'LENGTH (N).
-
--- HISTORY:
--- R.WILLIAMS 10/6/86
--- EDWARD V. BERARD 8/10/90 ADDED CHECKS FOR MULTI-DIMENSIONAL
--- ARRAYS
--- LDC 10/10/90 CHANGED DECLARATIONS OF AD1 - AD6 TO PROCEDURE
--- CALLS OF FA1 - FA6 TO ADDRESS_CHECK AS SUGGESTED
--- BY THE CRG.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH SYSTEM ;
-WITH REPORT ;
-
-PROCEDURE CC1224A IS
-
- SHORT_START : CONSTANT := -10 ;
- SHORT_END : CONSTANT := 10 ;
-
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
- SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ;
-
- MEDIUM_START : CONSTANT := 1 ;
- MEDIUM_END : CONSTANT := 15 ;
-
- TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ;
- MEDIUM_LENGTH : CONSTANT NATURAL :=
- (MEDIUM_END - MEDIUM_START + 1) ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (AUG, 10, 1990) ;
-
- TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>,
- MEDIUM_RANGE RANGE <>) OF DATE ;
-
- TYPE SECOND_TEMPLATE IS ARRAY (SHORT_RANGE, MEDIUM_RANGE)
- OF DATE ;
-
- FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 6 .. 10) ;
- SECOND_ARRAY : FIRST_TEMPLATE (0 .. 7, 1 .. 15) ;
- THIRD_ARRAY : SECOND_TEMPLATE ;
- FOURTH_ARRAY : SECOND_TEMPLATE ;
-
- SUBTYPE SUBINT IS INTEGER RANGE REPORT.IDENT_INT (1) ..
- REPORT.IDENT_INT (6);
-
- TYPE ARRA IS ARRAY (SUBINT) OF SUBINT;
- A1 : ARRA := (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => 1);
- A2 : ARRA := (A1'RANGE => 2);
-
- TYPE ARRB IS ARRAY (SUBINT RANGE <>) OF DATE ;
- A3 : ARRB (1 .. 6) :=
- (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => TODAY);
-
- TYPE ARRC IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF SUBINT;
- A4 : CONSTANT ARRC := (1 .. 6 => (1 .. 6 => 4));
-
- TYPE ARRD IS ARRAY (SUBINT, SUBINT) OF SUBINT;
- A5 : ARRD := (A4'RANGE (1) => (A4'RANGE (2) => 5));
-
- TYPE ARRE IS ARRAY (SUBINT) OF DATE ;
- A6 : ARRE := (A1'RANGE => TODAY);
-
- FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ;
- RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN
- RENAMES SYSTEM."=" ;
-
- GENERIC
-
- TYPE T1 IS (<>);
- TYPE T2 IS PRIVATE;
- X2 : T2;
-
- TYPE FARR1 IS ARRAY (SUBINT) OF T1;
- FA1 : FARR1;
-
- TYPE FARR2 IS ARRAY (SUBINT) OF SUBINT;
- FA2 : FARR2;
-
- TYPE FARR3 IS ARRAY (SUBINT RANGE <>) OF T2;
- FA3 : FARR3;
-
- TYPE FARR4 IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF T1;
- FA4 : FARR4;
-
- TYPE FARR5 IS ARRAY (SUBINT, SUBINT) OF SUBINT;
- FA5 : FARR5;
-
- TYPE FARR6 IS ARRAY (T1) OF T2;
- FA6 : FARR6;
-
- TYPE FARR7 IS ARRAY (T1) OF T2;
- FA7 : FARR7;
-
- PROCEDURE P ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE UNCONSTRAINED_ARRAY IS ARRAY
- (FIRST_INDEX RANGE <>, SECOND_INDEX RANGE <>) OF DATE ;
-
- PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ;
- FFIFS : IN FIRST_INDEX ;
- FFILS : IN FIRST_INDEX ;
- FSIFS : IN SECOND_INDEX ;
- FSILS : IN SECOND_INDEX ;
- FFLEN : IN NATURAL ;
- FSLEN : IN NATURAL ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : IN UNCONSTRAINED_ARRAY ;
- SFIFS : IN FIRST_INDEX ;
- SFILS : IN FIRST_INDEX ;
- SSIFS : IN SECOND_INDEX ;
- SSILS : IN SECOND_INDEX ;
- SFLEN : IN NATURAL ;
- SSLEN : IN NATURAL ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) ;
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- TYPE CONSTRAINED_ARRAY IS ARRAY
- (FIRST_INDEX,SECOND_INDEX) OF COMPONENT_TYPE ;
-
- PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : IN CONSTRAINED_ARRAY ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) ;
-
-
- PROCEDURE P IS
-
- IN1 : INTEGER := FA1'SIZE;
- IN2 : INTEGER := FA2'SIZE;
- IN3 : INTEGER := FA3'SIZE;
- IN4 : INTEGER := FA4'SIZE;
- IN5 : INTEGER := FA5'SIZE;
- IN6 : INTEGER := FA6'SIZE;
-
- B1 : FARR1;
-
- B2 : FARR2;
-
- SUBTYPE SARR3 IS FARR3 (FA3'RANGE);
- B3 : SARR3;
-
- SUBTYPE SARR4 IS FARR4 (FA4'RANGE (1), FA4'RANGE (2));
- B4 : SARR4;
-
- B5 : FARR5;
-
- B6 : FARR6 ;
-
- PROCEDURE ADDRESS_CHECK(ADDRESS : SYSTEM.ADDRESS) IS
-
- BEGIN
- IF REPORT.EQUAL(1, REPORT.IDENT_INT(2)) THEN
- REPORT.COMMENT("DON'T OPTIMIZE OUT ADDRESS_CHECK");
- END IF;
- END ADDRESS_CHECK;
-
- BEGIN -- P
-
- ADDRESS_CHECK(FA1'ADDRESS);
- ADDRESS_CHECK(FA2'ADDRESS);
- ADDRESS_CHECK(FA3'ADDRESS);
- ADDRESS_CHECK(FA4'ADDRESS);
- ADDRESS_CHECK(FA5'ADDRESS);
- ADDRESS_CHECK(FA6'ADDRESS);
-
- B1 := FA1;
-
- IF B1 /= FARR1 (FA1) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 1" );
- END IF;
-
- B2 := FA2;
-
- IF B2 /= FARR2 (A2) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 2" );
- END IF;
-
- B3 := FA3;
-
- IF B3 /= FARR3 (FA3) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 3" );
- END IF;
-
- B4 := FA4;
-
- IF B4 /= FARR4 (FA4) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 4" );
- END IF;
-
- B5 := FA5;
-
- IF B5 /= FARR5 (A5) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 5" );
- END IF;
-
- B6 := FA6;
-
- IF B6 /= FARR6 (FA6) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 6" );
- END IF;
-
- IF FA7 /= FARR7 (FA6) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 7" );
- END IF;
-
- B1 := FARR1'(FA1'RANGE => T1'VAL (1));
-
- IF B1 (1) /= FA1 (1) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 8" );
- END IF;
-
- B1 := FARR1'(1 => T1'VAL (1), 2 => T1'VAL (1),
- 3 .. 6 => T1'VAL (2));
-
- IF B1 (1) /= FA1 (1) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 9" );
- END IF;
-
- B2 := FARR2'(FA2'RANGE => 2);
-
- IF B2 (2) /= FA2 (2) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 10" );
- END IF;
-
- B3 := FARR3'(1|2|3 => X2, 4|5|6 => X2);
-
- IF B3 (3) /= FA3 (3) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 11" );
- END IF;
-
- B4 := FARR4'(FA5'RANGE (1) => (FA5'RANGE (2) => T1'VAL (4)));
-
- IF B4 (4, 4) /= FA4 (4, 4) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 12" );
- END IF;
-
- B5 := FARR5'(REPORT.IDENT_INT (1) ..
- REPORT.IDENT_INT (6) => (1 .. 6 => 5));
-
- IF B5 (5, 5) /= FA5 (5, 5) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 13" );
- END IF;
-
- B6 := FARR6'(FA6'RANGE => X2);
-
- IF B6 (T1'FIRST) /= FA6 (T1'FIRST) THEN
- REPORT.FAILED ("INCORRECT RESULTS - 14" );
- END IF;
-
- IF B1 NOT IN FARR1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 15" );
- END IF;
-
- IF FA2 NOT IN FARR2 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 16" );
- END IF;
-
- IF FA3 NOT IN FARR3 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 17" );
- END IF;
-
- IF B4 NOT IN FARR4 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 18" );
- END IF;
-
- IF B5 NOT IN FARR5 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 19" );
- END IF;
-
- IF FA6 NOT IN FARR6 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 20" );
- END IF;
-
- IF FA1'LENGTH /= FA1'LAST - FA1'FIRST + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 27" );
- END IF;
-
- IF FA2'LENGTH /= FA2'LAST - FA2'FIRST + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 28" );
- END IF;
-
- IF FA3'LENGTH /= FA3'LAST - FA3'FIRST + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 29" );
- END IF;
-
- IF FA4'LENGTH /= FA4'LAST - FA4'FIRST + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 30" );
- END IF;
-
- IF FA4'LENGTH (2) /= FA4'LAST (2) - FA4'FIRST (2) + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 31" );
- END IF;
-
- IF FA5'LENGTH /= FA5'LAST - FA5'FIRST + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 32" );
- END IF;
-
- IF FA5'LENGTH (2) /= FA5'LAST (2) - FA5'FIRST (2) + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 33" );
- END IF;
-
- IF FA6'LENGTH /= T1'POS (FA6'LAST) -
- T1'POS (FA6'FIRST) + 1 THEN
- REPORT.FAILED ("INCORRECT RESULTS - 34" );
- END IF;
-
- END P ;
-
- PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ;
- FFIFS : IN FIRST_INDEX ;
- FFILS : IN FIRST_INDEX ;
- FSIFS : IN SECOND_INDEX ;
- FSILS : IN SECOND_INDEX ;
- FFLEN : IN NATURAL ;
- FSLEN : IN NATURAL ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : IN UNCONSTRAINED_ARRAY ;
- SFIFS : IN FIRST_INDEX ;
- SFILS : IN FIRST_INDEX ;
- SSIFS : IN SECOND_INDEX ;
- SSILS : IN SECOND_INDEX ;
- SFLEN : IN NATURAL ;
- SSLEN : IN NATURAL ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) IS
-
- BEGIN -- TEST_PROCEDURE
-
- IF (FIRST'FIRST /= FFIFS) OR
- (FIRST'FIRST (1) /= FFIFS) OR
- (FIRST'FIRST (2) /= FSIFS) OR
- (SECOND'FIRST /= SFIFS) OR
- (SECOND'FIRST (1) /= SFIFS) OR
- (SECOND'FIRST (2) /= SSIFS) THEN
- REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LAST /= FFILS) OR
- (FIRST'LAST (1) /= FFILS) OR
- (FIRST'LAST (2) /= FSILS) OR
- (SECOND'LAST /= SFILS) OR
- (SECOND'LAST (1) /= SFILS) OR
- (SECOND'LAST (2) /= SSILS) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LENGTH /= FFLEN) OR
- (FIRST'LENGTH (1) /= FFLEN) OR
- (FIRST'LENGTH (2) /= FSLEN) OR
- (SECOND'LENGTH /= SFLEN) OR
- (SECOND'LENGTH (1) /= SFLEN) OR
- (SECOND'LENGTH (2) /= SSLEN) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ;
- END IF ;
-
- IF (FFIRT NOT IN FIRST'RANGE (1)) OR
- (FFIRT NOT IN FIRST'RANGE) OR
- (SFIRT NOT IN SECOND'RANGE (1)) OR
- (SFIRT NOT IN SECOND'RANGE) OR
- (FSIRT NOT IN FIRST'RANGE (2)) OR
- (SSIRT NOT IN SECOND'RANGE (2)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " &
- REMARKS) ;
- END IF ;
-
- END TEST_PROCEDURE ;
-
- PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ;
- FFIRT : IN FIRST_INDEX ;
- FSIRT : IN SECOND_INDEX ;
- SECOND : IN CONSTRAINED_ARRAY ;
- SFIRT : IN FIRST_INDEX ;
- SSIRT : IN SECOND_INDEX ;
- REMARKS : IN STRING) IS
-
- BEGIN -- CTEST_PROCEDURE
-
- IF (FIRST'FIRST /= FIRST_INDEX'FIRST) OR
- (FIRST'FIRST (1) /= FIRST_INDEX'FIRST) OR
- (FIRST'FIRST (2) /= SECOND_INDEX'FIRST) OR
- (SECOND'FIRST /= FIRST_INDEX'FIRST) OR
- (SECOND'FIRST (1) /= FIRST_INDEX'FIRST) OR
- (SECOND'FIRST (2) /= SECOND_INDEX'FIRST) THEN
- REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LAST /= FIRST_INDEX'LAST) OR
- (FIRST'LAST (1) /= FIRST_INDEX'LAST) OR
- (FIRST'LAST (2) /= SECOND_INDEX'LAST) OR
- (SECOND'LAST /= FIRST_INDEX'LAST) OR
- (SECOND'LAST (1) /= FIRST_INDEX'LAST) OR
- (SECOND'LAST (2) /= SECOND_INDEX'LAST) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ;
- END IF ;
-
- IF (FIRST'LENGTH /=
- FIRST_INDEX'POS (FIRST_INDEX'LAST)
- - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR
- (FIRST'LENGTH (1) /=
- FIRST_INDEX'POS (FIRST_INDEX'LAST)
- - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR
- (FIRST'LENGTH (2) /=
- SECOND_INDEX'POS (SECOND_INDEX'LAST)
- - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) OR
- (SECOND'LENGTH /=
- FIRST_INDEX'POS (FIRST_INDEX'LAST)
- - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR
- (SECOND'LENGTH (1) /=
- FIRST_INDEX'POS (FIRST_INDEX'LAST)
- - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR
- (SECOND'LENGTH (2) /=
- SECOND_INDEX'POS (SECOND_INDEX'LAST)
- - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ;
- END IF ;
-
- IF (FFIRT NOT IN FIRST'RANGE (1)) OR
- (FFIRT NOT IN FIRST'RANGE) OR
- (SFIRT NOT IN SECOND'RANGE (1)) OR
- (SFIRT NOT IN SECOND'RANGE) OR
- (FSIRT NOT IN FIRST'RANGE (2)) OR
- (SSIRT NOT IN SECOND'RANGE (2)) THEN
- REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " &
- REMARKS) ;
- END IF ;
-
- IF CONSTRAINED_ARRAY'SIZE <= 0 THEN
- REPORT.FAILED ("PROBLEMS WITH THE 'SIZE ATTRIBUTE. " &
- REMARKS) ;
- END IF ;
-
- IF FIRST'ADDRESS = SECOND'ADDRESS THEN
- REPORT.FAILED ("PROBLEMS WITH THE 'ADDRESS ATTRIBUTE. " &
- REMARKS) ;
- END IF ;
-
- END CTEST_PROCEDURE ;
-
- PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE
- (FIRST_INDEX => SHORT_RANGE,
- SECOND_INDEX => MEDIUM_RANGE,
- UNCONSTRAINED_ARRAY => FIRST_TEMPLATE) ;
-
- PROCEDURE NEW_CTEST_PROCEDURE IS NEW CTEST_PROCEDURE
- (FIRST_INDEX => SHORT_RANGE,
- SECOND_INDEX => MEDIUM_RANGE,
- COMPONENT_TYPE => DATE,
- CONSTRAINED_ARRAY => SECOND_TEMPLATE) ;
-
- PROCEDURE NP IS NEW P (SUBINT, DATE, TODAY, ARRA, A1,
- ARRA, A2, ARRB, A3, ARRC, A4, ARRD,
- A5, ARRE, A6, ARRE, A6);
-
-BEGIN -- CC1224A
-
- REPORT.TEST ("CC1224A", "FOR ARRAY TYPES WITH A NONLIMITED " &
- "COMPONENT TYPE (OF A FORMAL AND NONFORMAL GENERIC " &
- "TYPE), CHECK THAT THE FOLLOWING OPERATIONS " &
- "ARE IMPLICITY DECLARED AND ARE, THEREFORE, " &
- "AVAILABLE WITHIN THE GENERIC -- UNIT: " &
- "ASSIGNMENT, THE OPERATION ASSOCIATED WITH " &
- "AGGREGATE NOTATION, MEMBERSHIP TESTS, THE " &
- "OPERATION ASSOCIATED WITH INDEXED " &
- "COMPONENTS, QUALIFICATION, EXPLICIT " &
- "CONVERSION, 'SIZE, 'ADDRESS, 'FIRST, " &
- "'FIRST (N), 'LAST, 'LAST (N), 'RANGE, " &
- "'RANGE (N), 'LENGTH, 'LENGTH (N)" ) ;
-
- NP ;
-
- FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY,
- FFIFS => -10,
- FFILS => 10,
- FSIFS => 6,
- FSILS => 10,
- FFLEN => 21,
- FSLEN => 5,
- FFIRT => 0,
- FSIRT => 8,
- SECOND => SECOND_ARRAY,
- SFIFS => 0,
- SFILS => 7,
- SSIFS => 1,
- SSILS => 15,
- SFLEN => 8,
- SSLEN => 15,
- SFIRT => 5,
- SSIRT => 13,
- REMARKS => "FIRST_TEST_PROCEDURE") ;
-
- NEW_CTEST_PROCEDURE (FIRST => THIRD_ARRAY,
- FFIRT => -5,
- FSIRT => 11,
- SECOND => FOURTH_ARRAY,
- SFIRT => 0,
- SSIRT => 14,
- REMARKS => "NEW_CTEST_PROCEDURE") ;
-
- REPORT.RESULT ;
-
-END CC1224A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst b/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst
deleted file mode 100644
index dfad3b0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst
+++ /dev/null
@@ -1,350 +0,0 @@
--- CC1225A.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.
---*
--- OBJECTIVE:
--- CHECK, FOR A FORMAL ACCESS TYPE, THAT ALL ALLOWABLE OPERATIONS
--- ARE IMPLICITLY DECLARED.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- BCB 03/29/88 CREATED ORIGINAL TEST.
--- RDH 04/09/90 ADDED 'STORAGE_SIZE CLAUSES. CHANGED EXTENSION TO
--- 'TST'.
--- LDC 09/26/90 REMOVED 'USE PACK' AFTER THE WITH SINCE IT ISN'T
--- NEEDED, ADDED CHECK FOR NULL AFTER ASSIGMENT TO
--- NULL, ADDED CHECKS FOR OTHER RELATION OPERATORS,
--- CHANGED CHECK FOR 'ADDRESS TO A PROCEDURE CALL.
--- LDC 10/13/90 CHANGED CHECK FOR 'SIZE TO ONLY CHECK FOR
--- AVAILABILITY. CHANGED CHECK FOR 'ADDRESS TO A
--- MEMBERSHIP TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CC1225A IS
-
- TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TYPE AI IS ACCESS INTEGER;
-
- TYPE ACCINTEGER IS ACCESS INTEGER;
-
- TYPE REC IS RECORD
- COMP : INTEGER;
- END RECORD;
-
- TYPE DISCREC (DISC : INTEGER := 1) IS RECORD
- COMPD : INTEGER;
- END RECORD;
-
- TYPE AREC IS ACCESS REC;
-
- TYPE ADISCREC IS ACCESS DISCREC;
-
- TYPE ARR IS ARRAY(1..2,1..2) OF INTEGER;
-
- TYPE ONEDIM IS ARRAY(1..10) OF INTEGER;
-
- TYPE AA IS ACCESS ARR;
-
- TYPE AONEDIM IS ACCESS ONEDIM;
-
- TYPE ENUM IS (ONE, TWO, THREE);
-
- TASK TYPE T IS
- ENTRY HERE(VAL : IN OUT INTEGER);
- END T;
-
- TYPE ATASK IS ACCESS T;
-
- TYPE ANOTHERTASK IS ACCESS T;
- FOR ANOTHERTASK'STORAGE_SIZE USE 2 * TASK_STORAGE_SIZE;
-
- TASK TYPE T1 IS
- ENTRY HERE1(ENUM)(VAL1 : IN OUT INTEGER);
- END T1;
-
- TYPE ATASK1 IS ACCESS T1;
-
- TASK BODY T IS
- BEGIN
- ACCEPT HERE(VAL : IN OUT INTEGER) DO
- VAL := VAL * 2;
- END HERE;
- END T;
-
- TASK BODY T1 IS
- BEGIN
- SELECT
- ACCEPT HERE1(ONE)(VAL1 : IN OUT INTEGER) DO
- VAL1 := VAL1 * 1;
- END HERE1;
- OR
- ACCEPT HERE1(TWO)(VAL1 : IN OUT INTEGER) DO
- VAL1 := VAL1 * 2;
- END HERE1;
- OR
- ACCEPT HERE1(THREE)(VAL1 : IN OUT INTEGER) DO
- VAL1 := VAL1 * 3;
- END HERE1;
- END SELECT;
- END T1;
-
- GENERIC
- TYPE FORM IS (<>);
- TYPE ACCFORM IS ACCESS FORM;
- TYPE ACC IS ACCESS INTEGER;
- TYPE ACCREC IS ACCESS REC;
- TYPE ACCDISCREC IS ACCESS DISCREC;
- TYPE ACCARR IS ACCESS ARR;
- TYPE ACCONE IS ACCESS ONEDIM;
- TYPE ACCTASK IS ACCESS T;
- TYPE ACCTASK1 IS ACCESS T1;
- TYPE ANOTHERTASK1 IS ACCESS T;
- PACKAGE P IS
- END P;
-
- PACKAGE BODY P IS
- AF : ACCFORM;
- TYPE DER_ACC IS NEW ACC;
- A, B : ACC;
- DERA : DER_ACC;
- R : ACCREC;
- DR : ACCDISCREC;
- C : ACCARR;
- D, E : ACCONE;
- F : ACCTASK;
- G : ACCTASK1;
- INT : INTEGER := 5;
-
- BEGIN
- TEST ("CC1225A", "CHECK, FOR A FORMAL ACCESS TYPE, THAT " &
- "ALL ALLOWABLE OPERATIONS ARE IMPLICITLY " &
- "DECLARED");
-
- IF AF'ADDRESS NOT IN ADDRESS THEN
- FAILED ("IMPROPER RESULT FROM AF'ADDRESS TEST");
- END IF;
-
- DECLARE
- AF_SIZE : INTEGER := ACCFORM'SIZE;
- BEGIN
- IF AF_SIZE NOT IN INTEGER THEN
- FAILED ("IMPROPER RESULT FROM AF'SIZE");
- END IF;
- END;
-
- IF ANOTHERTASK1'STORAGE_SIZE < TASK_STORAGE_SIZE THEN
- FAILED ("IMPROPER VALUE FOR ANOTHERTASK1'STORAGE_SIZE");
- END IF;
-
- B := NEW INTEGER'(25);
-
- A := B;
-
- IF A.ALL /= 25 THEN
- FAILED ("IMPROPER VALUE FOR ASSIGNMENT OF VARIABLE " &
- "OF A FORMAL ACCESS TYPE FROM ANOTHER " &
- "VARIABLE OF A FORMAL ACCESS TYPE");
- END IF;
-
- A := NEW INTEGER'(10);
-
- IF A.ALL /= 10 THEN
- FAILED ("IMPROPER VALUE FOR VARIABLE OF FORMAL ACCESS " &
- "TYPE");
- END IF;
-
- IF A NOT IN ACC THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
- END IF;
-
- B := ACC'(A);
-
- IF B.ALL /= 10 THEN
- FAILED ("IMPROPER VALUE FROM QUALIFICATION");
- END IF;
-
- DERA := NEW INTEGER'(10);
- A := ACC(DERA);
-
- IF A.ALL /= IDENT_INT(10) THEN
- FAILED ("IMPROPER VALUE FROM EXPLICIT CONVERSION");
- END IF;
-
- IF A.ALL > IDENT_INT(10) THEN
- FAILED ("IMPROPER VALUE USED IN LESS THAN");
- END IF;
-
- IF A.ALL < IDENT_INT(10) THEN
- FAILED ("IMPROPER VALUE USED IN GREATER THAN");
- END IF;
-
- IF A.ALL >= IDENT_INT(11) THEN
- FAILED ("IMPROPER VALUE USED IN LESS THAN OR EQUAL");
- END IF;
-
- IF A.ALL <= IDENT_INT(9) THEN
- FAILED ("IMPROPER VALUE USED IN GREATER THAN OR EQUAL");
- END IF;
-
- IF NOT (A.ALL + A.ALL = IDENT_INT(20)) THEN
- FAILED ("IMPROPER VALUE FROM ADDITION");
- END IF;
-
- IF NOT (A.ALL - IDENT_INT(2) = IDENT_INT(8)) THEN
- FAILED ("IMPROPER VALUE FROM SUBTRACTION");
- END IF;
-
- IF NOT (A.ALL * IDENT_INT(3) = IDENT_INT(30)) THEN
- FAILED ("IMPROPER VALUE FROM MULTIPLICATION");
- END IF;
-
- IF NOT (A.ALL / IDENT_INT(3) = IDENT_INT(3)) THEN
- FAILED ("IMPROPER VALUE FROM DIVISION");
- END IF;
-
- IF NOT (A.ALL MOD IDENT_INT(3) = IDENT_INT(1)) THEN
- FAILED ("IMPROPER VALUE FROM MODULO");
- END IF;
-
- IF NOT (A.ALL REM IDENT_INT(7) = IDENT_INT(3)) THEN
- FAILED ("IMPROPER VALUE FROM REMAINDER");
- END IF;
-
- IF NOT (A.ALL ** IDENT_INT(2) = IDENT_INT(100)) THEN
- FAILED ("IMPROPER VALUE FROM EXPONENTIATION");
- END IF;
-
- IF NOT (+A.ALL = IDENT_INT(10)) THEN
- FAILED ("IMPROPER VALUE FROM IDENTITY");
- END IF;
-
- IF NOT (-A.ALL = IDENT_INT(-10)) THEN
- FAILED ("IMPROPER VALUE FROM NEGATION");
- END IF;
-
- A := NULL;
-
- IF A /= NULL THEN
- FAILED ("IMPROPER VALUE FROM ACCESS SET TO NULL");
- END IF;
-
- IF A'ADDRESS NOT IN ADDRESS THEN
- FAILED ("IMPROPER RESULT FROM A'ADDRESS TEST");
- END IF;
-
-
- DECLARE
- ACC_SIZE : INTEGER := ACC'SIZE;
- BEGIN
- IF ACC_SIZE NOT IN INTEGER THEN
- FAILED ("IMPROPER RESULT FROM ACC'SIZE");
- END IF;
- END;
-
- R := NEW REC'(COMP => 5);
-
- IF NOT EQUAL(R.COMP,5) THEN
- FAILED ("IMPROPER VALUE FOR RECORD COMPONENT");
- END IF;
-
- DR := NEW DISCREC'(DISC => 1, COMPD => 5);
-
- IF NOT EQUAL(DR.DISC,1) OR NOT EQUAL(DR.COMPD,5) THEN
- FAILED ("IMPROPER VALUES FOR DISCRIMINATED RECORD " &
- "COMPONENTS");
- END IF;
-
- C := NEW ARR'(1 => (1,2), 2 => (3,4));
-
- IF C(1,1) /= 1 OR C(1,2) /= 2 OR C(2,1) /= 3 OR C(2,2) /= 4
- THEN FAILED ("IMPROPER ARRAY COMPONENT VALUES");
- END IF;
-
- D := NEW ONEDIM'(1,2,3,4,5,6,7,8,9,10);
- E := NEW ONEDIM'(10,9,8,7,6,5,4,3,2,1);
-
- D(1..5) := E(1..5);
-
- IF D(1) /= 10 OR D(2) /= 9 OR D(3) /= 8
- OR D(4) /= 7 OR D(5) /= 6 THEN
- FAILED ("IMPROPER RESULTS FROM SLICE ASSIGNMENT");
- END IF;
-
- IF C'FIRST /= 1 OR C'FIRST(2) /= 1 THEN
- FAILED ("IMPROPER LOWER BOUNDS FOR CONSTRAINED ARRAY");
- END IF;
-
- IF C'LAST /= 2 OR C'LAST(2) /= 2 THEN
- FAILED ("IMPROPER UPPER BOUNDS FOR CONSTRAINED ARRAY");
- END IF;
-
- IF 1 NOT IN C'RANGE THEN
- FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 1");
- END IF;
-
- IF 1 NOT IN C'RANGE(2) THEN
- FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 2");
- END IF;
-
- IF C'LENGTH /= 2 THEN
- FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " &
- "ARRAY - 1");
- END IF;
-
- IF C'LENGTH(2) /= 2 THEN
- FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " &
- "ARRAY - 2");
- END IF;
-
- F := NEW T;
-
- F.HERE(INT);
-
- IF NOT EQUAL(INT,IDENT_INT(10)) THEN
- FAILED ("IMPROPER RESULTS FROM ENTRY SELECTION");
- END IF;
-
- G := NEW T1;
-
- G.HERE1(TWO)(INT);
-
- IF NOT EQUAL(INT,IDENT_INT(20)) THEN
- FAILED ("IMPROPER RESULTS FROM FAMILY ENTRY SELECTION");
- END IF;
-
- RESULT;
- END P;
-
- PACKAGE PACK IS NEW P(INTEGER,ACCINTEGER,AI,AREC,ADISCREC,
- AA,AONEDIM,ATASK,ATASK1,ANOTHERTASK);
-
-BEGIN
- NULL;
-END CC1225A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada
deleted file mode 100644
index c127dc1..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada
+++ /dev/null
@@ -1,176 +0,0 @@
--- CC1226B.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, FOR A FORMAL NONLIMITED PRIVATE TYPE, THAT ALL ALLOWABLE
--- OPERATIONS ARE IMPLICITLY DECLARED.
-
--- HISTORY:
--- BCB 04/04/88 CREATED ORIGINAL TEST.
--- RJW 03/28/90 INITIALIZED PREVIOUSLY UNINITIALIZED VARIABLES.
--- LDC 09/19/90 INITALIZED NLPVAR & NLPVAR2 TO DIFFERENT VALUES,
--- REMOVED USE CLAUSE.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CC1226B IS
-
- TYPE DISCREC(DISC1 : INTEGER := 1;
- DISC2 : BOOLEAN := FALSE) IS RECORD
- NULL;
- END RECORD;
-
- GENERIC
- TYPE NLP IS PRIVATE;
- TYPE NLPDISC(DISC1 : INTEGER;
- DISC2 : BOOLEAN) IS PRIVATE;
- WITH PROCEDURE INITIALIZE (N : OUT NLPDISC);
- WITH FUNCTION INITIALIZE RETURN NLP;
- WITH FUNCTION INITIALIZE_2 RETURN NLP;
- PACKAGE P IS
- FUNCTION IDENT(X : NLP) RETURN NLP;
- FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS;
- END P;
-
- PACKAGE BODY P IS
- TYPE DER_NLP IS NEW NLP;
- NLPVAR : NLP := INITIALIZE_2;
- NLPVAR2, NLPVAR3 : NLP := INITIALIZE;
- DERNLP : DER_NLP := DER_NLP (INITIALIZE);
- NDVAR : NLPDISC(DISC1 => 5, DISC2 => TRUE);
- NLPVARADDRESS : ADDRESS;
- NLPSIZE : INTEGER;
- NLPBASESIZE : INTEGER;
-
- FUNCTION IDENT(X : NLP) RETURN NLP IS
- Z : NLP := INITIALIZE;
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- END IF;
- RETURN Z;
- END IDENT;
-
- FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS
- I : INTEGER;
- Z : ADDRESS := I'ADDRESS;
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN Y;
- END IF;
- RETURN Z;
- END IDENT_ADR;
-
- BEGIN
- TEST ("CC1226B", "CHECK, FOR A FORMAL NONLIMITED PRIVATE " &
- "TYPE THAT ALL ALLOWABLE OPERATIONS ARE " &
- "IMPLICITLY DECLARED");
-
- INITIALIZE (NDVAR);
-
- NLPVAR := NLPVAR2;
-
- IF NLPVAR /= NLPVAR2 THEN
- FAILED ("IMPROPER VALUE FROM ASSIGNMENT");
- END IF;
-
- IF NLPVAR NOT IN NLP THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
- END IF;
-
- NLPVAR := NLP'(NLPVAR2);
-
- IF NLPVAR /= NLPVAR2 THEN
- FAILED ("IMPROPER RESULT FROM QUALIFICATION");
- END IF;
-
- NLPVAR := NLP(DERNLP);
-
- IF NLPVAR /= IDENT(NLP(DERNLP)) THEN
- FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION");
- END IF;
-
- NLPSIZE := IDENT_INT(NLP'SIZE);
-
- IF NLPSIZE /= INTEGER(NLP'SIZE) THEN
- FAILED ("IMPROPER VALUE FOR NLP'SIZE");
- END IF;
-
- NLPVARADDRESS := NLPVAR'ADDRESS;
-
- IF NLPVAR'ADDRESS /= IDENT_ADR(NLPVARADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR NLPVAR'ADDRESS");
- END IF;
-
- IF NDVAR.DISC1 /= IDENT_INT(5) THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE - 1");
- END IF;
-
- IF NOT NDVAR.DISC2 THEN
- FAILED ("IMPROPER DISCRIMINANT VALUE - 2");
- END IF;
-
- IF NOT NDVAR'CONSTRAINED THEN
- FAILED ("IMPROPER VALUE FOR NDVAR'CONSTRAINED");
- END IF;
-
- NLPVAR := NLPVAR3;
-
- IF NOT (NLPVAR = IDENT(NLPVAR3)) THEN
- FAILED ("IMPROPER VALUE FROM EQUALITY OPERATION");
- END IF;
-
- IF NLPVAR /= IDENT(NLPVAR3) THEN
- FAILED ("IMPROPER VALUE FROM INEQUALITY OPERATION");
- END IF;
-
- RESULT;
- END P;
-
- PROCEDURE INITIALIZE (I : OUT DISCREC) IS
- BEGIN
- I := (5, TRUE);
- END INITIALIZE;
-
- FUNCTION INITIALIZE RETURN INTEGER IS
- BEGIN
- RETURN 5;
- END INITIALIZE;
-
- FUNCTION INITIALIZE_OTHER RETURN INTEGER IS
- BEGIN
- RETURN 3;
- END INITIALIZE_OTHER;
-
- PACKAGE PACK IS NEW P(INTEGER,
- DISCREC,
- INITIALIZE,
- INITIALIZE,
- INITIALIZE_OTHER);
-
-BEGIN
- NULL;
-END CC1226B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada
deleted file mode 100644
index 39b4532..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada
+++ /dev/null
@@ -1,289 +0,0 @@
--- CC1227A.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, WHEN DERIVING FROM A FORMAL TYPE, THAT ALL THE PREDEFINED
--- OPERATIONS ASSOCIATED WITH THE CLASS OF THE FORMAL TYPE ARE
--- DECLARED FOR THE DERIVED TYPE.
-
--- HISTORY:
--- BCB 04/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CC1227A IS
-
- GENERIC
- TYPE FORM IS RANGE <>;
- PACKAGE P IS
- TYPE DER_FORM IS NEW FORM;
- FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM;
- FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS;
- END P;
-
- PACKAGE BODY P IS
- DER_VAR : DER_FORM;
- DER_FORM_BASE_FIRST : DER_FORM;
- DER_FORM_FIRST : DER_FORM;
- DER_FORM_LAST : DER_FORM;
- DER_FORM_SIZE : DER_FORM;
- DER_FORM_WIDTH : DER_FORM;
- DER_FORM_POS : DER_FORM;
- DER_FORM_VAL : DER_FORM;
- DER_FORM_SUCC : DER_FORM;
- DER_FORM_PRED : DER_FORM;
- DER_FORM_IMAGE : STRING(1..5);
- DER_FORM_VALUE : DER_FORM;
- DER_VAR_SIZE : DER_FORM;
- DER_VAR_ADDRESS : ADDRESS;
- DER_EQUAL, DER_UNEQUAL : DER_FORM;
- DER_GREATER : DER_FORM;
- DER_MOD, DER_REM : DER_FORM;
- DER_ABS, DER_EXP : DER_FORM;
- INT : INTEGER := 5;
- FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM IS
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN X;
- END IF;
- RETURN 0;
- END IDENT_DER;
- FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS
- X : DER_FORM;
- BEGIN
- IF EQUAL(3,3) THEN
- RETURN Y;
- END IF;
- RETURN X'ADDRESS;
- END IDENT_ADR;
- BEGIN
- TEST ("CC1227A", "CHECK, WHEN DERIVING FROM A FORMAL TYPE, " &
- "THAT ALL THE PREDEFINED OPERATIONS " &
- "ASSOCIATED WITH THE CLASS OF THE FORMAL " &
- "TYPE ARE DECLARED FOR THE DERIVED TYPE");
-
- DER_VAR := IDENT_DER(1);
-
- IF DER_VAR /= 1 THEN
- FAILED ("IMPROPER VALUE FROM ASSIGNMENT OPERATION");
- END IF;
-
- IF DER_VAR NOT IN DER_FORM THEN
- FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
- END IF;
-
- DER_VAR := DER_FORM'(2);
-
- IF DER_VAR /= IDENT_DER(2) THEN
- FAILED ("IMPROPER RESULT FROM QUALIFICATION");
- END IF;
-
- DER_VAR := DER_FORM(INT);
-
- IF DER_VAR /= IDENT_DER(5) THEN
- FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " &
- "INTEGER");
- END IF;
-
- DER_VAR := DER_FORM(3.0);
-
- IF DER_VAR /= IDENT_DER(3) THEN
- FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " &
- "FLOAT");
- END IF;
-
- DER_VAR := 1_000;
-
- IF DER_VAR /= IDENT_DER(1000) THEN
- FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION");
- END IF;
-
- DER_FORM_BASE_FIRST := DER_FORM'BASE'FIRST;
-
- DER_FORM_FIRST := DER_FORM'FIRST;
-
- IF DER_FORM_BASE_FIRST /= IDENT_DER(DER_FORM_FIRST) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'BASE'FIRST");
- END IF;
-
- IF DER_FORM_FIRST /= IDENT_DER(DER_FORM'FIRST) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'FIRST");
- END IF;
-
- DER_FORM_LAST := DER_FORM'LAST;
-
- IF DER_FORM_LAST /= IDENT_DER(DER_FORM'LAST) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'LAST");
- END IF;
-
- DER_FORM_SIZE := DER_FORM(DER_FORM'SIZE);
-
- IF DER_FORM_SIZE /= IDENT_DER(DER_FORM(DER_FORM'SIZE)) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'SIZE");
- END IF;
-
- DER_FORM_WIDTH := DER_FORM(DER_FORM'WIDTH);
-
- IF DER_FORM_WIDTH /= IDENT_DER(DER_FORM(DER_FORM'WIDTH)) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'WIDTH");
- END IF;
-
- DER_FORM_POS := DER_FORM(DER_FORM'POS(DER_VAR));
-
- IF DER_FORM_POS /= IDENT_DER(DER_FORM(DER_FORM'POS(DER_VAR)))
- THEN FAILED ("IMPROPER VALUE FOR DER_FORM'POS(DER_VAR)");
- END IF;
-
- DER_FORM_VAL := DER_FORM'VAL(DER_VAR);
-
- IF DER_FORM_VAL /= IDENT_DER(DER_FORM'VAL(DER_VAR)) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'VAL(DER_VAR)");
- END IF;
-
- DER_FORM_SUCC := DER_FORM'SUCC(DER_VAR);
-
- IF DER_FORM_SUCC /= IDENT_DER(DER_FORM'SUCC(DER_VAR)) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'SUCC(DER_VAR)");
- END IF;
-
- DER_FORM_PRED := DER_FORM'PRED(DER_VAR);
-
- IF DER_FORM_PRED /= IDENT_DER(DER_FORM'PRED(DER_VAR)) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'PRED(DER_VAR)");
- END IF;
-
- DER_FORM_IMAGE := DER_FORM'IMAGE(DER_VAR);
-
- IF DER_FORM_IMAGE(2..5) /= "1000" THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'IMAGE(DER_VAR)");
- END IF;
-
- DER_FORM_VALUE := DER_FORM'VALUE(DER_FORM_IMAGE);
-
- IF DER_FORM_VALUE /= IDENT_DER(1000) THEN
- FAILED ("IMPROPER VALUE FOR DER_FORM'VALUE" &
- "(DER_FORM_IMAGE)");
- END IF;
-
- DER_VAR_SIZE := DER_FORM(DER_VAR'SIZE);
-
- IF DER_VAR_SIZE /= IDENT_DER(DER_FORM(DER_VAR'SIZE)) THEN
- FAILED ("IMPROPER VALUE FOR DER_VAR'SIZE");
- END IF;
-
- DER_VAR_ADDRESS := DER_VAR'ADDRESS;
-
- IF DER_VAR_ADDRESS /= IDENT_ADR(DER_VAR'ADDRESS) THEN
- FAILED ("IMPROPER VALUE FOR DER_VAR'ADDRESS");
- END IF;
-
- DER_EQUAL := IDENT_DER(1000);
-
- IF DER_VAR /= DER_EQUAL THEN
- FAILED ("IMPROPER RESULT FROM INEQUALITY OPERATOR");
- END IF;
-
- DER_UNEQUAL := IDENT_DER(500);
-
- IF DER_VAR = DER_UNEQUAL THEN
- FAILED ("IMPROPER RESULT FROM EQUALITY OPERATOR");
- END IF;
-
- IF DER_VAR < DER_UNEQUAL THEN
- FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR");
- END IF;
-
- IF DER_VAR <= DER_UNEQUAL THEN
- FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " &
- "OPERATOR");
- END IF;
-
- DER_GREATER := IDENT_DER(1500);
-
- IF DER_VAR > DER_GREATER THEN
- FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR");
- END IF;
-
- IF DER_VAR >= DER_GREATER THEN
- FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " &
- "TO OPERATOR");
- END IF;
-
- DER_VAR := DER_VAR + DER_EQUAL;
-
- IF DER_VAR /= IDENT_DER(2000) THEN
- FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR");
- END IF;
-
- DER_VAR := DER_VAR - DER_EQUAL;
-
- IF DER_VAR /= IDENT_DER(1000) THEN
- FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR");
- END IF;
-
- DER_VAR := DER_VAR * IDENT_DER(2);
-
- IF DER_VAR /= IDENT_DER(2000) THEN
- FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR");
- END IF;
-
- DER_VAR := DER_VAR / IDENT_DER(2);
-
- IF DER_VAR /= IDENT_DER(1000) THEN
- FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR");
- END IF;
-
- DER_MOD := DER_GREATER MOD DER_VAR;
-
- IF DER_MOD /= IDENT_DER(500) THEN
- FAILED ("IMPROPER RESULT FROM MOD OPERATOR");
- END IF;
-
- DER_REM := DER_GREATER REM DER_VAR;
-
- IF DER_REM /= IDENT_DER(500) THEN
- FAILED ("IMPROPER RESULT FROM REM OPERATOR");
- END IF;
-
- DER_ABS := ABS(IDENT_DER(-1500));
-
- IF DER_ABS /= IDENT_DER(DER_GREATER) THEN
- FAILED ("IMPROPER RESULT FROM ABS OPERATOR");
- END IF;
-
- DER_EXP := IDENT_DER(2) ** IDENT_INT(2);
-
- IF DER_EXP /= IDENT_DER(4) THEN
- FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR");
- END IF;
-
- RESULT;
- END P;
-
- PACKAGE PACK IS NEW P(INTEGER);
-
-BEGIN
- NULL;
-END CC1227A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada
deleted file mode 100644
index 92c94d0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CC1301A.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 DEFAULT GENERIC SUBPROGRAM PARAMETERS WORK CORRECTLY,
--- INCLUDING OVERLOADED AND PREDEFINED OPERATOR_SYMBOLS,
--- AND SUBPROGRAMS HIDDEN AT THE INSTANTIATION.
--- BOTH KINDS OF DEFAULTS ARE TESTED, FOR BOTH PROCEDURES
--- AND FUNCTIONS.
-
--- DAT 8/14/81
--- JBG 5/5/83
--- JBG 8/3/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1301A IS
-
- FUNCTION "-" (R, S : INTEGER) RETURN INTEGER;
-
- FUNCTION NEXT (X : INTEGER) RETURN INTEGER;
-
- PROCEDURE BUMP (X : IN OUT INTEGER);
-
- GENERIC
- WITH FUNCTION "*" (A, B : INTEGER) RETURN INTEGER IS "-";
- WITH FUNCTION "+" (R, S: INTEGER) RETURN INTEGER IS
- STANDARD."+";
- WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ;
- WITH FUNCTION NEXTO (Q : INTEGER) RETURN INTEGER IS NEXT ;
- WITH PROCEDURE BUMPO (A : IN OUT INTEGER) IS BUMP;
- WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ;
- WITH PROCEDURE BUMP (Q : IN OUT INTEGER) IS <> ;
- TYPE INTEGER IS RANGE <> ;
- WITH FUNCTION "*" (A , B : INTEGER) RETURN INTEGER IS <> ;
- WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ;
- WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ;
- WITH PROCEDURE BUMP (Z : IN OUT INTEGER) IS <> ;
- PACKAGE PKG IS
- SUBTYPE INT IS STANDARD.INTEGER;
- DIFF : INT := -999;
- END PKG;
-
- TYPE NEWINT IS NEW INTEGER RANGE -1000 .. 1000;
-
- FUNCTION PLUS (Q1, Q2 : INTEGER) RETURN INTEGER RENAMES "+";
-
- FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN PLUS (X, PLUS (Y, -10));
- -- (X + Y - 10)
- END "+";
-
- FUNCTION "-" (R, S : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN - R + S;
- -- (-R + S - 10)
- END "-";
-
- FUNCTION NEXT (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN X + 1;
- -- (X + 1 - 10)
- -- (X - 9)
- END NEXT;
-
- PROCEDURE BUMP (X : IN OUT INTEGER) IS
- BEGIN
- X := NEXT (X);
- -- (X := X - 9)
- END BUMP;
-
- PACKAGE BODY PKG IS
- W : INTEGER;
- WI : INT;
- BEGIN
- W := NEXT (INTEGER'(3) * 4 - 2);
- -- (W := (4 ** 3 - 2) - 1)
- -- (W := 61)
- BUMP (W);
- -- (W := 61 + 7)
- -- (W := 68)
- WI := NEXT (INT'(3) * 4 - 2 + NEXTO (0));
- -- (3 * 4) => (3 - 4) => (-3 + 4 - 10) = -9
- -- ((-9) - 2) => (2 + 2 - (-9) - 20) = -7
- -- (-7 + (-9)) => -16
- -- (WI := 7 - (-16)) => (WI := 23)
- BUMPO (WI);
- -- (WI := 23 - 9) (= 14)
- BUMP (WI);
- -- (WI := 14 - 9) (= 5)
- DIFF := STANDARD."-" (INT(W), WI);
- -- (DIFF := 68 - 5) (= 63)
- END PKG;
-
- FUNCTION "*" (Y, X : NEWINT) RETURN NEWINT IS
- BEGIN
- RETURN X ** INTEGER(Y);
- -- (X,Y) (Y ** X)
- END "*";
-
- FUNCTION NEXT (Z : NEWINT) RETURN NEWINT IS
- BEGIN
- RETURN Z - 1;
- -- (Z - 1)
- END NEXT;
-
- PROCEDURE BUMP (ZZ : IN OUT NEWINT) IS
- BEGIN
- FAILED ("WRONG PROCEDURE CALLED");
- END BUMP;
-BEGIN
- TEST ("CC1301A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS");
-
- DECLARE
- PROCEDURE BUMP (QQQ : IN OUT NEWINT) IS
- BEGIN
- QQQ := QQQ + 7;
- -- (QQQ + 7)
- END BUMP;
-
- FUNCTION NEXT (Q7 : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN Q7 - 17;
- -- (-Q7 + 17 - 10)
- -- (7 - Q7)
- END NEXT;
-
- FUNCTION "-" (Q3, Q4 : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN -Q3 + Q4 + Q4;
- -- (-Q3 + Q4 - 10 + Q4 - 10) = (Q4 + Q4 - Q3 - 20)
- END "-";
-
- PACKAGE P1 IS NEW PKG (INTEGER => NEWINT);
-
- BEGIN
- IF P1.DIFF /= 63 THEN
- FAILED ("WRONG DEFAULT SUBPROGRAM PARAMETERS");
- END IF;
- END;
-
- RESULT;
-END CC1301A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada
deleted file mode 100644
index c61a310..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada
+++ /dev/null
@@ -1,174 +0,0 @@
--- CC1302A.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 GENERIC DEFAULT SUBPROGRAM PARAMETERS MAY BE ATTRIBUTES
--- OF TYPES, INCLUDING GENERIC FORMAL TYPES IN SAME GENERIC PART,
--- OR IN GENERIC PART OF ENCLOSING UNIT.
-
--- DAT 8/27/81
--- SPS 2/9/83
--- JBG 2/15/83
--- JBG 4/29/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1302A IS
-BEGIN
- TEST ("CC1302A", "GENERIC DEFAULT SUBPROGRAMS MAY BE"
- & " FUNCTION ATTRIBUTES OF TYPES");
-
- DECLARE
- GENERIC
- TYPE T IS ( <> );
- T_LAST : T;
- WITH FUNCTION SUCC (X : T) RETURN T IS T'SUCC;
- PACKAGE PK1 IS
- END PK1;
-
- SUBTYPE CH IS CHARACTER RANGE CHARACTER'FIRST .. '~';
- SUBTYPE BL IS BOOLEAN RANGE FALSE .. FALSE;
- SUBTYPE INT IS INTEGER RANGE -10 .. 10;
-
- PACKAGE BODY PK1 IS
- GENERIC
- TYPE TT IS ( <> );
- TT_LAST : TT;
- WITH FUNCTION PRED (X : TT) RETURN TT IS TT'PRED;
- WITH FUNCTION IM(X : T) RETURN STRING IS T'IMAGE;
- WITH FUNCTION VAL(X : STRING) RETURN TT IS TT'VALUE;
- PACKAGE PK2 IS END PK2;
-
- PACKAGE BODY PK2 IS
- BEGIN
-
--- CHECK THAT 'LAST GIVES RIGHT ANSWER
- IF T'LAST /= T_LAST THEN
- FAILED ("T'LAST INCORRECT");
- END IF;
-
- IF TT'LAST /= TT_LAST THEN
- FAILED ("TT'LAST INCORRECT");
- END IF;
-
--- CHECK SUCC FUNCTION
- BEGIN
- IF T'PRED(SUCC(T'LAST)) /= T'LAST THEN
- FAILED ("'PRED OR SUCC GIVES WRONG " &
- "RESULT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("SUCC HAS CONSTRAINTS OF " &
- "SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 1");
- END;
-
--- CHECK 'SUCC ATTRIBUTE
- BEGIN
- IF T'PRED(T'SUCC(T'LAST)) /= T'LAST THEN
- FAILED ("'PRED OR 'SUCC GIVES WRONG " &
- "RESULT");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("'PRED OR 'SUCC HAS CONSTRAINTS "&
- "OF SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 2");
- END;
-
--- CHECK VAL ATTRIBUTE
- BEGIN
- IF T'VAL(T'POS(T'SUCC(T'LAST))) /=
- T'VAL(T'POS(T'LAST)+1) THEN
- FAILED ("VAL OR POS ATTRIBUTE HAS " &
- "INCONSISTENT RESULTS");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("VAL OR POS ATTRIBUTE HAS " &
- "CONSTRAINTS OF SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 4");
- END;
-
--- CHECK VAL FUNCTION
- BEGIN
- IF TT'VAL(TT'POS(TT'SUCC(TT'LAST))) /=
- TT'VAL(TT'POS(TT'LAST)+1) THEN
- FAILED ("VAL FUNCTION GIVES INCORRECT " &
- "RESULTS");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("VAL FUNCTION HAS CONSTRAINTS " &
- "OF SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 6");
- END;
-
--- CHECK IM FUNCTION
- BEGIN
- IF T'IMAGE(T'SUCC(T'LAST)) /=
- IM (T'SUCC(T'LAST)) THEN
- FAILED ("IM FUNCTION GIVES INCORRECT " &
- "RESULTS");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("IM FUNCTION HAS CONSTRAINTS " &
- "OF SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 7");
- END;
-
--- CHECK PRED FUNCTION
- BEGIN
- IF PRED(TT'SUCC(TT'LAST)) /= TT'LAST THEN
- FAILED ("PRED FUNCTION GIVES INCORRECT " &
- "RESULTS");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("PRED FUNCTION HAS CONSTRAINTS " &
- "OF SUBTYPE");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 8");
- END;
-
- END PK2;
-
- PACKAGE PK3 IS NEW PK2 (T, T'LAST);
- END PK1;
-
- PACKAGE PKG1 IS NEW PK1 (CH, CH'LAST);
- PACKAGE PKG2 IS NEW PK1 (BL, BL'LAST);
- PACKAGE PKG3 IS NEW PK1 (INT, INT'LAST);
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC1302A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada
deleted file mode 100644
index 2556c9d..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CC1304A.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 GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER
--- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL
--- TYPE.
-
--- DAT 8/27/81
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1304A IS
-BEGIN
- TEST ("CC1304A", "GENERIC FORMAL SUBPROGRAMS MAY HAVE PARAMETERS"
- & " OF (AND RETURN) A FORMAL TYPE");
-
- DECLARE
- GENERIC
- TYPE T IS ( <> );
- WITH FUNCTION S (P : T) RETURN T;
- WITH PROCEDURE P (P : T);
- PROCEDURE PR (PARM : T);
-
- PROCEDURE PR (PARM: T) IS
- BEGIN
- P(P=>S(P=>PARM));
- END PR;
- BEGIN
- DECLARE
- C : CHARACTER := 'A';
- B : BOOLEAN := FALSE;
- I : INTEGER := 5;
- TYPE ENUM IS (E1, E2, E3);
- E : ENUM := E2;
-
- FUNCTION FC (P : CHARACTER) RETURN CHARACTER IS
- BEGIN
- RETURN 'B';
- END FC;
-
- FUNCTION FB (P : BOOLEAN) RETURN BOOLEAN IS
- BEGIN
- RETURN NOT P;
- END FB;
-
- FUNCTION FI (P : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN P + 1;
- END FI;
-
- FUNCTION FE (P : ENUM) RETURN ENUM IS
- BEGIN
- RETURN ENUM'SUCC (P);
- END FE;
-
- PROCEDURE PC (P : CHARACTER) IS
- BEGIN
- C := P;
- END PC;
-
- PROCEDURE PB (P : BOOLEAN) IS
- BEGIN
- B := P;
- END PB;
-
- PROCEDURE PI (P : INTEGER) IS
- BEGIN
- I := P;
- END PI;
-
- PROCEDURE PE (P : ENUM) IS
- BEGIN
- E := P;
- END PE;
-
- PACKAGE PKG2 IS
- PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC);
- PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB);
- PROCEDURE P3 IS NEW PR (INTEGER, FI, PI);
- PROCEDURE P4 IS NEW PR (ENUM, FE, PE);
- END PKG2;
-
- PACKAGE BODY PKG2 IS
- BEGIN
- P1 (C);
- P2 (B);
- P3 (I);
- P4 (E);
- END PKG2;
- BEGIN
- IF C /= 'B'
- OR B /= TRUE
- OR I /= 6
- OR E /= E3 THEN
- FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES");
- END IF;
- END;
- END;
-
- RESULT;
-END CC1304A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada
deleted file mode 100644
index 10086e8..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada
+++ /dev/null
@@ -1,166 +0,0 @@
--- CC1304B.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 GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER
--- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL
--- TYPE. CHECK MODES IN OUT AND OUT.
-
--- HISTORY:
--- BCB 08/04/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1304B IS
-
-BEGIN
- TEST ("CC1304B", "GENERIC FORMAL SUBPROGRAMS MAY HAVE A " &
- "PARAMETER OF A GENERIC FORMAL TYPE, AND MAY " &
- "RETURN A GENERIC FORMAL TYPE. CHECK MODES IN " &
- "OUT AND OUT");
-
- DECLARE
- GENERIC
- TYPE T IS ( <> );
- WITH PROCEDURE S (P : OUT T);
- WITH PROCEDURE P (P : IN OUT T);
- WITH FUNCTION L RETURN T;
- PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T);
-
- PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T) IS
- BEGIN
- S (P => PARM1);
- P (P => PARM2);
- PARM3 := L;
- END PR;
- BEGIN
- DECLARE
- C : CHARACTER := 'A';
- C1 : CHARACTER := 'Y';
- C2 : CHARACTER := 'I';
- B : BOOLEAN := FALSE;
- B1 : BOOLEAN := TRUE;
- B2 : BOOLEAN := FALSE;
- I : INTEGER := 5;
- I1 : INTEGER := 10;
- I2 : INTEGER := 0;
- TYPE ENUM IS (E1, E2, E3);
- F : ENUM := E2;
- F1 : ENUM := E1;
- F2 : ENUM := E2;
-
- PROCEDURE FC (P : OUT CHARACTER) IS
- BEGIN
- P := 'B';
- END FC;
-
- PROCEDURE FB (P : OUT BOOLEAN) IS
- BEGIN
- P := NOT B;
- END FB;
-
- PROCEDURE FI (P : OUT INTEGER) IS
- BEGIN
- P := I + 1;
- END FI;
-
- PROCEDURE FE (P : OUT ENUM) IS
- BEGIN
- P := ENUM'SUCC (F);
- END FE;
-
- PROCEDURE PC (P : IN OUT CHARACTER) IS
- BEGIN
- P := 'Z';
- END PC;
-
- PROCEDURE PB (P : IN OUT BOOLEAN) IS
- BEGIN
- P := NOT B1;
- END PB;
-
- PROCEDURE PI (P : IN OUT INTEGER) IS
- BEGIN
- P := I1 + 1;
- END PI;
-
- PROCEDURE PE (P : IN OUT ENUM) IS
- BEGIN
- P := ENUM'SUCC (F1);
- END PE;
-
- FUNCTION LC RETURN CHARACTER IS
- BEGIN
- RETURN 'J';
- END LC;
-
- FUNCTION LB RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END LB;
-
- FUNCTION LI RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(5);
- END LI;
-
- FUNCTION LE RETURN ENUM IS
- BEGIN
- RETURN ENUM'SUCC(F2);
- END LE;
-
- PACKAGE PKG2 IS
- PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC, LC);
- PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB, LB);
- PROCEDURE P3 IS NEW PR (INTEGER, FI, PI, LI);
- PROCEDURE P4 IS NEW PR (ENUM, FE, PE, LE);
- END PKG2;
-
- PACKAGE BODY PKG2 IS
- BEGIN
- P1 (C,C1,C2);
- P2 (B,B1,B2);
- P3 (I,I1,I2);
- P4 (F,F1,F2);
- END PKG2;
- BEGIN
- IF C /= 'B' OR B /= TRUE OR I /= 6 OR F /= E3 THEN
- FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " &
- "MODE OUT");
- END IF;
-
- IF C1 /= 'Z' OR B1 /= FALSE OR I1 /= 11 OR F1 /= E2 THEN
- FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " &
- "MODE IN OUT");
- END IF;
-
- IF C2 /= 'J' OR B2 /= TRUE OR I2 /= 5 OR F2 /= E3 THEN
- FAILED ("GENERIC FORMAL SUBPROGRAMS RETURNING A " &
- "GENERIC FORMAL TYPE");
- END IF;
- END;
- END;
-
- RESULT;
-END CC1304B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada
deleted file mode 100644
index 932b5ff..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada
+++ /dev/null
@@ -1,54 +0,0 @@
--- CC1307A.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 SUBPROGRAM PARAMETERS MAY HAVE AN OPERATOR_SYMBOL DEFAULT,
--- WHICH LOOKS THE SAME AS A DEFAULT STRING PARAMETER.
-
--- DAT 9/8/81
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1307A IS
-BEGIN
- TEST ("CC1307A", "GENERIC SUBPROGRAM AND STRING DEFAULT PARAMETERS"
- & " MAY LOOK THE SAME");
-
- DECLARE
- GENERIC
- WITH FUNCTION CAT (X, Y : STRING) RETURN STRING
- IS "&";
- S : STRING := "&";
- PACKAGE PK IS
- VAL : CONSTANT STRING := CAT (S, S);
- END PK;
-
- PACKAGE PK1 IS NEW PK;
- BEGIN
- IF PK1.VAL /= "&&" THEN
- FAILED ("INCORRECT GENERIC INSTANTIATION WITH DEFAULTS");
- END IF;
- END;
-
- RESULT;
-END CC1307A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada
deleted file mode 100644
index c5eb15a..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CC1307B.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 ENUMERATION LITERAL (BOTH AN IDENTIFIER AND A
--- CHARACTER LITERAL) MAY BE USED AS A DEFAULT SUBPROGRAM NAME
--- AND AS A DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER.
-
--- HISTORY:
--- BCB 08/09/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1307B IS
-
- TYPE ENUM IS (R, 'S', R1);
-
-BEGIN
- TEST ("CC1307B", "CHECK THAT AN ENUMERATION LITERAL (BOTH AN " &
- "IDENTIFIER AND A CHARACTER LITERAL) MAY BE " &
- "USED AS A DEFAULT SUBPROGRAM NAME AND AS A " &
- "DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER");
-
- DECLARE
- GENERIC
- WITH FUNCTION J RETURN ENUM IS R;
- WITH FUNCTION K RETURN ENUM IS 'S';
- OBJ1 : ENUM := R;
- OBJ2 : ENUM := 'S';
- PACKAGE P IS
- END P;
-
- PACKAGE BODY P IS
- VAR1, VAR2 : ENUM := R1;
- BEGIN
- VAR1 := J;
-
- IF VAR1 /= R THEN
- FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " &
- "NAME - IDENTIFIER");
- END IF;
-
- VAR2 := K;
-
- IF VAR2 /= 'S' THEN
- FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " &
- "NAME - CHARACTER LITERAL");
- END IF;
-
- IF OBJ1 /= R THEN
- FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " &
- "IDENTIFIER");
- END IF;
-
- IF OBJ2 /= 'S' THEN
- FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " &
- "CHARACTER LITERAL");
- END IF;
- END P;
-
- PACKAGE NEW_P IS NEW P;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC1307B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada
deleted file mode 100644
index 69a558f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- CC1308A.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 FORMAL SUBPROGRAM PARAMETERS MAY OVERLOAD EACH OTHER
--- AND OTHER VISIBLE SUBPROGRAMS AND ENUMERATION LITERALS WITHIN AND
--- OUTSIDE OF THE GENERIC UNIT.
-
--- HISTORY:
--- DAT 09/08/81 CREATED ORIGINAL TEST.
--- SPS 10/26/82
--- SPS 02/09/83
--- BCB 08/09/88 REPLACED THE OLD TEST WITH A VERSION BASED ON
--- AIG 6.6/T2.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1308A IS
-
- TYPE ENUM IS (F1,F2,F3,F4,F5,F6,F7);
-
- FUNCTION F1 (X : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN 2*X;
- END F1;
-
- PROCEDURE F1 (X : IN OUT INTEGER) IS
- BEGIN
- X := 3*X;
- END F1;
-
- PROCEDURE F2 (Y : IN OUT INTEGER; Z : IN OUT BOOLEAN) IS
- BEGIN
- Y := 2*Y;
- Z := NOT Z;
- END F2;
-
- PROCEDURE F2 (Y : IN OUT INTEGER) IS
- BEGIN
- Y := 3*Y;
- END F2;
-
- PROCEDURE F3 (B : BOOLEAN := FALSE; A : IN OUT INTEGER) IS
- BEGIN
- A := 2*A;
- END F3;
-
- PROCEDURE F3 (A : IN OUT INTEGER) IS
- BEGIN
- A := 3*A;
- END F3;
-
- PROCEDURE F4 (C : IN OUT INTEGER) IS
- BEGIN
- C := 2*C;
- END F4;
-
- PROCEDURE F4 (C : IN OUT BOOLEAN) IS
- BEGIN
- C := NOT C;
- END F4;
-
- PROCEDURE F5 (D : IN OUT INTEGER; E : IN OUT BOOLEAN) IS
- BEGIN
- D := 2*D;
- E := NOT E;
- END F5;
-
- PROCEDURE F5 (E : IN OUT BOOLEAN; D : IN OUT INTEGER) IS
- BEGIN
- E := NOT E;
- D := 3*D;
- END F5;
-
- FUNCTION F6 (G : INTEGER) RETURN INTEGER IS
- BEGIN
- RETURN 2*G;
- END F6;
-
- FUNCTION F6 (G : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END F6;
-
- FUNCTION F7 RETURN INTEGER IS
- BEGIN
- RETURN 25;
- END F7;
-
- FUNCTION F7 RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END F7;
-
-BEGIN
- TEST ("CC1308A", "CHECK THAT FORMAL SUBPROGRAM PARAMETERS MAY " &
- "OVERLOAD EACH OTHER AND OTHER VISIBLE " &
- "SUBPROGRAMS AND ENUMERATION LITERALS WITHIN " &
- "AND OUTSIDE OF THE GENERIC UNIT");
-
- DECLARE
- GENERIC
- WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER;
- WITH PROCEDURE F1 (X : IN OUT INTEGER);
-
- WITH PROCEDURE F2 (Y : IN OUT INTEGER;
- Z : IN OUT BOOLEAN);
- WITH PROCEDURE F2 (Y : IN OUT INTEGER);
-
- WITH PROCEDURE F3 (B : BOOLEAN := FALSE;
- A : IN OUT INTEGER);
- WITH PROCEDURE F3 (A : IN OUT INTEGER);
-
- WITH PROCEDURE F4 (C : IN OUT INTEGER);
- WITH PROCEDURE F4 (C : IN OUT BOOLEAN);
-
- WITH PROCEDURE F5 (D : IN OUT INTEGER;
- E : IN OUT BOOLEAN);
- WITH PROCEDURE F5 (E : IN OUT BOOLEAN;
- D : IN OUT INTEGER);
-
- WITH FUNCTION F6 (G : INTEGER) RETURN INTEGER;
- WITH FUNCTION F6 (G : INTEGER) RETURN BOOLEAN;
-
- WITH FUNCTION F7 RETURN INTEGER;
- WITH FUNCTION F7 RETURN BOOLEAN;
- PACKAGE P IS
- TYPE EN IS (F1,F2,F3,F4,F5,F6,F7);
- END P;
-
- PACKAGE BODY P IS
- X1, X2, Y1, Y2, A1, A2, C1, D1, D2, G1
- : INTEGER := IDENT_INT(5);
-
- VAL : INTEGER := IDENT_INT(0);
-
- Z1, B1, C2, E1, E2, BOOL : BOOLEAN := IDENT_BOOL(FALSE);
- BEGIN
- VAL := F1(X1);
-
- IF NOT EQUAL(VAL,10) THEN
- FAILED ("CASE 1 - WRONG VALUE RETURNED FROM " &
- "FUNCTION");
- END IF;
-
- F1(X2);
-
- IF NOT EQUAL(X2,15) THEN
- FAILED ("CASE 1 - WRONG VALUE ASSIGNED INSIDE " &
- "PROCEDURE");
- END IF;
-
- F2(Y1,Z1);
-
- IF NOT EQUAL(Y1,10) OR Z1 /= TRUE THEN
- FAILED ("CASE 2 - WRONG VALUES ASSIGNED INSIDE " &
- "PROCEDURE");
- END IF;
-
- F2(Y2);
-
- IF NOT EQUAL(Y2,15) THEN
- FAILED ("CASE 2 - WRONG VALUE ASSIGNED INSIDE " &
- "PROCEDURE");
- END IF;
-
- F3(B1,A1);
-
- IF NOT EQUAL(A1,10) OR B1 /= FALSE THEN
- FAILED ("CASE 3 - WRONG VALUES ASSIGNED INSIDE " &
- "PROCEDURE");
- END IF;
-
- F3(A2);
-
- IF NOT EQUAL(A2,15) THEN
- FAILED ("CASE 3 - WRONG VALUE ASSIGNED INSIDE " &
- "PROCEDURE");
- END IF;
-
- F4(C1);
-
- IF NOT EQUAL(C1,10) THEN
- FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " &
- "PROCEDURE - BASE TYPE INTEGER");
- END IF;
-
- F4(C2);
-
- IF C2 /= TRUE THEN
- FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " &
- "PROCEDURE - BASE TYPE BOOLEAN");
- END IF;
-
- F5(D1,E1);
-
- IF NOT EQUAL(D1,10) OR E1 /= TRUE THEN
- FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " &
- "PROCEDURE - ORDER WAS INTEGER, BOOLEAN");
- END IF;
-
- F5(E2,D2);
-
- IF E2 /= TRUE OR NOT EQUAL(D2,15) THEN
- FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " &
- "PROCEDURE - ORDER WAS BOOLEAN, INTEGER");
- END IF;
-
- VAL := F6(G1);
-
- IF NOT EQUAL(VAL,10) THEN
- FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " &
- "FUNCTION - TYPE INTEGER");
- END IF;
-
- BOOL := F6(G1);
-
- IF BOOL /= TRUE THEN
- FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " &
- "FUNCTION - TYPE BOOLEAN");
- END IF;
-
- VAL := F7;
-
- IF NOT EQUAL(VAL,25) THEN
- FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " &
- "PARAMETERLESS FUNCTION - TYPE INTEGER");
- END IF;
-
- BOOL := F7;
-
- IF BOOL /= FALSE THEN
- FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " &
- "PARAMETERLESS FUNCTION - TYPE BOOLEAN");
- END IF;
- END P;
-
- PACKAGE NEW_P IS NEW P (F1, F1, F2, F2, F3, F3,
- F4, F4, F5, F5, F6, F6, F7, F7);
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC1308A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada
deleted file mode 100644
index 28ea409..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CC1310A.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 DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE ENTRIES.
-
--- DAT 9/8/81
--- SPS 2/7/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1310A IS
-BEGIN
- TEST ("CC1310A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE"
- & " ENTRIES");
-
- DECLARE
- TASK T IS
- ENTRY ENT1;
- ENTRY ENT2 (I : IN INTEGER);
- END T;
-
- PROCEDURE P1 RENAMES T.ENT1;
-
- PROCEDURE P4 (I : IN INTEGER) RENAMES T.ENT2;
-
- INT : INTEGER := 0;
-
- TASK BODY T IS
- BEGIN
- ACCEPT ENT1;
- ACCEPT ENT2 (I : IN INTEGER) DO
- INT := INT + I;
- END ENT2;
- ACCEPT ENT2 (I : IN INTEGER) DO
- INT := INT + I;
- END ENT2;
- ACCEPT ENT1;
- END T;
-
- BEGIN
- DECLARE
- GENERIC
- WITH PROCEDURE P1 IS <> ;
- WITH PROCEDURE P2 IS T.ENT1;
- WITH PROCEDURE P3 (I : IN INTEGER) IS T.ENT2;
- WITH PROCEDURE P4 (I : IN INTEGER) IS <> ;
- PACKAGE PKG IS END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- P1;
- P4 (3);
- P3 (6);
- P2;
- END PKG;
-
- PACKAGE PP IS NEW PKG;
-
- BEGIN
- IF INT /= 9 THEN
- FAILED ("ENTRIES AS DEFAULT GENERIC PARAMETERS");
- END IF;
- END;
- END;
-
- RESULT;
-END CC1310A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada
deleted file mode 100644
index ce38abe..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada
+++ /dev/null
@@ -1,480 +0,0 @@
--- CC1311A.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 THE PARAMETERS OF A FORMAL
--- SUBPROGRAM ARE USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE
--- ACTUAL SUBPROGRAM PARAMETER.
-
--- HISTORY:
--- RJW 06/05/86 CREATED ORIGINAL TEST.
--- VCL 08/18/87 CHANGED A COUPLE OF STATIC DEFAULT EXPRESSIONS FOR
--- FORMAL SUBPROGRAM PARAMETERS TO DYNAMIC
--- EXPRESSIONS VIA THE USE OF THE IDENTITY FUNCTION.
--- EDWARD V. BERARD 08/13/90
--- ADDED CHECKS FOR MULTI-DIMENSIONAL ARRAYS.
-
-WITH REPORT ;
-
-PROCEDURE CC1311A IS
-
- TYPE NUMBERS IS (ZERO, ONE ,TWO);
-
- SHORT_START : CONSTANT := -100 ;
- SHORT_END : CONSTANT := 100 ;
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
-
- SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
-
- SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
-
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 8,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (DAY => 6,
- MONTH => JUN,
- YEAR => 1967) ;
-
- SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
-
- TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
- FIRST_HALF,
- FIRST_FIVE) OF DATE ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))))
- RETURN CUBE ;
-
- PROCEDURE PROC_WITH_3D_FUNC ;
-
- PROCEDURE PROC_WITH_3D_FUNC IS
-
- BEGIN -- PROC_WITH_3D_FUNC
-
- IF FUN /= CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " &
- "ARRAY, FUNCTION, AND PROCEDURE.") ;
- END IF ;
-
- END PROC_WITH_3D_FUNC ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))))
- RETURN CUBE ;
-
- PACKAGE PKG_WITH_3D_FUNC IS
- END PKG_WITH_3D_FUNC ;
-
- PACKAGE BODY PKG_WITH_3D_FUNC IS
- BEGIN -- PKG_WITH_3D_FUNC
-
- REPORT.TEST("CC1311A","CHECK THAT THE DEFAULT EXPRESSIONS " &
- "OF THE PARAMETERS OF A FORMAL SUBPROGRAM ARE " &
- "USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE " &
- "ACTUAL SUBPROGRAM PARAMETER" ) ;
-
- IF FUN /= CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " &
- "ARRAY, FUNCTION, AND PACKAGE.") ;
- END IF ;
-
- END PKG_WITH_3D_FUNC ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))))
- RETURN CUBE ;
-
- FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN ;
-
- FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN IS
- BEGIN -- FUNC_WITH_3D_FUNC
-
- RETURN FUN = CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) ;
-
- END FUNC_WITH_3D_FUNC ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))) ;
- OUTPUT : OUT CUBE) ;
-
- PROCEDURE PROC_WITH_3D_PROC ;
-
- PROCEDURE PROC_WITH_3D_PROC IS
-
- RESULTS : CUBE ;
-
- BEGIN -- PROC_WITH_3D_PROC
-
- PROC (OUTPUT => RESULTS) ;
-
- IF RESULTS /= CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " &
- "ARRAY, PROCEDURE, AND PROCEDURE.") ;
- END IF ;
-
- END PROC_WITH_3D_PROC ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))) ;
- OUTPUT : OUT CUBE) ;
-
- PACKAGE PKG_WITH_3D_PROC IS
- END PKG_WITH_3D_PROC ;
-
- PACKAGE BODY PKG_WITH_3D_PROC IS
-
- RESULTS : CUBE ;
-
- BEGIN -- PKG_WITH_3D_PROC
-
- PROC (OUTPUT => RESULTS) ;
-
- IF RESULTS /= CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " &
- "ARRAY, PROCEDURE, AND PACKAGE.") ;
- END IF ;
-
- END PKG_WITH_3D_PROC ;
-
- GENERIC
-
- TYPE FIRST_INDEX IS (<>) ;
- TYPE SECOND_INDEX IS (<>) ;
- TYPE THIRD_INDEX IS (<>) ;
- TYPE COMPONENT_TYPE IS PRIVATE ;
- DEFAULT_VALUE : IN COMPONENT_TYPE ;
- TYPE CUBE IS ARRAY (FIRST_INDEX,
- SECOND_INDEX,
- THIRD_INDEX) OF COMPONENT_TYPE ;
- WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) =>
- DEFAULT_VALUE))) ;
- OUTPUT : OUT CUBE) ;
-
- FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN ;
-
- FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN IS
-
- RESULTS : CUBE ;
-
- BEGIN -- FUNC_WITH_3D_PROC
-
- PROC (OUTPUT => RESULTS) ;
- RETURN RESULTS = CUBE'(CUBE'RANGE =>
- (CUBE'RANGE (2) =>
- (CUBE'RANGE (3) => DEFAULT_VALUE))) ;
-
- END FUNC_WITH_3D_PROC ;
-
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION F (X : T := T'VAL (0)) RETURN T;
- FUNCTION FUNC1 RETURN BOOLEAN;
-
- FUNCTION FUNC1 RETURN BOOLEAN IS
- BEGIN -- FUNC1
- RETURN F = T'VAL (0);
- END FUNC1;
-
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION F (X : T := T'VAL (REPORT.IDENT_INT(0)))
- RETURN T;
- PACKAGE PKG1 IS END PKG1;
-
- PACKAGE BODY PKG1 IS
- BEGIN -- PKG1
- IF F /= T'VAL (0) THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " &
- "FUNCTION 'F' AND PACKAGE 'PKG1'" );
- END IF;
- END PKG1;
- GENERIC
- TYPE T IS (<>);
- WITH FUNCTION F (X : T := T'VAL (0)) RETURN T;
- PROCEDURE PROC1;
-
- PROCEDURE PROC1 IS
- BEGIN -- PROC1
- IF F /= T'VAL (0) THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " &
- "FUNCTION 'F' AND PROCEDURE 'PROC1'" );
- END IF;
- END PROC1;
-
- GENERIC
- TYPE T IS (<>);
- WITH PROCEDURE P (RESULTS : OUT T ;
- X : T := T'VAL (0)) ;
- FUNCTION FUNC2 RETURN BOOLEAN;
-
- FUNCTION FUNC2 RETURN BOOLEAN IS
- RESULTS : T;
- BEGIN -- FUNC2
- P (RESULTS);
- RETURN RESULTS = T'VAL (0);
- END FUNC2;
-
- GENERIC
- TYPE T IS (<>);
- WITH PROCEDURE P (RESULTS : OUT T;
- X : T := T'VAL(REPORT.IDENT_INT(0)));
- PACKAGE PKG2 IS END PKG2 ;
-
- PACKAGE BODY PKG2 IS
- RESULTS : T;
- BEGIN -- PKG2
- P (RESULTS);
- IF RESULTS /= T'VAL (0) THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " &
- "PROCEDURE 'P' AND PACKAGE 'PKG2'" );
- END IF;
- END PKG2;
-
- GENERIC
- TYPE T IS (<>);
- WITH PROCEDURE P (RESULTS :OUT T; X : T := T'VAL (0));
- PROCEDURE PROC2;
-
- PROCEDURE PROC2 IS
- RESULTS : T;
- BEGIN -- PROC2
- P (RESULTS);
- IF RESULTS /= T'VAL (0) THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " &
- "PROCEDURE 'P' AND PROCEDURE 'PROC2'" );
- END IF;
- END PROC2;
-
- FUNCTION F1 (A : NUMBERS := ONE) RETURN NUMBERS IS
- BEGIN -- F1
- RETURN A;
- END;
-
- PROCEDURE P2 (OUTVAR : OUT NUMBERS; INVAR : NUMBERS := TWO) IS
- BEGIN -- P2
- OUTVAR := INVAR;
- END;
-
- FUNCTION TD_FUNC (FIRST : IN THREE_DIMENSIONAL :=
- (THREE_DIMENSIONAL'RANGE =>
- (THREE_DIMENSIONAL'RANGE (2) =>
- (THREE_DIMENSIONAL'RANGE (3) =>
- FIRST_DATE))))
- RETURN THREE_DIMENSIONAL IS
-
- BEGIN -- TD_FUNC
-
- RETURN FIRST ;
-
- END TD_FUNC ;
-
- PROCEDURE TD_PROC (INPUT : IN THREE_DIMENSIONAL :=
- (THREE_DIMENSIONAL'RANGE =>
- (THREE_DIMENSIONAL'RANGE (2) =>
- (THREE_DIMENSIONAL'RANGE (3) =>
- FIRST_DATE))) ;
- OUTPUT : OUT THREE_DIMENSIONAL) IS
- BEGIN -- TD_PROC
-
- OUTPUT := INPUT ;
-
- END TD_PROC ;
-
- PROCEDURE NEW_PROC_WITH_3D_FUNC IS NEW
- PROC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- FUN => TD_FUNC) ;
-
- PACKAGE NEW_PKG_WITH_3D_FUNC IS NEW
- PKG_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- FUN => TD_FUNC) ;
-
- FUNCTION NEW_FUNC_WITH_3D_FUNC IS NEW
- FUNC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- FUN => TD_FUNC) ;
-
- PROCEDURE NEW_PROC_WITH_3D_PROC IS NEW
- PROC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- PROC => TD_PROC) ;
-
- PACKAGE NEW_PKG_WITH_3D_PROC IS NEW
- PKG_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- PROC => TD_PROC) ;
-
- FUNCTION NEW_FUNC_WITH_3D_PROC IS NEW
- FUNC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT,
- SECOND_INDEX => FIRST_HALF,
- THIRD_INDEX => FIRST_FIVE,
- COMPONENT_TYPE => DATE,
- DEFAULT_VALUE => TODAY,
- CUBE => THREE_DIMENSIONAL,
- PROC => TD_PROC) ;
-
- FUNCTION NFUNC1 IS NEW FUNC1 (NUMBERS, F1);
- PACKAGE NPKG1 IS NEW PKG1 (NUMBERS, F1);
- PROCEDURE NPROC1 IS NEW PROC1 (NUMBERS, F1);
-
- FUNCTION NFUNC2 IS NEW FUNC2 (NUMBERS, P2);
- PACKAGE NPKG2 IS NEW PKG2 (NUMBERS, P2);
- PROCEDURE NPROC2 IS NEW PROC2 (NUMBERS, P2);
-
-BEGIN -- CC1311A
-
- IF NOT NFUNC1 THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE " &
- "WITH FUNCTION 'NFUNC1'" ) ;
- END IF ;
-
- IF NOT NFUNC2 THEN
- REPORT.FAILED ("INCORRECT DEFAULT VALUE " &
- "WITH FUNCTION 'NFUNC2'" ) ;
- END IF ;
-
- NPROC1 ;
- NPROC2 ;
-
- NEW_PROC_WITH_3D_FUNC ;
-
- IF NOT NEW_FUNC_WITH_3D_FUNC THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " &
- "FUNCTION, AND FUNCTION.") ;
- END IF ;
-
- NEW_PROC_WITH_3D_PROC ;
-
- IF NOT NEW_FUNC_WITH_3D_PROC THEN
- REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " &
- "FUNCTION, AND PROCEDURE.") ;
- END IF ;
-
- REPORT.RESULT ;
-
-END CC1311A ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada b/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada
deleted file mode 100644
index eb30726..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada
+++ /dev/null
@@ -1,332 +0,0 @@
--- CC1311B.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 PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE
--- THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF
--- THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF
--- SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION.
-
--- HISTORY:
--- RJW 06/11/86 CREATED ORIGINAL TEST.
--- DHH 10/20/86 CORRECTED RANGE ERRORS.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--- PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT
--- HAVE BEEN RELAXED.
--- PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC1311B IS
-
-BEGIN
- TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " &
- "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " &
- "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " &
- "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " &
- "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " &
- "FORMAL SUBPROGRAM DECLARATION" );
-
- DECLARE
- TYPE NUMBERS IS (ZERO, ONE ,TWO);
- SUBTYPE ZERO_TWO IS NUMBERS;
- SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE;
-
- FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS
- BEGIN
- RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE)));
- END FSUB;
-
- GENERIC
- WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO
- IS FSUB;
- FUNCTION FUNC RETURN ZERO_TWO;
-
- FUNCTION FUNC RETURN ZERO_TWO IS
- BEGIN
- RETURN F;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- RETURN ZERO;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "NFUNC1" );
- RETURN ZERO;
- END FUNC;
-
- FUNCTION NFUNC1 IS NEW FUNC;
-
- BEGIN
- IF NFUNC1 = ONE THEN
- FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" );
- END IF;
- END;
-
- DECLARE
- TYPE GENDER IS (MALE, FEMALE);
-
- TYPE PERSON (SEX : GENDER) IS
- RECORD
- CASE SEX IS
- WHEN MALE =>
- BEARDED : BOOLEAN;
- WHEN FEMALE =>
- CHILDREN : INTEGER;
- END CASE;
- END RECORD;
-
- SUBTYPE MAN IS PERSON (SEX => MALE);
- SUBTYPE TESTWRITER IS PERSON (FEMALE);
-
- ROSA : TESTWRITER := (FEMALE, 4);
-
- FUNCTION F (X : MAN) RETURN PERSON IS
- TOM : PERSON (MALE) := (MALE, FALSE);
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN TOM;
- END IF;
- END F;
-
- GENERIC
- TYPE T IS PRIVATE;
- X1 : T;
- WITH FUNCTION F (X : T) RETURN T IS <> ;
- PACKAGE PKG IS END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF F(X1) = X1 THEN
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PACKAGE " &
- "'PKG' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PACKAGE " &
- "'PKG' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PACKAGE 'PKG'" );
- END PKG;
-
- PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA);
-
- BEGIN
- COMMENT ( "PACKAGE BODY ELABORATED - 1" );
- END;
-
- DECLARE
- TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- SUBTYPE SUBV1 IS VECTOR (1 .. 5);
- SUBTYPE SUBV2 IS VECTOR (2 .. 6);
-
- V1 : SUBV1 := (1, 2, 3, 4, 5);
-
- FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS
- Z : SUBV2;
- BEGIN
- FOR I IN Y'RANGE LOOP
- Z (I) := IDENT_INT (Y (I));
- END LOOP;
- RETURN Z;
- END;
-
- GENERIC
- WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB;
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- BEGIN
- IF F = V1 THEN
- COMMENT ( "NO EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PROCEDURE " &
- "'PROC' - 1" );
- ELSE
- COMMENT ( "NO EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PROCEDURE " &
- "'PROC' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
- "FUNCTION 'F' AND PROCEDURE " &
- "'PROC'" );
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "FUNCTION 'F' AND PROCEDURE " &
- "'PROC'" );
- END PROC;
-
- PROCEDURE NPROC IS NEW PROC;
- BEGIN
- NPROC;
- END;
-
- DECLARE
-
- TYPE ACC IS ACCESS STRING;
-
- SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5;
- SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6;
-
- SUBTYPE ACC1 IS ACC (INDEX1);
- SUBTYPE ACC2 IS ACC (INDEX2);
-
- AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A');
- AC : ACC;
-
- PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS
- BEGIN
- RESULTS := NULL;
- END P;
-
- GENERIC
- WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2)
- IS P;
- FUNCTION FUNC RETURN ACC;
-
- FUNCTION FUNC RETURN ACC IS
- RESULTS : ACC;
- BEGIN
- P1 (RESULTS);
- RETURN RESULTS;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- RETURN NEW STRING'("ABCDE");
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "NFUNC2" );
- RETURN NULL;
- END FUNC;
-
- FUNCTION NFUNC2 IS NEW FUNC;
-
- BEGIN
- AC := NFUNC2;
- IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN
- FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" );
- END IF;
- END;
-
- DECLARE
- SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0;
- SUBTYPE FLOAT2 IS FLOAT RANGE 0.0 .. 1.0;
-
- PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RESULTS := X;
- ELSE
- RESULTS := 0.0;
- END IF;
- END PSUB;
-
- GENERIC
- WITH PROCEDURE P (RESULTS : OUT FLOAT1;
- X : FLOAT1 := -0.0625) IS PSUB;
- PACKAGE PKG IS END PKG;
-
- PACKAGE BODY PKG IS
- RESULTS : FLOAT1;
- BEGIN
- P (RESULTS);
- IF RESULTS = 1.0 THEN
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PACKAGE " &
- "'PKG' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PACKAGE " &
- "'PKG' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PACKAGE 'PKG'" );
- END PKG;
-
- PACKAGE NPKG IS NEW PKG;
- BEGIN
- COMMENT ( "PACKAGE BODY ELABORATED - 2" );
- END;
-
- DECLARE
- TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
- SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0;
- SUBTYPE FIXED2 IS FIXED RANGE 0.0 .. 0.5;
-
- PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RESULTS := X;
- ELSE
- RESULTS := X;
- END IF;
- END P;
-
- GENERIC
- TYPE F IS DELTA <>;
- F1 : F;
- WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ;
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- RESULTS : F;
- BEGIN
- P (RESULTS, F1);
- IF RESULTS = 0.0 THEN
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PROCEDURE " &
- "'PROC' - 1" );
- ELSE
- FAILED ( "NO EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PROCEDURE " &
- "'PROC' - 2" );
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ( "WRONG EXCEPTION RAISED WITH " &
- "PROCEDURE 'P' AND PROCEDURE " &
- "'PROC'" );
- END PROC;
-
- PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125);
-
- BEGIN
- NPROC;
- END;
-
- RESULT;
-
-END CC1311B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada b/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada
deleted file mode 100644
index 95b9e91e..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CC2002A.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 ELABORATION OF A GENERIC BODY HAS NO EFFECT OTHER
--- THAN TO ESTABLISH THE TEMPLATE BODY TO BE USED FOR THE
--- CORRESPONDING INSTANTIATIONS.
-
--- ASL 09/02/81
--- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC2002A IS
-
- GLOBAL : INTEGER := 0;
- Q : INTEGER RANGE 1..1 := 1;
-BEGIN
- TEST ("CC2002A","NO SIDE EFFECTS OF ELABORATION OF GENERIC BODY");
-
- BEGIN
- DECLARE
- GENERIC
- PACKAGE P IS
- END P;
-
- GENERIC PROCEDURE PROC;
-
- PROCEDURE PROC IS
- C : CONSTANT INTEGER RANGE 1 .. 1 := 2;
- BEGIN
- RAISE PROGRAM_ERROR;
- END PROC;
-
- PACKAGE BODY P IS
- C : CONSTANT BOOLEAN :=
- BOOLEAN'SUCC(IDENT_BOOL(TRUE));
- BEGIN
- GLOBAL := 1;
- Q := Q + 1;
- END P;
- BEGIN
- NULL;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING ELABORATION OF " &
- "GENERIC BODY");
- END;
-
- IF GLOBAL /= 0 THEN
- FAILED ("VALUE OF GLOBAL VARIABLE CHANGED BY ELABORATION " &
- "OF GENERIC BODY");
- END IF;
-
- RESULT;
-END CC2002A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30001.a b/gcc/testsuite/ada/acats/tests/cc/cc30001.a
deleted file mode 100644
index 69010e4..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc30001.a
+++ /dev/null
@@ -1,219 +0,0 @@
--- CC30001.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 non-overriding primitive subprogram is declared for
--- a type derived from a formal derived tagged type, the copy of that
--- subprogram in an instance can override a subprogram inherited from the
--- actual type.
---
--- TEST DESCRIPTION:
--- User writes program to handle both mail messages and system messages.
---
--- Mail messages are created by instantiating a generic "mail" package
--- with a root message type. System messages are created by
--- instantiating the generic with a system message type derived from the
--- root in a separate package. The system message type has a primitive
--- subprogram called Send.
---
--- Inside the generic, a "mail" type is derived from the generic formal
--- derived type, and a "Send" operation is declared.
---
--- Declare a root tagged type T. Declare a generic package with a formal
--- derived type using the root tagged type as ancestor. In the generic,
--- derive a type from the formal derived type and declare a primitive
--- subprogram for it. In a separate package, declare a derivative DT of
--- the root tagged type T and declare a primitive subprogram which is
--- type conformant with (and hence, overridable for) the primitive
--- declared in the generic. Instantiate the generic for DT. Make both
--- dispatching and non-dispatching calls to the primitive subprogram. In
--- both cases the version of the subprogram in the instance should be
--- called (since it overrides the implementation inherited from the
--- actual).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Apr 95 SAIC Replaced call involving instance for root tagged
--- type with a dispatching call involving instance
--- for derived type. Updated commentary. Moved
--- instantiations (and related commentary) to
--- library-level to avoid accessibility violation.
--- Commented out instantiation for root tagged type.
--- 27 Feb 97 PWB.CTA Added elaboration pragma.
---!
-
-package CC30001_0 is -- Root message type.
-
- type Msg_Type is tagged record
- Text : String (1 .. 20);
- Message_Sent : Boolean;
- end record;
-
-end CC30001_0;
-
-
- --==================================================================--
-
-
-with CC30001_0; -- Root message type.
-generic -- Generic "mail" package.
- type Message is new CC30001_0.Msg_Type with private;
-package CC30001_1 is
-
- type Mail_Type is new Message with record -- Derived from formal type.
- To : String (1 .. 8);
- end record;
-
- procedure Send (M : in out Mail_Type); -- For this test, this version
- -- of Send should be called in
- -- ... Other operations. -- all cases.
-
-end CC30001_1;
-
-
- --==================================================================--
-
-
-package body CC30001_1 is
-
- procedure Send (M : in out Mail_Type) is
- begin
- -- ... Code to send message omitted for brevity.
- M.Message_Sent := True;
- end Send;
-
-end CC30001_1;
-
-
- --==================================================================--
-
-
-with CC30001_0; -- Root message type.
-package CC30001_2 is -- System message type and operations.
-
- type Signal_Type is (Note, Warning, Error);
-
- type Sys_Message is new CC30001_0.Msg_Type with record -- Derived from
- Signal : Signal_Type := Warning; -- root type.
- end record;
-
- procedure Send (Item : in out Sys_Message); -- For this test, this version
- -- of Send should never be
- -- ... Other operations. -- called (it will have been
- -- overridden).
-end CC30001_2;
-
-
- --==================================================================--
-
-
-package body CC30001_2 is
-
- procedure Send (Item : in out Sys_Message) is
- begin
- -- ... Code to send message omitted for brevity.
- Item.Message_Sent := False; -- Ensure this procedure gives a different
- end Send; -- result than CC30001_1.Send.
-
-end CC30001_2;
-
-
- --==================================================================--
-
-
--- User first sets up support for mail messages by instantiating the
--- generic mail package for the root message type. An operation "Send" is
--- declared for the mail message type in the instance.
---
--- with CC30001_0; -- Root message type.
--- with CC30001_1; -- Generic "mail" package.
--- package Mail_Messages is new CC30001_1 (CC30001_0.Msg_Type);
-
-
- --==================================================================--
-
-
--- Next, the user sets up support for system messages by instantiating the
--- generic mail package with the system message type. An operation "Send"
--- is declared for the "system" mail message type in the instance. This
--- operation overrides the "Send" operation inherited from the system
--- message type actual (a situation the user may not have intended).
-
-with CC30001_1; -- Generic "mail" package.
-with CC30001_2; -- System message type and operations.
-pragma Elaborate (CC30001_1);
-package CC30001_3 is new CC30001_1 (CC30001_2.Sys_Message);
-
-
- --==================================================================--
-
-with CC30001_2; -- System message type and operations.
-with CC30001_3; -- Instance with mail type and operations.
-
-with Report;
-procedure CC30001 is
-
- package System_Messages renames CC30001_3;
-
-
- Sys_Msg1 : System_Messages.Mail_Type := (Text => "System shutting down",
- Signal => CC30001_2.Warning,
- To => "AllUsers",
- Message_Sent => False);
-
- Sys_Msg2 : System_Messages.Mail_Type'Class := Sys_Msg1;
-
-
- use System_Messages, CC30001_2; -- All versions of "Send"
- -- directly visible.
-
-begin
-
- Report.Test ("CC30001", "Check that if a non-overriding primitive " &
- "subprogram is declared for a type derived from a formal " &
- "derived tagged type, the copy of that subprogram in an " &
- "instance can override a subprogram inherited from the " &
- "actual type");
-
-
- Send (Sys_Msg1); -- Calls version declared in instance (version declared
- -- in CC30001_2 has been overridden).
-
- if not Sys_Msg1.Message_Sent then
- Report.Failed ("Non-dispatching call: instance operation not called");
- end if;
-
-
- Send (Sys_Msg2); -- Calls version declared in instance (version declared
- -- in CC30001_2 has been overridden).
-
- if not Sys_Msg2.Message_Sent then
- Report.Failed ("Dispatching call: instance operation not called");
- end if;
-
-
- Report.Result;
-end CC30001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30002.a b/gcc/testsuite/ada/acats/tests/cc/cc30002.a
deleted file mode 100644
index 5132f8c..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc30002.a
+++ /dev/null
@@ -1,349 +0,0 @@
--- CC30002.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 explicit declaration in the private part of an instance
--- does not override an implicit declaration in the instance, unless the
--- corresponding explicit declaration in the generic overrides a
--- corresponding implicit declaration in the generic. Check for primitive
--- subprograms of tagged types.
---
--- TEST DESCRIPTION:
--- Consider the following:
---
--- type Ancestor is tagged null record;
--- procedure R (X: in Ancestor);
---
--- generic
--- type Formal is new Ancestor with private;
--- package G is
--- type T is new Formal with null record;
--- -- Implicit procedure R (X: in T);
--- procedure P (X: in T); -- (1)
--- private
--- procedure Q (X: in T); -- (2)
--- procedure R (X: in T); -- (3) Overrides implicit R in generic.
--- end G;
---
--- type Actual is new Ancestor with null record;
--- procedure P (X: in Actual);
--- procedure Q (X: in Actual);
--- procedure R (X: in Actual);
---
--- package Instance is new G (Formal => Actual);
---
--- In the instance, the copy of P at (1) overrides Actual's P, since it
--- is declared in the visible part of the instance. The copy of Q at (2)
--- does not override anything. The copy of R at (3) overrides Actual's
--- R, even though it is declared in the private part, because within
--- the generic the explicit declaration of R overrides an implicit
--- declaration.
---
--- Thus, for calls involving a parameter with tag T:
--- - Calls to P will execute the body declared for T.
--- - Calls to Q from within Instance will execute the body declared
--- for T.
--- - Calls to Q from outside Instance will execute the body declared
--- for Actual.
--- - Calls to R will execute the body declared for T.
---
--- Verify this behavior for both dispatching and nondispatching calls to
--- Q and R.
---
---
--- CHANGE HISTORY:
--- 24 Feb 95 SAIC Initial prerelease version.
---
---!
-
-package CC30002_0 is
-
- type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance,
- Body_Of_Actual, Initial_Value);
-
- type Camera is tagged record
- -- ... Camera components.
- TC_Focus_Called : TC_Body_Kind := Initial_Value;
- TC_Shutter_Called : TC_Body_Kind := Initial_Value;
- end record;
-
- procedure Focus (C: in out Camera);
-
- -- ...Other operations.
-
-end CC30002_0;
-
-
- --==================================================================--
-
-
-package body CC30002_0 is
-
- procedure Focus (C: in out Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_Of_Ancestor;
- end Focus;
-
-end CC30002_0;
-
-
- --==================================================================--
-
-
-with CC30002_0;
-use CC30002_0;
-generic
- type Camera_Type is new CC30002_0.Camera with private;
-package CC30002_1 is
-
- type Speed_Camera is new Camera_Type with record
- Diag_Code: Positive;
- -- ...Other components.
- end record;
-
- -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic.
- procedure Self_Test_NonDisp (C: in out Speed_Camera);
- procedure Self_Test_Disp (C: in out Speed_Camera'Class);
-
-private
-
- -- The following explicit declaration of Set_Shutter_Speed does NOT override
- -- a corresponding implicit declaration in the generic. Therefore, its copy
- -- does NOT override the implicit declaration (inherited from the actual)
- -- in the instance.
-
- procedure Set_Shutter_Speed (C: in out Speed_Camera);
-
- -- The following explicit declaration of Focus DOES override a
- -- corresponding implicit declaration (inherited from the parent) in the
- -- generic. Therefore, its copy overrides the implicit declaration
- -- (inherited from the actual) in the instance.
-
- procedure Focus (C: in out Speed_Camera); -- Overrides implicit Focus
- -- in generic.
-end CC30002_1;
-
-
- --==================================================================--
-
-
-package body CC30002_1 is
-
- procedure Self_Test_NonDisp (C: in out Speed_Camera) is
- begin
- -- Nondispatching calls:
- Focus (C);
- Set_Shutter_Speed (C);
- end Self_Test_NonDisp;
-
- procedure Self_Test_Disp (C: in out Speed_Camera'Class) is
- begin
- -- Dispatching calls:
- Focus (C);
- Set_Shutter_Speed (C);
- end Self_Test_Disp;
-
- procedure Set_Shutter_Speed (C: in out Speed_Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Shutter_Called := Body_In_Instance;
- end Set_Shutter_Speed;
-
- procedure Focus (C: in out Speed_Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_In_Instance;
- end Focus;
-
-end CC30002_1;
-
-
- --==================================================================--
-
-
-with CC30002_0;
-package CC30002_2 is
-
- type Aperture_Camera is new CC30002_0.Camera with record
- FStop: Natural;
- -- ...Other components.
- end record;
-
- procedure Set_Shutter_Speed (C: in out Aperture_Camera);
- procedure Focus (C: in out Aperture_Camera);
-
-end CC30002_2;
-
-
- --==================================================================--
-
-
-package body CC30002_2 is
-
- procedure Set_Shutter_Speed (C: in out Aperture_Camera) is
- use CC30002_0;
- begin
- -- Artificial for testing purposes.
- C.TC_Shutter_Called := Body_Of_Actual;
- end Set_Shutter_Speed;
-
- procedure Focus (C: in out Aperture_Camera) is
- use CC30002_0;
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_Of_Actual;
- end Focus;
-
-end CC30002_2;
-
-
- --==================================================================--
-
-
--- Instance declaration.
-
-with CC30002_1;
-with CC30002_2;
-package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera);
-
-
- --==================================================================--
-
-
-with CC30002_0;
-with CC30002_1;
-with CC30002_2;
-with CC30002_3; -- Instance.
-
-with Report;
-procedure CC30002 is
-
- package Speed_Cameras renames CC30002_3;
-
- use CC30002_0;
-
- TC_Camera1: Speed_Cameras.Speed_Camera;
- TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1;
- TC_Camera3: Speed_Cameras.Speed_Camera;
- TC_Camera4: Speed_Cameras.Speed_Camera;
-
-begin
- Report.Test ("CC30002", "Check that an explicit declaration in the " &
- "private part of an instance does not override an implicit " &
- "declaration in the instance, unless the corresponding " &
- "explicit declaration in the generic overrides a " &
- "corresponding implicit declaration in the generic. Check " &
- "for primitive subprograms of tagged types");
-
---
--- Check non-dispatching calls outside instance:
---
-
- -- Non-overriding primitive operation:
-
- Speed_Cameras.Set_Shutter_Speed (TC_Camera1);
- if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Set_Shutter_Speed outside instance");
- end if;
-
-
- -- Overriding primitive operation:
-
- Speed_Cameras.Focus (TC_Camera1);
- if TC_Camera1.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Focus outside instance");
- end if;
-
-
---
--- Check dispatching calls outside instance:
---
-
- -- Non-overriding primitive operation:
-
- Speed_Cameras.Set_Shutter_Speed (TC_Camera2);
- if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Set_Shutter_Speed outside instance");
- end if;
-
-
- -- Overriding primitive operation:
-
- Speed_Cameras.Focus (TC_Camera2);
- if TC_Camera2.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Focus outside instance");
- end if;
-
-
-
---
--- Check non-dispatching calls within instance:
---
-
- Speed_Cameras.Self_Test_NonDisp (TC_Camera3);
-
- -- Non-overriding primitive operation:
-
- if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Set_Shutter_Speed inside instance");
- end if;
-
- -- Overriding primitive operation:
-
- if TC_Camera3.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Focus inside instance");
- end if;
-
-
-
---
--- Check dispatching calls within instance:
---
-
- Speed_Cameras.Self_Test_Disp (TC_Camera4);
-
- -- Non-overriding primitive operation:
-
- if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Set_Shutter_Speed inside instance");
- end if;
-
- -- Overriding primitive operation:
-
- if TC_Camera4.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Focus inside instance");
- end if;
-
- Report.Result;
-end CC30002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada
deleted file mode 100644
index 5e65adf..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CC3004A.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 IN A NAMED GENERIC ACTUAL PARAMETER
--- ASSOCIATION MAY BE OUT OF ORDER, AND ARE ASSOCIATED WITH THE
--- CORRECT FORMALS.
-
--- DAT 9/16/81
--- SPS 10/26/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3004A IS
-BEGIN
- TEST ("CC3004A", "ORDER OF NAMED GENERIC ACTUAL PARAMETERS");
-
- DECLARE
- GENERIC
- A,B : INTEGER;
- C : INTEGER;
- D : INTEGER;
- PACKAGE P1 IS END P1;
-
- TYPE AI IS ACCESS INTEGER;
-
- GENERIC
- TYPE D IS ( <> );
- VD : D;
- TYPE AD IS ACCESS D;
- VA : AD;
- PACKAGE P2 IS END P2;
-
- X : AI := NEW INTEGER '(IDENT_INT(23));
- Y : AI := NEW INTEGER '(IDENT_INT(77));
-
- PACKAGE BODY P1 IS
- BEGIN
- IF A /= IDENT_INT(4) OR
- B /= IDENT_INT(12) OR
- C /= IDENT_INT(11) OR
- D /= IDENT_INT(-33)
- THEN
- FAILED ("WRONG GENERIC PARAMETER ASSOCIATIONS");
- END IF;
- END P1;
-
- PACKAGE BODY P2 IS
- BEGIN
- IF VA.ALL /= VD THEN
- FAILED ("WRONG GENERIC PARM ASSOCIATIONS 2");
- END IF;
- END P2;
-
- PACKAGE N1 IS NEW P1 (C => 11, A => 4, D => -33, B => 12);
-
- PACKAGE N2 IS NEW P2 (VA => X, AD => AI, D => INTEGER,
- VD => 23);
-
- PACKAGE N3 IS NEW P2 (INTEGER, 77, VA => Y, AD => AI);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3004A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada
deleted file mode 100644
index e9d6daa..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CC3007A.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 NAMES IN A GENERIC DECLARATIONS ARE STATICALLY BOUND.
-
--- DAT 9/18/81
--- SPS 2/7/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3007A IS
-BEGIN
- TEST ("CC3007A", "NAMES IN GENERICS ARE STATICALLY BOUND");
-
- DECLARE
- I : INTEGER := 1;
- EX : EXCEPTION;
- IA : INTEGER := I'SIZE;
-
- FUNCTION F (X : INTEGER) RETURN INTEGER;
-
- PACKAGE P IS
- Q : INTEGER := 1;
- END P;
-
- GENERIC
- J : IN OUT INTEGER;
- WITH FUNCTION FP (X : INTEGER) RETURN INTEGER IS F;
- PACKAGE GP IS
- V1 : INTEGER := F(I);
- V2 : INTEGER := FP(I);
- END GP;
-
- GENERIC
- TYPE T IS RANGE <> ;
- WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER IS F;
- INP : IN T := T (I'SIZE);
- FUNCTION F1 (X : T) RETURN T;
-
- FUNCTION F1 (X : T) RETURN T IS
- BEGIN
- IF INP /= T(IA) THEN
- FAILED ("INCORRECT GENERIC BINDING 2");
- END IF;
- I := I + 1;
- RETURN 2 * T (F1 (F (INTEGER (X) + I + P.Q)));
- END F1;
-
- PACKAGE BODY GP IS
- PACKAGE P IS
- Q : INTEGER := I + 1;
- END P;
- I : INTEGER := 1000;
- FUNCTION F IS NEW F1 (INTEGER);
- FUNCTION F2 IS NEW F1 (INTEGER);
- BEGIN
- P.Q := F2 (J + P.Q + V1 + 2 * V2);
- J := P.Q;
- RAISE EX;
- END GP;
-
- FUNCTION F (X : INTEGER) RETURN INTEGER IS
- BEGIN
- I := I + 2;
- RETURN X + I;
- END;
- BEGIN
- DECLARE
- I : INTEGER := 1000;
- EX : EXCEPTION;
- FUNCTION F IS NEW F1 (INTEGER);
- V : INTEGER := F (3);
- BEGIN
- BEGIN
- DECLARE
- PACKAGE P IS NEW GP (V);
- BEGIN
- FAILED ("EX NOT RAISED");
- END;
- EXCEPTION
- WHEN EX =>
- FAILED ("WRONG EXCEPTION RAISED");
- WHEN OTHERS =>
- IF V /= 266 THEN
- FAILED ("WRONG BINDING IN GENERICS");
- END IF;
- RAISE;
- END;
-
- END;
- EXCEPTION
- WHEN EX => NULL;
- WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2");
- END;
-
- RESULT;
-END CC3007A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada
deleted file mode 100644
index 22bd4c0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada
+++ /dev/null
@@ -1,397 +0,0 @@
--- CC3007B.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 NAMES IN A GENERIC INSTANTIATION ARE STATICALLY
--- IDENTIFIED (I.E., BOUND) AT THE TEXTUAL POINT OF THE INSTANTIA-
--- TION, AND ARE BOUND BEFORE BEING "SUBSTITUTED" FOR THE COR-
--- RESPONDING GENERIC FORMAL PARAMETERS IN THE SPECIFICATION AND
--- BODY TEMPLATES.
---
--- SEE AI-00365/05-BI-WJ.
-
--- HISTORY:
--- EDWARD V. BERARD, 15 AUGUST 1990
--- DAS 08 OCT 90 CHANGED INSTANTIATIONS TO USE VARIABLES
--- M1 AND M2 IN THE FIRST_BLOCK INSTANTIA-
--- TION AND TO ASSIGN THIRD_DATE AND
--- FOURTH_DATE VALUES BEFORE AND AFTER THE
--- SECOND_BLOCK INSTANTIATION.
-
-WITH REPORT;
-
-PROCEDURE CC3007B IS
-
- INCREMENTED_VALUE : NATURAL := 0;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC);
- TYPE DAY_TYPE IS RANGE 1 .. 31;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE;
- DAY : DAY_TYPE;
- YEAR : YEAR_TYPE;
- END RECORD;
-
- TYPE DATE_ACCESS IS ACCESS DATE;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 8,
- YEAR => 1990);
-
- CHRISTMAS : DATE := (MONTH => DEC,
- DAY => 25,
- YEAR => 1948);
-
- WALL_DATE : DATE := (MONTH => NOV,
- DAY => 9,
- YEAR => 1989);
-
- BIRTH_DATE : DATE := (MONTH => OCT,
- DAY => 3,
- YEAR => 1949);
-
- FIRST_DUE_DATE : DATE := (MONTH => JAN,
- DAY => 23,
- YEAR => 1990);
-
- LAST_DUE_DATE : DATE := (MONTH => DEC,
- DAY => 20,
- YEAR => 1990);
-
- THIS_MONTH : MONTH_TYPE := AUG;
-
- STORED_RECORD : DATE := TODAY;
-
- STORED_INDEX : MONTH_TYPE := AUG;
-
- FIRST_DATE : DATE_ACCESS := NEW DATE'(WALL_DATE);
- SECOND_DATE : DATE_ACCESS := FIRST_DATE;
-
- THIRD_DATE : DATE_ACCESS := NEW DATE'(BIRTH_DATE);
- FOURTH_DATE : DATE_ACCESS := NEW DATE'(CHRISTMAS);
-
- TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE;
- REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990),
- (MAR, 23, 1990), (APR, 23, 1990),
- (MAY, 23, 1990), (JUN, 22, 1990),
- (JUL, 23, 1990), (AUG, 23, 1990),
- (SEP, 24, 1990), (OCT, 23, 1990),
- (NOV, 23, 1990), (DEC, 20, 1990));
-
- GENERIC
-
- NATURALLY : IN NATURAL;
- FIRST_RECORD : IN OUT DATE;
- SECOND_RECORD : IN OUT DATE;
- TYPE RECORD_POINTER IS ACCESS DATE;
- POINTER : IN OUT RECORD_POINTER;
- TYPE ARRAY_TYPE IS ARRAY (MONTH_TYPE) OF DATE;
- THIS_ARRAY : IN OUT ARRAY_TYPE;
- FIRST_ARRAY_ELEMENT : IN OUT DATE;
- SECOND_ARRAY_ELEMENT : IN OUT DATE;
- INDEX_ELEMENT : IN OUT MONTH_TYPE;
- POINTER_TEST : IN OUT DATE;
- ANOTHER_POINTER_TEST : IN OUT DATE;
-
- PACKAGE TEST_ACTUAL_PARAMETERS IS
-
- PROCEDURE EVALUATE_FUNCTION;
- PROCEDURE CHECK_RECORDS;
- PROCEDURE CHECK_ACCESS;
- PROCEDURE CHECK_ARRAY;
- PROCEDURE CHECK_ARRAY_ELEMENTS;
- PROCEDURE CHECK_SCALAR;
- PROCEDURE CHECK_POINTERS;
-
- END TEST_ACTUAL_PARAMETERS;
-
- PACKAGE BODY TEST_ACTUAL_PARAMETERS IS
-
- PROCEDURE EVALUATE_FUNCTION IS
- BEGIN -- EVALUATE_FUNCTION
-
- IF (INCREMENTED_VALUE = 0) OR
- (NATURALLY /= INCREMENTED_VALUE) THEN
- REPORT.FAILED ("PROBLEMS EVALUATING FUNCTION " &
- "PARAMETER.");
- END IF;
-
- END EVALUATE_FUNCTION;
-
- PROCEDURE CHECK_RECORDS IS
-
- STORE : DATE;
-
- BEGIN -- CHECK_RECORDS
-
- IF STORED_RECORD /= FIRST_RECORD THEN
- REPORT.FAILED ("PROBLEM WITH RECORD TYPES");
- ELSE
- STORED_RECORD := SECOND_RECORD;
- STORE := FIRST_RECORD;
- FIRST_RECORD := SECOND_RECORD;
- SECOND_RECORD := STORE;
- END IF;
-
- END CHECK_RECORDS;
-
- PROCEDURE CHECK_ACCESS IS
- BEGIN -- CHECK_ACCESS
-
- IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE
- THEN
- IF POINTER.ALL /= DATE'(WALL_DATE) THEN
- REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " &
- "- 1");
- ELSE
- POINTER.ALL := DATE'(BIRTH_DATE);
- END IF;
- ELSE
- IF POINTER.ALL /= DATE'(BIRTH_DATE) THEN
- REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " &
- "- 2");
- ELSE
- POINTER.ALL := DATE'(WALL_DATE);
- END IF;
- END IF;
-
- END CHECK_ACCESS;
-
- PROCEDURE CHECK_ARRAY IS
-
- STORE : DATE;
-
- BEGIN -- CHECK_ARRAY
-
- IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE
- THEN
- IF THIS_ARRAY (THIS_ARRAY'FIRST) /= FIRST_DUE_DATE
- THEN
- REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 1");
- ELSE
- THIS_ARRAY (THIS_ARRAY'FIRST) := LAST_DUE_DATE;
- THIS_ARRAY (THIS_ARRAY'LAST) := FIRST_DUE_DATE;
- END IF;
- ELSE
- IF THIS_ARRAY (THIS_ARRAY'FIRST) /= LAST_DUE_DATE
- THEN
- REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 2");
- ELSE
- THIS_ARRAY (THIS_ARRAY'FIRST) :=
- FIRST_DUE_DATE;
- THIS_ARRAY (THIS_ARRAY'LAST) := LAST_DUE_DATE;
- END IF;
- END IF;
-
- END CHECK_ARRAY;
-
- PROCEDURE CHECK_ARRAY_ELEMENTS IS
-
- STORE : DATE;
-
- BEGIN -- CHECK_ARRAY_ELEMENTS
-
- IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE
- THEN
- IF (FIRST_ARRAY_ELEMENT.MONTH /= MAY) OR
- (SECOND_ARRAY_ELEMENT.DAY /= 22) THEN
- REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " &
- "- 1");
- ELSE
- STORE := FIRST_ARRAY_ELEMENT;
- FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT;
- SECOND_ARRAY_ELEMENT := STORE;
- END IF;
- ELSE
- IF (FIRST_ARRAY_ELEMENT.MONTH /= JUN) OR
- (SECOND_ARRAY_ELEMENT.DAY /= 23) THEN
- REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " &
- "- 2");
- ELSE
- STORE := FIRST_ARRAY_ELEMENT;
- FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT;
- SECOND_ARRAY_ELEMENT := STORE;
- END IF;
- END IF;
-
- END CHECK_ARRAY_ELEMENTS;
-
- PROCEDURE CHECK_SCALAR IS
- BEGIN -- CHECK_SCALAR
-
- IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE
- THEN
- IF INDEX_ELEMENT /= STORED_INDEX THEN
- REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 1");
- ELSE
- INDEX_ELEMENT :=
- MONTH_TYPE'SUCC(INDEX_ELEMENT);
- STORED_INDEX := INDEX_ELEMENT;
- END IF;
- ELSE
- IF INDEX_ELEMENT /= STORED_INDEX THEN
- REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 2");
- ELSE
- INDEX_ELEMENT :=
- MONTH_TYPE'PRED (INDEX_ELEMENT);
- STORED_INDEX := INDEX_ELEMENT;
- END IF;
- END IF;
-
- END CHECK_SCALAR;
-
- PROCEDURE CHECK_POINTERS IS
-
- STORE : DATE;
-
- BEGIN -- CHECK_POINTERS
-
- IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE
- THEN
- IF (POINTER_TEST /= DATE'(OCT, 3, 1949)) OR
- (ANOTHER_POINTER_TEST /= DATE'(DEC, 25, 1948))
- THEN
- REPORT.FAILED ("PROBLEM WITH POINTER TEST " &
- "- 1");
- ELSE
- STORE := POINTER_TEST;
- POINTER_TEST := ANOTHER_POINTER_TEST;
- ANOTHER_POINTER_TEST := STORE;
- END IF;
- ELSE
- IF (POINTER_TEST /= DATE'(DEC, 25, 1948)) OR
- (ANOTHER_POINTER_TEST /= DATE'(OCT, 3, 1949))
- THEN
- REPORT.FAILED ("PROBLEM WITH POINTER TEST " &
- "- 2");
- ELSE
- STORE := POINTER_TEST;
- POINTER_TEST := ANOTHER_POINTER_TEST;
- ANOTHER_POINTER_TEST := STORE;
- END IF;
- END IF;
-
- END CHECK_POINTERS;
-
- END TEST_ACTUAL_PARAMETERS;
-
- FUNCTION INC RETURN NATURAL IS
- BEGIN -- INC
- INCREMENTED_VALUE := NATURAL'SUCC (INCREMENTED_VALUE);
- RETURN INCREMENTED_VALUE;
- END INC;
-
-BEGIN -- CC3007B
-
- REPORT.TEST ("CC3007B", "CHECK THAT THE NAMES IN A GENERIC " &
- "INSTANTIATION ARE STAICALLY IDENTIFIED (I.E., " &
- "BOUND) AT THE TEXTUAL POINT OF THE INSTANTIATION" &
- ", AND ARE BOUND BEFORE BEING SUBSTITUTED FOR " &
- "THE CORRESPONDING GENERIC FORMAL PARAMETERS IN " &
- "THE SPECIFICATION AND BODY TEMPLATES. " &
- "SEE AI-00365/05-BI-WJ.");
-
- FIRST_BLOCK:
-
- DECLARE
-
- M1 : MONTH_TYPE := MAY;
- M2 : MONTH_TYPE := JUN;
-
- PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS
- NEW TEST_ACTUAL_PARAMETERS (
- NATURALLY => INC,
- FIRST_RECORD => TODAY,
- SECOND_RECORD => CHRISTMAS,
- RECORD_POINTER => DATE_ACCESS,
- POINTER => SECOND_DATE,
- ARRAY_TYPE => DUE_DATES,
- THIS_ARRAY => REPORT_DATES,
- FIRST_ARRAY_ELEMENT => REPORT_DATES (M1),
- SECOND_ARRAY_ELEMENT => REPORT_DATES (M2),
- INDEX_ELEMENT => THIS_MONTH,
- POINTER_TEST => THIRD_DATE.ALL,
- ANOTHER_POINTER_TEST => FOURTH_DATE.ALL);
-
- BEGIN -- FIRST_BLOCK
-
- REPORT.COMMENT ("ENTERING FIRST BLOCK");
- NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR;
- M1 := SEP;
- M2 := OCT;
- -- NEW_TEST_ACTUAL_PARAMETERS SHOULD USE THE PREVIOUS
- -- VALUES OF MAY AND JUN.
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS;
-
- END FIRST_BLOCK;
-
- SECOND_BLOCK:
-
- DECLARE
-
- SAVE_THIRD_DATE : DATE_ACCESS := THIRD_DATE;
- SAVE_FOURTH_DATE : DATE_ACCESS := FOURTH_DATE;
-
- PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS
- NEW TEST_ACTUAL_PARAMETERS (
- NATURALLY => INC,
- FIRST_RECORD => TODAY,
- SECOND_RECORD => CHRISTMAS,
- RECORD_POINTER => DATE_ACCESS,
- POINTER => SECOND_DATE,
- ARRAY_TYPE => DUE_DATES,
- THIS_ARRAY => REPORT_DATES,
- FIRST_ARRAY_ELEMENT => REPORT_DATES (MAY),
- SECOND_ARRAY_ELEMENT => REPORT_DATES (JUN),
- INDEX_ELEMENT => THIS_MONTH,
- POINTER_TEST => THIRD_DATE.ALL,
- ANOTHER_POINTER_TEST => FOURTH_DATE.ALL);
-
- BEGIN -- SECOND_BLOCK
-
- REPORT.COMMENT ("ENTERING SECOND BLOCK");
- NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS;
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS;
-
- THIRD_DATE := NEW DATE'(JUL, 13, 1951);
- FOURTH_DATE := NEW DATE'(JUL, 4, 1976);
- NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS;
- THIRD_DATE := SAVE_THIRD_DATE;
- FOURTH_DATE := SAVE_FOURTH_DATE;
-
- END SECOND_BLOCK;
-
- REPORT.RESULT;
-
-END CC3007B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada
deleted file mode 100644
index 8ecba22..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada
+++ /dev/null
@@ -1,131 +0,0 @@
--- CC3011A.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 SUBPROGRAMS THAT WOULD HAVE THE SAME SPECIFICATION
--- AFTER GENERIC INSTANTIATION MAY BE DECLARED IN THE SAME
--- DECLARATIVE PART, AND THAT CALLS WITHIN THE INSTANTIATED UNIT ARE
--- UNAMBIGUOUS. CHECK THAT CALLS FROM OUTSIDE THE UNIT ARE UNAMBIGUOUS
--- IF FORMAL PARAMETER NAMES ARE USED OR IF ONLY ONE OF THE EQUIVALENT
--- PROGRAMS APPEARS IN THE VISIBLE PART OF THE PACKAGE.
-
--- DAT 9/18/81
--- SPS 10/19/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3011A IS
-BEGIN
- TEST ("CC3011A", "CHECK SUBPROGRAMS IN GENERIC PACKAGES WITH SAME"
- & " SPECIFICATION AFTER GENERIC PARAMETER SUBSTITUTION");
-
- DECLARE
- C : INTEGER := 0;
-
- GENERIC
- TYPE S IS ( <> );
- TYPE T IS PRIVATE;
- TYPE U IS RANGE <> ;
- VT : T;
- PACKAGE PKG IS
- PROCEDURE P1 (X : S);
- PRIVATE
- PROCEDURE P1 (X : T);
- VS : S := S'FIRST;
- VU : U := U'FIRST;
- END PKG;
-
- GENERIC
- TYPE S IS (<>);
- TYPE T IS RANGE <>;
- PACKAGE PP IS
- PROCEDURE P1 (D: S);
- PROCEDURE P1 (X: T);
- END PP;
-
- PACKAGE BODY PKG IS
- PROCEDURE P1 (X : S) IS
- BEGIN
- C := C + 1;
- END P1;
- PROCEDURE P1 (X : T) IS
- BEGIN
- C := C + 2;
- END P1;
- PROCEDURE P1 (X : U) IS
- BEGIN
- C := C + 4;
- END P1;
- BEGIN
- C := 0;
- P1 (VS);
- IF C /= IDENT_INT (1) THEN
- FAILED ("WRONG P1 CALLED -S");
- END IF;
- C := 0;
- P1 (VT);
- IF C /= IDENT_INT (2) THEN
- FAILED ("WRONG P1 CALLED -T");
- END IF;
- C := 0;
- P1 (VU);
- IF C /= IDENT_INT (4) THEN
- FAILED ("WRONG P1 CALLED -U");
- END IF;
- C := 0;
- END PKG;
-
- PACKAGE BODY PP IS
- PROCEDURE P1 (D: S) IS
- BEGIN
- C := C + 3;
- END P1;
- PROCEDURE P1 (X: T) IS
- BEGIN
- C := C + 5;
- END P1;
- BEGIN
- NULL;
- END PP;
-
- PACKAGE NP IS NEW PKG (INTEGER, INTEGER, INTEGER, 7);
- PACKAGE NPP IS NEW PP (INTEGER, INTEGER);
- BEGIN
- NP.P1 (4);
- IF C /= IDENT_INT (1) THEN
- FAILED ("INCORRECT OVERLOADING ON FORMAL TYPES");
- END IF;
- C := 0;
- NPP.P1 (D => 3);
- IF C /= IDENT_INT (3) THEN
- FAILED ("INCORRECT CALL TO P1 WITH D PARAMETER");
- END IF;
- C := 0;
- NPP.P1 (X => 7);
- IF C /= IDENT_INT (5) THEN
- FAILED ("INCORRECT CALL TO P1 WITH X PARAMETER");
- END IF;
- END;
-
- RESULT;
-END CC3011A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada
deleted file mode 100644
index 26dfde2..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CC3011D.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 A GENERIC PACKAGE INSTANTIATION CONTAINS DECLARATIONS
--- OF SUBPROGRAMS WITH THE SAME SPECIFICATIONS, THE CALLS TO THE
--- SUBPROGRAMS ARE NOT AMBIGIOUS WITHIN THE GENERIC BODY.
-
--- SPS 5/7/82
--- SPS 2/7/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3011D IS
-BEGIN
- TEST ("CC3011D", "SUBPROGRAMS WITH SAME SPECIFICATIONS NOT"
- & " AMBIGIOUS WITHIN GENERIC BODY");
-
- DECLARE
- TYPE FLAG IS (PRT,PRS);
- XX : FLAG;
-
- GENERIC
- TYPE S IS PRIVATE;
- TYPE T IS PRIVATE;
- V1 : S;
- V2 : T;
- PACKAGE P1 IS
- PROCEDURE PR(X : S);
- PROCEDURE PR(X : T);
- END P1;
-
- PACKAGE BODY P1 IS
- PROCEDURE PR (X : S) IS
- BEGIN
- XX := PRS;
- END;
-
- PROCEDURE PR (X : T ) IS
- BEGIN
- XX := PRT;
- END;
-
- BEGIN
- XX := PRT;
- PR (V1);
- IF XX /= PRS THEN
- FAILED ("WRONG BINDING FOR PR WITH TYPE S");
- END IF;
- XX := PRS;
- PR (V2);
- IF XX /= PRT THEN
- FAILED ("WRONG BINDING FOR PR WITH TYPE T");
- END IF;
- END P1;
-
- PACKAGE PAK IS NEW P1 (INTEGER, INTEGER, 1, 2);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3011D;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada
deleted file mode 100644
index da46501..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada
+++ /dev/null
@@ -1,247 +0,0 @@
--- CC3012A.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 GENERIC INSTANCES MAY BE OVERLOADED.
-
--- CHECK THAT THEY MAY OVERLOAD PREVIOUSLY DECLARED SUBPROGRAMS AND
--- ENUMERATION LITERALS.
-
--- DAT 9/16/81
--- SPS 10/19/82
--- SPS 2/8/83
--- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3012A IS
-BEGIN
- TEST ("CC3012A", "CHECK THAT GENERIC INSTANCES MAY OVERLOAD " &
- "OTHER IDENTIFIERS");
-
- DECLARE
- GENERIC
- TYPE T IS ( <> );
- V : IN T;
- PROCEDURE GP (X : IN OUT T);
-
- GENERIC
- TYPE T IS ( <> );
- FUNCTION LESS (X, Y : T) RETURN BOOLEAN;
-
- GENERIC
- TYPE T IS ( <> );
- FUNCTION PLUS (X, Y : T) RETURN T;
-
- GENERIC
- TYPE T IS PRIVATE;
- Z : T;
- FUNCTION F1 RETURN T;
-
- TYPE DC IS NEW CHARACTER RANGE IDENT_CHAR ('A') .. 'Z';
- TYPE DI IS NEW INTEGER;
- TYPE ENUM IS (E1, E2, E3, E4);
-
- VC : CHARACTER := 'A';
- VI : INTEGER := 5;
- VB : BOOLEAN := TRUE;
- VE : ENUM := E2;
-
- TYPE DENUM IS NEW ENUM RANGE E2 .. ENUM'LAST;
-
- VDE : DENUM := E4;
- VDC : DC := 'A';
- VDI : DI := 7;
-
- PROCEDURE GP (X : IN OUT T) IS
- BEGIN
- X := V;
- END GP;
-
- FUNCTION LESS (X, Y : T) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END LESS;
-
- FUNCTION PLUS (X, Y : T) RETURN T IS
- BEGIN
- RETURN T'FIRST;
- END PLUS;
-
- FUNCTION F1 RETURN T IS
- BEGIN
- RETURN Z;
- END F1;
-
- FUNCTION E5 RETURN INTEGER IS
- BEGIN
- RETURN 1;
- END E5;
-
- PACKAGE PKG IS
-
- PROCEDURE P IS NEW GP (CHARACTER, 'Q');
- PROCEDURE P IS NEW GP (INTEGER, -14);
- PROCEDURE P IS NEW GP (BOOLEAN, FALSE);
- PROCEDURE P IS NEW GP (ENUM, E4);
- PROCEDURE P IS NEW GP (DC, 'W');
- PROCEDURE P IS NEW GP (DI, -33);
- PROCEDURE P IS NEW GP (DENUM, E2);
-
- FUNCTION "<" IS NEW LESS (CHARACTER);
- FUNCTION "<" IS NEW LESS (INTEGER);
- FUNCTION "<" IS NEW LESS (BOOLEAN);
- FUNCTION "<" IS NEW LESS (ENUM);
- FUNCTION "<" IS NEW LESS (DC);
- FUNCTION "<" IS NEW LESS (DI);
- -- NOT FOR DENUM.
-
- FUNCTION "+" IS NEW PLUS (CHARACTER);
- FUNCTION "+" IS NEW PLUS (INTEGER);
- FUNCTION "+" IS NEW PLUS (BOOLEAN);
- FUNCTION "+" IS NEW PLUS (ENUM);
- FUNCTION "+" IS NEW PLUS (DC);
- -- NOT FOR DI.
- FUNCTION "+" IS NEW PLUS (DENUM);
-
- FUNCTION E2 IS NEW F1 (BOOLEAN, FALSE);
- FUNCTION E5 IS NEW F1 (DC, 'M');
-
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- P (VC);
- P (VI);
- P (VB);
- P (VE);
- P (X => VDE);
- P (X => VDC);
- P (X => VDI);
-
- IF VC /= 'Q' THEN
- FAILED ("OVERLOADED PROCEDURE - 1");
- END IF;
-
- IF VI /= -14 THEN
- FAILED ("OVERLOADED PROCEDURE - 2");
- END IF;
-
- IF VB /= FALSE THEN
- FAILED ("OVERLOADED PROCEDURE - 3");
- END IF;
-
- IF VE /= E4 THEN
- FAILED ("OVERLOADED PROCEDURE - 4");
- END IF;
-
- IF VDE /= E2 THEN
- FAILED ("OVERLOADED PROCEDURE - 5");
- END IF;
-
- IF VDC /= 'W' THEN
- FAILED ("OVERLOADED PROCEDURE - 6");
- END IF;
-
- IF VDI /= -33 THEN
- FAILED ("OVERLOADED PROCEDURE - 7");
- END IF;
-
- IF VC < ASCII.DEL THEN
- FAILED ("OVERLOADED LESS THAN - 1");
- END IF;
-
- IF VI < 1E3 THEN
- FAILED ("OVERLOADED LESS THAN - 2");
- END IF;
-
- IF FALSE < TRUE THEN
- FAILED ("OVERLOADED LESS THAN - 3");
- END IF;
-
- IF E1 < VE THEN
- FAILED ("OVERLOADED LESS THAN - 4");
- END IF;
-
- IF VDC < 'Z' THEN
- FAILED ("OVERLOADED LESS THAN - 5");
- END IF;
-
- IF VDI < 0 THEN
- FAILED ("OVERLOADED LESS THAN - 6");
- END IF;
-
-
- IF -14 + 5 /= -9 THEN
- FAILED ("OVERLOADED PLUS - 2");
- END IF;
-
- IF VI + 5 /= INTEGER'FIRST THEN
- FAILED ("OVERLOADED PLUS - 3");
- END IF;
-
- IF VB + TRUE /= FALSE THEN
- FAILED ("OVERLOADED PLUS - 4");
- END IF;
-
- IF VE + E2 /= E1 THEN
- FAILED ("OVERLOADED PLUS - 5");
- END IF;
-
- IF DENUM'(E3) + E2 /= E2 THEN
- FAILED ("OVERLOADED PLUS - 6");
- END IF;
-
- IF VDC + 'B' /= 'A' THEN
- FAILED ("OVERLOADED PLUS - 7");
- END IF;
-
- IF VDI + 14 /= -19 THEN -- -33 + 14
- FAILED ("OVERLOADED PLUS - 8");
- END IF;
-
- VI := E5;
- VDC := E5;
- VE := E2;
- VB := E2;
- IF VI /= 1 OR
- VDC /= 'M' OR
- VE /= ENUM'VAL(IDENT_INT(1)) OR
- VB /= FALSE THEN
- FAILED ("OVERLOADING OF ENUMERATION LITERALS " &
- "AND PREDEFINED SUBPROGRAMS");
- END IF;
- END PKG;
- BEGIN
- DECLARE
- USE PKG;
- BEGIN
- IF NOT (VI + 5 < 11) THEN
- FAILED ("INCORRECT VISIBILITY OF GENERIC OVERLOADING");
- END IF;
- END;
- END;
-
- RESULT;
-END CC3012A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada
deleted file mode 100644
index ca3543c..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CC3015A.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 A GENERIC PACKAGE INSTANTIATION IS ELABORATED,
--- STATEMENTS IN ITS PACKAGE BODY ARE EXECUTED AND EXPRESSIONS
--- REQUIRING EVALUATION ARE EVALUATED (E.G., DEFAULTS FOR OBJECT
--- DECLARATIONS ARE EVALUATED).
-
--- RJW 6/11/86
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3015A IS
- BOOL1, BOOL2 : BOOLEAN := FALSE;
-
- TYPE ENUM IS (BEFORE, AFTER);
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- BOOL2 := TRUE;
- RETURN I;
- END;
-
- FUNCTION CHECK (E : ENUM) RETURN CHARACTER IS
- BEGIN
- IF E = BEFORE THEN
- IF BOOL1 THEN
- FAILED ( "STATEMENT EXECUTED BEFORE " &
- "INSTANTIATION" );
- END IF;
- IF BOOL2 THEN
- FAILED ( "DEFAULT EXPRESSION EVALUATED " &
- "BEFORE INSTANTIATION" );
- END IF;
- ELSE
- IF BOOL1 THEN
- NULL;
- ELSE
- FAILED ( "STATEMENT NOT EXECUTED AT " &
- "INSTANTIATION" );
- END IF;
- IF BOOL2 THEN
- NULL;
- ELSE
- FAILED ( "DEFAULT EXPRESSION NOT EVALUATED " &
- "AT INSTANTIATION" );
- END IF;
- END IF;
- RETURN 'A';
- END;
-
- GENERIC
- TYPE INT IS RANGE <>;
- PACKAGE PKG IS END PKG;
-
- PACKAGE BODY PKG IS
- I : INT := INT'VAL (F(0));
- BEGIN
- BOOL1 := TRUE;
- END;
-
-BEGIN
- TEST ("CC3015A", "CHECK THAT WHEN A GENERIC PACKAGE " &
- "INSTANTIATION IS ELABORATED, STATEMENTS " &
- "IN ITS PACKAGE BODY ARE EXECUTED AND " &
- "EXPRESSIONS REQUIRING EVALUATION ARE " &
- "EVALUATED (E.G., DEFAULTS FOR OBJECT " &
- "DECLARATIONS ARE EVALUATED)" );
-
-
- DECLARE
- A : CHARACTER := CHECK (BEFORE);
-
- PACKAGE NPKG IS NEW PKG (INTEGER);
-
- B : CHARACTER := CHECK (AFTER);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3015A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada
deleted file mode 100644
index 2fbc090..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada
+++ /dev/null
@@ -1,396 +0,0 @@
--- CC3016B.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 INSTANCE OF A GENERIC PACKAGE MUST DECLARE A
--- PACKAGE. CHECK THAT THE DECLARATIVE ITEMS IN AN INSTANTIATION
--- OF A GENERIC PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER
--- DECLARED.
-
--- HISTORY:
--- EDWARD V. BERARD, 8 AUGUST 1990
-
-WITH REPORT ;
-
-PROCEDURE CC3016B IS
-
- WHEN_ELABORATED : NATURAL := 0 ;
-
- TYPE REAL IS DIGITS 6 ;
- REAL_VALUE : REAL := 3.14159 ;
-
- TRUE_VALUE : BOOLEAN := TRUE ;
-
- CHARACTER_VALUE : CHARACTER := 'Z' ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TYPE DATE_ACCESS IS ACCESS DATE ;
-
- THIS_MONTH : MONTH_TYPE := AUG ;
- THIS_YEAR : YEAR_TYPE := 1990 ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 8,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE_ACCESS := NEW DATE'(DAY => 6,
- MONTH => JUN,
- YEAR => 1967) ;
-
- TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE ;
- REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990),
- (MAR, 23, 1990), (APR, 23, 1990),
- (MAY, 23, 1990), (JUN, 22, 1990),
- (JUL, 23, 1990), (AUG, 23, 1990),
- (SEP, 24, 1990), (OCT, 23, 1990),
- (NOV, 23, 1990), (DEC, 20, 1990)) ;
-
- TYPE LIST_INDEX IS RANGE 1 .. 16 ;
- TYPE LIST IS ARRAY (LIST_INDEX) OF NATURAL ;
- ORDER_LIST : LIST := (OTHERS => 0) ;
-
- GENERIC
-
- TYPE RETURN_TYPE IS PRIVATE ;
- RETURN_VALUE : IN OUT RETURN_TYPE ;
- POSITION : IN NATURAL ;
- OFFSET : IN NATURAL ;
- WHEN_ELAB : IN OUT NATURAL ;
- TYPE INDEX IS RANGE <> ;
- TYPE LIST IS ARRAY (INDEX) OF NATURAL ;
- ORDER_LIST : IN OUT LIST ;
-
- FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE ;
-
- FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE IS
-
- BEGIN -- NAME
-
- IF (VALUE = POSITION) THEN
- WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ;
- ORDER_LIST (INDEX (POSITION)) := WHEN_ELAB ;
- RETURN RETURN_VALUE ;
- ELSIF (VALUE = (POSITION + OFFSET)) THEN
- WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ;
- ORDER_LIST (INDEX (POSITION + OFFSET)) := WHEN_ELAB ;
- RETURN RETURN_VALUE ;
- END IF ;
-
- END NAME ;
-
- GENERIC
-
- TYPE FIRST_TYPE IS PRIVATE ;
- WITH FUNCTION FIRST (POSITION : IN NATURAL)
- RETURN FIRST_TYPE ;
- FIRST_VALUE : IN NATURAL ;
- TYPE SECOND_TYPE IS PRIVATE ;
- WITH FUNCTION SECOND (POSITION : IN NATURAL)
- RETURN SECOND_TYPE ;
- SECOND_VALUE : IN NATURAL ;
- TYPE THIRD_TYPE IS PRIVATE ;
- WITH FUNCTION THIRD (POSITION : IN NATURAL)
- RETURN THIRD_TYPE ;
- THIRD_VALUE : IN NATURAL ;
- TYPE FOURTH_TYPE IS PRIVATE ;
- WITH FUNCTION FOURTH (POSITION : IN NATURAL)
- RETURN FOURTH_TYPE ;
- FOURTH_VALUE : IN NATURAL ;
- TYPE FIFTH_TYPE IS PRIVATE ;
- WITH FUNCTION FIFTH (POSITION : IN NATURAL)
- RETURN FIFTH_TYPE ;
- FIFTH_VALUE : IN NATURAL ;
- TYPE SIXTH_TYPE IS PRIVATE ;
- WITH FUNCTION SIXTH (POSITION : IN NATURAL)
- RETURN SIXTH_TYPE ;
- SIXTH_VALUE : IN NATURAL ;
- TYPE SEVENTH_TYPE IS PRIVATE ;
- WITH FUNCTION SEVENTH (POSITION : IN NATURAL)
- RETURN SEVENTH_TYPE ;
- SEVENTH_VALUE : IN NATURAL ;
- TYPE EIGHTH_TYPE IS PRIVATE ;
- WITH FUNCTION EIGHTH (POSITION : IN NATURAL)
- RETURN EIGHTH_TYPE ;
- EIGHTH_VALUE : IN NATURAL ;
- TYPE NINTH_TYPE IS PRIVATE ;
- WITH FUNCTION NINTH (POSITION : IN NATURAL)
- RETURN NINTH_TYPE ;
- NINTH_VALUE : IN NATURAL ;
- TYPE TENTH_TYPE IS PRIVATE ;
- WITH FUNCTION TENTH (POSITION : IN NATURAL)
- RETURN TENTH_TYPE ;
- TENTH_VALUE : IN NATURAL ;
- TYPE ELEVENTH_TYPE IS PRIVATE ;
- WITH FUNCTION ELEVENTH (POSITION : IN NATURAL)
- RETURN ELEVENTH_TYPE ;
- ELEVENTH_VALUE : IN NATURAL ;
- TYPE TWELFTH_TYPE IS PRIVATE ;
- WITH FUNCTION TWELFTH (POSITION : IN NATURAL)
- RETURN TWELFTH_TYPE ;
- TWELFTH_VALUE : IN NATURAL ;
- TYPE THIRTEENTH_TYPE IS PRIVATE ;
- WITH FUNCTION THIRTEENTH (POSITION : IN NATURAL)
- RETURN THIRTEENTH_TYPE ;
- THIRTEENTH_VALUE : IN NATURAL ;
- TYPE FOURTEENTH_TYPE IS PRIVATE ;
- WITH FUNCTION FOURTEENTH (POSITION : IN NATURAL)
- RETURN FOURTEENTH_TYPE ;
- FOURTEENTH_VALUE : IN NATURAL ;
- TYPE FIFTEENTH_TYPE IS PRIVATE ;
- WITH FUNCTION FIFTEENTH (POSITION : IN NATURAL)
- RETURN FIFTEENTH_TYPE ;
- FIFTEENTH_VALUE : IN NATURAL ;
- TYPE SIXTEENTH_TYPE IS PRIVATE ;
- WITH FUNCTION SIXTEENTH (POSITION : IN NATURAL)
- RETURN SIXTEENTH_TYPE ;
- SIXTEENTH_VALUE : IN NATURAL ;
-
- PACKAGE ORDER_PACKAGE IS
-
- A : FIRST_TYPE := FIRST (FIRST_VALUE) ;
- B : SECOND_TYPE := SECOND (SECOND_VALUE) ;
- C : THIRD_TYPE := THIRD (THIRD_VALUE) ;
- D : FOURTH_TYPE := FOURTH (FOURTH_VALUE) ;
- E : FIFTH_TYPE := FIFTH (FIFTH_VALUE) ;
- F : SIXTH_TYPE := SIXTH (SIXTH_VALUE) ;
- G : SEVENTH_TYPE := SEVENTH (SEVENTH_VALUE) ;
- H : EIGHTH_TYPE := EIGHTH (EIGHTH_VALUE) ;
- I : NINTH_TYPE := NINTH (NINTH_VALUE) ;
- J : TENTH_TYPE := TENTH (TENTH_VALUE) ;
- K : ELEVENTH_TYPE := ELEVENTH (ELEVENTH_VALUE) ;
- L : TWELFTH_TYPE := TWELFTH (TWELFTH_VALUE) ;
- M : THIRTEENTH_TYPE := THIRTEENTH (THIRTEENTH_VALUE) ;
- N : FOURTEENTH_TYPE := FOURTEENTH (FOURTEENTH_VALUE) ;
- O : FIFTEENTH_TYPE := FIFTEENTH (FIFTEENTH_VALUE) ;
- P : SIXTEENTH_TYPE := SIXTEENTH (SIXTEENTH_VALUE) ;
-
- END ORDER_PACKAGE ;
-
-
- FUNCTION BOOL IS NEW NAME (RETURN_TYPE => BOOLEAN,
- RETURN_VALUE => TRUE_VALUE,
- POSITION => 1,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- FUNCTION INT IS NEW NAME (RETURN_TYPE => YEAR_TYPE,
- RETURN_VALUE => THIS_YEAR,
- POSITION => 2,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- FUNCTION FLOAT IS NEW NAME (RETURN_TYPE => REAL,
- RETURN_VALUE => REAL_VALUE,
- POSITION => 3,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- FUNCTION CHAR IS NEW NAME (RETURN_TYPE => CHARACTER,
- RETURN_VALUE => CHARACTER_VALUE,
- POSITION => 4,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- FUNCTION ENUM IS NEW NAME (RETURN_TYPE => MONTH_TYPE,
- RETURN_VALUE => THIS_MONTH,
- POSITION => 5,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- FUNCTION ARRY IS NEW NAME (RETURN_TYPE => DUE_DATES,
- RETURN_VALUE => REPORT_DATES,
- POSITION => 6,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
-
- FUNCTION RCRD IS NEW NAME (RETURN_TYPE => DATE,
- RETURN_VALUE => TODAY,
- POSITION => 7,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
-
- FUNCTION ACSS IS NEW NAME (RETURN_TYPE => DATE_ACCESS,
- RETURN_VALUE => FIRST_DATE,
- POSITION => 8,
- OFFSET => 8,
- WHEN_ELAB => WHEN_ELABORATED,
- INDEX => LIST_INDEX,
- LIST => LIST,
- ORDER_LIST => ORDER_LIST) ;
-
- PACKAGE ELABORATION_ORDER IS NEW ORDER_PACKAGE
- (FIRST_TYPE => BOOLEAN,
- FIRST => BOOL,
- FIRST_VALUE => 1,
- THIRD_TYPE => REAL,
- THIRD => FLOAT,
- THIRD_VALUE => 3,
- SECOND_TYPE => YEAR_TYPE, -- ORDERING OF PARAMETERS
- SECOND => INT, -- IS DELIBERATE.
- SECOND_VALUE => 2,
- FOURTH_TYPE => CHARACTER,
- FOURTH => CHAR,
- FOURTH_VALUE => 4,
- FIFTH_TYPE => MONTH_TYPE,
- FIFTH => ENUM,
- FIFTH_VALUE => 5,
- SIXTH_TYPE => DUE_DATES,
- SIXTH => ARRY,
- SIXTH_VALUE => 6,
- SEVENTH_TYPE => DATE,
- SEVENTH => RCRD,
- SEVENTH_VALUE => 7,
- EIGHTH_TYPE => DATE_ACCESS,
- EIGHTH => ACSS,
- EIGHTH_VALUE => 8,
- NINTH_TYPE => BOOLEAN,
- NINTH => BOOL,
- NINTH_VALUE => 9,
- TENTH_TYPE => YEAR_TYPE,
- TENTH => INT,
- TENTH_VALUE => 10,
- ELEVENTH_TYPE => REAL,
- ELEVENTH => FLOAT,
- ELEVENTH_VALUE => 11,
- TWELFTH_TYPE => CHARACTER,
- TWELFTH => CHAR,
- TWELFTH_VALUE => 12,
- THIRTEENTH_TYPE => MONTH_TYPE,
- THIRTEENTH => ENUM,
- THIRTEENTH_VALUE => 13,
- FOURTEENTH_TYPE => DUE_DATES,
- FOURTEENTH => ARRY,
- FOURTEENTH_VALUE => 14,
- FIFTEENTH_TYPE => DATE,
- FIFTEENTH => RCRD,
- FIFTEENTH_VALUE => 15,
- SIXTEENTH_TYPE => DATE_ACCESS,
- SIXTEENTH => ACSS,
- SIXTEENTH_VALUE => 16) ;
-
-BEGIN
- REPORT.TEST("CC3016B", "CHECK THAT AN INSTANCE OF A GENERIC " &
- "PACKAGE MUST DECLARE A PACKAGE. CHECK THAT THE " &
- "DECLARATIVE ITEMS IN AN INSTANTIATION OF A GENERIC " &
- "PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER " &
- "DECLARED.");
-
- IF ORDER_LIST(1) /= REPORT.IDENT_INT(1) THEN
- REPORT.FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(2) /= REPORT.IDENT_INT(2) THEN
- REPORT.FAILED("INTEGER TYPE 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(3) /= REPORT.IDENT_INT(3) THEN
- REPORT.FAILED("REAL 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(4) /= REPORT.IDENT_INT(4) THEN
- REPORT.FAILED("CHARACTER 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(5) /= REPORT.IDENT_INT(5) THEN
- REPORT.FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(6) /= REPORT.IDENT_INT(6) THEN
- REPORT.FAILED("ARRAY 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(7) /= REPORT.IDENT_INT(7) THEN
- REPORT.FAILED("RECORD 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(8) /= REPORT.IDENT_INT(8) THEN
- REPORT.FAILED("ACCESS 1 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(9) /= REPORT.IDENT_INT(9) THEN
- REPORT.FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(10) /= REPORT.IDENT_INT(10) THEN
- REPORT.FAILED("INTEGER TYPE 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(11) /= REPORT.IDENT_INT(11) THEN
- REPORT.FAILED("REAL 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(12) /= REPORT.IDENT_INT(12) THEN
- REPORT.FAILED("CHARACTER 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(13) /= REPORT.IDENT_INT(13) THEN
- REPORT.FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(14) /= REPORT.IDENT_INT(14) THEN
- REPORT.FAILED("ARRAY 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(15) /= REPORT.IDENT_INT(15) THEN
- REPORT.FAILED("RECORD 2 ELABORATED OUT OF ORDER");
- END IF;
-
- IF ORDER_LIST(16) /= REPORT.IDENT_INT(16) THEN
- REPORT.FAILED("ACCESS 2 ELABORATED OUT OF ORDER");
- END IF;
-
- REPORT.RESULT ;
-
-END CC3016B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada
deleted file mode 100644
index 6376170..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada
+++ /dev/null
@@ -1,192 +0,0 @@
--- CC3016C.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 INSTANCE OF A GENERIC PACKAGE MUST DECLARE A
--- PACKAGE. CHECK THAT THE STATEMENTS IN AN INSTANTIATED GENERIC
--- PACKAGE BODY ARE EXECUTED AFTER THE ELABORATION OF THE
--- DECLARATIONS (IN SPEC AND IN BODY).
-
--- HISTORY:
--- EDWARD V. BERARD, 8 AUGUST 1990
-
-WITH REPORT;
-
-PROCEDURE CC3016C IS
-
- GENERIC
-
- TYPE SOME_TYPE IS PRIVATE ;
- FIRST_INITIAL_VALUE : IN SOME_TYPE ;
- SECOND_INITIAL_VALUE : IN SOME_TYPE ;
- WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ;
- RESULT : OUT SOME_TYPE) ;
- WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ;
- RESULT : OUT SOME_TYPE) ;
- WITH PROCEDURE THIRD_CHANGE (FIRST : IN SOME_TYPE ;
- RESULT : OUT SOME_TYPE) ;
- FIRST_EXPECTED_RESULT : IN SOME_TYPE ;
- SECOND_EXPECTED_RESULT : IN SOME_TYPE ;
- THIRD_EXPECTED_RESULT : IN SOME_TYPE ;
- FOURTH_EXPECTED_RESULT : IN SOME_TYPE ;
- FIFTH_EXPECTED_RESULT : IN SOME_TYPE ;
- SIXTH_EXPECTED_RESULT : IN SOME_TYPE ;
-
- PACKAGE OUTER IS
-
- VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ;
-
- FUNCTION INNER_VARIABLE RETURN SOME_TYPE ;
-
- GENERIC
-
- INITIAL_VALUE : IN SOME_TYPE ;
- WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ;
- RESULT : OUT SOME_TYPE) ;
- WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ;
- RESULT : OUT SOME_TYPE) ;
- FIRST_EXPECTED_RESULT : IN SOME_TYPE ;
- SECOND_EXPECTED_RESULT : IN SOME_TYPE ;
- THIRD_EXPECTED_RESULT : IN SOME_TYPE ;
- FOURTH_EXPECTED_RESULT : IN SOME_TYPE ;
-
- PACKAGE INNER IS
- VARIABLE : SOME_TYPE := INITIAL_VALUE ;
- END INNER ;
-
- END OUTER ;
-
-
- PACKAGE BODY OUTER IS
-
- ANOTHER_VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ;
-
- PACKAGE BODY INNER IS
- ANOTHER_VARIABLE : SOME_TYPE := INITIAL_VALUE ;
- BEGIN -- INNER
-
- CHANGE (FIRST => VARIABLE,
- RESULT => VARIABLE) ;
- CHANGE (FIRST => ANOTHER_VARIABLE,
- RESULT => ANOTHER_VARIABLE) ;
- OUTER.SECOND_CHANGE (FIRST => OUTER.VARIABLE,
- RESULT => OUTER.VARIABLE) ;
- OUTER.CHANGE (FIRST => OUTER.ANOTHER_VARIABLE,
- RESULT => OUTER.ANOTHER_VARIABLE) ;
-
- IF (VARIABLE /= FIRST_EXPECTED_RESULT) OR
- (ANOTHER_VARIABLE /= SECOND_EXPECTED_RESULT) OR
- (OUTER.VARIABLE
- /= THIRD_EXPECTED_RESULT) OR
- (OUTER.ANOTHER_VARIABLE
- /= FOURTH_EXPECTED_RESULT) THEN
- REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF INNER") ;
- END IF;
-
- END INNER ;
-
- PACKAGE NEW_INNER IS NEW INNER
- (INITIAL_VALUE => SECOND_INITIAL_VALUE,
- CHANGE => CHANGE,
- SECOND_CHANGE => THIRD_CHANGE,
- FIRST_EXPECTED_RESULT => FIRST_EXPECTED_RESULT,
- SECOND_EXPECTED_RESULT => SECOND_EXPECTED_RESULT,
- THIRD_EXPECTED_RESULT => THIRD_EXPECTED_RESULT,
- FOURTH_EXPECTED_RESULT => FOURTH_EXPECTED_RESULT) ;
-
- FUNCTION INNER_VARIABLE RETURN SOME_TYPE IS
- BEGIN
- RETURN NEW_INNER.VARIABLE ;
- END INNER_VARIABLE ;
-
- BEGIN -- OUTER
-
- SECOND_CHANGE (FIRST => VARIABLE,
- RESULT => VARIABLE) ;
- SECOND_CHANGE (FIRST => ANOTHER_VARIABLE,
- RESULT => ANOTHER_VARIABLE) ;
-
- IF (VARIABLE /= FIFTH_EXPECTED_RESULT) OR
- (ANOTHER_VARIABLE /= SIXTH_EXPECTED_RESULT) OR
- (NEW_INNER.VARIABLE /= FIRST_EXPECTED_RESULT) THEN
- REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF OUTER") ;
- END IF;
-
- END OUTER ;
-
- PROCEDURE DOUBLE (THIS_VALUE : IN INTEGER;
- GIVING_THIS_RESULT : OUT INTEGER) IS
- BEGIN -- DOUBLE
- GIVING_THIS_RESULT := 2 * THIS_VALUE ;
- END DOUBLE ;
-
- PROCEDURE ADD_20 (TO_THIS_VALUE : IN INTEGER;
- GIVING_THIS_RESULT : OUT INTEGER) IS
- BEGIN -- ADD_20
- GIVING_THIS_RESULT := TO_THIS_VALUE + 20 ;
- END ADD_20 ;
-
- PROCEDURE TIMES_FIVE (THIS_VALUE : IN INTEGER;
- GIVING_THIS_RESULT : OUT INTEGER) IS
- BEGIN -- TIMES_FIVE
- GIVING_THIS_RESULT := 5 * THIS_VALUE ;
- END TIMES_FIVE ;
-
-BEGIN -- CC3016C
-
- REPORT.TEST ("CC3016C" , "CHECK THAT AN INSTANCE OF A GENERIC PACKAGE " &
- "MUST DECLARE A PACKAGE. CHECK THAT THE STATEMENTS IN AN " &
- "INSTANTIATED GENERIC PACKAGE BODY ARE EXECUTED AFTER THE " &
- "ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY).") ;
-
- LOCAL_BLOCK:
-
- DECLARE
-
- PACKAGE NEW_OUTER IS NEW OUTER
- (SOME_TYPE => INTEGER,
- FIRST_INITIAL_VALUE => 7,
- SECOND_INITIAL_VALUE => 11,
- CHANGE => DOUBLE,
- SECOND_CHANGE => ADD_20,
- THIRD_CHANGE => TIMES_FIVE,
- FIRST_EXPECTED_RESULT => 22,
- SECOND_EXPECTED_RESULT => 22,
- THIRD_EXPECTED_RESULT => 27,
- FOURTH_EXPECTED_RESULT => 14,
- FIFTH_EXPECTED_RESULT => 47,
- SIXTH_EXPECTED_RESULT => 34) ;
-
- BEGIN -- LOCAL_BLOCK
-
- IF (NEW_OUTER.VARIABLE /= 47) OR
- (NEW_OUTER.INNER_VARIABLE /= 22) THEN
- REPORT.FAILED("ASSIGNED VALUES INCORRECT - " &
- "BODY OF MAIN PROGRAM") ;
- END IF;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT;
-
-END CC3016C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada
deleted file mode 100644
index ef94672..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada
+++ /dev/null
@@ -1,186 +0,0 @@
--- CC3016F.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 INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED
--- OF A PACKAGE.
-
--- CHECK THAT IF THE PARENT TYPE IN A DERIVED TYPE DEFINITION IS
--- A GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE DERIVED
--- TYPE IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE
--- FORMAL TYPE. THE OPERATIONS DECLARED FOR DERIVED TYPE IN THE
--- INSTANCE ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL
--- PARAMETER. SEE AI-00398.
-
--- HISTORY:
--- DAS 8 OCT 90 INITIAL VERSION.
--- JRL 02/19/93 ADDED USE CLAUSES FOR INSTANCES TO ENSURE DIRECT
--- OPERATOR VISIBILITY. CHANGED NT4'LAST TO P4.NT4'LAST
--- IN ASSIGNMENT STATEMENT FOR P4.X IN EXAMPLE_4.
--- CORRECTED ABE ERRORS IN EXAMPLE_2 AND EXAMPLE_3.
--- CHANGED R3."+" FROM MULTIPLICATION TO SUBTRACTION TO
--- AVOID CONSTRAINT_ERROR.
-
-WITH REPORT;
-
-PROCEDURE CC3016F IS
-BEGIN
- REPORT.TEST ("CC3016F", "CHECK THAT IF THE PARENT TYPE IN A " &
- "DERIVED TYPE DEFINITION IS A GENERIC " &
- "FORMAL TYPE, THE OPERATIONS DECLARED " &
- "FOR THE DERIVED TYPE IN THE TEMPLATE " &
- "ARE DETERMINED BY THE DECLARATION OF " &
- "THE FORMAL TYPE, AND THAT THE " &
- "OPERATIONS DECLARED FOR THE DERIVED " &
- "TYPE IN THE INSTANCE ARE DETERMINED BY " &
- "THE ACTUAL TYPE DENOTED BY THE FORMAL " &
- "PARAMETER (AI-00398)");
-EXAMPLE_2:
- DECLARE
- GENERIC
- TYPE PRIV IS PRIVATE;
- PACKAGE GP2 IS
- TYPE NT2 IS NEW PRIV;
- END GP2;
-
- PACKAGE R2 IS
- TYPE T2 IS RANGE 1..10;
- FUNCTION F RETURN T2;
- END R2;
-
- PACKAGE P2 IS NEW GP2 (PRIV => R2.T2);
- USE P2;
-
- XX1 : P2.NT2;
- XX2 : P2.NT2;
- XX3 : P2.NT2;
-
- PACKAGE BODY R2 IS
- FUNCTION F RETURN T2 IS
- BEGIN
- RETURN T2'LAST;
- END F;
- END R2;
- BEGIN
- XX1 := 5; -- IMPLICIT CONVERSION FROM
- -- UNIVERSAL INTEGER TO P2.NT2
- -- IN P2.
- XX2 := XX1 + XX1; -- PREDEFINED "+" DECLARED FOR
- -- P2.NT2.
- XX3 := P2.F; -- FUNCTION F DERIVED WITH THE
- -- INSTANCE.
-
- END EXAMPLE_2;
-
-EXAMPLE_3:
- DECLARE
- GENERIC
- TYPE T3 IS RANGE <>;
- PACKAGE GP3 IS
- TYPE NT3 IS NEW T3;
- X : NT3 := 5;
- Y : NT3 := X + 3; -- USES PREDEFINED "+" EVEN IN
- -- INSTANCES
- END GP3;
-
- PACKAGE R3 IS
- TYPE S IS RANGE 1..10;
- FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S;
- END R3;
-
- PACKAGE P3 IS NEW GP3 ( T3 => R3.S );
- USE P3;
-
- Z : P3.NT3;
-
- PACKAGE BODY R3 IS
- FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S IS
- BEGIN -- IMPLEMENT AS SUBTRACTION, NOT ADDITION
- RETURN LEFT - RIGHT;
- END "+";
- END R3;
- BEGIN
- Z := P3.X + 3; -- USES REDEFINED "+"
-
- IF ( P3.Y /= P3.NT3'(8) ) THEN
- REPORT.FAILED ("PREDEFINED ""+"" NOT USED TO COMPUTE " &
- "P3.Y");
- END IF;
-
- IF (Z /= P3.NT3'(2) ) THEN
- REPORT.FAILED ("REDEFINED ""+"" NOT USED TO COMPUTE Z");
- END IF;
- END EXAMPLE_3;
-
-EXAMPLE_4:
- DECLARE
- GENERIC
- TYPE T4 IS LIMITED PRIVATE;
- PACKAGE GP4 IS
- TYPE NT4 IS NEW T4;
- X : NT4;
- END GP4;
-
- PACKAGE P4 IS NEW GP4 (BOOLEAN);
- USE P4;
-
- BEGIN
- P4.X := P4.NT4'LAST;
- IF ( P4.X OR (NOT P4.X) ) THEN
- REPORT.COMMENT ("P4.X CORRECTLY HAS A BOOLEAN TYPE");
- END IF;
- END EXAMPLE_4;
-
-EXAMPLE_5:
- DECLARE
- GENERIC
- TYPE T5 (D : POSITIVE) IS PRIVATE;
- PACKAGE GP5 IS
- TYPE NT5 IS NEW T5;
- X : NT5 (D => 5);
- Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5
- END GP5;
-
- TYPE REC (A : POSITIVE) IS
- RECORD
- D : POSITIVE := 7;
- END RECORD;
- PACKAGE P5 IS NEW GP5 (T5 => REC);
- -- P5.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION
- -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE
- -- T5 WHICH DENOTES REC.
-
- W1 : POSITIVE := P5.X.D; -- VALUE IS 7
- W2 : POSITIVE := P5.X.A; -- VALUE IS 5
- W3 : POSITIVE := P5.Y; -- VALUE IS 5;
- BEGIN
- IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN
- REPORT.FAILED ("INCORRECT COMPONENT SELECTION");
- END IF;
- END EXAMPLE_5;
-
- REPORT.RESULT;
-
-END CC3016F;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada b/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada
deleted file mode 100644
index 933ec84..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CC3016I.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 INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED
--- OF A PACKAGE.
-
--- CHECK THAT IF THE DESIGNATED TYPE OF AN ACCESS TYPE IS A GENERIC
--- FORMAL TYPE, OR IS A TYPE DERIVED DIRECTLY OR INDIRECTLY FROM A
--- GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE ACCESS TYPE
--- IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE FORMAL
--- TYPE. THE OPERATIONS DECLARED FOR ACCESS TYPE IN THE INSTANCE
--- ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL PARAMETER.
--- SEE AI-00398.
-
--- HISTORY:
--- DAS 8 OCT 90 INITIAL VERSION.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3016I IS
-BEGIN
- TEST("CC3016I", "CHECK THAT AN INSTANTIATED PACKAGE HAS THE " &
- "PROPERTIES REQUIRED OF A PACKAGE.");
-
-EXAMPLE_5A:
- DECLARE
- GENERIC
- TYPE T5A (D : POSITIVE) IS PRIVATE;
- PACKAGE GP5A IS
- TYPE NT5A IS NEW T5A;
- X : NT5A (D => 5);
- Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5A
- END GP5A;
-
- TYPE REC (A : POSITIVE) IS
- RECORD
- D : POSITIVE := 7;
- END RECORD;
- PACKAGE P5A IS NEW GP5A (T5A => REC);
- -- P5A.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION
- -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE
- -- T5A WHICH DENOTES REC.
-
- W1 : POSITIVE := P5A.X.D; -- VALUE IS 7
- W2 : POSITIVE := P5A.X.A; -- VALUE IS 5
- W3 : POSITIVE := P5A.Y; -- VALUE IS 5;
- BEGIN
- IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN
- FAILED ("INCORRECT COMPONENT SELECTION - ACCESS");
- END IF;
- END EXAMPLE_5A;
-
- RESULT;
-
-END CC3016I;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada
deleted file mode 100644
index 0f8fcfd..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada
+++ /dev/null
@@ -1,470 +0,0 @@
--- CC3017B.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 INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A
--- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST
--- DECLARE A FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT RAISED
--- IF THE DEFAULT VALUE FOR A FORMAL PARAMETER DOES NOT SATISFY
--- THE CONSTRAINTS OF THE SUBTYPE_INDICATION WHEN THE
--- DECLARATION IS ELABORATED, ONLY WHEN THE DEFAULT IS USED.
-
--- SUBTESTS ARE:
--- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
--- INITIALIZED WITH A STATIC AGGREGATE.
--- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
--- INITIALIZED WITH A STATIC VALUE.
--- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
--- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
--- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--- WITH A STATIC AGGREGATE.
--- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
--- INITIALIZED WITH A STATIC AGGREGATE.
-
--- EDWARD V. BERARD, 7 AUGUST 1990
-
-WITH REPORT;
-
-PROCEDURE CC3017B IS
-
-BEGIN
-
- REPORT.TEST ("CC3017B", "CHECK THAT AN INSTANCE OF A GENERIC " &
- "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " &
- "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " &
- "FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT " &
- "RAISED IF AN INITIALIZATION VALUE DOES NOT SATISFY " &
- "CONSTRAINTS ON A FORMAL PARAMETER");
-
- --------------------------------------------------
-
- NONSTAT_ARRAY_PARMS:
-
- DECLARE
-
--- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
--- INITIALIZED WITH A STATIC AGGREGATE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE ;
-
- PROCEDURE PA (FIRST : IN INTEGER_TYPE ;
- SECOND : IN INTEGER_TYPE) ;
-
- PROCEDURE PA (FIRST : IN INTEGER_TYPE ;
- SECOND : IN INTEGER_TYPE) IS
-
- TYPE A1 IS ARRAY (INTEGER_TYPE RANGE LOWER .. FIRST,
- INTEGER_TYPE RANGE LOWER .. SECOND)
- OF INTEGER_TYPE;
-
- PROCEDURE PA1 (A : A1 := ((LOWER,UPPER),(UPPER,UPPER)))
- IS
- BEGIN
- REPORT.FAILED ("BODY OF PA1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN PA1");
- END PA1;
-
- BEGIN -- PA
- PA1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - PA1");
- END PA;
-
- PROCEDURE NEW_PA IS NEW PA (INTEGER_TYPE => NUMBER,
- LOWER => 1,
- UPPER => 50) ;
-
- BEGIN -- NONSTAT_ARRAY_PARMS
-
- NEW_PA (FIRST => NUMBER (25),
- SECOND => NUMBER (75));
-
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PA");
-
- END NONSTAT_ARRAY_PARMS ;
-
- --------------------------------------------------
-
- SCALAR_NON_STATIC:
-
- DECLARE
-
--- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
--- INITIALIZED WITH A STATIC VALUE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- STATIC_VALUE : IN INTEGER_TYPE ;
-
- PROCEDURE PB (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) ;
-
- PROCEDURE PB (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) IS
-
- SUBTYPE INT IS INTEGER_TYPE RANGE LOWER .. UPPER ;
-
- PROCEDURE PB1 (I : INT := STATIC_VALUE) IS
- BEGIN -- PB1
- REPORT.FAILED ("BODY OF PB1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN PB1");
- END PB1;
-
- BEGIN -- PB
- PB1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - PB1");
- END PB;
-
- PROCEDURE NEW_PB IS NEW PB (INTEGER_TYPE => NUMBER,
- STATIC_VALUE => 20) ;
-
- BEGIN -- SCALAR_NON_STATIC
-
- NEW_PB (LOWER => NUMBER (25),
- UPPER => NUMBER (75));
-
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PB");
- END SCALAR_NON_STATIC ;
-
- --------------------------------------------------
-
- REC_NON_STAT_COMPS:
-
- DECLARE
-
--- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
--- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- F_STATIC_VALUE : IN INTEGER_TYPE ;
- S_STATIC_VALUE : IN INTEGER_TYPE ;
- T_STATIC_VALUE : IN INTEGER_TYPE ;
- L_STATIC_VALUE : IN INTEGER_TYPE ;
-
- PROCEDURE PC (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) ;
-
- PROCEDURE PC (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) IS
-
- SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
- RANGE LOWER .. UPPER ;
- TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF
- SUBINTEGER_TYPE ;
- TYPE REC IS
- RECORD
- FIRST : SUBINTEGER_TYPE ;
- SECOND : AR1 ;
- END RECORD;
-
- PROCEDURE PC1 (R : REC := (F_STATIC_VALUE,
- (S_STATIC_VALUE,
- T_STATIC_VALUE,
- L_STATIC_VALUE))) IS
- BEGIN -- PC1
- REPORT.FAILED ("BODY OF PC1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN PC1");
- END PC1;
-
- BEGIN -- PC
- PC1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - PC1");
- END PC;
-
- PROCEDURE NEW_PC IS NEW PC (INTEGER_TYPE => NUMBER,
- F_STATIC_VALUE => 15,
- S_STATIC_VALUE => 19,
- T_STATIC_VALUE => 85,
- L_STATIC_VALUE => 99) ;
-
- BEGIN -- REC_NON_STAT_COMPS
- NEW_PC (LOWER => 20,
- UPPER => 80);
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PC");
- END REC_NON_STAT_COMPS ;
-
- --------------------------------------------------
-
- FIRST_STATIC_ARRAY:
-
- DECLARE
-
--- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--- WITH A STATIC AGGREGATE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- F_STATIC_VALUE : IN INTEGER_TYPE ;
- S_STATIC_VALUE : IN INTEGER_TYPE ;
- T_STATIC_VALUE : IN INTEGER_TYPE ;
- L_STATIC_VALUE : IN INTEGER_TYPE ;
- A_STATIC_VALUE : IN INTEGER_TYPE ;
- B_STATIC_VALUE : IN INTEGER_TYPE ;
- C_STATIC_VALUE : IN INTEGER_TYPE ;
- D_STATIC_VALUE : IN INTEGER_TYPE ;
-
- PROCEDURE P1D (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) ;
-
- PROCEDURE P1D (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) IS
-
- SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
- RANGE LOWER .. UPPER ;
-
- TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
- F_STATIC_VALUE .. S_STATIC_VALUE,
- INTEGER_TYPE RANGE
- T_STATIC_VALUE .. L_STATIC_VALUE)
- OF SUBINTEGER_TYPE ;
-
- PROCEDURE P1D1 (A : A1 :=
- ((A_STATIC_VALUE, B_STATIC_VALUE),
- (C_STATIC_VALUE, D_STATIC_VALUE))) IS
- BEGIN -- P1D1
- REPORT.FAILED ("BODY OF P1D1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN P1D1");
- END P1D1;
-
- BEGIN -- P1D
- P1D1 ;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - P1D1");
- END P1D;
-
- PROCEDURE NEW_P1D IS NEW P1D (INTEGER_TYPE => NUMBER,
- F_STATIC_VALUE => 21,
- S_STATIC_VALUE => 37,
- T_STATIC_VALUE => 67,
- L_STATIC_VALUE => 79,
- A_STATIC_VALUE => 11,
- B_STATIC_VALUE => 88,
- C_STATIC_VALUE => 87,
- D_STATIC_VALUE => 13) ;
-
- BEGIN -- FIRST_STATIC_ARRAY
- NEW_P1D (LOWER => 10,
- UPPER => 90);
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P1D");
- END FIRST_STATIC_ARRAY ;
-
- --------------------------------------------------
-
- SECOND_STATIC_ARRAY:
-
- DECLARE
-
--- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
--- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
--- WITH A STATIC AGGREGATE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- F_STATIC_VALUE : IN INTEGER_TYPE ;
- S_STATIC_VALUE : IN INTEGER_TYPE ;
- T_STATIC_VALUE : IN INTEGER_TYPE ;
- L_STATIC_VALUE : IN INTEGER_TYPE ;
- A_STATIC_VALUE : IN INTEGER_TYPE ;
- B_STATIC_VALUE : IN INTEGER_TYPE ;
-
- PROCEDURE P2D (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) ;
-
- PROCEDURE P2D (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) IS
-
- SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
- RANGE LOWER .. UPPER ;
-
- TYPE A1 IS ARRAY (INTEGER_TYPE RANGE
- F_STATIC_VALUE .. S_STATIC_VALUE,
- INTEGER_TYPE RANGE
- T_STATIC_VALUE .. L_STATIC_VALUE)
- OF SUBINTEGER_TYPE ;
-
- PROCEDURE P2D1 (A : A1 :=
- (F_STATIC_VALUE .. S_STATIC_VALUE =>
- (A_STATIC_VALUE, B_STATIC_VALUE))) IS
- BEGIN -- P2D1
- REPORT.FAILED ("BODY OF P2D1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN P2D1");
- END P2D1;
-
- BEGIN -- P2D
- P2D1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - P2D1");
- END P2D;
-
- PROCEDURE NEW_P2D IS NEW P2D (INTEGER_TYPE => NUMBER,
- F_STATIC_VALUE => 21,
- S_STATIC_VALUE => 37,
- T_STATIC_VALUE => 67,
- L_STATIC_VALUE => 79,
- A_STATIC_VALUE => 7,
- B_STATIC_VALUE => 93) ;
-
- BEGIN -- SECOND_STATIC_ARRAY
- NEW_P2D (LOWER => 5,
- UPPER => 95);
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P2D");
- END SECOND_STATIC_ARRAY ;
-
- --------------------------------------------------
-
- REC_NON_STATIC_CONS:
-
- DECLARE
-
--- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
--- INITIALIZED WITH A STATIC AGGREGATE.
-
- TYPE NUMBER IS RANGE 1 .. 100 ;
-
- GENERIC
-
- TYPE INTEGER_TYPE IS RANGE <> ;
- F_STATIC_VALUE : IN INTEGER_TYPE ;
- S_STATIC_VALUE : IN INTEGER_TYPE ;
- T_STATIC_VALUE : IN INTEGER_TYPE ;
- L_STATIC_VALUE : IN INTEGER_TYPE ;
- D_STATIC_VALUE : IN INTEGER_TYPE ;
-
- PROCEDURE PE (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) ;
-
- PROCEDURE PE (LOWER : IN INTEGER_TYPE ;
- UPPER : IN INTEGER_TYPE) IS
-
- SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE
- RANGE LOWER .. UPPER ;
- TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF
- SUBINTEGER_TYPE ;
-
- TYPE REC (DISCRIM : SUBINTEGER_TYPE) IS
- RECORD
- FIRST : SUBINTEGER_TYPE ;
- SECOND : AR1 ;
- END RECORD ;
-
- SUBTYPE REC4 IS REC (LOWER) ;
-
- PROCEDURE PE1 (R : REC4 := (D_STATIC_VALUE,
- F_STATIC_VALUE,
- (S_STATIC_VALUE,
- T_STATIC_VALUE,
- L_STATIC_VALUE))) IS
- BEGIN -- PE1
- REPORT.FAILED ("BODY OF PE1 EXECUTED");
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN PE1");
- END PE1;
-
- BEGIN -- PE
- PE1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - PE1");
- END PE;
-
- PROCEDURE NEW_PE IS NEW PE (INTEGER_TYPE => NUMBER,
- F_STATIC_VALUE => 37,
- S_STATIC_VALUE => 21,
- T_STATIC_VALUE => 67,
- L_STATIC_VALUE => 79,
- D_STATIC_VALUE => 44) ;
-
- BEGIN -- REC_NON_STATIC_CONS
- NEW_PE (LOWER => 2,
- UPPER => 99);
- EXCEPTION
- WHEN OTHERS =>
- REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PE");
- END REC_NON_STATIC_CONS ;
-
- --------------------------------------------------
-
- REPORT.RESULT;
-
-END CC3017B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada
deleted file mode 100644
index d464971..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada
+++ /dev/null
@@ -1,336 +0,0 @@
--- CC3017C.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 INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A
--- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST
--- DECLARE A FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS
--- ARE COPIED.
---
--- SUBTESTS ARE:
--- (A) SCALAR PARAMETERS TO PROCEDURES.
--- (B) SCALAR PARAMETERS TO FUNCTIONS.
--- (C) ACCESS PARAMETERS TO PROCEDURES.
--- (D) ACCESS PARAMETERS TO FUNCTIONS.
-
--- HISTORY:
--- EDWARD V. BERARD, 7 AUGUST 1990
--- CJJ 10/16/90 ADJUSTED LINES THAT WERE TOO LONG; REFORMATTED
--- HEADER TO CONFORM TO ACVC STANDARDS.
---
-
-WITH REPORT;
-PROCEDURE CC3017C IS
-
-BEGIN
- REPORT.TEST ("CC3017C", "CHECK THAT AN INSTANCE OF A GENERIC " &
- "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " &
- "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " &
- "FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS " &
- "ARE COPIED");
-
- --------------------------------------------------
-
- SCALAR_TO_PROCS:
-
- DECLARE
-
--- (A) SCALAR PARAMETERS TO PROCEDURES.
-
- TYPE NUMBER IS RANGE 0 .. 120 ;
- VALUE : NUMBER ;
- E : EXCEPTION ;
-
- GENERIC
-
- TYPE SCALAR_ITEM IS RANGE <> ;
-
- PROCEDURE P (P_IN : IN SCALAR_ITEM ;
- P_OUT : OUT SCALAR_ITEM ;
- P_IN_OUT : IN OUT SCALAR_ITEM) ;
-
- PROCEDURE P (P_IN : IN SCALAR_ITEM ;
- P_OUT : OUT SCALAR_ITEM ;
- P_IN_OUT : IN OUT SCALAR_ITEM) IS
-
- STORE : SCALAR_ITEM ;
-
- BEGIN -- P
-
- STORE := P_IN; -- SAVE VALUE OF P_IN AT PROC ENTRY.
-
- P_OUT := 10;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO SCALAR OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- STORE := P_IN; -- RESET STORE FOR NEXT CASE.
- END IF;
-
- P_IN_OUT := P_IN_OUT + 100;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- STORE := P_IN; -- RESET STORE FOR NEXT CASE.
- END IF;
-
- VALUE := VALUE + 1;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P;
-
- PROCEDURE NEW_P IS NEW P (SCALAR_ITEM => NUMBER) ;
-
- BEGIN -- SCALAR_TO_PROCS
- VALUE := 0; -- INITIALIZE VALUE SO VARIOUS CASES CAN BE DETECTED.
-
- NEW_P (P_IN => VALUE,
- P_OUT => VALUE,
- P_IN_OUT => VALUE);
-
- REPORT.FAILED ("EXCEPTION NOT RAISED - SCALARS TO PROCEDURES");
- EXCEPTION
- WHEN E =>
- IF (VALUE /= 1) THEN
- CASE VALUE IS
- WHEN 11 =>
- REPORT.FAILED ("OUT ACTUAL SCALAR " &
- "PARAMETER CHANGED GLOBAL VALUE");
- WHEN 101 =>
- REPORT.FAILED ("IN OUT ACTUAL SCALAR " &
- "PARAMETER CHANGED GLOBAL VALUE");
- WHEN 111 =>
- REPORT.FAILED ("OUT AND IN OUT ACTUAL " &
- "SCALAR PARAMETERS CHANGED " &
- "GLOBAL VALUE");
- WHEN OTHERS =>
- REPORT.FAILED ("UNDETERMINED CHANGE TO " &
- "GLOBAL VALUE");
- END CASE;
- END IF;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - SCALARS TO PROCEDURES");
- END SCALAR_TO_PROCS ;
-
- --------------------------------------------------
-
- SCALAR_TO_FUNCS:
-
- DECLARE
-
--- (B) SCALAR PARAMETERS TO FUNCTIONS.
-
- TYPE NUMBER IS RANGE 0 .. 101 ;
- FIRST : NUMBER ;
- SECOND : NUMBER ;
-
- GENERIC
-
- TYPE ITEM IS RANGE <> ;
-
- FUNCTION F (F_IN : IN ITEM) RETURN ITEM ;
-
- FUNCTION F (F_IN : IN ITEM) RETURN ITEM IS
-
- STORE : ITEM := F_IN;
-
- BEGIN -- F
-
- FIRST := FIRST + 1;
- IF (F_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL FUNCTION " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RETURN (100);
- END F;
-
- FUNCTION NEW_F IS NEW F (ITEM => NUMBER) ;
-
- BEGIN -- SCALAR_TO_FUNCS
- FIRST := 100 ;
- SECOND := NEW_F (FIRST) ;
- END SCALAR_TO_FUNCS ;
-
- --------------------------------------------------
-
- ACCESS_TO_PROCS:
-
- DECLARE
-
--- (C) ACCESS PARAMETERS TO PROCEDURES.
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TYPE DATE_ACCESS IS ACCESS DATE ;
- DATE_POINTER : DATE_ACCESS ;
-
- E : EXCEPTION;
-
- GENERIC
-
- TYPE ITEM IS PRIVATE ;
- TYPE ACCESS_ITEM IS ACCESS ITEM ;
-
- PROCEDURE P (P_IN : IN ACCESS_ITEM ;
- P_OUT : OUT ACCESS_ITEM ;
- P_IN_OUT : IN OUT ACCESS_ITEM) ;
-
- PROCEDURE P (P_IN : IN ACCESS_ITEM ;
- P_OUT : OUT ACCESS_ITEM ;
- P_IN_OUT : IN OUT ACCESS_ITEM) IS
-
- STORE : ACCESS_ITEM ;
-
- BEGIN -- P
-
- STORE := P_IN ; -- SAVE VALUE OF P_IN AT PROC ENTRY.
-
- DATE_POINTER := NEW DATE'(YEAR => 1990,
- DAY => 7,
- MONTH => AUG) ;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- STORE := P_IN; -- RESET STORE FOR NEXT CASE.
- END IF;
-
- P_OUT := NEW ITEM ;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO ACCESS OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- STORE := P_IN; -- RESET STORE FOR NEXT CASE.
- END IF;
-
- P_IN_OUT := NEW ITEM ;
- IF (P_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RAISE E; -- CHECK EXCEPTION HANDLING.
- END P ;
-
- PROCEDURE NEW_P IS NEW P (ITEM => DATE,
- ACCESS_ITEM => DATE_ACCESS) ;
-
- BEGIN -- ACCESS_TO_PROCS
- DATE_POINTER := NEW DATE'(MONTH => DEC,
- DAY => 25,
- YEAR => 2000) ;
-
- NEW_P (P_IN => DATE_POINTER,
- P_OUT => DATE_POINTER,
- P_IN_OUT => DATE_POINTER) ;
-
- REPORT.FAILED ("EXCEPTION NOT RAISED - ACCESS TO PROCEDURES");
- EXCEPTION
- WHEN E =>
- IF (DATE_POINTER.ALL /= (AUG, 7, 1990)) THEN
- REPORT.FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
- "PARAMETER VALUE CHANGED DESPITE " &
- "RAISED EXCEPTION");
- END IF;
- WHEN OTHERS =>
- REPORT.FAILED ("WRONG EXCEPTION RAISED - ACCESS TO PROCEDURES");
- END ACCESS_TO_PROCS ;
-
- --------------------------------------------------
-
- ACCESS_TO_FUNCS:
-
- DECLARE
-
--- (D) ACCESS PARAMETERS TO FUNCTIONS.
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TYPE DATE_ACCESS IS ACCESS DATE ;
- DATE_POINTER : DATE_ACCESS ;
- NEXT_DATE : DATE_ACCESS ;
-
- GENERIC
-
- TYPE ITEM IS PRIVATE ;
- TYPE ACCESS_ITEM IS ACCESS ITEM ;
-
- FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM ;
-
- FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM IS
-
- STORE : ACCESS_ITEM := F_IN ;
-
- BEGIN -- F
-
- DATE_POINTER := NEW DATE'(YEAR => 1990,
- DAY => 7,
- MONTH => AUG) ;
- IF (F_IN /= STORE) THEN
- REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL FUNCTION " &
- "PARAMETER CHANGES THE VALUE OF " &
- "INPUT PARAMETER");
- END IF;
-
- RETURN (NULL);
- END F ;
-
- FUNCTION NEW_F IS NEW F (ITEM => DATE,
- ACCESS_ITEM => DATE_ACCESS) ;
-
- BEGIN -- ACCESS_TO_FUNCS
- DATE_POINTER := NULL ;
- NEXT_DATE := NEW_F(F_IN => DATE_POINTER) ;
- END ACCESS_TO_FUNCS ;
-
- --------------------------------------------------
-
- REPORT.RESULT;
-
-END CC3017C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada
deleted file mode 100644
index 3f5e84e..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada
+++ /dev/null
@@ -1,173 +0,0 @@
--- CC3019A.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 INSTANTIATIONS OF NESTED GENERIC UNITS ARE PROCESSED
--- CORRECTLY.
-
--- JBG 11/6/85
-
-GENERIC
- TYPE ELEMENT_TYPE IS PRIVATE;
-PACKAGE CC3019A_QUEUES IS
-
- TYPE QUEUE_TYPE IS PRIVATE;
-
- PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE;
- VALUE : ELEMENT_TYPE);
-
- GENERIC
- WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE);
- PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE);
-
-PRIVATE
-
- TYPE CONTENTS_TYPE IS ARRAY (1..3) OF ELEMENT_TYPE;
- TYPE QUEUE_TYPE IS
- RECORD
- CONTENTS : CONTENTS_TYPE;
- SIZE : NATURAL := 0;
- END RECORD;
-
-END CC3019A_QUEUES;
-
-PACKAGE BODY CC3019A_QUEUES IS
-
- PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE;
- VALUE : ELEMENT_TYPE) IS
- BEGIN
- TO_Q.SIZE := TO_Q.SIZE + 1;
- TO_Q.CONTENTS(TO_Q.SIZE) := VALUE;
- END ADD;
-
--- GENERIC
--- WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE);
- PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE) IS
- BEGIN
- FOR I IN TO_Q.CONTENTS'FIRST .. TO_Q.SIZE LOOP
- APPLY (TO_Q.CONTENTS(I));
- END LOOP;
- END ITERATOR;
-
-END CC3019A_QUEUES;
-
-WITH REPORT; USE REPORT;
-WITH CC3019A_QUEUES;
-PROCEDURE CC3019A IS
-
- SUBTYPE STR6 IS STRING (1..6);
-
- TYPE STR6_ARR IS ARRAY (1..3) OF STR6;
- STR6_VALS : STR6_ARR := ("111111", "222222",
- IDENT_STR("333333"));
- CUR_STR_INDEX : NATURAL := 1;
-
- TYPE INT_ARR IS ARRAY (1..3) OF INTEGER;
- INT_VALS : INT_ARR := (-1, 3, IDENT_INT(3));
- CUR_INT_INDEX : NATURAL := 1;
-
--- THIS PROCEDURE IS CALLED ONCE FOR EACH ELEMENT OF THE QUEUE
---
- PROCEDURE CHECK_STR (VAL : STR6) IS
- BEGIN
- IF VAL /= STR6_VALS(CUR_STR_INDEX) THEN
- FAILED ("STR6 ITERATOR FOR INDEX =" &
- INTEGER'IMAGE(CUR_STR_INDEX) & " WITH VALUE " &
- """" & VAL & """");
- END IF;
- CUR_STR_INDEX := CUR_STR_INDEX + 1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("STR6 - CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("STR6 - UNEXPECTED EXCEPTION");
- END CHECK_STR;
-
- PROCEDURE CHECK_INT (VAL : INTEGER) IS
- BEGIN
- IF VAL /= INT_VALS(CUR_INT_INDEX) THEN
- FAILED ("INTEGER ITERATOR FOR INDEX =" &
- INTEGER'IMAGE(CUR_INT_INDEX) & " WITH VALUE " &
- """" & INTEGER'IMAGE(VAL) & """");
- END IF;
- CUR_INT_INDEX := CUR_INT_INDEX + 1;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("INTEGER - CONSTRAINT_ERROR RAISED");
- WHEN OTHERS =>
- FAILED ("INTEGER - UNEXPECTED EXCEPTION");
- END CHECK_INT;
-
- PACKAGE STR6_QUEUE IS NEW CC3019A_QUEUES (STR6);
- USE STR6_QUEUE;
-
- PACKAGE INT_QUEUE IS NEW CC3019A_QUEUES (INTEGER);
- USE INT_QUEUE;
-
-BEGIN
-
- TEST ("CC3019A", "CHECK NESTED GENERICS - ITERATORS");
-
- DECLARE
- Q1 : STR6_QUEUE.QUEUE_TYPE;
-
- PROCEDURE CHK_STR IS NEW STR6_QUEUE.ITERATOR (CHECK_STR);
-
- BEGIN
-
- ADD (Q1, "111111");
- ADD (Q1, "222222");
- ADD (Q1, "333333");
-
- CUR_STR_INDEX := 1;
- CHK_STR (Q1);
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - Q1");
- END;
-
--- REPEAT FOR INTEGERS
-
- DECLARE
- Q2 : INT_QUEUE.QUEUE_TYPE;
-
- PROCEDURE CHK_INT IS NEW INT_QUEUE.ITERATOR (CHECK_INT);
-
- BEGIN
-
- ADD (Q2, -1);
- ADD (Q2, 3);
- ADD (Q2, 3);
-
- CUR_INT_INDEX := 1;
- CHK_INT (Q2);
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION - Q2");
- END;
-
- RESULT;
-
-END CC3019A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada
deleted file mode 100644
index b7a7a9d..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- CC3019B0.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.
---*
--- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
--- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- WITH FUNCTION "=" (LEFT : IN ELEMENT ;
- RIGHT : IN ELEMENT) RETURN BOOLEAN ;
-
-PACKAGE CC3019B0_LIST_CLASS IS
-
- TYPE LIST IS LIMITED PRIVATE ;
-
- OVERFLOW : EXCEPTION ;
- UNDERFLOW : EXCEPTION ;
-
- PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ;
- TO_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ;
- FROM_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE COPY (THIS_LIST : IN OUT LIST ;
- TO_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ;
-
- GENERIC
-
- WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ;
-
- FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST)
- RETURN NATURAL ;
-
- FUNCTION "=" (LEFT : IN LIST ;
- RIGHT : IN LIST) RETURN BOOLEAN ;
-
-PRIVATE
-
- TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ;
-
- TYPE LIST IS RECORD
- LENGTH : NATURAL := 0 ;
- ACTUAL_LIST : LIST_TABLE ;
- END RECORD ;
-
-END CC3019B0_LIST_CLASS ;
-
-PACKAGE BODY CC3019B0_LIST_CLASS IS
-
- PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ;
- TO_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- ADD
-
- IF TO_THIS_LIST.LENGTH >= 10 THEN
- RAISE OVERFLOW ;
- ELSE
- TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ;
- ASSIGN (
- SOURCE => THIS_ELEMENT,
- DESTINATION =>
- TO_THIS_LIST.ACTUAL_LIST (TO_THIS_LIST.LENGTH));
- END IF ;
-
- END ADD ;
-
- PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ;
- FROM_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- DELETE
-
- IF FROM_THIS_LIST.LENGTH <= 0 THEN
- RAISE UNDERFLOW ;
- ELSE
- ASSIGN (
- SOURCE =>
- FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH),
- DESTINATION => THIS_ELEMENT) ;
- FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ;
- END IF ;
-
- END DELETE ;
-
- PROCEDURE COPY (THIS_LIST : IN OUT LIST ;
- TO_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- COPY
-
- TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ;
- FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP
- ASSIGN (
- SOURCE => THIS_LIST.ACTUAL_LIST (INDEX),
- DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX)) ;
- END LOOP ;
-
- END COPY ;
-
- PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- CLEAR
-
- THIS_LIST.LENGTH := 0 ;
-
- END CLEAR ;
-
- PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS
-
- CONTINUE : BOOLEAN := TRUE ;
- FINISHED : NATURAL := 0 ;
-
- BEGIN -- ITERATE
-
- WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH)
- LOOP
- FINISHED := FINISHED + 1 ;
- PROCESS (THIS_ELEMENT =>
- OVER_THIS_LIST.ACTUAL_LIST (FINISHED),
- CONTINUE => CONTINUE) ;
- END LOOP ;
-
- END ITERATE ;
-
- FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST)
- RETURN NATURAL IS
-
- BEGIN -- NUMBER_OF_ELEMENTS
-
- RETURN IN_THIS_LIST.LENGTH ;
-
- END NUMBER_OF_ELEMENTS ;
-
- FUNCTION "=" (LEFT : IN LIST ;
- RIGHT : IN LIST) RETURN BOOLEAN IS
-
- RESULT : BOOLEAN := TRUE ;
- INDEX : NATURAL := 0 ;
-
- BEGIN -- "="
-
- IF LEFT.LENGTH /= RIGHT.LENGTH THEN
- RESULT := FALSE ;
- ELSE
- WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP
- INDEX := INDEX + 1 ;
- IF LEFT.ACTUAL_LIST (INDEX) /=
- RIGHT.ACTUAL_LIST (INDEX) THEN
- RESULT := FALSE ;
- END IF ;
- END LOOP ;
- END IF ;
-
- RETURN RESULT ;
-
- END "=" ;
-
-END CC3019B0_LIST_CLASS ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada
deleted file mode 100644
index 15dcb13..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada
+++ /dev/null
@@ -1,174 +0,0 @@
--- CC3019B1.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.
---*
--- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
--- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED
--- BY THE MAIN PROCEDURE, I.E., CC3019B2M.ADA.
---
--- *** THIS FILE MUST BE COMPILED AFTER CC3019B0.ADA HAS BEEN
--- *** COMPILED.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-WITH CC3019B0_LIST_CLASS ;
-
-GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- WITH FUNCTION "=" (LEFT : IN ELEMENT ;
- RIGHT : IN ELEMENT) RETURN BOOLEAN ;
-
-PACKAGE CC3019B1_STACK_CLASS IS
-
- TYPE STACK IS LIMITED PRIVATE ;
-
- OVERFLOW : EXCEPTION ;
- UNDERFLOW : EXCEPTION ;
-
- PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ;
- ON_TO_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ;
- OFF_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE COPY (THIS_STACK : IN OUT STACK ;
- TO_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ;
-
- GENERIC
-
- WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ;
-
- FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK)
- RETURN NATURAL ;
-
- FUNCTION "=" (LEFT : IN STACK ;
- RIGHT : IN STACK) RETURN BOOLEAN ;
-
-PRIVATE
-
- PACKAGE NEW_LIST_CLASS IS
- NEW CC3019B0_LIST_CLASS (ELEMENT => ELEMENT,
- ASSIGN => ASSIGN,
- "=" => "=") ;
-
- TYPE STACK IS NEW NEW_LIST_CLASS.LIST ;
-
-END CC3019B1_STACK_CLASS ;
-
-PACKAGE BODY CC3019B1_STACK_CLASS IS
-
- PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ;
- ON_TO_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- PUSH
-
- NEW_LIST_CLASS.ADD (
- THIS_ELEMENT => THIS_ELEMENT,
- TO_THIS_LIST =>
- NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ;
-
- EXCEPTION
-
- WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ;
-
- END PUSH ;
-
- PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ;
- OFF_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- POP
-
- NEW_LIST_CLASS.DELETE (
- THIS_ELEMENT => THIS_ELEMENT,
- FROM_THIS_LIST =>
- NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ;
-
- EXCEPTION
-
- WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ;
-
- END POP ;
-
- PROCEDURE COPY (THIS_STACK : IN OUT STACK ;
- TO_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- COPY
-
- NEW_LIST_CLASS.COPY (
- THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK),
- TO_THIS_LIST => NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ;
-
- END COPY ;
-
- PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- CLEAR
-
- NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ;
-
- END CLEAR ;
-
- PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS
-
- PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE
- (PROCESS => PROCESS) ;
-
- BEGIN -- ITERATE
-
- STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ;
-
- END ITERATE ;
-
- FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK)
- RETURN NATURAL IS
-
- BEGIN -- NUMBER_OF_ELEMENTS
-
- RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS
- (IN_THIS_LIST => NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ;
-
- END NUMBER_OF_ELEMENTS ;
-
- FUNCTION "=" (LEFT : IN STACK ;
- RIGHT : IN STACK) RETURN BOOLEAN IS
-
- BEGIN -- "="
-
- RETURN NEW_LIST_CLASS."=" (
- LEFT => NEW_LIST_CLASS.LIST (LEFT),
- RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ;
-
- END "=" ;
-
-END CC3019B1_STACK_CLASS ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada
deleted file mode 100644
index 52bf79dd..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada
+++ /dev/null
@@ -1,300 +0,0 @@
--- CC3019B2M.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 INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G.,
--- TO SUPPORT ITERATORS. THIS TEST SPECIFICALLY CHECKS THAT A
--- NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS.
---
--- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
--- *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE
--- *** BEEN COMPILED.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-WITH REPORT ;
-WITH CC3019B1_STACK_CLASS ;
-
-PROCEDURE CC3019B2M IS
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- STORE_DATE : DATE ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 31,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (MONTH => JUN,
- DAY => 4,
- YEAR => 1967) ;
-
- BIRTH_DATE : DATE := (MONTH => OCT,
- DAY => 3,
- YEAR => 1949) ;
-
- WALL_DATE : DATE := (MONTH => NOV,
- DAY => 9,
- YEAR => 1989) ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ;
- TO_THIS_DATE : IN OUT DATE) ;
-
- FUNCTION IS_EQUAL (LEFT : IN DATE ;
- RIGHT : IN DATE) RETURN BOOLEAN ;
-
- PACKAGE DATE_STACK IS
- NEW CC3019B1_STACK_CLASS (ELEMENT => DATE,
- ASSIGN => ASSIGN,
- "=" => IS_EQUAL) ;
-
- FIRST_DATE_STACK : DATE_STACK.STACK ;
- SECOND_DATE_STACK : DATE_STACK.STACK ;
- THIRD_DATE_STACK : DATE_STACK.STACK ;
-
- FUNCTION "=" (LEFT : IN DATE_STACK.STACK ;
- RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN
- RENAMES DATE_STACK."=" ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ;
- TO_THIS_DATE : IN OUT DATE) IS
-
- BEGIN -- ASSIGN
-
- TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ;
-
- END ASSIGN ;
-
- FUNCTION IS_EQUAL (LEFT : IN DATE ;
- RIGHT : IN DATE) RETURN BOOLEAN IS
-
- BEGIN -- IS_EQUAL
-
- RETURN (LEFT.MONTH = RIGHT.MONTH) AND
- (LEFT.DAY = RIGHT.DAY) AND
- (LEFT.YEAR = RIGHT.YEAR) ;
-
- END IS_EQUAL ;
-
-BEGIN -- CC3019B2M
-
- REPORT.TEST ("CC3019B2M",
- "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
- "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
- "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " &
- "2 IS SUPPORTED FOR GENERICS.") ;
-
- DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
- END IF ;
-
- DATE_STACK.PUSH (THIS_ELEMENT => TODAY,
- ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
- END IF ;
-
- DATE_STACK.PUSH (THIS_ELEMENT => FIRST_DATE,
- ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
- END IF ;
-
- DATE_STACK.PUSH (THIS_ELEMENT => BIRTH_DATE,
- ON_TO_THIS_STACK => FIRST_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
- END IF ;
-
- DATE_STACK.POP (THIS_ELEMENT => STORE_DATE,
- OFF_THIS_STACK => FIRST_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
- END IF ;
-
- IF STORE_DATE /= BIRTH_DATE THEN
- REPORT.FAILED (
- "IMPROPER VALUE REMOVED FROM STACK - 1") ;
- END IF ;
-
- DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ;
- IF DATE_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
- END IF ;
-
- DATE_STACK.COPY (THIS_STACK => FIRST_DATE_STACK,
- TO_THIS_STACK => SECOND_DATE_STACK) ;
-
- IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN
- REPORT.FAILED (
- "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ;
- END IF ;
-
- DATE_STACK.POP (THIS_ELEMENT => STORE_DATE,
- OFF_THIS_STACK => SECOND_DATE_STACK) ;
- DATE_STACK.PUSH (THIS_ELEMENT => WALL_DATE,
- ON_TO_THIS_STACK => SECOND_DATE_STACK) ;
- IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN
- REPORT.FAILED (
- "PROBLEMS WITH POP OR TEST FOR EQUALITY") ;
- END IF ;
-
- UNDERFLOW_EXCEPTION_TEST:
-
- BEGIN -- UNDERFLOW_EXCEPTION_TEST
-
- DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
- DATE_STACK.POP (THIS_ELEMENT => STORE_DATE,
- OFF_THIS_STACK => THIRD_DATE_STACK) ;
- REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;
-
- EXCEPTION
-
- WHEN DATE_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION
- -- RAISED
- WHEN OTHERS =>
- REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
- "UNDERFLOW EXCEPTION TEST") ;
-
- END UNDERFLOW_EXCEPTION_TEST ;
-
- OVERFLOW_EXCEPTION_TEST:
-
- BEGIN -- OVERFLOW_EXCEPTION_TEST
-
- DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ;
- FOR INDEX IN 1 .. 10 LOOP
- DATE_STACK.PUSH ( THIS_ELEMENT => TODAY,
- ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
- END LOOP ;
-
- DATE_STACK.PUSH (THIS_ELEMENT => TODAY,
- ON_TO_THIS_STACK => THIRD_DATE_STACK) ;
- REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;
-
- EXCEPTION
-
- WHEN DATE_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION
- -- RAISED
- WHEN OTHERS =>
- REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
- "OVERFLOW EXCEPTION TEST") ;
-
- END OVERFLOW_EXCEPTION_TEST ;
-
- LOCAL_BLOCK:
-
- DECLARE
-
- TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ;
-
- FIRST_DATE_TABLE : DATE_TABLE ;
-
- TABLE_INDEX : POSITIVE := 1 ;
-
- PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE STORE_DATES (THIS_DATE : IN DATE ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE SHOW_DATE_ITERATE IS NEW
- DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ;
-
- PROCEDURE STORE_DATE_ITERATE IS NEW
- DATE_STACK.ITERATE (PROCESS => STORE_DATES) ;
-
- PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ;
- CONTINUE : OUT BOOLEAN) IS
- BEGIN -- SHOW_DATES
-
- REPORT.COMMENT ("THE MONTH IS " &
- MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ;
- REPORT.COMMENT ("THE DAY IS " &
- DAY_TYPE'IMAGE (THIS_DATE.DAY)) ;
- REPORT.COMMENT ("THE YEAR IS " &
- YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ;
-
- CONTINUE := TRUE ;
-
- END SHOW_DATES ;
-
- PROCEDURE STORE_DATES (THIS_DATE : IN DATE ;
- CONTINUE : OUT BOOLEAN) IS
- BEGIN -- STORE_DATES
-
- FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ;
- TABLE_INDEX := TABLE_INDEX + 1 ;
-
- CONTINUE := TRUE ;
-
- END STORE_DATES ;
-
- BEGIN -- LOCAL_BLOCK
-
- REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
- SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
-
- REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
- SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
-
- STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ;
- IF (FIRST_DATE_TABLE (1) /= TODAY) OR
- (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN
- REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
- END IF ;
-
- TABLE_INDEX := 1 ;
- STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ;
- IF (FIRST_DATE_TABLE (1) /= TODAY) OR
- (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN
- REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
- END IF ;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT ;
-
-END CC3019B2M ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada
deleted file mode 100644
index d34ff79..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada
+++ /dev/null
@@ -1,191 +0,0 @@
--- CC3019C0.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
--- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
--- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- WITH FUNCTION "=" (LEFT : IN ELEMENT ;
- RIGHT : IN ELEMENT) RETURN BOOLEAN ;
-
-PACKAGE CC3019C0_LIST_CLASS IS
-
- TYPE LIST IS LIMITED PRIVATE ;
-
- OVERFLOW : EXCEPTION ;
- UNDERFLOW : EXCEPTION ;
-
- PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ;
- TO_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ;
- FROM_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE COPY (THIS_LIST : IN OUT LIST ;
- TO_THIS_LIST : IN OUT LIST) ;
-
- PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ;
-
- GENERIC
-
- WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ;
-
- FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST)
- RETURN NATURAL ;
-
- FUNCTION "=" (LEFT : IN LIST ;
- RIGHT : IN LIST) RETURN BOOLEAN ;
-
-PRIVATE
-
- TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ;
-
- TYPE LIST IS RECORD
- LENGTH : NATURAL := 0 ;
- ACTUAL_LIST : LIST_TABLE ;
- END RECORD ;
-
-END CC3019C0_LIST_CLASS ;
-
-PACKAGE BODY CC3019C0_LIST_CLASS IS
-
- PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ;
- TO_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- ADD
-
- IF TO_THIS_LIST.LENGTH >= 10 THEN
- RAISE OVERFLOW ;
- ELSE
- TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ;
- ASSIGN (
- SOURCE => THIS_ELEMENT,
- DESTINATION =>
- TO_THIS_LIST.ACTUAL_LIST(TO_THIS_LIST.LENGTH));
- END IF ;
-
- END ADD ;
-
- PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ;
- FROM_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- DELETE
-
- IF FROM_THIS_LIST.LENGTH <= 0 THEN
- RAISE UNDERFLOW ;
- ELSE
- ASSIGN (
- SOURCE =>
- FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH),
- DESTINATION => THIS_ELEMENT) ;
- FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ;
- END IF ;
-
- END DELETE ;
-
- PROCEDURE COPY (THIS_LIST : IN OUT LIST ;
- TO_THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- COPY
-
- TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ;
- FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP
- ASSIGN (SOURCE => THIS_LIST.ACTUAL_LIST (INDEX),
- DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX));
- END LOOP ;
-
- END COPY ;
-
- PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS
-
- BEGIN -- CLEAR
-
- THIS_LIST.LENGTH := 0 ;
-
- END CLEAR ;
-
- PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS
-
- CONTINUE : BOOLEAN := TRUE ;
- FINISHED : NATURAL := 0 ;
-
- BEGIN -- ITERATE
-
- WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH)
- LOOP
- FINISHED := FINISHED + 1 ;
- PROCESS (THIS_ELEMENT =>
- OVER_THIS_LIST.ACTUAL_LIST (FINISHED),
- CONTINUE => CONTINUE) ;
- END LOOP ;
-
- END ITERATE ;
-
- FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST)
- RETURN NATURAL IS
-
- BEGIN -- NUMBER_OF_ELEMENTS
-
- RETURN IN_THIS_LIST.LENGTH ;
-
- END NUMBER_OF_ELEMENTS ;
-
- FUNCTION "=" (LEFT : IN LIST ;
- RIGHT : IN LIST) RETURN BOOLEAN IS
-
- RESULT : BOOLEAN := TRUE ;
- INDEX : NATURAL := 0 ;
-
- BEGIN -- "="
-
- IF LEFT.LENGTH /= RIGHT.LENGTH THEN
- RESULT := FALSE ;
- ELSE
- WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP
- INDEX := INDEX + 1 ;
- IF LEFT.ACTUAL_LIST (INDEX) /=
- RIGHT.ACTUAL_LIST (INDEX) THEN
- RESULT := FALSE ;
- END IF ;
- END LOOP ;
- END IF ;
-
- RETURN RESULT ;
-
- END "=" ;
-
-END CC3019C0_LIST_CLASS ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada
deleted file mode 100644
index 527c27f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada
+++ /dev/null
@@ -1,331 +0,0 @@
--- CC3019C1.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.
---*
--- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
--- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED
--- BY MAIN PROCEDURE CC3019C2M.ADA.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-WITH CC3019C0_LIST_CLASS ;
-
-GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- WITH FUNCTION "=" (LEFT : IN ELEMENT ;
- RIGHT : IN ELEMENT) RETURN BOOLEAN ;
-
-PACKAGE CC3019C1_NESTED_GENERICS IS
-
- TYPE NESTED_GENERICS_TYPE IS LIMITED PRIVATE ;
-
- PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ;
- DESTINATION : IN OUT NESTED_GENERICS_TYPE) ;
-
- PROCEDURE SET_ELEMENT
- (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
- TO_THIS_ELEMENT : IN OUT ELEMENT) ;
-
- PROCEDURE SET_NUMBER
- (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
- TO_THIS_NUMBER : IN NATURAL) ;
-
- FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ;
- RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN ;
-
- FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE)
- RETURN ELEMENT ;
-
- FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE)
- RETURN NATURAL ;
-
- GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- PACKAGE GENERIC_TASK IS
-
- TASK TYPE PROTECTED_AREA IS
-
- ENTRY STORE (ITEM : IN OUT ELEMENT) ;
- ENTRY GET (ITEM : IN OUT ELEMENT) ;
-
- END PROTECTED_AREA ;
-
- END GENERIC_TASK ;
-
- GENERIC
-
- TYPE ELEMENT IS LIMITED PRIVATE ;
-
- WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ;
- DESTINATION : IN OUT ELEMENT) ;
-
- WITH FUNCTION "=" (LEFT : IN ELEMENT ;
- RIGHT : IN ELEMENT) RETURN BOOLEAN ;
-
- PACKAGE STACK_CLASS IS
-
- TYPE STACK IS LIMITED PRIVATE ;
-
- OVERFLOW : EXCEPTION ;
- UNDERFLOW : EXCEPTION ;
-
- PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ;
- ON_TO_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ;
- OFF_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE COPY (THIS_STACK : IN OUT STACK ;
- TO_THIS_STACK : IN OUT STACK) ;
-
- PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ;
-
- GENERIC
-
- WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ;
-
- FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK)
- RETURN NATURAL ;
-
- FUNCTION "=" (LEFT : IN STACK ;
- RIGHT : IN STACK) RETURN BOOLEAN ;
-
- PRIVATE
-
- PACKAGE NEW_LIST_CLASS IS NEW
- CC3019C0_LIST_CLASS (ELEMENT => ELEMENT,
- ASSIGN => ASSIGN,
- "=" => "=") ;
-
- TYPE STACK IS NEW NEW_LIST_CLASS.LIST ;
-
- END STACK_CLASS ;
-
-PRIVATE
-
- TYPE NESTED_GENERICS_TYPE IS RECORD
- FIRST : ELEMENT ;
- SECOND : NATURAL ;
- END RECORD ;
-
-END CC3019C1_NESTED_GENERICS ;
-
-PACKAGE BODY CC3019C1_NESTED_GENERICS IS
-
- PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ;
- DESTINATION : IN OUT NESTED_GENERICS_TYPE) IS
-
- BEGIN -- COPY
-
- ASSIGN (SOURCE => SOURCE.FIRST,
- DESTINATION => DESTINATION.FIRST) ;
-
- DESTINATION.SECOND := SOURCE.SECOND ;
-
- END COPY ;
-
- PROCEDURE SET_ELEMENT
- (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
- TO_THIS_ELEMENT : IN OUT ELEMENT) IS
-
- BEGIN -- SET_ELEMENT
-
- ASSIGN (SOURCE => TO_THIS_ELEMENT,
- DESTINATION => FOR_THIS_NGT_OBJECT.FIRST) ;
-
- END SET_ELEMENT ;
-
- PROCEDURE SET_NUMBER
- (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ;
- TO_THIS_NUMBER : IN NATURAL) IS
-
- BEGIN -- SET_NUMBER
-
- FOR_THIS_NGT_OBJECT.SECOND := TO_THIS_NUMBER ;
-
- END SET_NUMBER ;
-
- FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ;
- RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN IS
-
- BEGIN -- "="
-
- IF (LEFT.FIRST = RIGHT.FIRST) AND
- (LEFT.SECOND = RIGHT.SECOND) THEN
- RETURN TRUE ;
- ELSE
- RETURN FALSE ;
- END IF ;
-
- END "=" ;
-
- FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE)
- RETURN ELEMENT IS
-
- BEGIN -- ELEMENT_OF
-
- RETURN THIS_NGT_OBJECT.FIRST ;
-
- END ELEMENT_OF ;
-
- FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE)
- RETURN NATURAL IS
-
- BEGIN -- NUMBER_OF
-
- RETURN THIS_NGT_OBJECT.SECOND ;
-
- END NUMBER_OF ;
-
- PACKAGE BODY GENERIC_TASK IS
-
- TASK BODY PROTECTED_AREA IS
-
- LOCAL_STORE : ELEMENT ;
-
- BEGIN -- PROTECTED_AREA
-
- LOOP
- SELECT
- ACCEPT STORE (ITEM : IN OUT ELEMENT) DO
- ASSIGN (SOURCE => ITEM,
- DESTINATION => LOCAL_STORE) ;
- END STORE ;
- OR
- ACCEPT GET (ITEM : IN OUT ELEMENT) DO
- ASSIGN (SOURCE => LOCAL_STORE,
- DESTINATION => ITEM) ;
- END GET ;
- OR
- TERMINATE ;
- END SELECT ;
- END LOOP ;
-
- END PROTECTED_AREA ;
-
- END GENERIC_TASK ;
-
- PACKAGE BODY STACK_CLASS IS
-
- PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ;
- ON_TO_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- PUSH
-
- NEW_LIST_CLASS.ADD (
- THIS_ELEMENT => THIS_ELEMENT,
- TO_THIS_LIST =>
- NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ;
-
- EXCEPTION
-
- WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ;
-
- END PUSH ;
-
- PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ;
- OFF_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- POP
-
- NEW_LIST_CLASS.DELETE (
- THIS_ELEMENT => THIS_ELEMENT,
- FROM_THIS_LIST =>
- NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ;
-
- EXCEPTION
-
- WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ;
-
- END POP ;
-
- PROCEDURE COPY (THIS_STACK : IN OUT STACK ;
- TO_THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- COPY
-
- NEW_LIST_CLASS.COPY (
- THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK),
- TO_THIS_LIST =>
- NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ;
-
- END COPY ;
-
- PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS
-
- BEGIN -- CLEAR
-
- NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ;
-
- END CLEAR ;
-
- PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS
-
- PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE
- (PROCESS => PROCESS) ;
-
- BEGIN -- ITERATE
-
- STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ;
-
- END ITERATE ;
-
- FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK)
- RETURN NATURAL IS
-
- BEGIN -- NUMBER_OF_ELEMENTS
-
- RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS
- (IN_THIS_LIST =>
- NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ;
-
- END NUMBER_OF_ELEMENTS ;
-
- FUNCTION "=" (LEFT : IN STACK ;
- RIGHT : IN STACK) RETURN BOOLEAN IS
-
- BEGIN -- "="
-
- RETURN NEW_LIST_CLASS."=" (
- LEFT => NEW_LIST_CLASS.LIST (LEFT),
- RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ;
-
- END "=" ;
-
- END STACK_CLASS ;
-
-END CC3019C1_NESTED_GENERICS ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada b/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada
deleted file mode 100644
index 8fab9e6..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada
+++ /dev/null
@@ -1,457 +0,0 @@
--- CC3019C2M.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 INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G.
--- TO SUPPORT ITERATORS.
-
--- THIS TEST SPECIFICALLY CHECKS THAT A
--- NESTING LEVEL OF 3 IS SUPPORTED FOR GENERICS:
--- INSTANTIATE CC3019C1_NESTED_GENERICS IN THE MAIN
--- PROCEDURE, THE INSTANTIATION OF CC3019C0_LIST_CLASS
--- IN GENERIC PACKAGE CC3019C1_NESTED_GENERICS, AND
--- THE INSTANTIATION OF NEW_LIST_CLASS.ITERATE IN
--- PROCEDURE ITERATE IN PACKAGE BODY STACK_CLASS.
---
--- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE
--- *** SOURCE CODE IN FILES CC3019C0.ADA AND CC3019C1.ADA HAVE
--- *** BEEN COMPILED.
---
--- HISTORY:
--- EDWARD V. BERARD, 31 AUGUST 1990
-
-WITH REPORT ;
-WITH CC3019C1_NESTED_GENERICS ;
-
-PROCEDURE CC3019C2M IS
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- STORE_DATE : DATE ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 31,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (MONTH => JUN,
- DAY => 4,
- YEAR => 1967) ;
-
- BIRTH_DATE : DATE := (MONTH => OCT,
- DAY => 3,
- YEAR => 1949) ;
-
- WALL_DATE : DATE := (MONTH => NOV,
- DAY => 9,
- YEAR => 1989) ;
-
- TYPE SEX IS (MALE, FEMALE) ;
-
- TYPE PERSON IS RECORD
- BIRTH_DATE : DATE ;
- GENDER : SEX ;
- NAME : STRING (1 .. 10) ;
- END RECORD ;
-
- FIRST_PERSON : PERSON ;
- SECOND_PERSON : PERSON ;
-
- MYSELF : PERSON := (BIRTH_DATE => BIRTH_DATE,
- GENDER => MALE,
- NAME => "ED ") ;
-
- FRIEND : PERSON := (BIRTH_DATE => DATE'(DEC, 27, 1949),
- GENDER => MALE,
- NAME => "DENNIS ") ;
-
- FATHER : PERSON := (BIRTH_DATE => DATE'(JUL, 5, 1925),
- GENDER => MALE,
- NAME => "EDWARD ") ;
-
- DAUGHTER : PERSON := (BIRTH_DATE => DATE'(DEC, 10, 1980),
- GENDER => FEMALE,
- NAME => "CHRISSY ") ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ;
- TO_THIS_DATE : IN OUT DATE) ;
-
- FUNCTION IS_EQUAL (LEFT : IN DATE ;
- RIGHT : IN DATE) RETURN BOOLEAN ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ;
- TO_THIS_PERSON : IN OUT PERSON) ;
-
- FUNCTION IS_EQUAL (LEFT : IN PERSON ;
- RIGHT : IN PERSON) RETURN BOOLEAN ;
-
--- INSTANTIATE OUTER GENERIC PACKAGE
-
- PACKAGE NEW_NESTED_GENERICS IS NEW
- CC3019C1_NESTED_GENERICS (ELEMENT => DATE,
- ASSIGN => ASSIGN,
- "=" => IS_EQUAL) ;
-
- FIRST_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
- SECOND_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
-
- FUNCTION "=" (LEFT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ;
- RIGHT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE)
- RETURN BOOLEAN RENAMES NEW_NESTED_GENERICS."=" ;
-
--- INSTANTIATE NESTED TASK PACKAGE
-
- PACKAGE NEW_GENERIC_TASK IS NEW
- NEW_NESTED_GENERICS.GENERIC_TASK (ELEMENT => PERSON,
- ASSIGN => ASSIGN) ;
-
- FIRST_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ;
- SECOND_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ;
-
--- INSTANTIATE NESTED STACK PACKAGE
-
- PACKAGE PERSON_STACK IS NEW
- NEW_NESTED_GENERICS.STACK_CLASS (ELEMENT => PERSON,
- ASSIGN => ASSIGN,
- "=" => IS_EQUAL) ;
-
- FIRST_PERSON_STACK : PERSON_STACK.STACK ;
- SECOND_PERSON_STACK : PERSON_STACK.STACK ;
- THIRD_PERSON_STACK : PERSON_STACK.STACK ;
-
- FUNCTION "=" (LEFT : IN PERSON_STACK.STACK ;
- RIGHT : IN PERSON_STACK.STACK) RETURN BOOLEAN
- RENAMES PERSON_STACK."=" ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ;
- TO_THIS_DATE : IN OUT DATE) IS
-
- BEGIN -- ASSIGN
-
- TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ;
-
- END ASSIGN ;
-
- FUNCTION IS_EQUAL (LEFT : IN DATE ;
- RIGHT : IN DATE) RETURN BOOLEAN IS
-
- BEGIN -- IS_EQUAL
-
- IF (LEFT.MONTH = RIGHT.MONTH) AND (LEFT.DAY = RIGHT.DAY)
- AND (LEFT.YEAR = RIGHT.YEAR) THEN
- RETURN TRUE ;
- ELSE
- RETURN FALSE ;
- END IF ;
-
- END IS_EQUAL ;
-
- PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ;
- TO_THIS_PERSON : IN OUT PERSON) IS
-
- BEGIN -- ASSIGN
-
- TO_THIS_PERSON := THE_VALUE_OF_THIS_PERSON ;
-
- END ASSIGN ;
-
- FUNCTION IS_EQUAL (LEFT : IN PERSON ;
- RIGHT : IN PERSON) RETURN BOOLEAN IS
-
- BEGIN -- IS_EQUAL
-
- IF (LEFT.BIRTH_DATE = RIGHT.BIRTH_DATE) AND
- (LEFT.GENDER = RIGHT.GENDER) AND
- (LEFT.NAME = RIGHT.NAME) THEN
- RETURN TRUE ;
- ELSE
- RETURN FALSE ;
- END IF ;
-
- END IS_EQUAL ;
-
-BEGIN -- CC3019C2M
-
- REPORT.TEST ("CC3019C2M",
- "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " &
- "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " &
- "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF 3 " &
- "IS SUPPORTED FOR GENERICS.") ;
-
--- CHECK THE OUTERMOST GENERIC (NEW_NESTED_GENERICS)
-
- NEW_NESTED_GENERICS.SET_ELEMENT (
- FOR_THIS_NGT_OBJECT => FIRST_NNG,
- TO_THIS_ELEMENT => TODAY) ;
- NEW_NESTED_GENERICS.SET_NUMBER (
- FOR_THIS_NGT_OBJECT => FIRST_NNG,
- TO_THIS_NUMBER => 1) ;
-
- NEW_NESTED_GENERICS.SET_ELEMENT (
- FOR_THIS_NGT_OBJECT => SECOND_NNG,
- TO_THIS_ELEMENT => FIRST_DATE) ;
- NEW_NESTED_GENERICS.SET_NUMBER (
- FOR_THIS_NGT_OBJECT => SECOND_NNG,
- TO_THIS_NUMBER => 2) ;
-
- IF FIRST_NNG = SECOND_NNG THEN
- REPORT.FAILED ("PROBLEMS WITH TESTING EQUALITY FOR " &
- "OUTERMOST GENERIC") ;
- END IF ;
-
- IF (NEW_NESTED_GENERICS.ELEMENT_OF (THIS_NGT_OBJECT => FIRST_NNG)
- /= TODAY) OR
- (NEW_NESTED_GENERICS.ELEMENT_OF (
- THIS_NGT_OBJECT => SECOND_NNG)
- /= FIRST_DATE) THEN
- REPORT.FAILED ("PROBLEMS WITH EXTRACTING ELEMENTS IN " &
- "OUTERMOST GENERIC") ;
- END IF ;
-
- IF (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => FIRST_NNG)
- /= 1) OR
- (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => SECOND_NNG)
- /= 2) THEN
- REPORT.FAILED ("PROBLEMS WITH EXTRACTING NUMBERS IN " &
- "OUTERMOST GENERIC") ;
- END IF ;
-
- NEW_NESTED_GENERICS.COPY (SOURCE => FIRST_NNG,
- DESTINATION => SECOND_NNG) ;
-
- IF FIRST_NNG /= SECOND_NNG THEN
- REPORT.FAILED ("PROBLEMS WITH COPYING OR TESTING EQUALITY " &
- "IN OUTERMOST GENERIC") ;
- END IF ;
-
--- CHECK THE FIRST NESTED GENERIC (GENERIC_TASK)
-
- FIRST_GENERIC_TASK.STORE (ITEM => MYSELF) ;
- SECOND_GENERIC_TASK.STORE (ITEM => FRIEND) ;
-
- FIRST_GENERIC_TASK.GET (ITEM => FIRST_PERSON) ;
- SECOND_GENERIC_TASK.GET (ITEM => SECOND_PERSON) ;
-
- IF (FIRST_PERSON /= MYSELF) OR (SECOND_PERSON /= FRIEND) THEN
- REPORT.FAILED ("PROBLEMS WITH NESTED TASK GENERIC") ;
- END IF ;
-
--- CHECK THE SECOND NESTED GENERIC (STACK_CLASS)
-
- PERSON_STACK.CLEAR (THIS_STACK => FIRST_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_PERSON_STACK) /= 0 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ;
- END IF ;
-
- PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF,
- ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_PERSON_STACK) /= 1 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ;
- END IF ;
-
- PERSON_STACK.PUSH (THIS_ELEMENT => FRIEND,
- ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ;
- END IF ;
-
- PERSON_STACK.PUSH (THIS_ELEMENT => FATHER,
- ON_TO_THIS_STACK => FIRST_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_PERSON_STACK) /= 3 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ;
- END IF ;
-
- PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON,
- OFF_THIS_STACK => FIRST_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ;
- END IF ;
-
- IF FIRST_PERSON /= FATHER THEN
- REPORT.FAILED (
- "IMPROPER VALUE REMOVED FROM STACK - 1") ;
- END IF ;
-
- PERSON_STACK.CLEAR (THIS_STACK => SECOND_PERSON_STACK) ;
- IF PERSON_STACK.NUMBER_OF_ELEMENTS
- (ON_THIS_STACK => SECOND_PERSON_STACK) /= 0 THEN
- REPORT.FAILED (
- "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ;
- END IF ;
-
- PERSON_STACK.COPY (THIS_STACK => FIRST_PERSON_STACK,
- TO_THIS_STACK => SECOND_PERSON_STACK) ;
-
- IF FIRST_PERSON_STACK /= SECOND_PERSON_STACK THEN
- REPORT.FAILED (
- "PROBLEMS WITH COPY OR TEST FOR EQUALITY (STACK)") ;
- END IF ;
-
- PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON,
- OFF_THIS_STACK => SECOND_PERSON_STACK) ;
- PERSON_STACK.PUSH (THIS_ELEMENT => DAUGHTER,
- ON_TO_THIS_STACK => SECOND_PERSON_STACK) ;
- IF FIRST_PERSON_STACK = SECOND_PERSON_STACK THEN
- REPORT.FAILED (
- "PROBLEMS WITH POP OR TEST FOR EQUALITY (STACK)") ;
- END IF ;
-
- UNDERFLOW_EXCEPTION_TEST:
-
- BEGIN -- UNDERFLOW_EXCEPTION_TEST
-
- PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
- PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON,
- OFF_THIS_STACK => THIRD_PERSON_STACK) ;
- REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ;
-
- EXCEPTION
-
- WHEN PERSON_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION
- -- RAISED
- WHEN OTHERS =>
- REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
- "UNDERFLOW EXCEPTION TEST") ;
-
- END UNDERFLOW_EXCEPTION_TEST ;
-
- OVERFLOW_EXCEPTION_TEST:
-
- BEGIN -- OVERFLOW_EXCEPTION_TEST
-
- PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ;
- FOR INDEX IN 1 .. 10 LOOP
- PERSON_STACK.PUSH (
- THIS_ELEMENT => MYSELF,
- ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
- END LOOP ;
-
- PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF,
- ON_TO_THIS_STACK => THIRD_PERSON_STACK) ;
- REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ;
-
- EXCEPTION
-
- WHEN PERSON_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION
- -- RAISED
- WHEN OTHERS =>
- REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " &
- "OVERFLOW EXCEPTION TEST") ;
-
- END OVERFLOW_EXCEPTION_TEST ;
-
- LOCAL_BLOCK:
-
- DECLARE
-
- TYPE PERSON_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF PERSON;
-
- FIRST_PERSON_TABLE : PERSON_TABLE ;
-
- TABLE_INDEX : POSITIVE := 1 ;
-
- PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ;
- CONTINUE : OUT BOOLEAN) ;
-
- PROCEDURE GATHER_PERSON_ITERATE IS NEW
- PERSON_STACK.ITERATE (PROCESS => GATHER_PEOPLE) ;
-
- PROCEDURE SHOW_PERSON_ITERATE IS NEW
- PERSON_STACK.ITERATE (PROCESS => SHOW_PEOPLE) ;
-
- PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ;
- CONTINUE : OUT BOOLEAN) IS
- BEGIN -- GATHER_PEOPLE
-
- FIRST_PERSON_TABLE (TABLE_INDEX) := THIS_PERSON ;
- TABLE_INDEX := TABLE_INDEX + 1 ;
-
- CONTINUE := TRUE ;
-
- END GATHER_PEOPLE ;
-
- PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ;
- CONTINUE : OUT BOOLEAN) IS
-
- BEGIN -- SHOW_PEOPLE
-
- REPORT.COMMENT ("THE BIRTH MONTH IS " &
- MONTH_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.MONTH)) ;
- REPORT.COMMENT ("THE BIRTH DAY IS " &
- DAY_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.DAY)) ;
- REPORT.COMMENT ("THE BIRTH YEAR IS " &
- YEAR_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.YEAR)) ;
- REPORT.COMMENT ("THE GENDER IS " &
- SEX'IMAGE (THIS_PERSON.GENDER)) ;
- REPORT.COMMENT ("THE NAME IS " & THIS_PERSON.NAME) ;
-
- CONTINUE := TRUE ;
-
- END SHOW_PEOPLE ;
-
- BEGIN -- LOCAL_BLOCK
-
- REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ;
- SHOW_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK) ;
-
- REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ;
- SHOW_PERSON_ITERATE (OVER_THIS_STACK => SECOND_PERSON_STACK) ;
-
- GATHER_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK);
- IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
- (FIRST_PERSON_TABLE (2) /= FRIEND) THEN
- REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ;
- END IF ;
-
- TABLE_INDEX := 1 ;
- GATHER_PERSON_ITERATE(OVER_THIS_STACK => SECOND_PERSON_STACK);
- IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR
- (FIRST_PERSON_TABLE (2) /= DAUGHTER) THEN
- REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ;
- END IF ;
-
- END LOCAL_BLOCK ;
-
- REPORT.RESULT ;
-
-END CC3019C2M ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada
deleted file mode 100644
index cd238c1..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada
+++ /dev/null
@@ -1,207 +0,0 @@
--- CC3106B.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 FORMAL PARAMETER DENOTES THE ACTUAL
--- IN AN INSTANTIATION.
-
--- HISTORY:
--- LDC 06/20/88 CREATED ORIGINAL TEST
--- EDWARD V. BERARD, 10 AUGUST 1990 ADDED CHECKS FOR MULTI-
--- DIMENSIONAL ARRAYS
-
-WITH REPORT ;
-
-PROCEDURE CC3106B IS
-
-BEGIN -- CC3106B
-
- REPORT.TEST("CC3106B","CHECK THAT THE FORMAL PARAMETER DENOTES " &
- "THE ACTUAL IN AN INSTANTIATION");
-
- LOCAL_BLOCK:
-
- DECLARE
-
- SUBTYPE SM_INT IS INTEGER RANGE 0..15 ;
- TYPE PCK_BOL IS ARRAY (5..18) OF BOOLEAN ;
- PRAGMA PACK(PCK_BOL) ;
-
- SHORT_START : CONSTANT := -100 ;
- SHORT_END : CONSTANT := 100 ;
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
-
- SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
-
- SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
-
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 8,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (DAY => 6,
- MONTH => JUN,
- YEAR => 1967) ;
-
- WALL_DATE : DATE := (MONTH => NOV,
- DAY => 9,
- YEAR => 1989) ;
-
- SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
-
- TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
- FIRST_HALF,
- FIRST_FIVE) OF DATE ;
-
- TD_ARRAY : THREE_DIMENSIONAL := (THREE_DIMENSIONAL'RANGE =>
- (THREE_DIMENSIONAL'RANGE (2) =>
- (THREE_DIMENSIONAL'RANGE (3) =>
- TODAY))) ;
-
- TASK TYPE TSK IS
- ENTRY ENT_1;
- ENTRY ENT_2;
- ENTRY ENT_3;
- END TSK;
-
- GENERIC
-
- TYPE GEN_TYPE IS (<>);
- GEN_BOLARR : IN OUT PCK_BOL;
- GEN_TYP : IN OUT GEN_TYPE;
- GEN_TSK : IN OUT TSK;
- TEST_VALUE : IN DATE ;
- TEST_CUBE : IN OUT THREE_DIMENSIONAL ;
-
- PACKAGE P IS
- PROCEDURE GEN_PROC1 ;
- PROCEDURE GEN_PROC2 ;
- PROCEDURE GEN_PROC3 ;
- PROCEDURE ARRAY_TEST ;
- END P;
-
- ACT_BOLARR : PCK_BOL := (OTHERS => FALSE);
- SI : SM_INT := 0 ;
- T : TSK;
-
- PACKAGE BODY P IS
-
- PROCEDURE GEN_PROC1 IS
- BEGIN -- GEN_PROC1
- GEN_BOLARR(14) := REPORT.IDENT_BOOL(TRUE);
- GEN_TYP := GEN_TYPE'VAL(4);
- IF ACT_BOLARR(14) /= TRUE OR SI /= REPORT.IDENT_INT(4)
- THEN
- REPORT.FAILED("VALUES ARE DIFFERENT THAN " &
- "INSTANTIATED VALUES");
- END IF;
- END GEN_PROC1;
-
- PROCEDURE GEN_PROC2 IS
- BEGIN -- GEN_PROC2
- IF GEN_BOLARR(9) /= REPORT.IDENT_BOOL(TRUE) OR
- GEN_TYPE'POS(GEN_TYP) /= REPORT.IDENT_INT(2) THEN
- REPORT.FAILED("VALUES ARE DIFFERENT THAN " &
- "VALUES ASSIGNED IN THE MAIN " &
- "PROCEDURE");
- END IF;
- GEN_BOLARR(18) := TRUE;
- GEN_TYP := GEN_TYPE'VAL(9);
- END GEN_PROC2;
-
- PROCEDURE GEN_PROC3 IS
- BEGIN -- GEN_PROC3
- GEN_TSK.ENT_2;
- END GEN_PROC3 ;
-
- PROCEDURE ARRAY_TEST IS
- BEGIN -- ARRAY_TEST
-
- TEST_CUBE (0, JUN, 'C') := TEST_VALUE ;
-
- IF (TD_ARRAY (0, JUN, 'C') /= TEST_VALUE) OR
- (TEST_CUBE (-5, MAR, 'A') /= WALL_DATE) THEN
- REPORT.FAILED ("MULTI-DIMENSIONAL ARRAY VALUES ARE " &
- "DIFFERENT THAN THE VALUES ASSIGNED " &
- "IN THE MAIN AND ARRAY_TEST PROCEDURES.") ;
- END IF ;
-
- END ARRAY_TEST ;
-
- END P ;
-
- TASK BODY TSK IS
- BEGIN -- TSK
- ACCEPT ENT_1 DO
- REPORT.COMMENT("TASK ENTRY 1 WAS CALLED");
- END;
- ACCEPT ENT_2 DO
- REPORT.COMMENT("TASK ENTRY 2 WAS CALLED");
- END;
- ACCEPT ENT_3 DO
- REPORT.COMMENT("TASK ENTRY 3 WAS CALLED");
- END;
- END TSK;
-
- PACKAGE INSTA1 IS NEW P (GEN_TYPE => SM_INT,
- GEN_BOLARR => ACT_BOLARR,
- GEN_TYP => SI,
- GEN_TSK => T,
- TEST_VALUE => FIRST_DATE,
- TEST_CUBE => TD_ARRAY) ;
-
- BEGIN -- LOCAL_BLOCK
-
- INSTA1.GEN_PROC1;
- ACT_BOLARR(9) := TRUE;
- SI := 2;
- INSTA1.GEN_PROC2;
- IF ACT_BOLARR(18) /= REPORT.IDENT_BOOL(TRUE) OR
- SI /= REPORT.IDENT_INT(9) THEN
- REPORT.FAILED("VALUES ARE DIFFERENT THAN VALUES " &
- "ASSIGNED IN THE GENERIC PROCEDURE");
- END IF;
-
- T.ENT_1;
- INSTA1.GEN_PROC3;
- T.ENT_3;
-
- TD_ARRAY (-5, MAR, 'A') := WALL_DATE ;
- INSTA1.ARRAY_TEST ;
-
- END LOCAL_BLOCK;
-
- REPORT.RESULT;
-
-END CC3106B ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada
deleted file mode 100644
index dc709c3..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada
+++ /dev/null
@@ -1,180 +0,0 @@
--- CC3120A.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 GENERIC IN PARAMETERS ARE ALWAYS COPIED, AND THAT
--- GENERIC IN OUT PARAMETERS ARE ALWAYS RENAMED.
-
--- DAT 8/10/81
--- SPS 10/21/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3120A IS
-BEGIN
- TEST ("CC3120A", "GENERIC IN PARMS ARE COPIED, GENERIC IN OUT"
- & " PARMS ARE RENAMED");
-
- DECLARE
- S1, S2 : INTEGER;
- A1, A2, A3 : STRING (1 .. IDENT_INT (3));
-
- TYPE REC IS RECORD
- C1, C2 : INTEGER := 1;
- END RECORD;
-
- R1, R2 : REC;
-
- PACKAGE P IS
- TYPE PRIV IS PRIVATE;
- PROCEDURE SET_PRIV (P : IN OUT PRIV);
- PRIVATE
- TYPE PRIV IS NEW REC;
- END P;
- USE P;
-
- P1, P2 : PRIV;
- EX : EXCEPTION;
-
- GENERIC
- TYPE T IS PRIVATE;
- P1 : IN OUT T;
- P2 : IN T;
- PROCEDURE GP;
-
- B_ARR : ARRAY (1..10) OF BOOLEAN;
-
- PACKAGE BODY P IS
- PROCEDURE SET_PRIV (P : IN OUT PRIV) IS
- BEGIN
- P.C1 := 3;
- END SET_PRIV;
- END P;
-
- PROCEDURE GP IS
- BEGIN
- IF P1 = P2 THEN
- FAILED ("PARAMETER SCREW_UP SOMEWHERE");
- END IF;
- P1 := P2;
- IF P1 /= P2 THEN
- FAILED ("ASSIGNMENT SCREW_UP SOMEWHERE");
- END IF;
- RAISE EX;
- FAILED ("RAISE STATEMENT DOESN'T WORK");
- END GP;
- BEGIN
- S1 := 4;
- S2 := 5;
- A1 := "XYZ";
- A2 := "ABC";
- A3 := "DEF";
- R1.C1 := 4;
- R2.C1 := 5;
- B_ARR := (1|3|5|7|9 => TRUE, 2|4|6|8|10 => FALSE);
- SET_PRIV (P2);
-
- IF S1 = S2
- OR A1 = A3
- OR R1 = R2
- OR P1 = P2 THEN
- FAILED ("WRONG ASSIGNMENT");
- END IF;
- BEGIN
- DECLARE
- PROCEDURE PR IS NEW GP (INTEGER, S1, S2);
- BEGIN
- S2 := S1;
- PR; -- OLD S2 ASSIGNED TO S1, SO S1 /= S2 NOW
- FAILED ("EX NOT RAISED 1");
- EXCEPTION
- WHEN EX => NULL;
- END;
-
- DECLARE
- SUBTYPE STR_1_3 IS STRING (IDENT_INT (1)..3);
- PROCEDURE PR IS NEW GP (STR_1_3, A1, A3);
- BEGIN
- A3 := A1;
- PR;
- FAILED ("EX NOT RAISED 2");
- EXCEPTION
- WHEN EX => NULL;
- END;
-
- DECLARE
- PROCEDURE PR IS NEW GP (REC, R1, R2);
- BEGIN
- R2 := R1;
- PR;
- FAILED ("EX NOT RAISED 3");
- EXCEPTION
- WHEN EX => NULL;
- END;
-
- DECLARE
- PROCEDURE PR IS NEW GP (PRIV, P1, P2);
- BEGIN
- P2 := P1;
- PR;
- FAILED ("EX NOT RAISED 4");
- EXCEPTION
- WHEN EX => NULL;
- END;
- DECLARE
- PROCEDURE PR IS NEW GP (CHARACTER,
- A3(IDENT_INT(2)),
- A3(IDENT_INT(3)));
- BEGIN
- A3(3) := A3(2);
- PR;
- FAILED ("EX NOT RAISED 5");
- EXCEPTION
- WHEN EX => NULL;
- END;
-
- DECLARE
- PROCEDURE PR IS NEW GP (BOOLEAN,
- B_ARR(IDENT_INT(2)),
- B_ARR(IDENT_INT(3)));
- BEGIN
- B_ARR(3) := B_ARR(2);
- PR;
- FAILED ("EX NOT RAISED 6");
- EXCEPTION
- WHEN EX => NULL;
- END;
- END;
-
- IF S1 = S2
- OR A1 = A2
- OR R1 = R2
- OR P1 = P2
- OR A3(2) = A3(3)
- OR B_ARR(2) = B_ARR(3) THEN
- FAILED ("ASSIGNMENT FAILED 2");
- END IF;
- END;
-
- RESULT;
-END CC3120A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada
deleted file mode 100644
index d25f444..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- CC3120B.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 TASKS ARE NOT COPIED AS GENERIC IN OUT PARMS.
-
--- DAT 8/27/81
--- SPS 4/6/82
--- JBG 3/23/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3120B IS
-BEGIN
- TEST ("CC3120B", "TASKS ARE NOT COPIED AS GENERIC PARAMETERS");
-
- DECLARE
- PACKAGE P IS
- TYPE T IS LIMITED PRIVATE;
- PROCEDURE UPDT (TPARM: IN T; I : IN OUT INTEGER);
- PRIVATE
- TASK TYPE T1 IS
- ENTRY GET (I : OUT INTEGER);
- ENTRY PUT (I : IN INTEGER);
- END T1;
- TYPE T IS RECORD
- C : T1;
- END RECORD;
- END P;
- USE P;
- TT : T;
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- T1 : IN OUT T;
- WITH PROCEDURE UPDT (TPARM : IN T; I: IN OUT INTEGER)
- IS <> ;
- PROCEDURE PR;
-
- PROCEDURE PR IS
- I : INTEGER;
- BEGIN
- I := 5;
- -- PR.I
- -- UPDT.I UPDT.T1.I
- -- 5 4
- UPDT (T1, I);
- -- 4 5
- IF I /= 4 THEN
- FAILED ("BAD VALUE 1");
- END IF;
- I := 6;
- -- 6 5
- UPDT (T1, I);
- -- 5 6
- IF I /= 5 THEN
- FAILED ("BAD VALUE 3");
- END IF;
- RAISE TASKING_ERROR;
- FAILED ("INCORRECT RAISE STATEMENT");
- END PR;
-
- PACKAGE BODY P IS
- PROCEDURE UPDT (TPARM : IN T; I : IN OUT INTEGER) IS
- V : INTEGER := I;
- -- UPDT.I => V
- -- T1.I => UPDT.I
- -- V => T1.I
- BEGIN
- TPARM.C.GET (I);
- TPARM.C.PUT (V);
- END UPDT;
-
- TASK BODY T1 IS
- I : INTEGER;
- BEGIN
- I := 1;
- LOOP
- SELECT
- ACCEPT GET (I : OUT INTEGER) DO
- I := T1.I;
- END GET;
- OR
- ACCEPT PUT (I : IN INTEGER) DO
- T1.I := I;
- END PUT;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END T1;
- END P;
- BEGIN
- DECLARE
- X : INTEGER := 2;
- PROCEDURE PPP IS NEW PR (T, TT);
- BEGIN
- -- X
- -- UPDT.I UPDT.T1.I
- -- 2 1
- UPDT (TT, X);
- -- 1 2
- X := X + 3;
- -- 4 2
- UPDT (TT, X);
- -- 2 4
- IF X /= 2 THEN
- FAILED ("WRONG VALUE FOR X");
- END IF;
- BEGIN
- PPP;
- FAILED ("PPP NOT CALLED");
- EXCEPTION
- WHEN TASKING_ERROR => NULL;
- END;
- X := 12;
- -- 12 6
- UPDT (TT, X);
- -- 6 12
- IF X /= 6 THEN
- FAILED ("WRONG FINAL VALUE IN TASK");
- END IF;
- END;
- END;
-
- RESULT;
-END CC3120B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada
deleted file mode 100644
index a0a8e4a..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- CC3121A.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 UNCONSTRAINED FORMAL GENERIC PARAMETER OF MODE "IN"
--- HAVING AN ARRAY TYPE OR A TYPE WITH DISCRIMINANTS HAS THE CONSTRAINTS
--- OF THE ACTUAL PARAMETER.
-
--- TBN 9/29/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3121A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 10;
-
- TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER;
-
- TYPE REC1 (D : INT) IS
- RECORD
- VAR1 : INTEGER := 1;
- END RECORD;
-
- TYPE REC2 (D : INT := 2) IS
- RECORD
- A : ARRAY1 (D .. IDENT_INT(4));
- B : REC1 (D);
- C : INTEGER := 1;
- END RECORD;
-
- TYPE ARRAY2 IS ARRAY (INT RANGE <>) OF REC2;
-
-BEGIN
- TEST ("CC3121A", "CHECK THAT AN UNCONSTRAINED FORMAL GENERIC " &
- "PARAMETER OF MODE 'IN' HAVING AN ARRAY TYPE " &
- "OR A TYPE WITH DISCRIMINANTS HAS THE " &
- "CONSTRAINTS OF THE ACTUAL PARAMETER");
-
- DECLARE
- OBJ_ARA1 : ARRAY1 (IDENT_INT(2) .. 5);
-
- GENERIC
- VAR : ARRAY1;
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- BEGIN
- IF VAR'FIRST /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FOR VAR'FIRST");
- END IF;
- IF VAR'LAST /= IDENT_INT(5) THEN
- FAILED ("INCORRECT RESULTS FOR VAR'LAST");
- END IF;
- END PROC;
-
- PROCEDURE PROC1 IS NEW PROC (OBJ_ARA1);
- BEGIN
- PROC1;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- OBJ_REC2 : REC2;
-
- GENERIC
- VAR : REC2;
- FUNCTION FUNC RETURN INTEGER;
-
- FUNCTION FUNC RETURN INTEGER IS
- BEGIN
- IF VAR.D /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.D");
- END IF;
- IF VAR.A'FIRST /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST");
- END IF;
- IF VAR.A'LAST /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.A'LAST");
- END IF;
- IF VAR.B.D /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.B.D");
- END IF;
- RETURN IDENT_INT(1);
- END FUNC;
-
- FUNCTION FUNC1 IS NEW FUNC (OBJ_REC2);
-
- BEGIN
- IF FUNC1 /= IDENT_INT(1) THEN
- FAILED ("INCORRECT RESULTS FROM FUNC1 CALL");
- END IF;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- OBJ_ARA2 : ARRAY2 (IDENT_INT(6) .. 8);
-
- GENERIC
- VAR : ARRAY2;
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- BEGIN
- IF VAR'FIRST /= IDENT_INT(6) THEN
- FAILED ("INCORRECT RESULTS FOR VAR'FIRST");
- END IF;
- IF VAR'LAST /= IDENT_INT(8) THEN
- FAILED ("INCORRECT RESULTS FOR VAR'LAST");
- END IF;
- IF VAR(6).D /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR(6).D");
- END IF;
- IF VAR(6).A'FIRST /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR(6).A'FIRST");
- END IF;
- IF VAR(6).A'LAST /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RESULTS FROM VAR(6).A'LAST");
- END IF;
- IF VAR(6).B.D /= IDENT_INT(2) THEN
- FAILED ("INCORRECT RESULTS FROM VAR(6).B.D");
- END IF;
- END PROC;
-
- PROCEDURE PROC2 IS NEW PROC (OBJ_ARA2);
- BEGIN
- PROC2;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- OBJ_REC3 : REC2 (3);
-
- GENERIC
- VAR : REC2;
- PACKAGE PAC IS
- PAC_VAR : INTEGER := 1;
- END PAC;
-
- PACKAGE BODY PAC IS
- BEGIN
- IF VAR.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.D");
- END IF;
- IF VAR.A'FIRST /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST");
- END IF;
- IF VAR.A'LAST /= IDENT_INT(4) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.A'LAST");
- END IF;
- IF VAR.B.D /= IDENT_INT(3) THEN
- FAILED ("INCORRECT RESULTS FROM VAR.B.D");
- END IF;
- END PAC;
-
- PACKAGE PAC1 IS NEW PAC (OBJ_REC3);
-
- BEGIN
- NULL;
- END;
-
- -------------------------------------------------------------------
-
- RESULT;
-END CC3121A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada
deleted file mode 100644
index 917f5fd..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- CC3123A.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 DEFAULT EXPRESSIONS FOR GENERIC IN PARAMETERS ARE ONLY
--- EVALUATED IF THERE ARE NO ACTUAL PARAMETERS.
-
--- TBN 12/01/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3123A IS
-
-BEGIN
- TEST ("CC3123A", "CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN " &
- "PARAMETERS ARE ONLY EVALUATED IF THERE ARE " &
- "NO ACTUAL PARAMETERS");
- DECLARE
- TYPE ENUM IS (I, II, III);
- OBJ_INT : INTEGER := 1;
- OBJ_ENUM : ENUM := I;
-
- GENERIC
- GEN_INT : IN INTEGER := IDENT_INT(2);
- GEN_BOOL : IN BOOLEAN := IDENT_BOOL(FALSE);
- GEN_ENUM : IN ENUM := II;
- PACKAGE P IS
- PAC_INT : INTEGER := GEN_INT;
- PAC_BOOL : BOOLEAN := GEN_BOOL;
- PAC_ENUM : ENUM := GEN_ENUM;
- END P;
-
- PACKAGE P1 IS NEW P;
- PACKAGE P2 IS
- NEW P (IDENT_INT(OBJ_INT), GEN_ENUM => OBJ_ENUM);
- PACKAGE P3 IS NEW P (GEN_BOOL => IDENT_BOOL(TRUE));
- BEGIN
- IF P1.PAC_INT /= 2 OR P1.PAC_BOOL OR P1.PAC_ENUM /= II THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED");
- END IF;
- IF P2.PAC_INT /= 1 OR P2.PAC_BOOL OR P2.PAC_ENUM /= I THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " &
- "- 1");
- END IF;
- IF P3.PAC_INT /= 2 OR NOT(P3.PAC_BOOL) OR
- P3.PAC_ENUM /= II THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " &
- "- 2");
- END IF;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- OBJ_INT1 : INTEGER := 3;
-
- FUNCTION FUNC (X : INTEGER) RETURN INTEGER;
-
- GENERIC
- GEN_INT1 : IN INTEGER := FUNC (1);
- GEN_INT2 : IN INTEGER := FUNC (GEN_INT1 + 1);
- PROCEDURE PROC;
-
- PROCEDURE PROC IS
- PROC_INT1 : INTEGER := GEN_INT1;
- PROC_INT2 : INTEGER := GEN_INT2;
- BEGIN
- IF PROC_INT1 /= 3 THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
- "CORRECTLY - 3");
- END IF;
- IF PROC_INT2 /= 4 THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
- "CORRECTLY - 4");
- END IF;
- END PROC;
-
- FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS
- BEGIN
- IF X /= IDENT_INT(4) THEN
- FAILED ("DEFAULT VALUES WERE NOT EVALUATED " &
- "CORRECTLY - 5");
- END IF;
- RETURN IDENT_INT(X);
- END FUNC;
-
- PROCEDURE NEW_PROC IS NEW PROC (GEN_INT1 => OBJ_INT1);
-
- BEGIN
- NEW_PROC;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER;
- TYPE REC IS
- RECORD
- ANS : BOOLEAN;
- ARA : ARA_TYP;
- END RECORD;
- TYPE ARA_REC IS ARRAY (1 .. 5) OF REC;
-
- FUNCTION F (X : INTEGER) RETURN INTEGER;
-
- OBJ_REC : REC := (FALSE, (3, 4));
- OBJ_ARA : ARA_REC := (1 .. 5 => (FALSE, (3, 4)));
-
- GENERIC
- GEN_OBJ1 : IN ARA_TYP := (F(1), 2);
- GEN_OBJ2 : IN REC := (TRUE, GEN_OBJ1);
- GEN_OBJ3 : IN ARA_REC := (1 .. F(5) => (TRUE, (1, 2)));
- FUNCTION FUNC RETURN INTEGER;
-
- FUNCTION FUNC RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END FUNC;
-
- FUNCTION F (X : INTEGER) RETURN INTEGER IS
- BEGIN
- FAILED ("DEFAULT VALUES WERE EVALUATED - 1");
- RETURN IDENT_INT(X);
- END F;
-
- FUNCTION NEW_FUNC IS NEW FUNC ((3, 4), OBJ_REC, OBJ_ARA);
-
- BEGIN
- IF NOT EQUAL (NEW_FUNC, 1) THEN
- FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 1");
- END IF;
- END;
-
- -------------------------------------------------------------------
- DECLARE
- SUBTYPE INT IS INTEGER RANGE 1 .. 5;
- TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER;
- TYPE COLOR IS (RED, WHITE);
- TYPE CON_REC (D : INT) IS
- RECORD
- A : COLOR;
- B : ARA_TYP;
- END RECORD;
- TYPE UNCON_OR_CON_REC (D : INT := 2) IS
- RECORD
- A : COLOR;
- B : ARA_TYP;
- END RECORD;
- FUNCTION F (X : COLOR) RETURN COLOR;
-
- OBJ_CON1 : CON_REC (1) := (1, WHITE, (3, 4));
- OBJ_UNCON : UNCON_OR_CON_REC := (2, WHITE, (3, 4));
- OBJ_CON2 : UNCON_OR_CON_REC (3) := (3, WHITE, (3, 4));
-
- GENERIC
- GEN_CON1 : IN CON_REC := (2, F(RED), (1, 2));
- GEN_UNCON : IN UNCON_OR_CON_REC := (2, F(RED), (1, 2));
- GEN_CON2 : IN UNCON_OR_CON_REC := GEN_UNCON;
- FUNCTION FUNC RETURN INTEGER;
-
- FUNCTION FUNC RETURN INTEGER IS
- BEGIN
- RETURN IDENT_INT(1);
- END FUNC;
-
- FUNCTION F (X : COLOR) RETURN COLOR IS
- BEGIN
- FAILED ("DEFAULT VALUES WERE EVALUATED - 2");
- RETURN WHITE;
- END F;
-
- FUNCTION NEW_FUNC IS NEW FUNC (OBJ_CON1, OBJ_UNCON, OBJ_CON2);
-
- BEGIN
- IF NOT EQUAL (NEW_FUNC, 1) THEN
- FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 2");
- END IF;
- END;
-
- RESULT;
-END CC3123A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada
deleted file mode 100644
index 4adff6d..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CC3125A.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 IF THE INITIAL VALUE OF A
--- GENERIC IN PARAMETER DOES NOT SATISFY ITS SUBTYPE CONSTRAINT.
-
--- THIS TEST CHECKS PARAMETERS OF A NON-GENERIC TYPE.
-
--- DAT 8/10/81
--- SPS 4/14/82
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3125A IS
-
-BEGIN
- TEST ("CC3125A","GENERIC PARAMETER DEFAULTS OF " &
- "NON-GENERIC TYPE EVALUATED AND CHECKED WHEN " &
- "DECLARATION IS INSTANTIATED AND DEFAULT USED");
-
- FOR I IN 1 .. 3 LOOP
- COMMENT ("LOOP ITERATION");
- BEGIN
-
- DECLARE
- SUBTYPE T IS INTEGER RANGE 1 .. IDENT_INT(1);
- SUBTYPE I_1_2 IS INTEGER RANGE
- IDENT_INT (1) .. IDENT_INT (2);
-
- GENERIC
- P,Q : T := I_1_2'(I);
- PACKAGE PKG IS
- R: T := P;
- END PKG;
-
- BEGIN
-
- BEGIN
- DECLARE
- PACKAGE P1 IS NEW PKG;
- BEGIN
- IF I = IDENT_INT(1) THEN
- IF P1.R /= IDENT_INT(1)
- THEN FAILED ("BAD INITIAL"&
- " VALUE");
- END IF;
- ELSIF I = 2 THEN
- FAILED ("SUBTYPE NOT CHECKED AT " &
- "INSTANTIATION");
- ELSE
- FAILED ("DEFAULT NOT EVALUATED AT " &
- "INSTANTIATION");
- END IF;
- EXCEPTION
- WHEN OTHERS => FAILED ("WRONG HANDLER");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- CASE I IS
- WHEN 1 =>
- FAILED ("INCORRECT EXCEPTION");
- WHEN 2 =>
- COMMENT ("CONSTRAINT CHECKED" &
- " ON INSTANTIATION");
- WHEN 3 =>
- COMMENT ("DEFAULT EVALUATED " &
- "ON INSTANTIATION");
- END CASE;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- CASE I IS
- WHEN 1 =>
- FAILED ("NO EXCEPTION SHOULD BE RAISED");
- WHEN 2 =>
- FAILED ("DEFAULT CHECKED AGAINST " &
- "SUBTYPE AT DECLARATION");
- WHEN 3 =>
- FAILED ("DEFAULT EVALUATED AT " &
- "DECLARATION");
- END CASE;
- END;
- END LOOP;
-
- RESULT;
-END CC3125A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada
deleted file mode 100644
index 84d6d11..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- CC3125B.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 A GENERIC IN PARAMETER
--- HAVING AN ENUMERATION TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL
--- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER.
-
--- TBN 12/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3125B IS
-
- TYPE COLOR IS (GREEN, RED, WHITE, BLUE, ORANGE, PINK);
- SUBTYPE FLAG IS COLOR RANGE RED .. BLUE;
-
- FUNCTION IDENT_COL (X : COLOR) RETURN COLOR IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- END IF;
- RETURN GREEN;
- END IDENT_COL;
-
-BEGIN
- TEST ("CC3125B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " &
- "GENERIC IN PARAMETER HAVING AN ENUMERATION " &
- "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " &
- "PARAMETER LIES OUTSIDE THE RANGE OF THE " &
- "FORMAL PARAMETER");
- DECLARE
- GENERIC
- GEN_COL : IN FLAG;
- PACKAGE P IS
- PAC_COL : FLAG := GEN_COL;
- END P;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE P1 IS NEW P(IDENT_COL(RED));
- BEGIN
- IF P1.PAC_COL /= IDENT_COL(RED) THEN
- FAILED ("INCORRECT VALUE PASSED - 1");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P2 IS NEW P(IDENT_COL(GREEN));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P3 IS NEW P(IDENT_COL(PINK));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- GENERIC
- TYPE GEN_TYP IS (<>);
- GEN_COL : IN GEN_TYP;
- PACKAGE Q IS
- PAC_COL : GEN_TYP := GEN_COL;
- END Q;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE Q1 IS NEW Q(FLAG, IDENT_COL(BLUE));
- BEGIN
- IF Q1.PAC_COL /= IDENT_COL(BLUE) THEN
- FAILED ("INCORRECT VALUE PASSED - 4");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q2 IS NEW Q(FLAG, IDENT_COL(GREEN));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q3 IS NEW Q(FLAG, IDENT_COL(PINK));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- END;
-
- RESULT;
-END CC3125B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada
deleted file mode 100644
index 42904bd..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- CC3125C.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 A GENERIC IN PARAMETER
--- HAVING A FLOATING POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL
--- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER.
-
--- TBN 12/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3125C IS
-
- TYPE FLT IS DIGITS 5 RANGE -10.0 .. 10.0;
- SUBTYPE FLO IS FLT RANGE -5.0 .. 5.0;
-
- FUNCTION IDENT_FLT (X : FLT) RETURN FLT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- END IF;
- RETURN 0.0;
- END IDENT_FLT;
-
-BEGIN
- TEST ("CC3125C", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " &
- "GENERIC IN PARAMETER HAVING A FLOATING POINT " &
- "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " &
- "PARAMETER LIES OUTSIDE THE RANGE OF THE " &
- "FORMAL PARAMETER");
- DECLARE
- GENERIC
- GEN_FLO : IN FLO;
- PACKAGE P IS
- PAC_FLO : FLT := GEN_FLO;
- END P;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE P1 IS NEW P(IDENT_FLT(-5.0));
- BEGIN
- IF P1.PAC_FLO /= IDENT_FLT(-5.0) THEN
- FAILED ("INCORRECT VALUE PASSED - 1");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P2 IS NEW P(IDENT_FLT(-5.1));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P3 IS NEW P(IDENT_FLT(5.1));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- GENERIC
- TYPE GEN_TYP IS DIGITS <>;
- GEN_FLO : IN GEN_TYP;
- PACKAGE Q IS
- PAC_FLO : GEN_TYP := GEN_FLO;
- END Q;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE Q1 IS NEW Q(FLO, IDENT_FLT(5.0));
- BEGIN
- IF Q1.PAC_FLO /= IDENT_FLT(5.0) THEN
- FAILED ("INCORRECT VALUE PASSED - 4");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q2 IS NEW Q(FLO, IDENT_FLT(-5.1));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q3 IS NEW Q(FLO, IDENT_FLT(5.1));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- END;
-
- RESULT;
-END CC3125C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada
deleted file mode 100644
index 5977eb9..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- CC3125D.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 A GENERIC IN PARAMETER
--- HAVING A FIXED POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL
--- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER.
-
--- TBN 12/15/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3125D IS
-
- TYPE FIXED IS DELTA 0.125 RANGE -10.0 .. 10.0;
- SUBTYPE FIX IS FIXED RANGE -5.0 .. 5.0;
-
- FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- END IF;
- RETURN 0.0;
- END IDENT_FIX;
-
-BEGIN
- TEST ("CC3125D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " &
- "GENERIC IN PARAMETER HAVING A FIXED POINT " &
- "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " &
- "PARAMETER LIES OUTSIDE THE RANGE OF THE " &
- "FORMAL PARAMETER");
- DECLARE
- GENERIC
- GEN_FIX : IN FIX;
- PACKAGE P IS
- PAC_FIX : FIXED := GEN_FIX;
- END P;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE P1 IS NEW P(IDENT_FIX(-5.0));
- BEGIN
- IF P1.PAC_FIX /= IDENT_FIX(-5.0) THEN
- FAILED ("INCORRECT VALUE PASSED - 1");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P2 IS NEW P(IDENT_FIX(-5.2));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DECLARE
- PACKAGE P3 IS NEW P(IDENT_FIX(5.2));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 3");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
- END;
- -------------------------------------------------------------------
-
- DECLARE
- GENERIC
- TYPE GEN_TYP IS DELTA <>;
- GEN_FIX : IN GEN_TYP;
- PACKAGE Q IS
- PAC_FIX : GEN_TYP := GEN_FIX;
- END Q;
- BEGIN
- BEGIN
- DECLARE
- PACKAGE Q1 IS NEW Q(FIX, IDENT_FIX(5.0));
- BEGIN
- IF Q1.PAC_FIX /= IDENT_FIX(5.0) THEN
- FAILED ("INCORRECT VALUE PASSED - 4");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q2 IS NEW Q(FIX, IDENT_FIX(-5.2));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 5");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- DECLARE
- PACKAGE Q3 IS NEW Q(FIX, IDENT_FIX(5.2));
- BEGIN
- FAILED ("NO EXCEPTION RAISED - 6");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
- END;
- END;
-
- RESULT;
-END CC3125D;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada
deleted file mode 100644
index ba23464..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada
+++ /dev/null
@@ -1,188 +0,0 @@
--- CC3126A.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 CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL
--- PARAMETER DOES NOT HAVE THE SAME NUMBER OF COMPONENTS
--- (PER DIMENSION) AS THE FORMAL PARAMETER. ALSO THAT FOR NULL
--- ARRAYS NO ERROR IS RAISED.
-
--- HISTORY:
--- LB 12/02/86
--- DWC 08/11/87 CHANGED HEADING FORMAT.
--- RJW 10/26/89 INITIALIZED VARIABLE H.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3126A IS
-
-BEGIN
- TEST ("CC3126A","GENERIC ACTUAL PARAMETER MUST HAVE THE SAME "&
- "NUMBER OF COMPONENTS (PER DIMENSION) AS THE "&
- "GENERIC FORMAL PARMETER");
- BEGIN
- DECLARE
- TYPE ARRY1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE ARR IS ARRY1 (1 .. 10);
-
- GENERIC
- GARR : IN ARR;
- PACKAGE P IS
- NARR : ARR := GARR;
- END P;
-
- BEGIN
- BEGIN
- DECLARE
- X : ARRY1 (2 .. 11) := (2 .. 11 => 0);
- PACKAGE Q IS NEW P(X);
- BEGIN
- Q.NARR(2) := 1;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 1");
- END;
-
- BEGIN
- DECLARE
- S : ARRY1 (1 .. 11) := (1 .. 11 => 0);
- PACKAGE R IS NEW P(S);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 2");
- R.NARR(1) := IDENT_INT(R.NARR(1));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 2");
- END;
-
- BEGIN
- DECLARE
- G : ARRY1 (1 .. 9) := (1 .. 9 => 0);
- PACKAGE K IS NEW P(G);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 3");
- IF EQUAL(3,3) THEN
- K.NARR(1) := IDENT_INT(K.NARR(1));
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- S : ARRY1 (1 .. 11) := (1 .. 11 => 0);
- PACKAGE F IS NEW P(S(2 .. 11));
- BEGIN
- F.NARR(2) := IDENT_INT(F.NARR(2));
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 4");
- END;
- END;
-
- DECLARE
- SUBTYPE STR IS STRING(1 .. 20);
-
- GENERIC
- GVAR : IN STR;
- PACKAGE M IS
- NVAR : STR := GVAR;
- END M;
-
- BEGIN
- BEGIN
- DECLARE
- L : STRING (2 .. 15);
- PACKAGE U IS NEW M(L);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 5");
- U.NVAR(2) := IDENT_CHAR(U.NVAR(2));
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 5");
- END;
-
- BEGIN
- DECLARE
- H : STRING (1 .. 20) := (OTHERS => 'R');
- PACKAGE J IS NEW M(H);
- BEGIN
- IF EQUAL(3,3) THEN
- J.NVAR(2) := IDENT_CHAR(J.NVAR(2));
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 6");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED STRINGS");
- END;
-
- DECLARE
- TYPE NARRY IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- SUBTYPE SNARRY IS NARRY (2 .. 0);
-
- GENERIC
- RD : IN SNARRY;
- PACKAGE JA IS
- CD : SNARRY := RD;
- END JA;
- BEGIN
- BEGIN
- DECLARE
- AD : NARRY(1 .. 0);
- PACKAGE PA IS NEW JA(AD);
- BEGIN
- IF NOT EQUAL(0,PA.CD'LAST) THEN
- FAILED ("PARAMETER ATTRIBUTE INCORRECT");
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 7");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ARRAYS "&
- "WITH NULL RANGES");
- END;
- END;
-
- RESULT;
-
-END CC3126A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada
deleted file mode 100644
index 9e1ccdb..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada
+++ /dev/null
@@ -1,143 +0,0 @@
--- CC3127A.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:
--- FOR A CONSTRAINED IN FORMAL PARAMETER HAVING A RECORD OR PRIVATE
--- TYPE WITH DISCRIMINANTS, CHECK THAT CONSTRAINT_ERROR IS RAISED
--- IF AND ONLY IF CORRESPONDING DISCRIMINANTS OF THE ACTUAL AND
--- FORMAL PARAMETER DO NOT HAVE THE SAME VALUES.
-
--- HISTORY:
--- LB 12/04/86 CREATED ORIGINAL TEST.
--- VCL 08/19/87 CORRECTED THE FORMAT OF THIS HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3127A IS
-
- TYPE INT IS RANGE 1 .. 20;
-
-BEGIN
- TEST ("CC3127A","CORRESPONDING DISCRIMINANTS OF THE GENERIC "&
- "ACTUAL PARAMETER AND THE GENERIC FORMAL "&
- "PARAMETER MUST HAVE THE SAME VALUES.");
- BEGIN
- DECLARE
- TYPE REC (A : INT) IS
- RECORD
- RINT : POSITIVE := 2;
- END RECORD;
- SUBTYPE CON_REC IS REC(4);
-
- GENERIC
- GREC : IN CON_REC;
- PACKAGE PA IS
- NREC : CON_REC := GREC;
- END PA;
- BEGIN
- BEGIN
- DECLARE
- RVAR : REC(3);
- PACKAGE AB IS NEW PA(RVAR);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 1");
- AB.NREC.RINT := IDENT_INT(AB.NREC.RINT);
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 1");
- END;
-
- BEGIN
- DECLARE
- SVAR : REC(4);
- PACKAGE CD IS NEW PA(SVAR);
- BEGIN
- IF EQUAL(3,3) THEN
- CD.NREC.RINT := IDENT_INT(CD.NREC.RINT);
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 2");
- END;
- END;
-
- DECLARE
- PACKAGE EF IS
- TYPE PRI_REC (G : INT) IS PRIVATE;
- PRIVATE
- TYPE PRI_REC (G : INT) IS
- RECORD
- PINT : POSITIVE := 2;
- END RECORD;
- END EF;
- SUBTYPE CPRI_REC IS EF.PRI_REC(4);
-
- GENERIC
- GEN_REC : IN CPRI_REC;
- PACKAGE GH IS
- NGEN_REC : CPRI_REC := GEN_REC;
- END GH;
-
- BEGIN
- BEGIN
- DECLARE
- PVAR : EF.PRI_REC(4);
- PACKAGE LM IS NEW GH(PVAR);
- BEGIN
- IF EQUAL(3,3) THEN
- LM.NGEN_REC := LM.NGEN_REC;
- END IF;
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED 3");
- END;
-
- BEGIN
- DECLARE
- PTVAR : EF.PRI_REC(5);
- PACKAGE PAC IS NEW GH(PTVAR);
- BEGIN
- FAILED ("EXCEPTION NOT RAISED 4");
- IF EQUAL(3,5) THEN
- COMMENT ("DISCRIMINANT OF PAC.NGEN_REC IS "&
- INT'IMAGE(PAC.NGEN_REC.G));
- END IF;
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED 4");
- END;
- END;
- END;
-
- RESULT;
-
-END CC3127A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada
deleted file mode 100644
index 9afdd77..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada
+++ /dev/null
@@ -1,358 +0,0 @@
--- CC3128A.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 A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE,
--- CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT
--- NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY
--- THE FORMAL PARAMETER'S CONSTRAINTS.
-
--- HISTORY:
--- RJW 10/28/88 CREATED ORIGINAL TEST.
--- JRL 02/28/96 Removed cases where the designated subtypes of the formal
--- and actual do not statically match. Corrected commentary.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3128A IS
-
-BEGIN
- TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " &
- "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " &
- "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " &
- "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " &
- "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " &
- "CONSTRAINTS");
-
- DECLARE
- TYPE REC (D : INTEGER := 10) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACCREC IS ACCESS REC;
-
- SUBTYPE LINK IS ACCREC (5);
-
- GENERIC
- LINK1 : LINK;
- FUNCTION F (I : INTEGER) RETURN INTEGER;
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- IF I /= 5 THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
- "TO CALL TO FUNCTION F - 1");
- END IF;
- IF NOT EQUAL (I, 5) AND THEN
- NOT EQUAL (LINK1.D, LINK1.D) THEN
- COMMENT ("DISREGARD");
- END IF;
- RETURN I + 1;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1");
- RETURN I + 1;
- END F;
-
- GENERIC
- TYPE PRIV (D : INTEGER) IS PRIVATE;
- PRIV1 : PRIV;
- PACKAGE GEN IS
- TYPE ACCPRIV IS ACCESS PRIV;
- SUBTYPE LINK IS ACCPRIV (5);
- GENERIC
- LINK1 : LINK;
- I : IN OUT INTEGER;
- PACKAGE P IS END P;
- END GEN;
-
- PACKAGE BODY GEN IS
- PACKAGE BODY P IS
- BEGIN
- IF I /= 5 THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
- "TO PACKAGE BODY P - 1");
- END IF;
- IF NOT EQUAL (I, 5) AND THEN
- NOT EQUAL (LINK1.D, LINK1.D) THEN
- COMMENT ("DISREGARD");
- END IF;
- I := I + 1;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WITHIN " &
- "PACKAGE P - 1");
- I := I + 1;
- END P;
-
- BEGIN
- BEGIN
- DECLARE
- AR10 : ACCPRIV;
- I : INTEGER := IDENT_INT (5);
- PACKAGE P1 IS NEW P (AR10, I);
- BEGIN
- IF I /= 6 THEN
- FAILED ("INCORRECT RESULT - " &
- "PACKAGE P1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED TOO LATE - " &
- "PACKAGE P1 - 1");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
- "OF PACKAGE P1 WITH NULL ACCESS " &
- "VALUE");
- END;
-
- BEGIN
- DECLARE
- AR10 : ACCPRIV := NEW PRIV'(PRIV1);
- I : INTEGER := IDENT_INT (0);
- PACKAGE P1 IS NEW P (AR10, I);
- BEGIN
- FAILED ("NO EXCEPTION RAISED BY " &
- "INSTANTIATION OF PACKAGE P1");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED TOO LATE - " &
- "PACKAGE P1 - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED AT " &
- "INSTANTIATION OF PACKAGE P1");
- END;
- END GEN;
-
- PACKAGE NEWGEN IS NEW GEN (REC, (D => 10));
-
- BEGIN
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (5);
- AR10 : ACCREC;
- FUNCTION F1 IS NEW F (AR10);
- BEGIN
- I := F1 (I);
- IF I /= 6 THEN
- FAILED ("INCORRECT RESULT RETURNED BY " &
- "FUNCTION F1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT CALL TO " &
- "FUNCTION F1 - 1");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
- "FUNCTION F1 WITH NULL ACCESS VALUE");
- END;
-
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (0);
- AR10 : ACCREC := NEW REC'(D => 10);
- FUNCTION F1 IS NEW F (AR10);
- BEGIN
- FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
- "OF FUNCTION F1");
- I := F1 (I);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT CALL TO " &
- "FUNCTION F1 - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED AT " &
- "INSTANTIATION OF FUNCTION F1");
- END;
- END;
-
- DECLARE
- TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
-
- TYPE ACCARR IS ACCESS ARR;
-
- SUBTYPE LINK IS ACCARR (1 .. 5);
-
- GENERIC
- LINK1 : LINK;
- FUNCTION F (I : INTEGER) RETURN INTEGER;
-
- FUNCTION F (I : INTEGER) RETURN INTEGER IS
- BEGIN
- IF I /= 5 THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
- "TO CALL TO FUNCTION F - 2");
- END IF;
- IF NOT EQUAL (I, 5) AND THEN
- NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
- THEN
- COMMENT ("DISREGARD");
- END IF;
- RETURN I + 1;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2");
- RETURN I + 1;
- END F;
-
- GENERIC
- TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
- PACKAGE GEN IS
- TYPE ACCGENARR IS ACCESS GENARR;
- SUBTYPE LINK IS ACCGENARR (1 .. 5);
- GENERIC
- LINK1 : LINK;
- I : IN OUT INTEGER;
- PACKAGE P IS END P;
- END GEN;
-
- PACKAGE BODY GEN IS
- PACKAGE BODY P IS
- BEGIN
- IF I /= 5 THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
- "TO PACKAGE BODY P - 2");
- END IF;
- IF NOT EQUAL (I, 5) AND THEN
- NOT
- EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
- THEN
- COMMENT ("DISREGARD");
- END IF;
- I := I + 1;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED WITHIN " &
- "PACKAGE P - 2");
- I := I + 1;
- END P;
-
- BEGIN
- BEGIN
- DECLARE
- AR26 : ACCGENARR (2 .. 6);
- I : INTEGER := IDENT_INT (5);
- PACKAGE P2 IS NEW P (AR26, I);
- BEGIN
- IF I /= 6 THEN
- FAILED ("INCORRECT RESULT - " &
- "PACKAGE P2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED TOO LATE - " &
- "PACKAGE P2 - 1");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
- "OF PACKAGE P2 WITH NULL ACCESS " &
- "VALUE");
- END;
-
- BEGIN
- DECLARE
- AR26 : ACCGENARR
- (IDENT_INT (2) .. IDENT_INT (6)) :=
- NEW GENARR'(1,2,3,4,5);
- I : INTEGER := IDENT_INT (0);
- PACKAGE P2 IS NEW P (AR26, I);
- BEGIN
- FAILED ("NO EXCEPTION RAISED BY " &
- "INSTANTIATION OF PACKAGE P2");
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED TOO LATE - " &
- "PACKAGE P2 - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED AT " &
- "INSTANTIATION OF PACKAGE P2");
- END;
- END GEN;
-
- PACKAGE NEWGEN IS NEW GEN (ARR);
-
- BEGIN
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (5);
- AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6));
- FUNCTION F2 IS NEW F (AR26);
- BEGIN
- I := F2 (I);
- IF I /= 6 THEN
- FAILED ("INCORRECT RESULT RETURNED BY " &
- "FUNCTION F2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT CALL TO " &
- "FUNCTION F2 - 1");
- END;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
- "FUNCTION F2 WITH NULL ACCESS VALUE");
- END;
-
- BEGIN
- DECLARE
- I : INTEGER := IDENT_INT (0);
- AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5);
- FUNCTION F2 IS NEW F (AR26);
- BEGIN
- FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
- "OF FUNCTION F2");
- I := F2 (I);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED AT CALL TO " &
- "FUNCTION F2 - 2");
- END;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED AT " &
- "INSTANTIATION OF FUNCTION F2");
- END;
- END;
- RESULT;
-END CC3128A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada
deleted file mode 100644
index b0228ea..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CC3203A.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 A GENERIC FORMAL LIMITED/NON LIMITED PRIVATE TYPE HAS
--- DISCRIMINANTS, THE ACTUAL PARAMETER CAN HAVE DEFAULT DISCRIMINANT
--- VALUES.
-
--- SPS 7/9/82
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3203A IS
-BEGIN
- TEST ("CC3203A", "CHECK DEFAULT VALUES FOR LIMITED/" &
- "NON LIMITED GENERIC FORMAL PRIVATE TYPES");
- DECLARE
- SD : INTEGER := IDENT_INT(0);
-
- FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER;
-
- TYPE REC (D : INTEGER := 3) IS
- RECORD NULL; END RECORD;
-
- TYPE RC(C : INTEGER := INIT_RC (1)) IS
- RECORD NULL; END RECORD;
-
- GENERIC
- TYPE PV(X : INTEGER) IS PRIVATE;
- TYPE LP(X : INTEGER) IS LIMITED PRIVATE;
- PACKAGE PACK IS
- SUBTYPE NPV IS PV;
- SUBTYPE NLP IS LP;
- END PACK;
-
- FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER IS
- BEGIN
- SD := SD + X;
- RETURN SD;
- END INIT_RC;
-
- PACKAGE P1 IS NEW PACK (REC, RC);
-
- PACKAGE P2 IS
- P1VP : P1.NPV;
- P1VL : P1.NLP;
- P1VL2 : P1.NLP;
- END P2;
- USE P2;
- BEGIN
-
- IF P1VP.D /= IDENT_INT(3) THEN
- FAILED ("DEFAULT DISCRIMINANT VALUE WRONG");
- END IF;
-
- IF P1VL.C /= 1 THEN
- FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT");
- END IF;
-
- IF P1VL2.C /= IDENT_INT(2) THEN
- FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT " &
- "WHEN NEEDED");
- END IF;
- END;
-
- RESULT;
-
-END CC3203A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada
deleted file mode 100644
index 8b6fa03..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- CC3207B.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 INSTANTIATION IS LEGAL IF A FORMAL
--- PARAMETER HAVING A LIMITED PRIVATE TYPE WITHOUT
--- A DISCRIMINANT IS USED TO DECLARE AN ACCESS
--- TYPE IN A BLOCK THAT CONTAINS A SELECTIVE WAIT
--- WITH A TERMINATE ALTERNATIVE, AND ACTUAL
--- PARAMETER'S BASE IS A TASK TYPE OR TYPE WITH A
--- SUBCOMPONENT OF A TASK TYPE.
-
--- HISTORY:
--- LDC 06/24/88 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3207B IS
-BEGIN
- TEST("CC3207B","CHECK THAT INSTANTIATION IS LEGAL IF A " &
- "FORMAL PARAMETER HAVING A LIMITED PRIVATE " &
- "TYPE WITHOUT A DISCRIMINANT IS USED TO " &
- "DECLARE AN ACCESS TYPE IN A BLOCK THAT " &
- "CONTAINS A SELECTIVE WAIT WITH A TERMINATE " &
- "ALTERNATIVE, AND ACTUAL PARAMETER'S BASE " &
- "A TASK TYPE OR TYPE WITH A SUBCOMPONENT OF " &
- "A TASK TYPE. ");
-
- DECLARE
- TASK TYPE TT IS
- ENTRY E;
- END TT;
-
- TYPE TT_ARR IS ARRAY (1..2) OF TT;
-
- TYPE TT_REC IS RECORD
- COMP : TT_ARR;
- END RECORD;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE GEN IS
- TASK TSK IS
- ENTRY ENT(A : OUT INTEGER);
- END TSK;
- END GEN;
-
- INT : INTEGER;
-
- TASK BODY TT IS
- BEGIN
- SELECT
- ACCEPT E;
- OR
- TERMINATE;
- END SELECT;
- END TT;
-
- PACKAGE BODY GEN IS
- TASK BODY TSK IS
- BEGIN
- DECLARE
- TYPE ACC_T IS ACCESS T;
- TA : ACC_T := NEW T;
- BEGIN
- SELECT
- ACCEPT ENT(A : OUT INTEGER) DO
- A := IDENT_INT(7);
- END;
- OR
- TERMINATE;
- END SELECT;
- END;
- END TSK;
- END GEN;
-
- PACKAGE GEN_TSK IS NEW GEN(TT);
- PACKAGE GEN_TSK_SUB IS NEW GEN(TT_REC);
-
- BEGIN
- GEN_TSK.TSK.ENT(INT);
-
- IF INT /= IDENT_INT(7) THEN
- FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK");
- END IF;
-
- INT := 0;
- GEN_TSK_SUB.TSK.ENT(INT);
-
- IF INT /= IDENT_INT(7) THEN
- FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK, " &
- "WITH ACTUAL PARAMETER'S BASE IS A SUB" &
- "COMPONENT OF A TASK TYPE");
- END IF;
- RESULT;
- END;
-END CC3207B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada
deleted file mode 100644
index d80ec17..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- CC3220A.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 DISCRETE FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND
--- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING
--- OPERATIONS OF THE ACTUAL TYPE.
-
--- TBN 10/08/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3220A IS
-
- GENERIC
- TYPE T IS (<>);
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
-BEGIN
- TEST ("CC3220A", "CHECK THAT A DISCRETE FORMAL TYPE DENOTES ITS " &
- "ACTUAL PARAMETER, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- OBJ_INT : INTEGER := 1;
-
- PACKAGE P1 IS NEW P (INTEGER);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1);
- IF PAC_VAR /= OBJ_INT THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_INT := PAC_VAR + OBJ_INT;
- IF OBJ_INT <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_INT;
- IF PAC_VAR NOT IN INTEGER THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_INT NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF INTEGER'POS(2) /= SUB_T'POS(2) THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_NEWT := 1;
- OBJ_NEWT := OBJ_NEWT + 1;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF NEW_T'SUCC(2) /= 3 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- END;
-
- DECLARE
- TYPE ENUM IS (RED, YELLOW, GREEN, BLUE);
- OBJ_ENU : ENUM := RED;
-
- PACKAGE P2 IS NEW P (ENUM);
- USE P2;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(RED);
- IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- IF PAC_VAR NOT IN ENUM THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF OBJ_ENU NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN
- FAILED ("INCORRECT RESULTS - 11");
- END IF;
- OBJ_ENU := SUB_T'SUCC(PAC_VAR);
- IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN
- FAILED ("INCORRECT RESULTS - 12");
- END IF;
- OBJ_NEWT := BLUE;
- OBJ_NEWT := NEW_T'PRED(OBJ_NEWT);
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 13");
- END IF;
- IF NEW_T'WIDTH /= 6 THEN
- FAILED ("INCORRECT RESULTS - 14");
- END IF;
- END;
-
- DECLARE
- OBJ_CHR : CHARACTER := 'A';
-
- PACKAGE P3 IS NEW P (CHARACTER);
- USE P3;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- ARA_NEWT : ARRAY (1 .. 5) OF NEW_T;
- BEGIN
- PAC_VAR := SUB_T'('A');
- IF (PAC_VAR < OBJ_CHR) OR (PAC_VAR > OBJ_CHR) THEN
- FAILED ("INCORRECT RESULTS - 15");
- END IF;
- IF PAC_VAR NOT IN CHARACTER THEN
- FAILED ("INCORRECT RESULTS - 16");
- END IF;
- IF OBJ_CHR NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 17");
- END IF;
- IF CHARACTER'VAL(0) /= SUB_T'VAL(0) THEN
- FAILED ("INCORRECT RESULTS - 18");
- END IF;
- OBJ_CHR := SUB_T'SUCC(PAC_VAR);
- IF SUB_T'POS('A') /= 65 AND THEN OBJ_CHR /= 'A' THEN
- FAILED ("INCORRECT RESULTS - 19");
- END IF;
- OBJ_NEWT := 'C';
- OBJ_NEWT := NEW_T'PRED(OBJ_NEWT);
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 20");
- END IF;
- IF NEW_T'IMAGE('A') /= "'A'" THEN
- FAILED ("INCORRECT RESULTS - 21");
- END IF;
- ARA_NEWT := "HELLO";
- IF (NEW_T'('H') & NEW_T'('I')) /= "HI" THEN
- FAILED ("INCORRECT RESULTS - 22");
- END IF;
- END;
-
- RESULT;
-END CC3220A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada
deleted file mode 100644
index e7c7287..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- CC3221A.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 INTEGER FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND
--- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING
--- OPERATIONS OF THE ACTUAL TYPE.
-
--- TBN 10/09/86
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3221A IS
-
- GENERIC
- TYPE T IS RANGE <>;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
-BEGIN
- TEST ("CC3221A", "CHECK THAT AN INTEGER FORMAL TYPE DENOTES ITS " &
- "ACTUAL PARAMETER, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW P (INTEGER);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1);
- IF PAC_VAR /= OBJ_INT THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_INT := PAC_VAR + OBJ_INT;
- IF OBJ_INT <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_INT;
- IF PAC_VAR NOT IN INTEGER THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_INT NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF INTEGER'POS(2) /= SUB_T'POS(2) THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- PAC_VAR := 1;
- OBJ_FIX := PAC_VAR * OBJ_FIX;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- OBJ_INT := 1;
- OBJ_FIX := OBJ_FIX / OBJ_INT;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- OBJ_INT := OBJ_INT ** PAC_VAR;
- IF OBJ_INT /= 1 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_FLO := OBJ_FLO ** PAC_VAR;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- OBJ_NEWT := 1;
- OBJ_NEWT := OBJ_NEWT - 1;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- IF NEW_T'SUCC(2) /= 3 THEN
- FAILED ("INCORRECT RESULTS - 11");
- END IF;
- END;
-
- RESULT;
-END CC3221A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada
deleted file mode 100644
index 57cb198..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- CC3222A.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 FLOATING POINT FORMAL TYPE DENOTES ITS ACTUAL
--- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH
--- CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
-
--- HISTORY:
--- TBN 10/09/86 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3222A IS
-
- TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0;
-
- GENERIC
- TYPE T IS DIGITS <>;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN (0.0);
- END IF;
- END IDENT_FLO;
-
-BEGIN
- TEST ("CC3222A", "CHECK THAT A FLOATING POINT FORMAL TYPE " &
- "DENOTES ITS ACTUAL PARAMETER, AND OPERATIONS " &
- "OF THE FORMAL TYPE ARE IDENTIFIED WITH " &
- "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
-
- PACKAGE P1 IS NEW P (FLOAT);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FLO THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO);
- IF OBJ_FLO <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_FLO;
- IF PAC_VAR NOT IN FLOAT THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FLO NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := 1.0;
- OBJ_FLO := PAC_VAR * OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_FLO := 1.0;
- OBJ_FLO := OBJ_FLO / OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := PAC_VAR ** OBJ_INT;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF SUB_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF NEW_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3222A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada
deleted file mode 100644
index 469a496..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada
+++ /dev/null
@@ -1,114 +0,0 @@
--- CC3223A.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 FIXED POINT FORMAL TYPE DENOTES ITS ACTUAL
--- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED
--- WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
-
--- HISTORY:
--- TBN 10/09/86 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3223A IS
-
- TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- GENERIC
- TYPE T IS DELTA <>;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN (0.0);
- END IF;
- END IDENT_FIX;
-
-BEGIN
- TEST ("CC3223A", "CHECK THAT A FIXED POINT FORMAL TYPE DENOTES " &
- "ITS ACTUAL PARAMETER, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- OBJ_INT : INTEGER := 1;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW P (FIXED);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FIX THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX);
- IF OBJ_FIX <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := OBJ_INT * OBJ_FIX;
- IF PAC_VAR NOT IN FIXED THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FIX NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF SUB_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF NEW_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- OBJ_NEWT := NEW_T'SMALL + 1.0;
- OBJ_FIX := 1.0;
- OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_FIX := 1.0;
- OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF FIXED'SMALL /= NEW_T'SMALL THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3223A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada
deleted file mode 100644
index 5da67ea..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada
+++ /dev/null
@@ -1,313 +0,0 @@
--- CC3224A.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 ARRAY TYPE DENOTES ITS ACTUAL
--- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE
--- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
-
--- HISTORY:
--- DHH 09/19/88 CREATED ORIGINAL TEST.
--- EDWARD V. BERARD, 14 AUGUST 1990 ADDED CHECKS FOR MULTI-
--- DIMENSIONAL ARRAYS
--- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
-
-WITH REPORT ;
-
-PROCEDURE CC3224A IS
-
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
- TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
- TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN;
-
- Q : ARR;
- R : B_ARR;
-
- GENERIC
- TYPE T IS ARRAY(INT) OF INTEGER;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- X : SUB_T := (1, 2, 3);
- END P;
-
- GENERIC
- TYPE T IS ARRAY(INT) OF BOOLEAN;
- PACKAGE BOOL IS
- SUBTYPE SUB_T IS T;
- END BOOL;
-
- SHORT_START : CONSTANT := -100 ;
- SHORT_END : CONSTANT := 100 ;
- TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ;
-
- SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ;
-
- TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG,
- SEP, OCT, NOV, DEC) ;
-
- SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ;
-
- TYPE DAY_TYPE IS RANGE 1 .. 31 ;
- TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ;
- TYPE DATE IS RECORD
- MONTH : MONTH_TYPE ;
- DAY : DAY_TYPE ;
- YEAR : YEAR_TYPE ;
- END RECORD ;
-
- TODAY : DATE := (MONTH => AUG,
- DAY => 8,
- YEAR => 1990) ;
-
- FIRST_DATE : DATE := (DAY => 6,
- MONTH => JUN,
- YEAR => 1967) ;
-
- WALL_DATE : DATE := (MONTH => NOV,
- DAY => 9,
- YEAR => 1989) ;
-
- SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ;
-
- TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT,
- FIRST_HALF,
- FIRST_FIVE) OF DATE ;
-
- TD_ARRAY : THREE_DIMENSIONAL ;
- SECOND_TD_ARRAY : THREE_DIMENSIONAL ;
-
- GENERIC
-
- TYPE CUBE IS ARRAY (REALLY_SHORT,
- FIRST_HALF,
- FIRST_FIVE) OF DATE ;
-
- PACKAGE TD_ARRAY_PACKAGE IS
-
- SUBTYPE SUB_CUBE IS CUBE ;
- TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE =>
- (THREE_DIMENSIONAL'RANGE (2) =>
- (THREE_DIMENSIONAL'RANGE (3) =>
- TODAY))) ;
-
- END TD_ARRAY_PACKAGE ;
-
-
-BEGIN -- CC3224A
-
- REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " &
- "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " &
- "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " &
- "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");
-
- ONE_DIMENSIONAL:
-
- DECLARE
-
- PACKAGE P1 IS NEW P (ARR);
-
- TYPE NEW_T IS NEW P1.SUB_T;
- OBJ_NEWT : NEW_T;
-
- BEGIN -- ONE_DIMENSIONAL
-
- IF NEW_T'FIRST /= ARR'FIRST THEN
- REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF NEW_T'LAST /= ARR'LAST THEN
- REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN
- REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN
- REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF 2 NOT IN NEW_T'RANGE THEN
- REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF 3 NOT IN NEW_T'RANGE(1) THEN
- REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF NEW_T'LENGTH /= ARR'LENGTH THEN
- REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED");
- END IF;
-
- IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN
- REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED");
- END IF;
-
- OBJ_NEWT := (1, 2, 3);
- IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN
- REPORT.FAILED("ASSIGNMENT REPORT.FAILED");
- END IF;
-
- IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN
- REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED");
- END IF;
-
- Q := (1, 2, 3);
- IF NEW_T(Q) /= OBJ_NEWT THEN
- REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED");
- END IF;
-
- IF Q(1) /= OBJ_NEWT(1) THEN
- REPORT.FAILED("INDEXING REPORT.FAILED");
- END IF;
-
- IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN
- REPORT.FAILED("SLICE REPORT.FAILED");
- END IF;
-
- IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN
- REPORT.FAILED("CATENATION REPORT.FAILED");
- END IF;
-
- IF NOT (P1.X IN ARR) THEN
- REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL");
- END IF;
-
- END ONE_DIMENSIONAL ;
-
- BOOLEAN_ONE_DIMENSIONAL:
-
- DECLARE
-
- PACKAGE B1 IS NEW BOOL (B_ARR);
-
- TYPE NEW_T IS NEW B1.SUB_T;
- OBJ_NEWT : NEW_T;
-
- BEGIN -- BOOLEAN_ONE_DIMENSIONAL
-
- OBJ_NEWT := (TRUE, TRUE, TRUE);
- R := (TRUE, TRUE, TRUE);
-
- IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /=
- NEW_T'((FALSE, FALSE, FALSE)) THEN
- REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ;
- END IF;
-
- IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /=
- NEW_T'((FALSE, FALSE, TRUE)) THEN
- REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ;
- END IF;
-
- IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /=
- NEW_T'((TRUE, TRUE, TRUE)) THEN
- REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ;
- END IF ;
-
- END BOOLEAN_ONE_DIMENSIONAL ;
-
- THREE_DIMENSIONAL_TEST:
-
- DECLARE
-
- PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ;
-
- TYPE NEW_CUBE IS NEW TD.SUB_CUBE ;
- NEW_CUBE_OBJECT : NEW_CUBE ;
-
- BEGIN -- THREE_DIMENSIONAL_TEST
-
- IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR
- (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR
- (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR
- (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN
- REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" &
- "DIMENSIONAL ARRAYS.") ;
- END IF ;
-
- IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR
- (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR
- (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR
- (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" &
- "DIMENSIONAL ARRAYS.") ;
- END IF ;
-
- IF (-5 NOT IN NEW_CUBE'RANGE) OR
- (-3 NOT IN NEW_CUBE'RANGE (1)) OR
- (FEB NOT IN NEW_CUBE'RANGE (2)) OR
- ('C' NOT IN NEW_CUBE'RANGE (3)) THEN
- REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" &
- "DIMENSIONAL ARRAYS.") ;
- END IF ;
-
- IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR
- (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR
- (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR
- (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN
- REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" &
- "DIMENSIONAL ARRAYS.") ;
- END IF ;
-
- NEW_CUBE_OBJECT := (NEW_CUBE'RANGE =>
- (NEW_CUBE'RANGE (2) =>
- (NEW_CUBE'RANGE (3) =>
- FIRST_DATE))) ;
- IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN
- REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " &
- "ARRAYS FAILED.") ;
- END IF ;
-
- IF NEW_CUBE'(NEW_CUBE'RANGE =>
- (NEW_CUBE'RANGE (2) =>
- (NEW_CUBE'RANGE (3) =>
- WALL_DATE))) NOT IN NEW_CUBE THEN
- REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" &
- "DIMENSIONAL ARRAYS FAILED.") ;
- END IF ;
-
- SECOND_TD_ARRAY := (NEW_CUBE'RANGE =>
- (NEW_CUBE'RANGE (2) =>
- (NEW_CUBE'RANGE (3) =>
- FIRST_DATE))) ;
- IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN
- REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" &
- "DIMENSIONAL ARRAYS FAILED.") ;
- END IF ;
-
- IF SECOND_TD_ARRAY (-2, FEB, 'B')
- /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN
- REPORT.FAILED ("INDEXING FOR MULTI-" &
- "DIMENSIONAL ARRAYS FAILED.") ;
- END IF ;
-
- IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN
- REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " &
- "DOES NOT DENOTE ACTUAL.") ;
- END IF ;
-
- END THREE_DIMENSIONAL_TEST ;
-
- REPORT.RESULT ;
-
-END CC3224A ;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada
deleted file mode 100644
index 478664f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- CC3225A.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 FORMAL ACCESS TYPE DENOTES ITS ACTUAL
--- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE
--- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE.
-
--- HISTORY:
--- DHH 10/21/88 CREATED ORIGINAL TEST.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3225A IS
-
- GENERIC
- TYPE NODE IS PRIVATE;
- TYPE T IS ACCESS NODE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : SUB_T;
- END P;
-
-BEGIN
- TEST ("CC3225A", "CHECK THAT A FORMAL ACCESS TYPE DENOTES ITS " &
- "ACTUAL PARAMETER, AND THAT OPERATIONS OF THE " &
- "FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " &
- "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
- TYPE ARR IS ARRAY(1 .. 3) OF INTEGER;
- TYPE ACC_ARR IS ACCESS ARR;
-
- Q : ACC_ARR := NEW ARR;
-
- PACKAGE P1 IS NEW P (ARR, ACC_ARR);
- USE P1;
-
- BEGIN
- PAC_VAR := NEW ARR'(1, 2, 3);
- IF PAC_VAR'FIRST /= Q'FIRST THEN
- FAILED("'FIRST ATTRIBUTE FAILED");
- END IF;
- IF PAC_VAR'LAST /= Q'LAST THEN
- FAILED("'LAST ATTRIBUTE FAILED");
- END IF;
- IF PAC_VAR'FIRST(1) /= Q'FIRST(1) THEN
- FAILED("'FIRST(N) ATTRIBUTE FAILED");
- END IF;
- IF NOT (PAC_VAR'LAST(1) = Q'LAST(1)) THEN
- FAILED("'LAST(N) ATTRIBUTE FAILED");
- END IF;
- IF 2 NOT IN PAC_VAR'RANGE THEN
- FAILED("'RANGE ATTRIBUTE FAILED");
- END IF;
- IF 3 NOT IN PAC_VAR'RANGE(1) THEN
- FAILED("'RANGE(N) ATTRIBUTE FAILED");
- END IF;
- IF PAC_VAR'LENGTH /= Q'LENGTH THEN
- FAILED("'LENGTH ATTRIBUTE FAILED");
- END IF;
- IF PAC_VAR'LENGTH(1) /= Q'LENGTH(1) THEN
- FAILED("'LENGTH(N) ATTRIBUTE FAILED");
- END IF;
-
- PAC_VAR.ALL := (1, 2, 3);
- IF IDENT_INT(3) /= PAC_VAR(3) THEN
- FAILED("ASSIGNMENT FAILED");
- END IF;
-
- IF SUB_T'(PAC_VAR) NOT IN SUB_T THEN
- FAILED("QUALIFIED EXPRESSION FAILED");
- END IF;
-
- Q.ALL := PAC_VAR.ALL;
- IF SUB_T(Q) = PAC_VAR THEN
- FAILED("EXPLICIT CONVERSION FAILED");
- END IF;
- IF Q(1) /= PAC_VAR(1) THEN
- FAILED("INDEXING FAILED");
- END IF;
- IF (1, 2) /= PAC_VAR(1 .. 2) THEN
- FAILED("SLICE FAILED");
- END IF;
- IF (1, 2) & PAC_VAR(3) /= PAC_VAR.ALL THEN
- FAILED("CATENATION FAILED");
- END IF;
- END;
-
- DECLARE
- TASK TYPE TSK IS
- ENTRY ONE;
- END TSK;
-
- GENERIC
- TYPE T IS ACCESS TSK;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : SUB_T;
- END P;
-
- TYPE ACC_TSK IS ACCESS TSK;
-
- PACKAGE P1 IS NEW P(ACC_TSK);
- USE P1;
-
- GLOBAL : INTEGER := 5;
-
- TASK BODY TSK IS
- BEGIN
- ACCEPT ONE DO
- GLOBAL := 1;
- END ONE;
- END;
- BEGIN
- PAC_VAR := NEW TSK;
- PAC_VAR.ONE;
- IF GLOBAL /= 1 THEN
- FAILED("TASK ENTRY SELECTION FAILED");
- END IF;
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- I : INTEGER;
- B : BOOLEAN;
- END RECORD;
-
- TYPE ACC_REC IS ACCESS REC;
-
- PACKAGE P1 IS NEW P (REC, ACC_REC);
- USE P1;
-
- BEGIN
- PAC_VAR := NEW REC'(4, (PAC_VAR IN ACC_REC));
- IF PAC_VAR.I /= IDENT_INT(4) AND NOT PAC_VAR.B THEN
- FAILED("RECORD COMPONENT SELECTION FAILED");
- END IF;
- END;
-
- DECLARE
- TYPE REC(B : BOOLEAN := FALSE) IS
- RECORD
- NULL;
- END RECORD;
-
- TYPE ACC_REC IS ACCESS REC;
-
- PACKAGE P1 IS NEW P (REC, ACC_REC);
- USE P1;
-
- BEGIN
- PAC_VAR := NEW REC'(B => PAC_VAR IN ACC_REC);
- IF NOT PAC_VAR.B THEN
- FAILED("DISCRIMINANT SELECTION FAILED");
- END IF;
- END;
-
- RESULT;
-END CC3225A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada
deleted file mode 100644
index 7f40896..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- CC3230A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER AN ENUMERATION TYPE, AND OPERATIONS OF THE
--- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE
--- ACTUAL TYPE.
-
--- HISTORY:
--- TBN 09/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3230A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
-BEGIN
- TEST ("CC3230A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " &
- "ENUMERATION TYPE, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE
- TYPE ENUM IS (RED, YELLOW, GREEN, BLUE);
- OBJ_ENU : ENUM := RED;
-
- PACKAGE P2 IS NEW P (ENUM);
- USE P2;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(RED);
- IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- IF PAC_VAR NOT IN ENUM THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- IF OBJ_ENU NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- OBJ_ENU := SUB_T'SUCC(PAC_VAR);
- IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_NEWT := BLUE;
- OBJ_NEWT := NEW_T'PRED(OBJ_NEWT);
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF NEW_T'WIDTH /= 6 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- END;
-
- DECLARE
- TYPE ENUM IS (RED, YELLOW, GREEN, BLUE);
- OBJ_ENU : ENUM := RED;
-
- PACKAGE P2 IS NEW LP (ENUM);
- USE P2;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(RED);
- IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- IF PAC_VAR NOT IN ENUM THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF OBJ_ENU NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN
- FAILED ("INCORRECT RESULTS - 11");
- END IF;
- OBJ_ENU := SUB_T'SUCC(PAC_VAR);
- IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN
- FAILED ("INCORRECT RESULTS - 12");
- END IF;
- OBJ_NEWT := BLUE;
- OBJ_NEWT := NEW_T'PRED(OBJ_NEWT);
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 13");
- END IF;
- IF NEW_T'WIDTH /= 6 THEN
- FAILED ("INCORRECT RESULTS - 14");
- END IF;
- END;
-
- RESULT;
-END CC3230A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada
deleted file mode 100644
index a36bccf..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada
+++ /dev/null
@@ -1,177 +0,0 @@
--- CC3231A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER AN INTEGER TYPE, AND OPERATIONS OF THE FORMAL
--- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
--- TYPE.
-
--- HISTORY:
--- TBN 09/14/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3231A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
-BEGIN
- TEST ("CC3231A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " &
- "INTEGER TYPE, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE -- PRIVATE TYPE.
- TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW P (INTEGER);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1);
- IF PAC_VAR /= OBJ_INT THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_INT := PAC_VAR + OBJ_INT;
- IF OBJ_INT <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_INT;
- IF PAC_VAR NOT IN INTEGER THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_INT NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF INTEGER'POS(2) /= SUB_T'POS(2) THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- PAC_VAR := 1;
- OBJ_FIX := PAC_VAR * OBJ_FIX;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- OBJ_INT := 1;
- OBJ_FIX := OBJ_FIX / OBJ_INT;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- OBJ_INT := OBJ_INT ** PAC_VAR;
- IF OBJ_INT /= 1 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_FLO := OBJ_FLO ** PAC_VAR;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- OBJ_NEWT := 1;
- OBJ_NEWT := OBJ_NEWT - 1;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- IF NEW_T'SUCC(2) /= 3 THEN
- FAILED ("INCORRECT RESULTS - 11");
- END IF;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPE.
- TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW LP (INTEGER);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1);
- IF PAC_VAR /= OBJ_INT THEN
- FAILED ("INCORRECT RESULTS - 12");
- END IF;
- OBJ_INT := PAC_VAR + OBJ_INT;
- IF OBJ_INT <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 13");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_INT;
- IF PAC_VAR NOT IN INTEGER THEN
- FAILED ("INCORRECT RESULTS - 14");
- END IF;
- IF OBJ_INT NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 15");
- END IF;
- IF INTEGER'POS(2) /= SUB_T'POS(2) THEN
- FAILED ("INCORRECT RESULTS - 16");
- END IF;
- PAC_VAR := 1;
- OBJ_FIX := PAC_VAR * OBJ_FIX;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 17");
- END IF;
- OBJ_INT := 1;
- OBJ_FIX := OBJ_FIX / OBJ_INT;
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 18");
- END IF;
- OBJ_INT := OBJ_INT ** PAC_VAR;
- IF OBJ_INT /= 1 THEN
- FAILED ("INCORRECT RESULTS - 19");
- END IF;
- OBJ_FLO := OBJ_FLO ** PAC_VAR;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 20");
- END IF;
- OBJ_NEWT := 1;
- OBJ_NEWT := OBJ_NEWT - 1;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 21");
- END IF;
- IF NEW_T'SUCC(2) /= 3 THEN
- FAILED ("INCORRECT RESULTS - 22");
- END IF;
- END;
-
- RESULT;
-END CC3231A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada
deleted file mode 100644
index 9b4b544..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada
+++ /dev/null
@@ -1,179 +0,0 @@
--- CC3232A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER A FLOATING POINT TYPE, AND OPERATIONS OF THE
--- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE
--- ACTUAL TYPE.
-
--- HISTORY:
--- TBN 09/15/88 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3232A IS
-
- TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0;
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
- FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN (0.0);
- END IF;
- END IDENT_FLO;
-
-BEGIN
- TEST ("CC3232A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER A " &
- "FLOATING POINT TYPE, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE -- PRIVATE TYPE.
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
-
- PACKAGE P1 IS NEW P (FLOAT);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FLO THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO);
- IF OBJ_FLO <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_FLO;
- IF PAC_VAR NOT IN FLOAT THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FLO NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := 1.0;
- OBJ_FLO := PAC_VAR * OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_FLO := 1.0;
- OBJ_FLO := OBJ_FLO / OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := PAC_VAR ** OBJ_INT;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF SUB_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF NEW_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPE.
- OBJ_INT : INTEGER := 1;
- OBJ_FLO : FLOAT := 1.0;
-
- PACKAGE P1 IS NEW LP (FLOAT);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FLO THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO);
- IF OBJ_FLO <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := PAC_VAR * OBJ_FLO;
- IF PAC_VAR NOT IN FLOAT THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FLO NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := 1.0;
- OBJ_FLO := PAC_VAR * OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_FLO := 1.0;
- OBJ_FLO := OBJ_FLO / OBJ_FLO;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- PAC_VAR := 1.0;
- OBJ_FLO := PAC_VAR ** OBJ_INT;
- IF OBJ_FLO /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF SUB_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF NEW_T'DIGITS /= 5 THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3232A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada
deleted file mode 100644
index c344cfc..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada
+++ /dev/null
@@ -1,175 +0,0 @@
--- CC3233A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER, A FIXED POINT TYPE AND OPERATIONS OF THE FORMAL
--- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
--- TYPE.
-
--- HISTORY:
--- TBN 09/15/88 CREATED ORIGINAL TEST.
--- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3233A IS
-
- TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
- FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN X;
- ELSE
- RETURN (0.0);
- END IF;
- END IDENT_FIX;
-
-BEGIN
- TEST ("CC3233A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, A " &
- "FIXED POINT TYPE AND OPERATIONS OF THE FORMAL " &
- "TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE -- PRIVATE TYPE.
- OBJ_INT : INTEGER := 1;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW P (FIXED);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FIX THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX);
- IF OBJ_FIX <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := OBJ_INT * OBJ_FIX;
- IF PAC_VAR NOT IN FIXED THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FIX NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF SUB_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF NEW_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- OBJ_NEWT := NEW_T'SMALL + 1.0;
- OBJ_FIX := 1.0;
- OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_FIX := 1.0;
- OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF FIXED'SMALL /= NEW_T'SMALL THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPE.
- OBJ_INT : INTEGER := 1;
- OBJ_FIX : FIXED := 1.0;
-
- PACKAGE P1 IS NEW LP (FIXED);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1.0);
- IF PAC_VAR /= OBJ_FIX THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX);
- IF OBJ_FIX <= PAC_VAR THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR := OBJ_INT * OBJ_FIX;
- IF PAC_VAR NOT IN FIXED THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_FIX NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF SUB_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_NEWT := 1.0;
- OBJ_NEWT := OBJ_NEWT - 1.0;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF NEW_T'DELTA /= 0.125 THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- OBJ_NEWT := NEW_T'SMALL + 1.0;
- OBJ_FIX := 1.0;
- OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_FIX := 1.0;
- OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX);
- IF OBJ_FIX /= 1.0 THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF FIXED'SMALL /= NEW_T'SMALL THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3233A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada
deleted file mode 100644
index 487b26c..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CC3234A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER AN ARRAY TYPE, AND OPERATIONS OF THE FORMAL
--- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
--- TYPE.
-
--- HISTORY:
--- TBN 09/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3234A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
-BEGIN
- TEST ("CC3234A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " &
- "ARRAY TYPE, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE -- PRIVATE TYPE.
- TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER;
-
- OBJ_ARR : ARRAY_TYPE := (OTHERS => 1);
-
- PACKAGE P1 IS NEW P (ARRAY_TYPE);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
- IF PAC_VAR /= OBJ_ARR THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1);
- IF OBJ_ARR(1) <= PAC_VAR(1) THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3);
- IF PAC_VAR NOT IN ARRAY_TYPE THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF OBJ_ARR NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- OBJ_ARR(1..5) := PAC_VAR(6..10);
- IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2);
- OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
- OBJ_NEWT := NEW_T(PAC_VAR);
- IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPE.
- TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER;
-
- OBJ_ARR : ARRAY_TYPE := (OTHERS => 1);
-
- PACKAGE P1 IS NEW LP (ARRAY_TYPE);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
- IF PAC_VAR /= OBJ_ARR THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1);
- IF OBJ_ARR(1) <= PAC_VAR(1) THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3);
- IF PAC_VAR NOT IN ARRAY_TYPE THEN
- FAILED ("INCORRECT RESULTS - 11");
- END IF;
- IF OBJ_ARR NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 12");
- END IF;
- IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN
- FAILED ("INCORRECT RESULTS - 13");
- END IF;
- OBJ_ARR(1..5) := PAC_VAR(6..10);
- IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN
- FAILED ("INCORRECT RESULTS - 14");
- END IF;
- PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2);
- OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1);
- OBJ_NEWT := NEW_T(PAC_VAR);
- IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN
- FAILED ("INCORRECT RESULTS - 15");
- END IF;
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 16");
- END IF;
- END;
-
- RESULT;
-END CC3234A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada
deleted file mode 100644
index f32c3e1..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- CC3235A.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 PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS
--- ACTUAL PARAMETER AN ACCESS TYPE, AND OPERATIONS OF THE FORMAL
--- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL
--- TYPE.
-
--- HISTORY:
--- TBN 09/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3235A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
-BEGIN
- TEST ("CC3235A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " &
- "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " &
- "ACCESS TYPE, AND OPERATIONS OF THE " &
- "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " &
- "OPERATIONS OF THE ACTUAL TYPE");
-
- DECLARE -- PRIVATE TYPE.
- TYPE ENUM IS (RED, YELLOW, GREEN, BLUE);
-
- TYPE ACCESS_TYPE IS ACCESS ENUM;
-
- OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED);
-
- PACKAGE P1 IS NEW P (ACCESS_TYPE);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := NEW ENUM'(RED);
- IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR
- (PAC_VAR.ALL > OBJ_ACC.ALL) THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- IF PAC_VAR NOT IN ACCESS_TYPE THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- IF OBJ_ACC NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL));
- IF OBJ_ACC.ALL /= YELLOW THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- OBJ_NEWT := NEW ENUM'(BLUE);
- OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL));
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 5");
- END IF;
- END;
-
- DECLARE -- LIMITED PRIVATE TYPE.
- TYPE ENUM IS (RED, YELLOW, GREEN, BLUE);
-
- TYPE ACCESS_TYPE IS ACCESS ENUM;
-
- OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED);
-
- PACKAGE P1 IS NEW LP (ACCESS_TYPE);
- USE P1;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T;
- BEGIN
- PAC_VAR := NEW ENUM'(RED);
- IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR
- (PAC_VAR.ALL > OBJ_ACC.ALL) THEN
- FAILED ("INCORRECT RESULTS - 6");
- END IF;
- IF PAC_VAR NOT IN ACCESS_TYPE THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF OBJ_ACC NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL));
- IF OBJ_ACC.ALL /= YELLOW THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- OBJ_NEWT := NEW ENUM'(BLUE);
- OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL));
- IF OBJ_NEWT NOT IN NEW_T THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3235A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada
deleted file mode 100644
index d02dec2..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CC3236A.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 FORMAL PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS
--- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE
--- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE
--- WHEN THE ACTUAL PARAMETER IS A TYPE WITH DISCRIMINANTS.
-
--- HISTORY:
--- DHH 10/24/88 CREATED ORIGINAL TEST.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3236A IS
-
- GENERIC
- TYPE T IS PRIVATE;
- PACKAGE P IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END P;
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- PACKAGE LP IS
- SUBTYPE SUB_T IS T;
- PAC_VAR : T;
- END LP;
-
-BEGIN
- TEST ("CC3236A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " &
- "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " &
- "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " &
- "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " &
- "TYPE, WHEN THE ACTUAL PARAMETER IS A TYPE " &
- "WITH DISCRIMINANTS");
-
- DECLARE
- TYPE REC(X : INTEGER := 5) IS
- RECORD
- NULL;
- END RECORD;
- OBJ_REC : REC(4);
-
- PACKAGE P2 IS NEW P (REC);
- USE P2;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T(4);
- BEGIN
- PAC_VAR := SUB_T'((X => 4));
- IF PAC_VAR /= OBJ_REC THEN
- FAILED ("INCORRECT RESULTS - 1");
- END IF;
- IF PAC_VAR NOT IN REC THEN
- FAILED ("INCORRECT RESULTS - 2");
- END IF;
- IF OBJ_REC NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 3");
- END IF;
- IF PAC_VAR.X /= OBJ_NEWT.X THEN
- FAILED ("INCORRECT RESULTS - 4");
- END IF;
- END;
-
- DECLARE
- TYPE REC(X : INTEGER := 5) IS
- RECORD
- NULL;
- END RECORD;
- OBJ_REC : REC(4);
-
- PACKAGE P2 IS NEW LP (REC);
- USE P2;
-
- TYPE NEW_T IS NEW SUB_T;
- OBJ_NEWT : NEW_T(4);
- BEGIN
- PAC_VAR := SUB_T'(X => 4);
- IF PAC_VAR /= OBJ_REC THEN
- FAILED ("INCORRECT RESULTS - 7");
- END IF;
- IF PAC_VAR NOT IN REC THEN
- FAILED ("INCORRECT RESULTS - 8");
- END IF;
- IF OBJ_REC NOT IN SUB_T THEN
- FAILED ("INCORRECT RESULTS - 9");
- END IF;
- IF PAC_VAR.X /= OBJ_NEWT.X THEN
- FAILED ("INCORRECT RESULTS - 10");
- END IF;
- END;
-
- RESULT;
-END CC3236A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada
deleted file mode 100644
index 1983b94..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CC3240A.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 FORMAL PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS
--- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE
--- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE
--- WHEN THE FORMAL TYPE IS A TYPE WITH DISCRIMINANTS.
-
--- HISTORY:
--- RJW 10/13/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3240A IS
-
-BEGIN
- TEST ("CC3240A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " &
- "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " &
- "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " &
- "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " &
- "TYPE, WHEN THE FORMAL TYPE IS A TYPE " &
- "WITH DISCRIMINANTS");
-
- DECLARE
-
- GENERIC
- TYPE T(A : INTEGER) IS PRIVATE;
- PACKAGE P IS
- SUBTYPE S IS T;
- TX : T(5);
- END P;
-
- TYPE REC (L : INTEGER) IS
- RECORD
- A : INTEGER;
- END RECORD;
-
- PACKAGE P1 IS NEW P (REC);
- USE P1;
-
- BEGIN
- TX := (L => 5, A => 7);
- IF NOT (TX IN REC) THEN
- FAILED ("MEMBERSHIP TEST - PRIVATE");
- END IF;
-
- IF TX.A /= 7 OR TX.L /= 5 THEN
- FAILED ("SELECTED COMPONENTS - PRIVATE");
- END IF;
-
- IF S(TX) /= REC(TX) THEN
- FAILED ("EXPLICIT CONVERSION - PRIVATE");
- END IF;
-
- IF NOT TX'CONSTRAINED THEN
- FAILED ("'CONSTRAINED - PRIVATE");
- END IF;
- END;
-
- DECLARE
- TYPE REC(L : INTEGER) IS
- RECORD
- A : INTEGER;
- END RECORD;
-
- GENERIC
- TYPE T(A : INTEGER) IS LIMITED PRIVATE;
- TX : IN OUT T;
- PACKAGE LP IS
- SUBTYPE S IS T;
- END LP;
-
- R : REC (5) := (5, 7);
-
- PACKAGE BODY LP IS
- BEGIN
- IF (TX IN S) /= (R IN REC) THEN
- FAILED ("MEMBERSHIP TEST - LIMITED PRIVATE");
- END IF;
-
- IF TX.A /= 5 THEN
- FAILED ("SELECTED COMPONENTS - LIMITED PRIVATE");
- END IF;
-
- IF (S(TX) IN S) /= (REC(R) IN REC) THEN
- FAILED ("EXPLICIT CONVERSION - LIMITED PRIVATE");
- END IF;
-
- IF NOT TX'CONSTRAINED THEN
- FAILED ("'CONSTRAINED - LIMITED PRIVATE");
- END IF;
- END LP;
-
- PACKAGE P1 IS NEW LP (REC, R);
- USE P1;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3240A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada
deleted file mode 100644
index 66d0f38..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CC3305A.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 A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF
--- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT.
-
--- CHECK WHEN THE SCALAR TYPE IS DEFINED BY (<>).
-
--- SPS 7/15/82
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3305A IS
-BEGIN
-
- TEST ("CC3305A", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " &
- "TYPES OF THE FORM (<>)");
-
- DECLARE
- TYPE COLOR IS (RED, BLUE, YELLOW, ORANGE, GREEN, PURPLE);
- SUBTYPE P_COLOR IS COLOR RANGE BLUE .. ORANGE;
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
- SUBTYPE ATOC IS CHARACTER RANGE CHARACTER'VAL(1) ..
- CHARACTER'VAL(3);
-
- GENERIC
- TYPE GFT IS (<>);
- PACKAGE PK IS END PK;
-
- PACKAGE BODY PK IS
- BEGIN
- FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP
- COMMENT ("START OF ITERATION");
- DECLARE
- VAR : GFT;
- BEGIN
- VAR := GFT'VAL (I);
- IF I = 0 OR I = 4 THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I /= 0 AND I /= 4 THEN
- FAILED ("CONSTRAINT_ERROR RAISED " &
- "INAPPROPRIATELY");
- END IF;
- END;
- END LOOP;
- END PK;
-
- BEGIN
- COMMENT ("INSTANTIATION WITH P_COLOR");
- DECLARE
- PACKAGE NPC IS NEW PK (P_COLOR);
- BEGIN
- NULL;
- END;
-
- COMMENT ("INSTANTIATION WITH INT");
-
- DECLARE
- PACKAGE NPI IS NEW PK (INT);
- BEGIN
- NULL;
- END;
-
- COMMENT ("INSTANTIATION WITH ATOC");
-
- DECLARE
- PACKAGE NPA IS NEW PK (ATOC);
- BEGIN
- NULL;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION");
- END;
-
- RESULT;
-END CC3305A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada
deleted file mode 100644
index 7273c68..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CC3305B.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 A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF
--- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT.
-
--- CHECK WHEN THE SCALAR TYPE IS DEFINED BY RANGE <>.
-
--- SPS 7/15/82
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3305B IS
-BEGIN
-
- TEST ("CC3305B", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " &
- "TYPES OF THE FORM RANGE <>");
-
- DECLARE
- SUBTYPE INT IS INTEGER RANGE 1 .. 3;
-
- GENERIC
- TYPE GFT IS RANGE <>;
- PACKAGE PK IS END PK;
-
- PACKAGE BODY PK IS
- BEGIN
- FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP
- COMMENT ("START OF ITERATION");
- DECLARE
- VAR : GFT;
- BEGIN
- VAR := GFT(I);
- IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I /= IDENT_INT(0) AND
- I /= IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR RAISED " &
- "INAPPROPRIATELY");
- END IF;
- END;
- END LOOP;
- END PK;
-
- BEGIN
-
- DECLARE
- PACKAGE NPI IS NEW PK (INT);
- BEGIN
- NULL;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION");
- END;
-
- RESULT;
-END CC3305B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada
deleted file mode 100644
index 6cb53a8..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CC3305C.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 A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF
--- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT.
-
--- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DIGITS <>.
-
--- SPS 7/15/82
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3305C IS
-BEGIN
-
- TEST ("CC3305C", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " &
- "TYPES OF THE FORM DIGITS <>");
-
- DECLARE
- SUBTYPE FL IS FLOAT RANGE 1.0 .. 3.0;
-
- GENERIC
- TYPE GFT IS DIGITS <>;
- PACKAGE PK IS END PK;
-
- PACKAGE BODY PK IS
- BEGIN
- FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP
- COMMENT ("START OF ITERATION");
- DECLARE
- VAR : GFT;
- BEGIN
- VAR := GFT (I);
- IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I /= IDENT_INT(0) AND
- I /= IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR RAISED " &
- "INAPPROPRIATELY");
- END IF;
- END;
- END LOOP;
- END PK;
-
- BEGIN
-
- DECLARE
- PACKAGE NP IS NEW PK (FL);
- BEGIN
- NULL;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION");
- END;
-
- RESULT;
-END CC3305C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada b/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada
deleted file mode 100644
index 1faa64f6..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CC3305D.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 A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF
--- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT.
-
--- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DELTA <>.
-
--- SPS 7/15/82
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CC3305D IS
-BEGIN
-
- TEST ("CC3305D", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " &
- "TYPES OF THE FORM DELTA <>");
-
- DECLARE
- TYPE FX IS DELTA 0.1 RANGE 1.0 .. 3.0;
-
- GENERIC
- TYPE GFT IS DELTA <>;
- PACKAGE PK IS END PK;
-
- PACKAGE BODY PK IS
- BEGIN
- FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP
- COMMENT ("START OF ITERATION");
- DECLARE
- VAR : GFT;
- BEGIN
- VAR := GFT (I);
- IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF I /= IDENT_INT(0) AND
- I /= IDENT_INT(4) THEN
- FAILED ("CONSTRAINT_ERROR RAISED " &
- "INAPPROPRIATELY");
- END IF;
- END;
- END LOOP;
- END PK;
-
- BEGIN
-
- DECLARE
- PACKAGE NP IS NEW PK (FX);
- BEGIN
- NULL;
- END;
-
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION");
- END;
-
- RESULT;
-END CC3305D;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada
deleted file mode 100644
index 198f47e..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada
+++ /dev/null
@@ -1,251 +0,0 @@
--- CC3601A.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 PREDEFINED OPERATORS MAY BE PASSED AS ACTUAL
--- GENERIC SUBPROGRAM PARAMETERS (CHECKS FOR "=" AND "/=" ARE IN
--- CC3601C).
-
--- R.WILLIAMS 10/9/86
--- JRL 11/15/95 Added unknown discriminant part to all formal
--- private types.
-
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3601A IS
-
- GENERIC
- TYPE T (<>) IS PRIVATE;
- V, V1 : T;
- KIND : STRING;
- WITH FUNCTION F1 (X : IN T) RETURN T;
- PACKAGE GP1 IS
- R : BOOLEAN := F1 (V) = V1;
- END GP1;
-
- PACKAGE BODY GP1 IS
- BEGIN
- IF NOT (IDENT_BOOL(R)) THEN
- FAILED ( "INCORRECT VALUE FOR UNARY OP - " & KIND);
- END IF;
- END GP1;
-
- GENERIC
- TYPE T (<>) IS PRIVATE;
- V, V1, V2 : IN T;
- KIND : STRING;
- WITH FUNCTION F1 (P1 : IN T; P2 : IN T) RETURN T;
- PACKAGE GP2 IS
- R : BOOLEAN := V /= F1 (V1, V2);
- END GP2;
-
- PACKAGE BODY GP2 IS
- BEGIN
- IF IDENT_BOOL (R) THEN
- FAILED ( "INCORRECT VALUE FOR BINARY OP - " & KIND);
- END IF;
- END GP2;
-
-
- GENERIC
- TYPE T1 (<>) IS PRIVATE;
- TYPE T2 (<>) IS PRIVATE;
- V1 : T1;
- V2 : T2;
- KIND : STRING;
- WITH FUNCTION F1 (X : IN T1) RETURN T2;
- PACKAGE GP3 IS
- R : BOOLEAN := F1 (V1) = V2;
- END GP3;
-
- PACKAGE BODY GP3 IS
- BEGIN
- IF NOT (IDENT_BOOL(R)) THEN
- FAILED ( "INCORRECT VALUE FOR OP - " & KIND);
- END IF;
- END GP3;
-
-BEGIN
- TEST ( "CC3601A", "CHECK THAT PREDEFINED OPERATORS MAY BE " &
- "PASSED AS ACTUAL GENERIC SUBPROGRAM " &
- "PARAMETERS" );
-
-
- BEGIN -- CHECKS WITH RELATIONAL OPERATORS AND LOGICAL OPERATORS AS
- -- ACTUAL PARAMETERS.
-
- FOR I1 IN BOOLEAN LOOP
-
- FOR I2 IN BOOLEAN LOOP
- COMMENT ( "B1 = " & BOOLEAN'IMAGE (I1) & " AND " &
- "B2 = " & BOOLEAN'IMAGE (I2) );
- DECLARE
- B1 : BOOLEAN := IDENT_BOOL (I1);
- B2 : BOOLEAN := IDENT_BOOL (I2);
-
- PACKAGE P1 IS
- NEW GP1 (BOOLEAN, NOT B2, B2,
- """NOT"" - 1", "NOT");
- PACKAGE P2 IS
- NEW GP2 (BOOLEAN, B1 OR B2, B1, B2,
- "OR", "OR");
- PACKAGE P3 IS
- NEW GP2 (BOOLEAN, B1 AND B2, B2, B1,
- "AND", "AND");
- PACKAGE P4 IS
- NEW GP2 (BOOLEAN, B1 /= B2, B1, B2,
- "XOR", "XOR");
- PACKAGE P5 IS
- NEW GP2 (BOOLEAN, B1 < B2, B1, B2,
- "<", "<");
- PACKAGE P6 IS
- NEW GP2 (BOOLEAN, B1 <= B2, B1, B2,
- "<=", "<=");
- PACKAGE P7 IS
- NEW GP2 (BOOLEAN, B1 > B2, B1, B2,
- ">", ">");
- PACKAGE P8 IS
- NEW GP2 (BOOLEAN, B1 >= B2, B1, B2,
- ">=", ">=");
-
- TYPE AB IS ARRAY (BOOLEAN RANGE <> )
- OF BOOLEAN;
- AB1 : AB (BOOLEAN) := (B1, B2);
- AB2 : AB (BOOLEAN) := (B2, B1);
- T : AB (B1 .. B2) := (B1 .. B2 => TRUE);
- F : AB (B1 .. B2) := (B1 .. B2 => FALSE);
- VB1 : AB (B1 .. B1) := (B1 => B2);
- VB2 : AB (B2 .. B2) := (B2 => B1);
-
- PACKAGE P9 IS
- NEW GP1 (AB, AB1, NOT AB1,
- """NOT"" - 2", "NOT");
- PACKAGE P10 IS
- NEW GP1 (AB, T, F,
- """NOT"" - 3", "NOT");
- PACKAGE P11 IS
- NEW GP1 (AB, VB2, (B2 => NOT B1),
- """NOT"" - 4", "NOT");
- PACKAGE P12 IS
- NEW GP2 (AB, AB1 AND AB2, AB1, AB2,
- "AND", "AND");
- BEGIN
- NULL;
- END;
- END LOOP;
- END LOOP;
- END;
-
- DECLARE -- CHECKS WITH ADDING AND MULTIPLYING OPERATORS, "**",
- -- AND "ABS".
-
- PACKAGE P1 IS NEW GP1 (INTEGER, -4, -4, """+"" - 1", "+");
-
- PACKAGE P2 IS NEW GP1 (FLOAT, 4.0, 4.0, """+"" - 2", "+");
-
- PACKAGE P3 IS NEW GP1 (DURATION, -4.0, -4.0, """+"" - 3",
- "+");
- PACKAGE P4 IS NEW GP1 (INTEGER, -4, 4, """-"" - 1", "-");
-
- PACKAGE P5 IS NEW GP1 (FLOAT, 0.0, 0.0, """-"" - 2", "-");
-
- PACKAGE P6 IS NEW GP1 (DURATION, 1.0, -1.0, """-"" - 3",
- "-");
- PACKAGE P7 IS NEW GP2 (INTEGER, 6, 1, 5, """+"" - 1", "+");
-
- PACKAGE P8 IS NEW GP2 (FLOAT, 6.0, 1.0, 5.0, """+"" - 2",
- "+");
- PACKAGE P9 IS NEW GP2 (DURATION, 6.0, 1.0, 5.0, """+"" - 3",
- "+");
- PACKAGE P10 IS NEW GP2 (INTEGER, 1, 6, 5, """-"" - 1",
- "-" );
- PACKAGE P11 IS NEW GP2 (DURATION, 11.0, 6.0,-5.0,
- """-"" - 2", "-");
- PACKAGE P12 IS NEW GP2 (FLOAT, 1.0, 6.0, 5.0, """-"" - 3",
- "-");
-
- SUBTYPE SUBINT IS INTEGER RANGE 0 .. 2;
- TYPE STR IS ARRAY (SUBINT RANGE <>) OF CHARACTER;
- VSTR : STR (0 .. 1) := "AB";
-
- PACKAGE P13 IS NEW GP2 (STR, VSTR (0 .. 0) &
- VSTR (1 .. 1),
- VSTR (0 .. 0),
- VSTR (1 .. 1), """&"" - 1", "&");
-
- PACKAGE P14 IS NEW GP2 (STR, VSTR (1 .. 1) &
- VSTR (0 .. 0),
- VSTR (1 .. 1),
- VSTR (0 .. 0), """&"" - 2", "&");
-
- PACKAGE P15 IS NEW GP2 (INTEGER, 0, -1, 0, """*"" - 1", "*");
-
- PACKAGE P16 IS NEW GP2 (FLOAT, 6.0, 3.0, 2.0, """*"" - 2",
- "*");
- PACKAGE P17 IS NEW GP2 (INTEGER, 0, 0, 6, """/"" - 1", "/");
-
- PACKAGE P18 IS NEW GP2 (FLOAT, 3.0, 6.0, 2.0, """/"" - 2",
- "/");
- PACKAGE P19 IS NEW GP2 (INTEGER, -1, -11, 5, "REM", "REM");
-
- PACKAGE P20 IS NEW GP2 (INTEGER, 4, -11, 5, "MOD", "MOD");
-
- PACKAGE P21 IS NEW GP1 (INTEGER, 5, 5, """ABS"" - 1", "ABS");
-
- PACKAGE P22 IS NEW GP1 (FLOAT, -5.0, 5.0, """ABS"" - 2",
- "ABS");
-
- PACKAGE P23 IS NEW GP1 (DURATION, 0.0, 0.0, """ABS"" - 3",
- "ABS");
-
- PACKAGE P24 IS NEW GP2 (INTEGER, 9, 3, 2, """**"" - 1",
- "**");
-
- PACKAGE P25 IS NEW GP2 (INTEGER, 1, 5, 0, """**"" - 2",
- "**");
-
- BEGIN
- NULL;
- END;
-
- DECLARE -- CHECKS WITH ATTRIBUTES.
-
- TYPE WEEKDAY IS (MON, TUES, WED, THUR, FRI);
-
- PACKAGE P1 IS NEW GP1 (WEEKDAY, TUES, WED, "WEEKDAY'SUCC",
- WEEKDAY'SUCC);
-
- PACKAGE P2 IS NEW GP1 (WEEKDAY, TUES, MON, "WEEKDAY'PRED",
- WEEKDAY'PRED);
-
- PACKAGE P3 IS NEW GP3 (WEEKDAY, STRING, THUR, "THUR",
- "WEEKDAY'IMAGE", WEEKDAY'IMAGE);
-
- PACKAGE P4 IS NEW GP3 (STRING, WEEKDAY, "FRI", FRI,
- "WEEKDAY'VALUE", WEEKDAY'VALUE);
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3601A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada b/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada
deleted file mode 100644
index a011977..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- CC3601C.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 "/=" MAY BE PASSED AS A GENERIC ACTUAL FUNCTION
--- PARAMETER.
-
--- DAT 10/6/81
--- SPS 10/27/82
--- JRK 2/9/83
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3601C IS
-BEGIN
- TEST ("CC3601C", "/= AS GENERIC ACTUAL PARAMETER");
-
- DECLARE
- PACKAGE PK IS
- TYPE LP IS LIMITED PRIVATE;
- FUNCTION "=" (X, Y : LP) RETURN BOOLEAN;-- RETURNS FALSE.
- TYPE INT IS NEW INTEGER;
- PRIVATE
- TASK TYPE LP;
- END PK;
- USE PK;
-
- V1, V2 : LP;
-
- TYPE REC IS RECORD
- C : LP;
- END RECORD;
-
- R1, R2 : REC;
-
- TYPE INT IS NEW INTEGER;
-
- B1 : BOOLEAN := TRUE;
- B2 : BOOLEAN := TRUE;
- INTEGER_3 : INTEGER := 3;
- INTEGER_4 : INTEGER := 4;
- INT_3 : INT := 3;
- INT_4 : INT := 4;
- INT_5 : INT := 5;
- PK_INT_M1 : PK.INT := -1;
- PK_INT_M2 : PK.INT := -2;
- PK_INT_1 : PK.INT := 1;
- PK_INT_2 : PK.INT := 2;
- PK_INT_3 : PK.INT := 3;
-
- FUNCTION "=" (Q, R : LP) RETURN BOOLEAN;-- RETURNS TRUE.
-
- GENERIC
- TYPE T IS LIMITED PRIVATE;
- V1, V2 : IN OUT T;
- WITH FUNCTION NE (ZA : IN T; ZB : T) RETURN BOOLEAN;
- VALUE : IN BOOLEAN; -- SHOULD BE VALUE OF NE(V1,V2).
- STR : STRING;
- PACKAGE GP IS END GP;
-
- FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN;
-
- FUNCTION NE (Q : INT; R : IN INT) RETURN BOOLEAN
- RENAMES "/=";
-
- FUNCTION NE (Q : PK.INT; R : IN PK.INT) RETURN BOOLEAN
- RENAMES "/=";
-
- PACKAGE BODY GP IS
- BEGIN
- IF IDENT_BOOL(VALUE) /= NE (V1, V2) THEN
- FAILED ("WRONG /= ACTUAL GENERIC PARAMETER "
- & STR);
- END IF;
- END GP;
-
- FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN IS
- BEGIN
- RETURN FALSE;
- END "=";
-
- FUNCTION "=" (Q, R : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END "=";
-
- PACKAGE BODY PK IS
- FUNCTION "=" (X, Y : LP) RETURN BOOLEAN IS
- BEGIN
- RETURN R1 = R1; -- FALSE.
- END "=";
- TASK BODY LP IS BEGIN NULL; END;
- END PK;
-
- PACKAGE P1 IS NEW GP (LP, V1, V2, "/=", FALSE, "1");
-
- FUNCTION "NOT" (X : BOOLEAN) RETURN BOOLEAN IS
- BEGIN RETURN X; END "NOT"; -- ENSURES USE OF PREDEFINED "NOT"
-
- PACKAGE P2 IS NEW GP (LP, V1, V2, "/=", FALSE, "2");
- PACKAGE P3 IS NEW GP (LP, V1, V2, PK."/=", TRUE, "3");
- PACKAGE P4 IS NEW GP (PK.LP, V1, V2, "/=", FALSE, "4");
- PACKAGE P5 IS NEW GP (PK.LP, V1, V2, PK."/=", TRUE, "5");
- PACKAGE P6 IS NEW GP (REC, R1, R2, "/=", TRUE, "6");
- PACKAGE P7 IS NEW GP (INTEGER, INTEGER_3, INTEGER_4, "/=",
- TRUE, "7");
- PACKAGE P8 IS NEW GP (BOOLEAN, B1, B2, "/=", FALSE,"8");
- PACKAGE P9 IS NEW GP (INT, INT_3, INT_5, "/=", TRUE, "9");
- PACKAGE P10 IS NEW GP (INT, INT_3, INT_3, "/=", FALSE, "10");
- PACKAGE P11 IS NEW GP (INT, INT_3, INT_4, NE, TRUE, "11");
- PACKAGE P12 IS NEW GP (INT, INT_3, INT_3, NE, FALSE, "12");
- PACKAGE P13 IS NEW GP (PK.INT, PK_INT_3, PK_INT_3, NE,
- FALSE, "13");
- PACKAGE P14 IS NEW GP (PK.INT, PK_INT_M1, PK_INT_M2, NE,
- TRUE, "14");
- PACKAGE P15 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, "/=",
- FALSE, "15");
- PACKAGE P16 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, "/=",
- TRUE, "16");
- PACKAGE P17 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, PK."/=",
- FALSE, "17");
- PACKAGE P18 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, PK."/=",
- TRUE, "18");
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CC3601C;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada
deleted file mode 100644
index 005995e..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- CC3602A.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 ENTRIES MAY BE PASSED AS GENERIC SUBPROGRAM
--- PARAMETERS.
-
--- HISTORY:
--- DAT 9/25/81 CREATED ORIGINAL TEST.
--- LDC 10/6/88 REVISED; CHECKED THAT DEFAULT NAME CAN BE
--- IDENTIFIED WITH ENTRY.
-
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3602A IS
- COUNTER : INTEGER := 0;
-BEGIN
- TEST ("CC3602A", "ENTRIES AS GENERIC SUBPROGRAM PARAMETERS");
-
- DECLARE
- TASK TSK IS
- ENTRY ENT;
- END TSK;
-
- GENERIC
- WITH PROCEDURE P;
- PROCEDURE GP;
-
- GENERIC
- WITH PROCEDURE P;
- PACKAGE PK IS END PK;
-
-
- PROCEDURE E1 RENAMES TSK.ENT;
-
- GENERIC
- WITH PROCEDURE P IS TSK.ENT;
- PROCEDURE GP_DEF1;
-
- GENERIC
- WITH PROCEDURE P IS E1;
- PROCEDURE GP_DEF2;
-
- GENERIC
- WITH PROCEDURE P IS TSK.ENT;
- PACKAGE PK_DEF1 IS END PK_DEF1;
-
- GENERIC
- WITH PROCEDURE P IS E1;
- PACKAGE PK_DEF2 IS END PK_DEF2;
-
- PROCEDURE GP IS
- BEGIN
- P;
- END GP;
-
- PACKAGE BODY PK IS
- BEGIN
- P;
- END PK;
-
-
- PROCEDURE GP_DEF1 IS
- BEGIN
- P;
- END GP_DEF1;
-
- PROCEDURE GP_DEF2 IS
- BEGIN
- P;
- END GP_DEF2;
-
- PACKAGE BODY PK_DEF1 IS
- BEGIN
- P;
- END PK_DEF1;
-
- PACKAGE BODY PK_DEF2 IS
- BEGIN
- P;
- END PK_DEF2;
-
- TASK BODY TSK IS
- BEGIN
- LOOP
- SELECT
- ACCEPT ENT DO
- COUNTER := COUNTER + 1;
- END ENT;
- OR
- TERMINATE;
- END SELECT;
- END LOOP;
- END TSK;
-
- BEGIN
- DECLARE
- PROCEDURE P1 IS NEW GP (TSK.ENT);
- PROCEDURE E RENAMES TSK.ENT;
- PROCEDURE P2 IS NEW GP (E);
- PACKAGE PK1 IS NEW PK (TSK.ENT);
- PACKAGE PK2 IS NEW PK (E);
-
- PROCEDURE P3 IS NEW GP_DEF1;
- PROCEDURE P4 IS NEW GP_DEF2;
- PACKAGE PK3 IS NEW PK_DEF1;
- PACKAGE PK4 IS NEW PK_DEF2;
- BEGIN
- P1;
- P2;
- TSK.ENT;
- E;
- P3;
- P4;
- END;
- TSK.ENT;
- END;
-
- IF COUNTER /= 11 THEN
- FAILED ("INCORRECT CALL OF ENTRY AS GENERIC PARAMETER");
- END IF;
-
- RESULT;
-END CC3602A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada
deleted file mode 100644
index 45e65b2..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- CC3603A.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 ENUMERATION LITERALS (BOTH IDENTIFIERS AND CHARACTER
--- LITERALS) MAY BE PASSED AS ACTUALS CORRESPONDING TO GENERIC
--- FORMAL SUBPROGRAMS.
-
--- HISTORY:
--- RJW 06/11/86 CREATED ORIGINAL TEST.
--- VCL 08/18/87 CHANGED THE SECOND ACTUAL GENERIC PARAMETER IN THE
--- INSTANTIATION OF PROCEDURE NP3 TO
--- 'IDENT_CHAR('X')'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3603A IS
-
-BEGIN
- TEST ("CC3603A", "CHECK THAT ENUMERATION LITERALS (BOTH " &
- "IDENTIFIERS AND CHARACTER LITERALS) MAY " &
- "BE PASSED AS ACTUALS CORRESPONDING TO " &
- "GENERIC FORMAL SUBPROGRAMS" );
-
- DECLARE
-
- TYPE ENUM1 IS ('A', 'B');
- TYPE ENUM2 IS (C, D);
-
- GENERIC
- TYPE E IS (<>);
- E1 : E;
- WITH FUNCTION F RETURN E;
- PROCEDURE P;
-
- PROCEDURE P IS
- BEGIN
- IF F /= E1 THEN
- FAILED ( "WRONG VALUE FOR " & E'IMAGE (E1) &
- " AS ACTUAL PARAMETER" );
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED INSIDE OF P WITH " &
- E'IMAGE (E1) &
- " AS ACTUAL PARAMETER" );
- END P;
-
- PROCEDURE NP1 IS NEW P (ENUM1, 'A', 'A');
- PROCEDURE NP2 IS NEW P (ENUM2, D, D);
- PROCEDURE NP3 IS NEW P (CHARACTER, IDENT_CHAR('X'), 'X');
- BEGIN
- BEGIN
- NP1;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED WHEN NP1 CALLED" );
- END;
-
- BEGIN
- NP2;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED WHEN NP2 CALLED" );
- END;
-
- BEGIN
- NP3;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ( "EXCEPTION RAISED WHEN NP3 CALLED" );
- END;
- END;
- RESULT;
-
-END CC3603A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada
deleted file mode 100644
index b9fb50b..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada
+++ /dev/null
@@ -1,381 +0,0 @@
--- CC3605A.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 SOME DIFFERENCES BETWEEN THE FORMAL AND THE
--- ACTUAL SUBPROGRAMS DO NOT INVALIDATE A MATCH.
--- 1) CHECK DIFFERENT PARAMETER NAMES.
--- 2) CHECK DIFFERENT PARAMETER CONSTRAINTS.
--- 3) CHECK ONE PARAMETER CONSTRAINED AND THE OTHER
--- UNCONSTRAINED (WITH ARRAY, RECORD, ACCESS, AND
--- PRIVATE TYPES).
--- 4) CHECK PRESENCE OR ABSENCE OF AN EXPLICIT "IN" MODE
--- INDICATOR.
--- 5) DIFFERENT TYPE MARKS USED TO SPECIFY THE TYPE OF
--- PARAMETERS.
-
--- HISTORY:
--- LDC 10/04/88 CREATED ORIGINAL TEST.
-
-PACKAGE CC3605A_PACK IS
-
- SUBTYPE INT IS INTEGER RANGE -100 .. 100;
-
- TYPE PRI_TYPE (SIZE : INT) IS PRIVATE;
-
- SUBTYPE PRI_CONST IS PRI_TYPE (2);
-
-PRIVATE
-
- TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
-
- TYPE PRI_TYPE (SIZE : INT) IS
- RECORD
- SUB_A : ARR_TYPE (1 .. SIZE);
- END RECORD;
-
-END CC3605A_PACK;
-
-
-WITH REPORT;
-USE REPORT;
-WITH CC3605A_PACK;
-USE CC3605A_PACK;
-
-PROCEDURE CC3605A IS
-
- SUBTYPE ZERO_TO_TEN IS INTEGER
- RANGE IDENT_INT (0) .. IDENT_INT (10);
-
- SUBTYPE ONE_TO_FIVE IS INTEGER
- RANGE IDENT_INT (1) .. IDENT_INT (5);
-
- SUBPRG_ACT : BOOLEAN := FALSE;
-BEGIN
- TEST
- ("CC3605A", "CHECK THAT SOME DIFFERENCES BETWEEN THE " &
- "FORMAL AND THE ACTUAL PARAMETERS DO NOT " &
- "INVALIDATE A MATCH");
-
-----------------------------------------------------------------------
--- DIFFERENT PARAMETER NAMES
-----------------------------------------------------------------------
-
- DECLARE
-
- PROCEDURE ACT_PROC (DIFF_NAME_PARM : ONE_TO_FIVE) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : ONE_TO_FIVE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (ONE_TO_FIVE'FIRST);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("DIFFERENT PARAMETER NAMES MADE MATCH INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- DIFFERENT PARAMETER CONSTRAINTS
-----------------------------------------------------------------------
-
- DECLARE
-
- PROCEDURE ACT_PROC (PARM : ONE_TO_FIVE) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : ZERO_TO_TEN);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (ONE_TO_FIVE'FIRST);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("DIFFERENT PARAMETER CONSTRAINTS MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- ONE PARAMETER CONSTRAINED (ARRAY)
-----------------------------------------------------------------------
-
- DECLARE
-
- TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
-
- SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST ..
- ONE_TO_FIVE'LAST);
-
- PASSED_PARM : ARR_CONST := (OTHERS => TRUE);
-
- PROCEDURE ACT_PROC (PARM : ARR_CONST) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : ARR_TYPE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (PASSED_PARM);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("ONE ARRAY PARAMETER CONSTRAINED MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- ONE PARAMETER CONSTRAINED (RECORDS)
-----------------------------------------------------------------------
-
- DECLARE
-
- TYPE REC_TYPE (BOL : BOOLEAN) IS
- RECORD
- SUB_A : INTEGER;
- CASE BOL IS
- WHEN TRUE =>
- DSCR_A : INTEGER;
-
- WHEN FALSE =>
- DSCR_B : BOOLEAN;
-
- END CASE;
- END RECORD;
-
- SUBTYPE REC_CONST IS REC_TYPE (TRUE);
-
- PASSED_PARM : REC_CONST := (TRUE, 1, 2);
-
- PROCEDURE ACT_PROC (PARM : REC_CONST) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : REC_TYPE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (PASSED_PARM);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("ONE RECORD PARAMETER CONSTRAINED MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- ONE PARAMETER CONSTRAINED (ACCESS)
-----------------------------------------------------------------------
-
- DECLARE
-
- TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
-
- SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST ..
- ONE_TO_FIVE'LAST);
-
- TYPE ARR_ACC_TYPE IS ACCESS ARR_TYPE;
-
- SUBTYPE ARR_ACC_CONST IS ARR_ACC_TYPE (1 .. 3);
-
- PASSED_PARM : ARR_ACC_TYPE := NULL;
-
- PROCEDURE ACT_PROC (PARM : ARR_ACC_CONST) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : ARR_ACC_TYPE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (PASSED_PARM);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("ONE ACCESS PARAMETER CONSTRAINED MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- ONE PARAMETER CONSTRAINED (PRIVATE)
-----------------------------------------------------------------------
-
- DECLARE
- PASSED_PARM : PRI_CONST;
-
- PROCEDURE ACT_PROC (PARM : PRI_CONST) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : PRI_TYPE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (PASSED_PARM);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("ONE PRIVATE PARAMETER CONSTRAINED MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- PRESENCE (OR ABSENCE) OF AN EXPLICIT "IN" MODE
-----------------------------------------------------------------------
-
- DECLARE
-
- PROCEDURE ACT_PROC (PARM : INTEGER) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM : IN INTEGER);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (1);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED
- ("PRESENCE OF AN EXPLICIT 'IN' MODE MADE MATCH " &
- "INVALID");
- END IF;
- END;
-
-----------------------------------------------------------------------
--- DIFFERENT TYPE MARKS
-----------------------------------------------------------------------
-
- DECLARE
-
- SUBTYPE MARK_1_TYPE IS INTEGER;
-
- SUBTYPE MARK_2_TYPE IS INTEGER;
-
- PROCEDURE ACT_PROC (PARM1 : IN MARK_1_TYPE) IS
- BEGIN
- SUBPRG_ACT := TRUE;
- END ACT_PROC;
-
- GENERIC
-
- WITH PROCEDURE PASSED_PROC (PARM2 : MARK_2_TYPE);
-
- PROCEDURE GEN_PROC;
-
- PROCEDURE GEN_PROC IS
- BEGIN
- PASSED_PROC (1);
- END GEN_PROC;
-
- PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC);
- BEGIN
- SUBPRG_ACT := FALSE;
- INST_PROC;
- IF NOT SUBPRG_ACT THEN
- FAILED ("DIFFERENT TYPE MARKS MADE MATCH INVALID");
- END IF;
- END;
- RESULT;
-END CC3605A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada b/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada
deleted file mode 100644
index 4d63b71..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CC3606A.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 DEFAULT EXPRESSIONS OF A FORMAL SUBPROGRAM'S
--- FORMAL PARAMETERS ARE USED WHEN THE FORMAL SUBPROGRAM IS
--- CALLED IN THE INSTANTIATED UNIT (RATHER THAN ANY DEFAULT
--- ASSOCIATED WITH ACTUAL SUBPROGRAM'S PARAMETERS).
-
--- HISTORY:
--- BCB 09/29/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3606A IS
-
- X : BOOLEAN;
- Y : BOOLEAN;
-
- FUNCTION FUNC (A : INTEGER := 35) RETURN BOOLEAN IS
- BEGIN
- RETURN (A = 7);
- END FUNC;
-
- PROCEDURE PROC (B : INTEGER := 35) IS
- BEGIN
- IF B /= 7 THEN
- FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " &
- "PROCEDURE NOT USED - 1");
- END IF;
- END PROC;
-
- FUNCTION FUNC1 (C : INTEGER := 35) RETURN BOOLEAN IS
- BEGIN
- RETURN (C = 7);
- END FUNC1;
-
- PROCEDURE PROC3 (D : INTEGER := 35) IS
- BEGIN
- IF D /= 7 THEN
- FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " &
- "PROCEDURE NOT USED - 2");
- END IF;
- END PROC3;
-
- GENERIC
- WITH FUNCTION FUNC (A : INTEGER := 7) RETURN BOOLEAN;
- FUNCTION GENFUNC RETURN BOOLEAN;
-
- FUNCTION GENFUNC RETURN BOOLEAN IS
- BEGIN
- IF NOT FUNC THEN
- FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " &
- "FUNCTION NOT USED - 1");
- END IF;
- RETURN TRUE;
- END GENFUNC;
-
- GENERIC
- WITH PROCEDURE PROC (B : INTEGER := 7);
- PACKAGE PKG IS
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- PROC;
- END PKG;
-
- GENERIC
- WITH FUNCTION FUNC1 (C : INTEGER := 7) RETURN BOOLEAN;
- PROCEDURE PROC2;
-
- PROCEDURE PROC2 IS
- BEGIN
- IF NOT FUNC1 THEN
- FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " &
- "FUNCTION NOT USED - 2");
- END IF;
- END PROC2;
-
- GENERIC
- WITH PROCEDURE PROC3 (D : INTEGER := 7) IS <>;
- FUNCTION GENFUNC1 RETURN BOOLEAN;
-
- FUNCTION GENFUNC1 RETURN BOOLEAN IS
- BEGIN
- PROC3;
- RETURN TRUE;
- END GENFUNC1;
-
- FUNCTION NEWFUNC IS NEW GENFUNC(FUNC);
-
- PACKAGE PACK IS NEW PKG(PROC);
-
- PROCEDURE PROC4 IS NEW PROC2(FUNC1);
-
- FUNCTION NEWFUNC1 IS NEW GENFUNC1;
-
-BEGIN
-
- TEST ("CC3606A", "CHECK THAT THE DEFAULT EXPRESSIONS OF A " &
- "FORMAL SUBPROGRAM'S FORMAL PARAMETERS ARE " &
- "USED WHEN THE FORMAL SUBPROGRAM IS CALLED IN " &
- "THE INSTANTIATED UNIT (RATHER THAN ANY " &
- "DEFAULT ASSOCIATED WITH ACTUAL SUBPROGRAM'S " &
- "PARAMETERS)");
-
- X := NEWFUNC;
- Y := NEWFUNC1;
- PROC4;
-
- RESULT;
-END CC3606A;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada
deleted file mode 100644
index 79dc8a7b..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CC3606B.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 ANY CONSTRAINTS SPECIFIED FOR THE ACTUAL
--- SUBPROGRAM'S PARAMETERS ARE USED IN PLACE OF THOSE
--- ASSOCIATED WITH THE FORMAL SUBPROGRAM'S PARAMETERS
--- (INCLUDING PARAMETERS SPECIFIED WITH A FORMAL GENERIC TYPE).
-
--- HISTORY:
--- LDC 06/30/88 CREATED ORIGINAL TEST.
--- PWN 05/31/96 Corrected spelling problems.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CC3606B IS
-
- SUBTYPE ONE_TO_TEN IS
- INTEGER RANGE IDENT_INT (1) .. IDENT_INT (10);
- SUBTYPE ONE_TO_FIVE IS
- INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5);
-
-BEGIN
- TEST ( "CC3606B", "CHECK THAT ANY CONSTRAINTS SPECIFIED FOR " &
- "THE ACTUAL SUBPROGRAM'S PARAMETERS ARE USED " &
- "IN PLACE OF THOSE ASSOCIATED WITH THE " &
- "FORMAL SUBPROGRAM'S PARAMETERS (INCLUDING " &
- "PARAMETERS SPECIFIED WITH A FORMAL GENERIC " &
- "TYPE)");
- DECLARE
- GENERIC
- BRIAN : IN OUT INTEGER;
- WITH PROCEDURE PASSED_PROC(LYNN :IN OUT ONE_TO_TEN);
- PACKAGE GEN IS
- END GEN;
-
- DOUG : INTEGER := 10;
-
- PACKAGE BODY GEN IS
- BEGIN
- PASSED_PROC(BRIAN);
- FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN GEN");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("OTHER EXCEPTION WAS RAISED FOR ACTUAL " &
- "PARAMETER");
- END GEN;
-
- PROCEDURE PROC(JODIE : IN OUT ONE_TO_FIVE) IS
- JOHN : ONE_TO_TEN;
- BEGIN
- JOHN := IDENT_INT(JODIE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED INSIDE PROCEDURE");
- END PROC;
-
- PACKAGE GEN_PCK IS NEW GEN( DOUG, PROC);
-
- BEGIN
- NULL;
- END;
- DECLARE
- TYPE ENUM IS (DAYTON, BEAVERCREEK, CENTERVILLE, ENGLEWOOD,
- FAIRBORN, HUBER_HEIGHTS, KETTERING, MIAMISBURG,
- OAKWOOD, RIVERSIDE, TROTWOOD, WEST_CARROLLTON,
- VANDALIA);
- SUBTYPE SUB_ENUM IS ENUM RANGE CENTERVILLE..FAIRBORN;
-
- GENERIC
- TYPE T_TYPE IS (<>);
- BRIAN : T_TYPE;
- WITH FUNCTION PASSED_FUNC(LYNN : T_TYPE)
- RETURN T_TYPE;
-
- PACKAGE GEN_TWO IS
- END GEN_TWO;
-
- DOUG : ENUM := ENUM'FIRST;
-
- PACKAGE BODY GEN_TWO IS
-
- DAVE : T_TYPE;
-
- BEGIN
- DAVE := PASSED_FUNC(BRIAN);
- FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN " &
- "GEN_TWO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("OTHER EXCEPTION WAS " &
- "RAISED FOR ACTUAL " &
- "PARAMETER");
- END GEN_TWO;
-
- FUNCTION FUNC(JODIE : SUB_ENUM) RETURN SUB_ENUM IS
- BEGIN
- RETURN ENUM'VAL(IDENT_INT(ENUM'POS(JODIE)));
- EXCEPTION
- WHEN OTHERS =>
- FAILED("EXCEPTION RAISED INSIDE PROCEDURE");
- END FUNC;
-
- PACKAGE GEN_PCK_TWO IS NEW GEN_TWO( ENUM, DOUG, FUNC);
-
- BEGIN
- RESULT;
- END;
-END CC3606B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada b/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada
deleted file mode 100644
index 701c739..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- CC3607B.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 WHEN A DEFAULT SUBPROGRAM IS SPECIFIED WITH A BOX, A
--- SUBPROGRAM DIRECTLY VISIBLE AT THE POINT OF INSTANTIATION
--- IS USED.
-
--- HISTORY:
--- LDC 08/23/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CC3607B IS
-
-BEGIN
- TEST ("CC3607B", "CHECK THAT WHEN A DEFAULT SUBPROGRAM IS " &
- "SPECIFIED WITH A BOX, A SUBPROGRAM DIRECTLY " &
- "VISIBLE AT THE POINT OF INSTANTIATION IS USED");
- DECLARE
- PACKAGE PROC_PACK IS
- PROCEDURE PROC;
-
- GENERIC
- WITH PROCEDURE PROC IS <>;
- PACKAGE GEN_PACK IS
- PROCEDURE DO_PROC;
- END GEN_PACK;
- END PROC_PACK;
- USE PROC_PACK;
-
- PACKAGE BODY PROC_PACK IS
- PROCEDURE PROC IS
- BEGIN
- FAILED("WRONG SUBPROGRAM WAS USED");
- END PROC;
-
- PACKAGE BODY GEN_PACK IS
- PROCEDURE DO_PROC IS
- BEGIN
- PROC;
- END DO_PROC;
- END GEN_PACK;
- END PROC_PACK;
-
- PROCEDURE PROC IS
- BEGIN
- COMMENT ("SUBPROGRAM VISIBLE AT INSTANTIATION WAS " &
- "USED");
- END PROC;
-
- PACKAGE NEW_PACK IS NEW GEN_PACK;
-
- BEGIN
- NEW_PACK.DO_PROC;
- END;
-
- RESULT;
-END CC3607B;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc40001.a b/gcc/testsuite/ada/acats/tests/cc/cc40001.a
deleted file mode 100644
index bf42470..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc40001.a
+++ /dev/null
@@ -1,403 +0,0 @@
--- CC40001.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 adjust is called on the value of a constant object created
--- by the evaluation of a generic association for a formal object of
--- mode in.
---
--- Check that those values are also subsequently finalized.
---
--- TEST DESCRIPTION:
--- Create a backdrop of a controlled type sufficient to check that the
--- correct operations get called at appropriate times. Create a generic
--- unit that takes a formal parameter of a formal type. Create instances
--- of this generic using various "levels" of the controlled type. Check
--- the same case for a generic child unit.
---
--- The cases tested are where the type of the formal object is:
--- a visible classwide type : CC40001_2
--- a formal private type : CC40001_3
--- a formal tagged type : CC40001_4
---
--- To more fully take advantage of the features of the language, and
--- present a test which is "user oriented" this test utilizes multiple
--- aspects of the language in combination. Using Ada.Strings.Unbounded
--- in combination with Ada.Finalization and Ada.Calendar to build layers
--- of an object oriented system will likely be very common in actual
--- practice. A common paradigm in the language will also be the use of
--- a parent package defining "basic" tagged types, and child packages
--- will expand on those types via derivation. The model used in this
--- test is a simple type containing a character identity (used in the
--- identity). The next level of type add a timestamp. Further levels
--- might add location information, etc. however for the purposes of this
--- test we stop at the second layer, as it is sufficient to test the
--- stated objective.
---
---
--- CHANGE HISTORY:
--- 06 FEB 96 SAIC Initial version
--- 30 APR 96 SAIC Added finalization checks for 2.1
--- 13 FEB 97 PWB.CTA Moved global objects into bodies, after Initialize
--- body is elaborated; counted finalizations correctly.
---!
-
------------------------------------------------------------------ CC40001_0
-
-with Ada.Finalization;
-with Ada.Strings.Unbounded;
-package CC40001_0 is
-
- type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted );
-
- type Simple_Object(ID: Character) is
- new Ada.Finalization.Controlled with
- record
- TC_Current_State : States := Defaulted;
- Name : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- procedure User_Operation( COB: in out Simple_Object; Name : String );
- procedure Initialize( COB: in out Simple_Object );
- procedure Adjust ( COB: in out Simple_Object );
- procedure Finalize ( COB: in out Simple_Object );
-
- Finalization_Count : Natural;
-
-end CC40001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CC40001_0 is
-
- procedure User_Operation( COB: in out Simple_Object; Name : String ) is
- begin
- COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name);
- end User_Operation;
-
- procedure Initialize( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Initialized;
- end Initialize;
-
- procedure Adjust ( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Adjusted;
- TCTouch.Touch('A'); -------------------------------------------------- A
- TCTouch.Touch(COB.ID); ------------------------------------------------ ID
- -- note that the calls to touch will not be directly validated, it is
- -- expected that some number > 0 of calls will be made to this procedure,
- -- the subtests then clear (Flush) the Touch buffer and perform actions
- -- where an incorrect implementation might call this procedure. Such a
- -- call will fail on the attempt to "Validate" the null string.
- end Adjust;
-
- procedure Finalize ( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Erroneous;
- Finalization_Count := Finalization_Count +1;
- end Finalize;
-
- TC_Global_Object : Simple_Object('G');
-
-end CC40001_0;
-
------------------------------------------------------------------ CC40001_1
-
-with Ada.Calendar;
-package CC40001_0.CC40001_1 is
-
- type Object_In_Time(ID: Character) is
- new Simple_Object(ID) with
- record
- Birth : Ada.Calendar.Time;
- Activity : Ada.Calendar.Time;
- end record;
-
- procedure User_Operation( COB: in out Object_In_Time;
- Name: String );
-
- procedure Initialize( COB: in out Object_In_Time );
- procedure Adjust ( COB: in out Object_In_Time );
- procedure Finalize ( COB: in out Object_In_Time );
-
-end CC40001_0.CC40001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CC40001_0.CC40001_1 is
-
- procedure Initialize( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Initialized;
- COB.Birth := Ada.Calendar.Clock;
- end Initialize;
-
- procedure Adjust ( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Adjusted;
- TCTouch.Touch('a'); ------------------------------------------------ a
- TCTouch.Touch(COB.ID); ------------------------------------------------ ID
- end Adjust;
-
- procedure Finalize ( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Erroneous;
- Finalization_Count := Finalization_Count +1;
- end Finalize;
-
- procedure User_Operation( COB: in out Object_In_Time;
- Name: String ) is
- begin
- CC40001_0.User_Operation( Simple_Object(COB), Name );
- COB.Activity := Ada.Calendar.Clock;
- COB.TC_Current_State := Reset;
- end User_Operation;
-
- TC_Time_Object : Object_In_Time('g');
-
-end CC40001_0.CC40001_1;
-
------------------------------------------------------------------ CC40001_2
-
-generic
- TC_Check_Object : in CC40001_0.Simple_Object'Class;
-package CC40001_0.CC40001_2 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_2 is
-
- procedure TC_Verify_State is
- begin
- if TC_Check_Object.TC_Current_State /= Adjusted then
- Report.Failed( "CC40001_2 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_2;
-
------------------------------------------------------------------ CC40001_3
-
-generic
- type Formal_Private(<>) is private;
- TC_Check_Object : in Formal_Private;
- with function Bad_Status( O: Formal_Private ) return Boolean;
-package CC40001_0.CC40001_3 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_3 is
-
- procedure TC_Verify_State is
- begin
- if Bad_Status( TC_Check_Object ) then
- Report.Failed( "CC40001_3 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_3;
-
------------------------------------------------------------------ CC40001_4
-
-generic
- type Formal_Tagged_Private(<>) is tagged private;
- TC_Check_Object : in Formal_Tagged_Private;
- with function Bad_Status( O: Formal_Tagged_Private ) return Boolean;
-package CC40001_0.CC40001_4 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_4;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_4 is
-
- procedure TC_Verify_State is
- begin
- if Bad_Status( TC_Check_Object ) then
- Report.Failed( "CC40001_4 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_4;
-
-------------------------------------------------------------------- CC40001
-
-with Report;
-with TCTouch;
-with CC40001_0.CC40001_1;
-with CC40001_0.CC40001_2;
-with CC40001_0.CC40001_3;
-with CC40001_0.CC40001_4;
-procedure CC40001 is
-
- function Not_Adjusted( CO : CC40001_0.Simple_Object )
- return Boolean is
- use type CC40001_0.States;
- begin
- return CO.TC_Current_State /= CC40001_0.Adjusted;
- end Not_Adjusted;
-
- function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time )
- return Boolean is
- use type CC40001_0.States;
- begin
- return CO.TC_Current_State /= CC40001_0.Adjusted;
- end Not_Adjusted;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1
-
- procedure Subtest_1 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_1_1 is
- new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object
-
- package Subtest_1_2 is
- new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries, no further calls
- -- to Touch should occur before the call to Validate
-
- -- set the objects TC_Current_State to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 1" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" );
-
- -- check that the objects TC_Current_State is "Adjusted"
- Subtest_1_1.TC_Verify_State;
- Subtest_1_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 1" );
-
- end Subtest_1;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2
-
- procedure Subtest_2 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_2_1 is -- generic formal object is discriminated private
- new CC40001_0.CC40001_3( CC40001_0.Simple_Object,
- Object_0,
- Not_Adjusted );
-
- package Subtest_2_2 is -- generic formal object is discriminated private
- new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time,
- Object_1,
- Not_Adjusted );
-
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries
-
- -- set the objects state to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 2" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" );
-
- Subtest_2_1.TC_Verify_State;
- Subtest_2_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 2" );
-
- end Subtest_2;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3
-
- procedure Subtest_3 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_3_1 is -- generic formal object is discriminated tagged
- new CC40001_0.CC40001_4( CC40001_0.Simple_Object,
- Object_0,
- Not_Adjusted );
-
- package Subtest_3_2 is -- generic formal object is discriminated tagged
- new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time,
- Object_1,
- Not_Adjusted );
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries
-
- -- set the objects state to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 3" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" );
-
- Subtest_3_1.TC_Verify_State;
- Subtest_3_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 3" );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("CC40001", "Check that adjust and finalize are called on " &
- "the constant object created by the " &
- "evaluation of a generic association for a " &
- "formal object of mode in" );
-
- -- check that the created constant objects are properly adjusted
- -- and subsequently finalized
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_1;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 1");
- end if;
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_2;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 2");
- end if;
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_3;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 3");
- end if;
-
- Report.Result;
-
-end CC40001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50001.a b/gcc/testsuite/ada/acats/tests/cc/cc50001.a
deleted file mode 100644
index 32a1afe..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50001.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CC50001.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 an instance, each implicit declaration of a predefined
--- operator of a formal tagged private type declares a view of the
--- corresponding predefined operator of the actual type (even if the
--- operator has been overridden for the actual type). Check that the
--- body executed is determined by the type and tag of the operands.
---
--- TEST DESCRIPTION:
--- The formal tagged private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- to be passed as actuals. For tagged types, definite implies
--- nondiscriminated, and indefinite implies discriminated (with known
--- or unknown discriminants).
---
--- Only nonlimited tagged types are tested, since equality operators
--- are not predefined for limited types.
---
--- A tagged type is passed as an actual to a generic formal tagged
--- private type. The tagged type overrides the predefined equality
--- operator. A subprogram within the generic calls the equality operator
--- of the formal type. In an instance, the equality operator denotes
--- a view of the predefined operator of the actual type, but the
--- call dispatches to the body of the overriding operator.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected expected result on
--- calls to "=" within the instance. Modified
--- commentary.
---
---!
-
-package CC50001_0 is
-
- type Count_Type is tagged record -- Nondiscriminated
- Count : Integer := 0; -- tagged type.
- end record;
-
- function "="(Left, Right : Count_Type) -- User-defined
- return Boolean; -- equality operator.
-
-
- subtype Str_Len is Natural range 0 .. 100;
- subtype Stu_ID is String (1 .. 5);
- subtype Dept_ID is String (1 .. 4);
- subtype Emp_ID is String (1 .. 9);
- type Status is (Student, Faculty, Staff);
-
- type Person_Type (Stat : Status; -- Discriminated
- NameLen, AddrLen : Str_Len) is -- tagged type.
- tagged record
- Name : String (1 .. NameLen);
- Address : String (1 .. AddrLen);
- case Stat is
- when Student =>
- Student_ID : Stu_ID;
- when Faculty =>
- Department : Dept_ID;
- when Staff =>
- Employee_ID : Emp_ID;
- end case;
- end record;
-
- function "="(Left, Right : Person_Type) -- User-defined
- return Boolean; -- equality operator.
-
-
- -- Testing entities: ------------------------------------------------
-
- TC_Count_Item : constant Count_Type := (Count => 111);
-
- TC_Person_Item : constant Person_Type :=
- (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
-
- ---------------------------------------------------------------------
-
-
-end CC50001_0;
-
-
- --===================================================================--
-
-
-package body CC50001_0 is
-
- function "="(Left, Right : Count_Type) return Boolean is
- begin
- return False; -- Return FALSE even if Left = Right.
- end "=";
-
-
- function "="(Left, Right : Person_Type) return Boolean is
- begin
- return False; -- Return FALSE even if Left = Right.
- end "=";
-
-end CC50001_0;
-
-
- --===================================================================--
-
-
-with CC50001_0; -- Tagged (actual) type declarations.
-generic -- Generic stack abstraction.
-
- type Item (<>) is tagged private; -- Formal tagged private type.
-
-package CC50001_1 is
-
- -- Simulate a generic stack abstraction. In a real application, the
- -- second operand of Push might be of type Stack, and type Stack
- -- would have at least one component (pointing to the top stack item).
-
- type Stack is private;
-
- procedure Push (I : in Item; TC_Check : out Boolean);
-
- -- ... Other stack operations.
-
-private
-
- -- ... Stack and ancillary type declarations.
-
- type Stack is record -- Artificial.
- null;
- end record;
-
-end CC50001_1;
-
-
- --===================================================================--
-
-
-package body CC50001_1 is
-
- -- For the sake of brevity, the implementation of Push is completely
- -- artificial; the goal is to model a call of the equality operator within
- -- the generic.
- --
- -- A real application might implement Push such that it does not add new
- -- items to the stack if they are identical to the top item; in that
- -- case, the equality operator would be called as part of an "if"
- -- condition.
-
- procedure Push (I : in Item; TC_Check : out Boolean) is
- begin
- TC_Check := not (I = I); -- Call user-defined "="; should
- -- return FALSE. Negation of
- -- result makes TC_Check TRUE.
- end Push;
-
-end CC50001_1;
-
-
- --==================================================================--
-
-
-with CC50001_0; -- Tagged (actual) type declarations.
-with CC50001_1; -- Generic stack abstraction.
-
-use CC50001_0; -- Overloaded "=" directly visible.
-
-with Report;
-procedure CC50001 is
-
- package Count_Stacks is new CC50001_1 (CC50001_0.Count_Type);
- package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);
-
- User_Defined_Op_Called : Boolean;
-
-begin
- Report.Test ("CC50001", "Check that, in an instance, each implicit " &
- "declaration of a primitive subprogram of a formal tagged " &
- "private type declares a view of the corresponding " &
- "predefined operator of the actual type (even if the " &
- "operator has been overridden or hidden for the actual type)");
-
---
--- Test which "=" is called inside generic:
---
-
- User_Defined_Op_Called := False;
-
- Count_Stacks.Push (CC50001_0.TC_Count_Item,
- User_Defined_Op_Called);
-
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called inside generic for Count");
- end if;
-
-
- User_Defined_Op_Called := False;
-
- Person_Stacks.Push (CC50001_0.TC_Person_Item,
- User_Defined_Op_Called);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called inside generic " &
- "for Person");
- end if;
-
-
---
--- Test which "=" is called outside generic:
---
-
- User_Defined_Op_Called := False;
-
- User_Defined_Op_Called :=
- not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called outside generic "&
- "for Count");
- end if;
-
-
- User_Defined_Op_Called := False;
-
- User_Defined_Op_Called :=
- not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called outside generic "&
- "for Person");
- end if;
-
-
- Report.Result;
-end CC50001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a
deleted file mode 100644
index 4d5dfdf..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a
+++ /dev/null
@@ -1,313 +0,0 @@
--- CC50A01.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 formal parameter of a library-level generic unit may be
--- a formal tagged private type. Check that a nonlimited tagged type may
--- be passed as an actual. Check that if the formal type is indefinite,
--- both indefinite and definite types may be passed as actuals.
---
--- TEST DESCRIPTION:
--- The generic package declares a formal tagged private type (this can
--- be considered the parent "mixin" class). This type is extended in
--- the generic to provide support for stacks of items of any nonlimited
--- tagged type. Stacks are modeled as singly linked lists, with the list
--- nodes being objects of the extended type.
---
--- A generic testing procedure pushes items onto a stack, and pops them
--- back off, verifying the state of the stack at various points along the
--- way. The push and pop routines exercise functionality important to
--- tagged types, such as type conversion toward the root of the derivation
--- class and extension aggregates.
---
--- The formal tagged private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- to be passed as actuals. For tagged types, definite implies
--- nondiscriminated, and indefinite implies discriminated (with known
--- or unknown discriminants).
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FC50A00.A
--- -> CC50A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of
--- BC50A01_0 to library level.
--- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma
--- Elaborate to context clauses for CC50A01_2 & _3.
---
---!
-
-with FC50A00; -- Tagged (actual) type declarations.
-generic -- Generic stack abstraction.
-
- type Item (<>) is tagged private; -- Formal tagged private type.
- TC_Default_Value : Item; -- Needed in View_Top (see
- -- below).
-package CC50A01_0 is
-
- type Stack is private;
-
--- Note that because the actual type corresponding to Item may be
--- unconstrained, the functions of removing the top item from the stack and
--- returning the value of the top item of the stack have been separated into
--- Pop and View_Top, respectively. This is necessary because otherwise the
--- returned value would have to be an out parameter of Pop, which would
--- require the user (in the unconstrained case) to create an uninitialized
--- unconstrained object to serve as the actual, which is illegal.
-
- procedure Push (I : in Item; S : in out Stack);
- procedure Pop (S : in out Stack);
- function View_Top (S : Stack) return Item;
-
- function Size_Of (S : Stack) return Natural;
-
-private
-
- type Stack_Item;
- type Stack_Ptr is access Stack_Item;
-
- type Stack_Item is new Item with record -- Extends formal type.
- Next : Stack_Ptr := null;
- end record;
-
- type Stack is record
- Top : Stack_Ptr := null;
- Size : Natural := 0;
- end record;
-
-end CC50A01_0;
-
-
- --==================================================================--
-
-
-package body CC50A01_0 is
-
- -- Link NewItem in at the top of the stack (the extension aggregate within
- -- the allocator initializes the inherited portion of NewItem to equal I,
- -- and NewItem.Next to point to what S.Top points to).
-
- procedure Push (I : in Item; S : in out Stack) is
- NewItem : Stack_Ptr;
- begin
- NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate.
- S.Top := NewItem;
- S.Size := S.Size + 1;
- end Push;
-
-
- -- Remove item from top of stack. This procedure only updates the state of
- -- the stack; it does not return the value of the popped item. Hence, in
- -- order to accomplish a "true" pop, both View_Top and Pop must be called
- -- consecutively.
- --
- -- If the stack is empty, the Pop is ignored (for simplicity; in a true
- -- application this might be treated as an error condition).
-
- procedure Pop (S : in out Stack) is
- begin
- if S.Top = null then -- Stack is empty.
- null;
- -- Raise exception.
- else
- S.Top := S.Top.Next;
- S.Size := S.Size - 1;
- -- Deallocate discarded node.
- end if;
- end Pop;
-
-
- -- Return the value of the top item on the stack. This procedure only
- -- returns the value; it does not remove the top item from the stack.
- -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
- -- be called consecutively.
- --
- -- Since items on the stack are of a type (Stack_Item) derived from Item,
- -- which is a (tagged) private type, type conversion toward the root is the
- -- only way to get a value of type Item for return to the caller.
- --
- -- If the stack is empty, View_Top returns a pre-specified default value.
- -- (In a true application, an exception might be raised instead).
-
- function View_Top (S : Stack) return Item is
- begin
- if S.Top = null then -- Stack is empty.
- return TC_Default_Value; -- Testing artifice.
- -- Raise exception.
- else
- return Item(S.Top.all); -- Type conversion.
- end if;
- end View_Top;
-
-
- function Size_Of (S : Stack) return Natural is
- begin
- return (S.Size);
- end Size_Of;
-
-
-end CC50A01_0;
-
-
- --==================================================================--
-
-
--- The formal package Stacker below is needed to gain access to the
--- appropriate version of the "generic" type Stack. It is provided with an
--- explicit actual part in order to restrict the packages that can be passed
--- as actuals to those which have been instantiated with the same actuals
--- which this generic procedure has been instantiated with.
-
-with CC50A01_0; -- Generic stack abstraction.
-generic
- type Item_Type (<>) is tagged private; -- Formal tagged private type.
- Default : Item_Type;
- with package Stacker is new CC50A01_0 (Item_Type, Default);
-procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
-
-
- --==================================================================--
-
---
--- This generic procedure performs all of the testing of the
--- stack abstraction.
---
-
-with Report;
-procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
-begin
- Stacker.Push (I, S); -- Push onto empty stack.
- Stacker.Push (I, S); -- Push onto nonempty stack.
-
- if Stacker.Size_Of (S) /= 2 then
- Report.Failed (" Wrong stack size after 2 Pushes");
- end if;
-
- -- Calls to View_Top must initialize a declared object of type Item_Type
- -- because the type may be unconstrained.
-
- declare
- Buffer1 : Item_Type := Stacker.View_Top (S);
- begin
- Stacker.Pop (S); -- Pop item off nonempty stack.
- if Buffer1 /= I then
- Report.Failed (" Wrong stack item value after 1st Pop");
- end if;
- end;
-
- declare
- Buffer2 : Item_Type := Stacker.View_Top (S);
- begin
- Stacker.Pop (S); -- Pop last item off stack.
- if Buffer2 /= I then
- Report.Failed (" Wrong stack item value after 2nd Pop");
- end if;
- end;
-
- if Stacker.Size_Of (S) /= 0 then
- Report.Failed (" Wrong stack size after 2 Pops");
- end if;
-
- declare
- Buffer3 : Item_Type := Stacker.View_Top (S);
- begin
- if Buffer3 /= Default then
- Report.Failed (" Wrong result after Pop of empty stack");
- end if;
- Stacker.Pop (S); -- Pop off empty stack.
- end;
-
-end CC50A01_1;
-
-
- --==================================================================--
-
-
-with FC50A00;
-
-with CC50A01_0;
-pragma Elaborate (CC50A01_0);
-
-package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
- FC50A00.TC_Default_Count);
-
-
- --==================================================================--
-
-
-with FC50A00;
-
-with CC50A01_0;
-pragma Elaborate (CC50A01_0);
-
-package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
- FC50A00.TC_Default_Person);
-
-
- --==================================================================--
-
-
-with FC50A00; -- Tagged (actual) type declarations.
-with CC50A01_0; -- Generic stack abstraction.
-with CC50A01_1; -- Generic stack testing procedure.
-with CC50A01_2;
-with CC50A01_3;
-
-with Report;
-procedure CC50A01 is
-
- package Count_Stacks renames CC50A01_2;
- package Person_Stacks renames CC50A01_3;
-
-
- procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
- FC50A00.TC_Default_Count,
- Count_Stacks);
- Count_Stack : Count_Stacks.Stack;
-
-
- procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
- FC50A00.TC_Default_Person,
- Person_Stacks);
- Person_Stack : Person_Stacks.Stack;
-
-begin
- Report.Test ("CC50A01", "Check that a formal parameter of a " &
- "library-level generic unit may be a formal tagged " &
- "private type");
-
- Report.Comment ("Testing definite tagged type..");
- TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
-
- Report.Comment ("Testing indefinite tagged type..");
- TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
-
- Report.Result;
-end CC50A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a02.a b/gcc/testsuite/ada/acats/tests/cc/cc50a02.a
deleted file mode 100644
index 6c2bf5f..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50a02.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CC50A02.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 nonlimited tagged type may be passed as an actual to a
--- formal (non-tagged) private type. Check that if the formal type has
--- an unknown discriminant part, a class-wide type may also be passed as
--- an actual.
---
--- TEST DESCRIPTION:
--- A generic package declares a formal private type and defines a
--- stack abstraction. Stacks are modeled as singly linked lists of
--- pointers to elements. Pointers are used because the elements may
--- be unconstrained.
---
--- A generic testing procedure pushes an item onto a stack, then views
--- the item on top of the stack.
---
--- The formal private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- (including class-wide types) to be passed as actuals. For tagged types,
--- definite implies nondiscriminated, and indefinite implies discriminated
--- (with known/unknown discriminants).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC50A00.A
--- -> CC50A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package
--- exception name in exception choice.
---
---!
-
-generic -- Generic stack abstraction.
- type Item (<>) is private; -- Formal private type.
-package CC50A02_0 is
-
- type Stack is private;
-
- procedure Push (I : in Item; S : in out Stack);
- function View_Top (S : Stack) return Item;
-
- -- ...Other stack operations...
-
- Stack_Empty : exception;
-
-private
-
- type Item_Ptr is access Item;
-
- type Stack_Item;
- type Stack_Ptr is access Stack_Item;
-
- type Stack_Item is record
- Item : Item_Ptr;
- Next : Stack_Ptr;
- end record;
-
- type Stack is record
- Top : Stack_Ptr := null;
- Size : Natural := 0;
- end record;
-
-end CC50A02_0;
-
-
- --==================================================================--
-
-
-package body CC50A02_0 is
-
- -- Link NewItem in at the top of the stack.
-
- procedure Push (I : in Item; S : in out Stack) is
- NewItem : Item_Ptr := new Item'(I);
- Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
- begin
- S.Top := Element;
- S.Size := S.Size + 1;
- end Push;
-
-
- -- Return (copy) of top item on stack. Do NOT remove from stack.
-
- function View_Top (S : Stack) return Item is
- begin
- if S.Top = null then
- raise Stack_Empty;
- else
- return S.Top.Item.all;
- end if;
- end View_Top;
-
-end CC50A02_0;
-
-
- --==================================================================--
-
-
--- The formal package Stacker below is needed to gain access to the
--- appropriate version of the "generic" type Stack. It is provided with an
--- explicit actual part in order to restrict the packages that can be passed
--- as actuals to those which have been instantiated with the same actuals
--- which this generic procedure has been instantiated with.
-
-with CC50A02_0; -- Generic stack abstraction.
-generic
- type Item_Type (<>) is private; -- Formal private type.
- with package Stacker is new CC50A02_0 (Item_Type);
-procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);
-
-
- --==================================================================--
-
---
--- This generic procedure performs all of the testing of the
--- stack abstraction.
---
-
-with Report;
-procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
-begin
- Stacker.Push (I, S); -- Push onto empty stack.
-
- -- Calls to View_Top must initialize a declared object of type Item_Type
- -- because the type may be unconstrained.
-
- declare
- Buffer : Item_Type := Stacker.View_Top (S);
- begin
- if Buffer /= I then
- Report.Failed (" Expected item not on stack");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed (" Unexpected error: Tags of pushed and popped " &
- "items don't match");
- end;
-
-
-exception
- when others =>
- Report.Failed (" Unexpected error: Item not pushed onto stack");
-end CC50A02_1;
-
-
- --==================================================================--
-
-
-with FC50A00; -- Tagged (actual) type declarations.
-with CC50A02_0; -- Generic stack abstraction.
-with CC50A02_1; -- Generic stack testing procedure.
-
-with Report;
-procedure CC50A02 is
-
- --
- -- Pass a nondiscriminated tagged actual:
- --
-
- package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type);
- procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
- Count_Stacks);
- Count_Stack : Count_Stacks.Stack;
-
-
- --
- -- Pass a discriminated tagged actual:
- --
-
- package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type);
- procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
- Person_Stacks);
- Person_Stack : Person_Stacks.Stack;
-
-
- --
- -- Pass a class-wide actual:
- --
-
- package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class);
- procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
- People_Stacks);
- People_Stack : People_Stacks.Stack;
-
-begin
- Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
- "to a formal (nontagged) private type");
-
- Report.Comment ("Testing definite tagged type..");
- TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
-
- Report.Comment ("Testing indefinite tagged type..");
- TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
-
- Report.Comment ("Testing class-wide type..");
- TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);
-
- Report.Result;
-end CC50A02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51001.a b/gcc/testsuite/ada/acats/tests/cc/cc51001.a
deleted file mode 100644
index 6aa76a6..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51001.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- CC51001.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 formal parameter of a generic package may be a formal
--- derived type. Check that the formal derived type may have an unknown
--- discriminant part. Check that the ancestor type in a formal derived
--- type definition may be a tagged type, and that the actual parameter
--- may be a descendant of the ancestor type. Check that the formal derived
--- type belongs to the derivation class rooted at the ancestor type;
--- specifically, that components of the ancestor type may be referenced
--- within the generic. Check that if a formal derived subtype is
--- indefinite then the actual may be either definite or indefinite.
---
--- TEST DESCRIPTION:
--- Define a class of tagged types with a definite root type. Extend the
--- root type with a discriminated component. Since discriminants of
--- tagged types may not have defaults, the type is indefinite.
---
--- Extend the extension with a second discriminated component, but with
--- a new discriminant part. Declare a generic package with a formal
--- derived type using the root type of the class as ancestor, and an
--- unknown discriminant part. Declare an operation in the generic which
--- accesses the common component of types in the class.
---
--- In the main program, instantiate the generic with each type in the
--- class and verify that the operation correctly accesses the common
--- component.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51001_0 is -- Root type for message class.
-
- subtype Msg_String is String (1 .. 20);
-
- type Msg_Type is tagged record -- Root type of
- Text : Msg_String := (others => ' '); -- class (definite).
- end record;
-
-end CC51001_0;
-
-
--- No body for CC51001_0.
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-package CC51001_1 is -- Extensions to message class.
-
- subtype Source_Length is Natural range 0 .. 10;
-
- type From_Msg_Type (SLen : Source_Length) is -- Direct derivative
- new CC51001_0.Msg_Type with record -- of root type
- From : String (1 .. SLen); -- (indefinite).
- end record;
-
- subtype Dest_Length is Natural range 0 .. 10;
-
-
-
- type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect
- new From_Msg_Type (SLen => 10) with record -- derivative of
- To : String (1 .. DLen); -- root type
- end record; -- (indefinite).
-
-end CC51001_1;
-
-
--- No body for CC51001_1.
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-generic -- I/O operations for message class.
- type Message_Type (<>) is new CC51001_0.Msg_Type with private;
-package CC51001_2 is
-
- -- This subprogram contains an artificial result for testing purposes:
- -- the function returns the text of the message to the caller as a string.
-
- function Print_Message (M : in Message_Type) return String;
-
- -- ... Other operations.
-
-end CC51001_2;
-
-
- --==================================================================--
-
-
-package body CC51001_2 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Print_Message (M : in Message_Type) return String is
- begin
- return M.Text;
- end Print_Message;
-
-end CC51001_2;
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-with CC51001_1; -- Extensions to message class.
-with CC51001_2; -- I/O operations for message class.
-
-with Report;
-procedure CC51001 is
-
- -- Instantiate for various types in the class:
-
- package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite.
- package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite.
- package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite.
-
-
-
- Msg : CC51001_0.Msg_Type := (Text => "This is message #001");
- FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002",
- SLen => 2,
- From => "Me");
- TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003",
- From => "You ",
- DLen => 4,
- To => "Them");
-
- Expected_Msg : constant String := "This is message #001";
- Expected_FMsg : constant String := "This is message #002";
- Expected_TFMsg : constant String := "This is message #003";
-
-begin
- Report.Test ("CC51001", "Check that the formal derived type may have " &
- "an unknown discriminant part. Check that the ancestor " &
- "type in a formal derived type definition may be a " &
- "tagged type, and that the actual parameter may be any " &
- "definite or indefinite descendant of the ancestor type");
-
- if (Msgs.Print_Message (Msg) /= Expected_Msg) then
- Report.Failed ("Wrong result for definite root type");
- end if;
-
- if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then
- Report.Failed ("Wrong result for direct indefinite derivative");
- end if;
-
- if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then
- Report.Failed ("Wrong result for Indirect indefinite derivative");
- end if;
-
- Report.Result;
-end CC51001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51002.a b/gcc/testsuite/ada/acats/tests/cc/cc51002.a
deleted file mode 100644
index 1083d18..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51002.a
+++ /dev/null
@@ -1,198 +0,0 @@
--- CC51002.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, for formal derived tagged types, the formal parameter
--- names and default expressions for a primitive subprogram in an
--- instance are determined by the primitive subprogram of the ancestor
--- type, but that the primitive subprogram body executed is that of the
--- actual type.
---
--- TEST DESCRIPTION:
--- Define a root tagged type in a library-level package and give it a
--- primitive subprogram. Provide a default expression for a non-tagged
--- parameter of the subprogram. Declare a library-level generic subprogram
--- with a formal derived type using the root type as ancestor. Call
--- the primitive subprogram of the root type using named association for
--- the tagged parameter, and provide no actual for the defaulted
--- parameter. Extend the root type in a second package and override the
--- root type's subprogram with one which has different parameter names
--- and no default expression for the non-tagged parameter. Instantiate
--- the generic subprogram for each of the tagged types in the class and
--- call the instances.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51002_0 is -- Root message type and operations.
-
- type Recipients is (None, Root, Sysop, Local, Remote);
-
- type Msg_Type is tagged record -- Root type of
- Text : String (1 .. 10); -- class.
- end record;
-
- function Send (Msg : in Msg_Type; -- Primitive
- To : Recipients := Local) return Boolean; -- subprogram.
-
- -- ...Other message operations.
-
-end CC51002_0;
-
-
- --==================================================================--
-
-
-package body CC51002_0 is
-
- -- The implementation of Send is purely artificial; the validity of
- -- its implementation in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- function Send (Msg : in Msg_Type;
- To : Recipients := Local) return Boolean is
- begin
- return (Msg.Text = "Greetings!" and To = Local);
- end Send;
-
-end CC51002_0;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-generic -- Message class function.
- type Msg_Block is new CC51002_0.Msg_Type with private;
-function CC51002_1 (M : in Msg_Block) return Boolean;
-
-
- --==================================================================--
-
-
-function CC51002_1 (M : in Msg_Block) return Boolean is
- Okay : Boolean := False;
-begin
-
- -- The call to Send below uses the ancestor type's parameter name, which
- -- should be legal even if the actual subprogram called does not have a
- -- parameter of that name. Furthermore, it uses the ancestor type's default
- -- expression for the second parameter, which should be legal even if the
- -- the actual subprogram called has no such default expression.
-
- Okay := Send (Msg => M);
- -- ...Other processing.
- return Okay;
-
-end CC51002_1;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-package CC51002_2 is -- Extended message type and operations.
-
- type Sender_Type is (Inside, Outside);
-
- type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of
- From : Sender_Type; -- root type of
- end record; -- class.
-
-
- -- Note: this overriding version of Send has different parameter names
- -- from the root type's function. It also has no default expression.
-
- function Send (M : Who_Msg_Type; -- Overrides
- R : CC51002_0.Recipients) return Boolean; -- root type's
- -- operation.
- -- ...Other extended message operations.
-
-end CC51002_2;
-
-
- --==================================================================--
-
-
-package body CC51002_2 is
-
- -- The implementation of Send is purely artificial; the validity of
- -- its implementation in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
- use type CC51002_0.Recipients;
- begin
- return (M.Text = "Willkommen" and
- M.From = Outside and
- R = CC51002_0.Local);
- end Send;
-
-end CC51002_2;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-with CC51002_1; -- Message class function.
-with CC51002_2; -- Extended message type and operations.
-
-with Report;
-procedure CC51002 is
-
- function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type);
- function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
-
- Mess : CC51002_0.Msg_Type := (Text => "Greetings!");
- WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
- From => CC51002_2.Outside);
-
- TC_Okay_MStatus : Boolean := False;
- TC_Okay_WMStatus : Boolean := False;
-
-begin
- Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
- "the formal parameter names and default expressions for " &
- "a primitive subprogram in an instance are determined by " &
- "the primitive subprogram of the ancestor type, but that " &
- "the primitive subprogram body executed is that of the" &
- "actual type");
-
- TC_Okay_MStatus := Send_Msg (Mess);
- if not TC_Okay_MStatus then
- Report.Failed ("Wrong result from call to root type's operation");
- end if;
-
- TC_Okay_WMStatus := Send_WMsg (WMess);
- if not TC_Okay_WMStatus then
- Report.Failed ("Wrong result from call to derived type's operation");
- end if;
-
- Report.Result;
-end CC51002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51003.a b/gcc/testsuite/ada/acats/tests/cc/cc51003.a
deleted file mode 100644
index 68ea32e..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51003.a
+++ /dev/null
@@ -1,187 +0,0 @@
--- CC51003.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 ancestor type of a formal derived type is a composite
--- type that is not an array type, the formal type inherits components,
--- including discriminants, from the ancestor type.
---
--- Check for the case where the ancestor type is a record type, and the
--- formal derived type is declared in a generic subprogram.
---
--- TEST DESCRIPTION:
--- Define a discriminated record type in a package. Declare a
--- library-level generic subprogram with a formal derived type using the
--- record type as ancestor. Give the generic subprogram an in out
--- parameter of the formal derived type. Inside the generic, use the
--- discriminant component and modify the remaining components of the
--- record parameter. In the main program, declare record objects with two
--- different discriminant values. Derive an indefinite type from the
--- record type with a new discriminant part. Instantiate the generic
--- subprogram for the root record subtype and the derived subtype. Call
--- the root subtype instance with actual parameters having the two
--- discriminant values. Also call the derived subtype instance with
--- an appropriate actual.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Jan 95 SAIC Removed unknown discriminant part from formal
--- derived type.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype
--- instantiation and associated declarations.
--- Modified commentary.
---
---!
-
-
--- Simulate a fragment of a matrix manipulation application.
-
-package CC51003_0 is -- Matrix types.
-
- type Matrix is array (Natural range <>, Natural range <>) of Integer;
-
- type Square (Side : Natural) is record
- Mat : Matrix (1 .. Side, 1 .. Side);
- end record;
-
- type Double_Square (Number : Natural) is record
- Left : Square (Number);
- Right : Square (Number);
- end record;
-
-end CC51003_0;
-
-
--- No body for CC51003_0;
-
-
- --==================================================================--
-
-
-with CC51003_0; -- Matrix types.
-generic -- Generic double-matrix "clear" operation.
- type Dbl_Square is new CC51003_0.Double_Square; -- Indefinite
-procedure CC51003_1 (Dbl : in out Dbl_Square); -- formal.
-
-
- --==================================================================--
-
-
-procedure CC51003_1 (Dbl : in out Dbl_Square) is
-begin
- for I in 1 .. Dbl.Number loop -- Discriminants inherited from ancestor
- for J in 1 .. Dbl.Number loop -- type (should work even for derived type
- -- declaring new discriminant part).
- Dbl.Left.Mat (I, J) := 0; -- Other components inherited from
- Dbl.Right.Mat (I, J) := 0; -- ancestor type.
-
- end loop;
- end loop;
-end CC51003_1;
-
-
- --==================================================================--
-
-
-with CC51003_0; -- Matrix types.
-with CC51003_1; -- Generic double-matrix "clear" operation.
-
-with Report;
-procedure CC51003 is
-
- use CC51003_0; -- "/=" operator directly visible for Double_Square.
-
- -- Matrices of root type:
-
- Mat_2x2 : Square(Side => 2) := (Side => 2,
- Mat => ( (1, 2), (3, 4) ));
- Dbl_Mat_2x2 : Double_Square(Number => 2) := (2, Mat_2x2, Mat_2x2);
-
-
- Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) ));
- Expected_2x2 : constant Double_Square(2) := (Number => 2,
- others => Zero_2x2);
-
-
-
- Mat_3x3 : Square(Side => 3) := (Side => 3,
- Mat => (1 => (1, 4, 9),
- others => (1 => 5,
- others => 7)));
- Dbl_Mat_3x3 : Double_Square(3) := (Number => 3, others => Mat_3x3);
-
-
- Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0)));
- Expected_3x3 : constant Double_Square(Number => 3) :=
- (3, Zero_3x3, Zero_3x3);
-
-
- -- Derived type with new discriminant part (which constrains parent):
-
- type New_Dbl_Sq (Num : Natural) is new Double_Square(Num);
-
- New_Dbl_2x2 : New_Dbl_Sq (Num => 2) := (2, Mat_2x2, Mat_2x2);
- Expected_New_2x2 : constant New_Dbl_Sq := (Num => 2, others => Zero_2x2);
-
-
-
- -- Instantiations:
-
- procedure Clr_Dbl is new CC51003_1 (Double_Square);
- procedure Clr_New_Dbl is new CC51003_1 (New_Dbl_Sq);
-
-
-begin
- Report.Test ("CC51003", "Check that a formal derived record type " &
- "inherits components, including discriminants, " &
- "from its ancestor type");
-
- -- Simulate use of matrix manipulation operations.
-
- Clr_Dbl (Dbl_Mat_2x2);
-
- if (Dbl_Mat_2x2 /= Expected_2x2) then
- Report.Failed ("Wrong result for root type (2x2 matrix)");
- end if;
-
-
- Clr_Dbl (Dbl_Mat_3x3);
-
- if (Dbl_Mat_3x3 /= Expected_3x3) then
- Report.Failed ("Wrong result for root type (3x3 matrix)");
- end if;
-
-
- Clr_New_Dbl (New_Dbl_2x2);
-
- if (New_Dbl_2x2 /= Expected_New_2x2) then
- Report.Failed ("Wrong result for derived type (2x2 matrix)");
- end if;
-
-
- Report.Result;
-
-end CC51003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51004.a b/gcc/testsuite/ada/acats/tests/cc/cc51004.a
deleted file mode 100644
index 09b1b57..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51004.a
+++ /dev/null
@@ -1,181 +0,0 @@
--- CC51004.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 ancestor type of a formal derived type is a composite
--- type that is not an array type, the formal type inherits components,
--- including discriminants, from the ancestor type.
---
--- Check for the case where the ancestor type is a tagged type, and the
--- formal derived type is declared in a generic subprogram.
---
--- TEST DESCRIPTION:
--- Define a discriminated tagged type in a package. Declare a
--- library-level generic subprogram with a formal derived type using the
--- tagged type as ancestor. Give the generic subprogram an in out
--- parameter of the formal derived type. Inside the generic, use the
--- discriminant component and modify the remaining components of the
--- tagged parameter. In the main program, declare tagged record objects
--- with two different discriminant values. Derive an indefinite type from
--- the tagged type with a new discriminant part. Instantiate the
--- generic subprogram for the root tagged subtype and the derived subtype.
--- Call the root subtype instance with actual parameters having the two
--- discriminant values. Also call the derived subtype instance with an
--- appropriate actual.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Jan 94 SAIC Removed unknown discriminant part from formal
--- derived type. Moved declaration of type
--- New_Dbl_Sq from main subprogram to CC51004_0.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype
--- instantiation and associated declarations.
--- Modified commentary.
---
---!
-
--- Simulate a fragment of a matrix manipulation application.
-
-package CC51004_0 is -- Matrix types.
-
- type Matrix is array (Natural range <>, Natural range <>) of Integer;
-
- type Square (Side : Natural) is record
- Mat : Matrix (1 .. Side, 1 .. Side);
- end record;
-
- type Sq_Type (Num1 : Natural) is tagged record
- One : Square (Num1);
- end record;
-
- -- Extended type with new discriminant part (which constrains parent):
-
- type New_Dbl_Sq (Num2 : Natural) is new Sq_Type(Num2) with record
- Two : Square (Num2);
- end record;
-
-end CC51004_0;
-
-
--- No body for CC51004_0;
-
-
- --==================================================================--
-
-
-with CC51004_0; -- Matrix types.
-generic -- Generic matrix "clear" operation.
- type Squares is new CC51004_0.Sq_Type with private; -- Indefinite
-procedure CC51004_1 (Sq : in out Squares); -- formal.
-
-
- --==================================================================--
-
-
-procedure CC51004_1 (Sq : in out Squares) is
-begin
- for I in 1 .. Sq.Num1 loop -- Discriminants inherited from ancestor
- for J in 1 .. Sq.Num1 loop -- type (should work even for derived type
- -- declaring new discriminant part).
- Sq.One.Mat (I, J) := 0; -- Other components inherited from
- -- ancestor type.
- end loop;
- end loop;
-end CC51004_1;
-
-
- --==================================================================--
-
-
-with CC51004_0; -- Matrix types.
-with CC51004_1; -- Generic double-matrix "clear" operation.
-
-with Report;
-procedure CC51004 is
-
- use CC51004_0; -- "/=" operator directly visible for Sq_Type.
-
- -- Matrices of root type:
-
- Mat_2x2 : Square(Side => 2) := (Side => 2, Mat => ( (1, 2), (3, 4) ));
- One_Mat_2x2 : Sq_Type(Num1 => 2) := (2, Mat_2x2);
-
- Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) ));
- Expected_2x2 : constant Sq_Type(2) := (Num1 => 2, One => Zero_2x2);
-
-
- Mat_3x3 : Square(Side => 3) := (Side => 3,
- Mat => (1 => (5, 2, 7),
- others => (1 => 4,
- others => 9)));
- One_Mat_3x3 : Sq_Type(3) := (Num1 => 3, One => Mat_3x3);
-
- Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0)));
- Expected_3x3 : constant Sq_Type(Num1 => 3) := (3, Zero_3x3);
-
-
- New_Dbl_2x2 : New_Dbl_Sq(Num2 => 2) := (2, others => Mat_2x2);
- Expected_New_2x2 : constant New_Dbl_Sq := (2, Zero_2x2, Mat_2x2);
-
-
-
- -- Instantiations:
-
- procedure Clr_Mat is new CC51004_1 (Sq_Type);
- procedure Clr_New_Dbl is new CC51004_1 (New_Dbl_Sq);
-
-
-begin
- Report.Test ("CC51004", "Check that a formal derived tagged type " &
- "inherits components, including discriminants, " &
- "from its ancestor type");
-
- -- Simulate use of matrix manipulation operations.
-
-
- Clr_Mat (One_Mat_2x2);
-
- if (One_Mat_2x2 /= Expected_2x2) then
- Report.Failed ("Wrong result root type (2x2 matrix)");
- end if;
-
-
- Clr_Mat (One_Mat_3x3);
-
- if (One_Mat_3x3 /= Expected_3x3) then
- Report.Failed ("Wrong result root type (3x3 matrix)");
- end if;
-
-
- Clr_New_Dbl (New_Dbl_2x2);
-
- if (New_Dbl_2x2 /= Expected_New_2x2) then
- Report.Failed ("Wrong result extended type (2x2 matrix)");
- end if;
-
-
- Report.Result;
-end CC51004;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51006.a b/gcc/testsuite/ada/acats/tests/cc/cc51006.a
deleted file mode 100644
index b4dc4cd..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51006.a
+++ /dev/null
@@ -1,224 +0,0 @@
--- CC51006.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 an instance, each implicit declaration of a primitive
--- subprogram of a formal (nontagged) derived type declares a view of
--- the corresponding primitive subprogram of the ancestor type, even if
--- the subprogram has been overridden for the actual type. Check that for
--- a formal derived type with no discriminant part, if the ancestor
--- subtype is an unconstrained scalar subtype then the actual may be
--- either constrained or unconstrained.
---
--- TEST DESCRIPTION:
--- The formal derived type has no discriminant part, but the ancestor
--- subtype is unconstrained, making the formal type unconstrained. Since
--- the ancestor subtype is a scalar subtype (not an access or composite
--- subtype), the actual may be either constrained or unconstrained.
---
--- Declare a root type of a class as an unconstrained scalar (use floating
--- point). Declare a primitive subprogram of the root type. Declare a
--- generic package which has a formal derived type with the scalar root
--- type as ancestor. Inside the generic, declare an operation which calls
--- the ancestor type's primitive subprogram. Derive both constrained and
--- unconstrained types from the root type and override the primitive
--- subprogram for each. Declare a constrained subtype of the unconstrained
--- derivative. Instantiate the generic package for the derived types and
--- the subtype and call the "generic" operation for each one. Confirm that
--- in all cases the root type's implementation of the primitive
--- subprogram is called.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51006_0 is -- Weight class.
-
- type Weight_Type is digits 3; -- Root type of class (unconstrained).
-
- function Weight_To_String (Wt : Weight_Type) return String;
-
- -- ... Other operations.
-
-end CC51006_0;
-
-
- --==================================================================--
-
-
-package body CC51006_0 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Weight_To_String (Wt : Weight_Type) return String is
- begin
- if Wt > 0.0 then -- Always true for this test.
- return ("Root type's implementation called");
- else
- return ("Unexpected result ");
- end if;
- end Weight_To_String;
-
-end CC51006_0;
-
-
- --==================================================================--
-
-
-with CC51006_0; -- Weight class.
-generic -- Generic weight operations.
- type Weight is new CC51006_0.Weight_Type;
-package CC51006_1 is
-
- procedure Output_Weight (Wt : in Weight; TC_Return : out String);
-
- -- ... Other operations.
-
-end CC51006_1;
-
-
- --==================================================================--
-
-
-package body CC51006_1 is
-
-
- -- The implementation of this procedure is purely artificial, and contains
- -- an artificial parameter for testing purposes: the procedure returns the
- -- weight string to the caller.
-
- procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
- begin
- TC_Return := Weight_To_String (Wt); -- Should always call root type's
- end Output_Weight; -- implementation.
-
-
-end CC51006_1;
-
-
- --==================================================================--
-
-
-with CC51006_0; -- Weight class.
-use CC51006_0;
-package CC51006_2 is -- Extensions to weight class.
-
- type Grams is new Weight_Type; -- Unconstrained
- -- derivative.
-
- function Weight_To_String (Wt : Grams) return String; -- Overrides root
- -- type's operation.
-
- subtype Milligrams is Grams -- Constrained
- range 0.0 .. 0.999; -- subtype (of der.).
-
- type Pounds is new Weight_Type -- Constrained
- range 0.0 .. 500.0; -- derivative.
-
- function Weight_To_String (Wt : Pounds) return String; -- Overrides root
- -- type's operation.
-
-end CC51006_2;
-
-
- --==================================================================--
-
-
-package body CC51006_2 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Weight_To_String (Wt : Grams) return String is
- begin
- return ("GRAMS: Should never be called ");
- end Weight_To_String;
-
-
- function Weight_To_String (Wt : Pounds) return String is
- begin
- return ("POUNDS: Should never be called ");
- end Weight_To_String;
-
-end CC51006_2;
-
-
- --==================================================================--
-
-
-with CC51006_1; -- Generic weight operations.
-with CC51006_2; -- Extensions to weight class.
-
-with Report;
-procedure CC51006 is
-
- package Metric_Wts_G is new CC51006_1 (CC51006_2.Grams); -- Unconstr.
- package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
- package US_Wts is new CC51006_1 (CC51006_2.Pounds); -- Constr.
-
- Gms : CC51006_2.Grams := 113.451;
- Mgm : CC51006_2.Milligrams := 0.549;
- Lbs : CC51006_2.Pounds := 24.52;
-
-
- subtype TC_Buffers is String (1 .. 33);
-
- TC_Expected : constant TC_Buffers := "Root type's implementation called";
- TC_Buffer : TC_Buffers;
-
-begin
- Report.Test ("CC51006", "Check that, in an instance, each implicit " &
- "declaration of a primitive subprogram of a formal " &
- "(nontagged) type declares a view of the corresponding " &
- "primitive subprogram of the ancestor type");
-
-
- Metric_Wts_G.Output_Weight (Gms, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for unconstrained derivative");
- end if;
-
-
- Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for constrained subtype");
- end if;
-
-
- US_Wts.Output_Weight (Lbs, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for constrained derivative");
- end if;
-
- Report.Result;
-end CC51006;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51007.a b/gcc/testsuite/ada/acats/tests/cc/cc51007.a
deleted file mode 100644
index d8f7877..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51007.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CC51007.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 generic formal derived tagged type is a private extension.
--- Specifically, check that, for a generic formal derived type whose
--- ancestor type has abstract primitive subprograms, neither the formal
--- derived type nor its descendants need be abstract. Check that objects
--- and components of the formal derived type and its nonabstract
--- descendants may be declared and allocated, as may nonabstract
--- functions returning these types, and that aggregates of nonabstract
--- descendants of the formal derived type are legal. Check that calls to
--- the abstract primitive subprograms of the ancestor dispatch to the
--- bodies corresponding to the tag of the actual parameters.
---
--- TEST DESCRIPTION:
--- Although the ancestor type is abstract and has abstract primitive
--- subprograms, these subprograms, when inherited by a formal nonabstract
--- derived type, are not abstract, since the formal derived type is a
--- nonabstract private extension.
---
--- Thus, derivatives of the formal derived type need not be abstract,
--- and both the formal derived type and its derivatives are considered
--- nonabstract types.
---
--- This test verifies that the restrictions placed on abstract types do
--- not apply to the formal derived type or its derivatives. Specifically,
--- objects of, components of, allocators of, and nonabstract functions
--- returning the formal derived type or its derivatives are legal. In
--- addition, the test verifies that a call within the instance to a
--- primitive subprogram of the (abstract) ancestor type dispatches to
--- the body corresponding to the tag of the actual parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected
--- dispatching call. Editorial changes to commentary.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
--- to library level.
--- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clauses of CC51007_1 and CC51007_4.
---
---!
-
-package CC51007_0 is
-
- Max_Length : constant := 10;
- type Text is new String(1 .. Max_Length);
-
- type Alert is abstract tagged record -- Root type of class
- Message : Text := (others => '*'); -- (abstract).
- end record;
-
- procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching
- -- operation.
-
-end CC51007_0;
-
--- No body for CC51007_0;
-
-
- --===================================================================--
-
-
-with CC51007_0;
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package CC51007_1 is
-
- type Low_Alert is new CC51007_0.Alert with record
- Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
- end record;
-
- procedure Handle (A: in out Low_Alert); -- Overrides parent's
- -- implementation.
- Low : Low_Alert;
-
-end CC51007_1;
-
-
- --===================================================================--
-
-
-package body CC51007_1 is
-
- procedure Handle (A: in out Low_Alert) is -- Artificial for
- begin -- testing.
- A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
- A.Message := "Low Alert!";
- end Handle;
-
-end CC51007_1;
-
-
- --===================================================================--
-
-
-with CC51007_1;
-package CC51007_2 is
-
- type Person is (OOD, CO, CinC);
-
- type Medium_Alert is new CC51007_1.Low_Alert with record
- Action_Officer : Person := OOD;
- end record;
-
- procedure Handle (A: in out Medium_Alert); -- Overrides parent's
- -- implementation.
- Med : Medium_Alert;
-
-end CC51007_2;
-
-
- --===================================================================--
-
-
-with Ada.Calendar;
-package body CC51007_2 is
-
- procedure Handle (A: in out Medium_Alert) is -- Artificial for
- begin -- testing.
- A.Action_Officer := CO;
- A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
- A.Message := "Med Alert!";
- end Handle;
-
-end CC51007_2;
-
-
- --===================================================================--
-
-
-with CC51007_0;
-generic
- type Alert_Type is new CC51007_0.Alert with private;
- Initial_State : in Alert_Type;
-package CC51007_3 is
-
- function Clear_Message (A: Alert_Type) -- Function returning
- return Alert_Type; -- formal type.
-
-
- Max_Note : Natural := 10;
- type Note is new String (1 .. Max_Note);
-
- type Extended_Alert is new Alert_Type with record
- Addendum : Note := (others => '*');
- end record;
-
- -- In instance, inherits version of Handle from
- -- actual corresponding to formal type.
-
- function Annotate_Alert (A: in Alert_Type'Class) -- Function returning
- return Extended_Alert; -- derived type.
-
-
- Init_Ext_Alert : constant Extended_Alert := -- Object declaration.
- (Initial_State with Addendum => "----------"); -- Aggregate.
-
-
- type Alert_Type_Ptr is access constant Alert_Type;
- type Ext_Alert_Ptr is access Extended_Alert;
-
- Init_Alert_Ptr : Alert_Type_Ptr :=
- new Alert_Type'(Initial_State); -- Allocator.
-
- Init_Ext_Alert_Ptr : Ext_Alert_Ptr :=
- new Extended_Alert'(Init_Ext_Alert); -- Allocator.
-
-
- type Alert_Pair is record
- A : Alert_Type; -- Component.
- EA : Extended_Alert; -- Component.
- end record;
-
-end CC51007_3;
-
-
- --===================================================================--
-
-
-package body CC51007_3 is
-
- function Clear_Message (A: Alert_Type) return Alert_Type is
- Temp : Alert_Type := A; -- Object declaration.
- begin
- Temp.Message := (others => '-');
- return Temp;
- end Clear_Message;
-
- function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
- Temp : Alert_Type'Class := A;
- begin
- Handle (Temp); -- Dispatching call to
- -- operation of ancestor.
- return (Alert_Type(Temp) with Addendum => "No comment");
- end Annotate_Alert;
-
-end CC51007_3;
-
-
- --===================================================================--
-
-
-with CC51007_1;
-
-with CC51007_3;
-pragma Elaborate (CC51007_3);
-
-package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
-
-
- --===================================================================--
-
-
-with CC51007_1;
-with CC51007_2;
-with CC51007_3;
-with CC51007_4;
-
-with Ada.Calendar;
-with Report;
-procedure CC51007 is
-
- package Alert_Support renames CC51007_4;
-
- Ext : Alert_Support.Extended_Alert;
-
- TC_Result : Alert_Support.Extended_Alert;
-
- TC_Low_Expected : constant Alert_Support.Extended_Alert :=
- (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
- Message => "Low Alert!",
- Addendum => "No comment");
-
- TC_Med_Expected : constant Alert_Support.Extended_Alert :=
- (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
- Message => "Med Alert!",
- Addendum => "No comment");
-
- TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
-
-
- use type Alert_Support.Extended_Alert;
-
-begin
- Report.Test ("CC51007", "Check that, for a generic formal derived type " &
- "whose ancestor type has abstract primitive subprograms, " &
- "neither the formal derived type nor its descendants need " &
- "be abstract, and that objects of, components of, " &
- "allocators of, aggregates of, and nonabstract functions " &
- "returning these types are legal. Check that calls to the " &
- "abstract primitive subprograms of the ancestor dispatch " &
- "to the bodies corresponding to the tag of the actual " &
- "parameters");
-
-
- TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching
- -- call.
- if TC_Result /= TC_Low_Expected then
- Report.Failed ("Wrong results from dispatching call (Low_Alert)");
- end if;
-
-
- TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching
- -- call.
- if TC_Result /= TC_Med_Expected then
- Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
- end if;
-
-
- TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching
- -- call.
- if TC_Result /= TC_Ext_Expected then
- Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
- end if;
-
-
- Report.Result;
-end CC51007;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51008.a b/gcc/testsuite/ada/acats/tests/cc/cc51008.a
deleted file mode 100644
index b95ae6c..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51008.a
+++ /dev/null
@@ -1,124 +0,0 @@
--- CC51008.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 ACAA 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 operations are inherited for a formal derived type whose
--- ancestor is also a formal type as described in the corrigendum.
--- (Defect Report 8652/0038, as reflected in Technical Corrigendum 1,
--- RM95 12.5.1(21/1)).
---
--- CHANGE HISTORY:
--- 29 Jan 2001 PHL Initial version.
--- 30 Apr 2002 RLB Readied for release.
---
---!
-package CC51008_0 is
-
- type R0 is
- record
- C : Float;
- end record;
-
- procedure S (X : R0);
-
-end CC51008_0;
-
-with Report;
-use Report;
-package body CC51008_0 is
- procedure S (X : R0) is
- begin
- Comment ("CC51008_0.S called");
- end S;
-end CC51008_0;
-
-with CC51008_0;
-generic
- type F1 is new CC51008_0.R0;
- type F2 is new F1;
-package CC51008_1 is
- procedure G (O1 : F1; O2 : F2);
-end CC51008_1;
-
-package body CC51008_1 is
- procedure G (O1 : F1; O2 : F2) is
- begin
- S (O1);
- S (O2);
- end G;
-end CC51008_1;
-
-with CC51008_0;
-package CC51008_2 is
- type R2 is new CC51008_0.R0;
- procedure S (X : out R2);
-end CC51008_2;
-
-with Report;
-use Report;
-package body CC51008_2 is
- procedure S (X : out R2) is
- begin
- Failed ("CC51008_2.S called");
- end S;
-end CC51008_2;
-
-with CC51008_2;
-package CC51008_3 is
- type R3 is new CC51008_2.R2;
- procedure S (X : R3);
-end CC51008_3;
-
-with Report;
-use Report;
-package body CC51008_3 is
- procedure S (X : R3) is
- begin
- Failed ("CC51008_3.S called");
- end S;
-end CC51008_3;
-
-with CC51008_1;
-with CC51008_2;
-with CC51008_3;
-with Report;
-use Report;
-procedure CC51008 is
-
- package Inst is new CC51008_1 (CC51008_2.R2,
- CC51008_3.R3);
-
- X2 : constant CC51008_2.R2 := (C => 2.0);
- X3 : constant CC51008_3.R3 := (C => 3.0);
-
-begin
- Test ("CC51008",
- "Check that operations are inherited for a formal derived " &
- "type whose ancestor is also a formal type as described in " &
- "RM95 12.5.1(21/1)");
- Inst.G (X2, X3);
- Result;
-end CC51008;
-
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51a01.a b/gcc/testsuite/ada/acats/tests/cc/cc51a01.a
deleted file mode 100644
index 60c32be..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51a01.a
+++ /dev/null
@@ -1,193 +0,0 @@
--- CC51A01.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 an instance, each implicit declaration of a user-defined
--- subprogram of a formal derived record type declares a view of the
--- corresponding primitive subprogram of the ancestor, even if the
--- primitive subprogram has been overridden for the actual type.
---
--- TEST DESCRIPTION:
--- Declare a "fraction" type abstraction in a package (foundation code).
--- Declare a "fraction" I/O routine in a generic package with a formal
--- derived type whose ancestor type is the fraction type declared in
--- the first package. Within the I/O routine, call other operations of
--- ancestor type. Derive from the root fraction type in another package
--- and override one of the operations called in the generic I/O routine.
--- Derive from the derivative of the root fraction type. Instantiate
--- the generic package for each of the three types and call the I/O
--- routine.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51A00.A
--- CC51A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC51A00; -- Fraction type abstraction.
-generic -- Fraction I/O support.
- type Fraction is new FC51A00.Fraction_Type; -- Formal derived type of a
-package CC51A01_0 is -- (private) record type.
-
- -- Simulate writing a fraction to standard output. In a real application,
- -- this subprogram might be a procedure which uses Text_IO routines. For
- -- the purposes of the test, the "output" is returned to the caller as a
- -- string.
- function Put (Item : in Fraction) return String;
-
- -- ... Other I/O operations for fractions.
-
-end CC51A01_0;
-
-
- --==================================================================--
-
-
-package body CC51A01_0 is
-
- function Put (Item : in Fraction) return String is
- Num : constant String := -- Fraction's primitive subprograms
- Integer'Image (Numerator (Item)); -- are inherited from its parent
- Den : constant String := -- (FC51A00.Fraction_Type) and NOT
- Integer'Image (Denominator (Item)); -- from the actual type.
- begin
- return (Num & '/' & Den);
- end Put;
-
-end CC51A01_0;
-
-
- --==================================================================--
-
-
-with FC51A00; -- Fraction type abstraction.
-package CC51A01_1 is
-
- -- Derive directly from the root type of the class and override one of the
- -- primitive subprograms.
-
- type Pos_Fraction is new FC51A00.Fraction_Type; -- Derived directly from
- -- root type of class.
- -- Inherits "/" from root type.
- -- Inherits "-" from root type.
- -- Inherits Numerator from root type.
- -- Inherits Denominator from root type.
-
- -- Return absolute value of numerator as integer.
- function Numerator (Frac : Pos_Fraction) -- Overrides parent's
- return Integer; -- operation.
-
-end CC51A01_1;
-
-
- --==================================================================--
-
-
-package body CC51A01_1 is
-
- -- This body should never be called.
- --
- -- The test sends the function Numerator a fraction with a negative
- -- numerator, and expects this negative numerator to be returned. This
- -- version of the function returns the absolute value of the numerator.
- -- Thus, a call to this version is detectable by examining the sign
- -- of the return value.
-
- function Numerator (Frac : Pos_Fraction) return Integer is
- Converted_Frac : FC51A00.Fraction_Type := FC51A00.Fraction_Type (Frac);
- Orig_Numerator : Integer := FC51A00.Numerator (Converted_Frac);
- begin
- return abs (Orig_Numerator);
- end Numerator;
-
-end CC51A01_1;
-
-
- --==================================================================--
-
-
-with FC51A00; -- Fraction type abstraction.
-with CC51A01_0; -- Fraction I/O support.
-with CC51A01_1; -- Positive fraction type abstraction.
-
-with Report;
-procedure CC51A01 is
-
- type Distance is new CC51A01_1.Pos_Fraction; -- Derived indirectly from
- -- root type of class.
- -- Inherits "/" indirectly from root type.
- -- Inherits "-" indirectly from root type.
- -- Inherits Numerator directly from parent type.
- -- Inherits Denominator indirectly from root type.
-
- use FC51A00, CC51A01_1; -- All primitive subprograms
- -- directly visible.
-
- package Fraction_IO is new CC51A01_0 (Fraction_Type);
- package Pos_Fraction_IO is new CC51A01_0 (Pos_Fraction);
- package Distance_IO is new CC51A01_0 (Distance);
-
- -- For each of the instances above, the subprogram "Put" should produce
- -- the same result. That is, the primitive subprograms called by Put
- -- should in all cases be those of the type Fraction_Type, which is the
- -- ancestor type for the formal derived type in the generic unit. In
- -- particular, for Pos_Fraction_IO and Distance_IO, the versions of
- -- Numerator called should NOT be those of the actual types, which override
- -- Fraction_Type's version.
-
- TC_Expected_Result : constant String := "-3/ 16";
-
- TC_Root_Type_Of_Class : Fraction_Type := -3/16;
- TC_Direct_Derivative : Pos_Fraction := -3/16;
- TC_Indirect_Derivative : Distance := -3/16;
-
-begin
- Report.Test ("CC51A01", "Check that, in an instance, each implicit " &
- "declaration of a user-defined subprogram of a formal " &
- "derived record type declares a view of the corresponding " &
- "primitive subprogram of the ancestor, even if the " &
- "primitive subprogram has been overridden for the actual " &
- "type");
-
- if (Fraction_IO.Put (TC_Root_Type_Of_Class) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for root type");
- end if;
-
- if (Pos_Fraction_IO.Put (TC_Direct_Derivative) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for direct derivative");
- end if;
-
- if (Distance_IO.Put (TC_Indirect_Derivative) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for INdirect derivative");
- end if;
-
- Report.Result;
-end CC51A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51b03.a b/gcc/testsuite/ada/acats/tests/cc/cc51b03.a
deleted file mode 100644
index 0cbeeb4..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51b03.a
+++ /dev/null
@@ -1,258 +0,0 @@
--- CC51B03.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 attribute S'Definite, where S is an indefinite formal
--- private or derived type, returns true if the actual corresponding to
--- S is definite, and returns false otherwise.
---
--- TEST DESCRIPTION:
--- A definite subtype is any subtype which is not indefinite. An
--- indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants (this includes class-wide
--- types).
--- c) A subtype with unconstrained discriminants without defaults.
---
--- The possible forms of indefinite formal subtype are as follows:
---
--- Formal derived types:
--- X - Ancestor is an unconstrained array type
--- * - Ancestor is a discriminated record type without defaults
--- X - Ancestor is a discriminated tagged type
--- * - Ancestor type has unknown discriminants
--- - Formal type has an unknown discriminant part
--- * - Formal type has a known discriminant part
---
--- Formal private types:
--- - Formal type has an unknown discriminant part
--- * - Formal type has a known discriminant part
---
--- The formal subtypes preceded by an 'X' above are not covered, because
--- other rules prevent a definite subtype from being passed as an actual.
--- The formal subtypes preceded by an '*' above are not covered, because
--- 'Definite is less likely to be used for these formals.
---
--- The following kinds of actuals are passed to various of the formal
--- types listed above:
---
--- - Undiscriminated type
--- - Type with defaulted discriminants
--- - Type with undefaulted discriminants
--- - Class-wide type
---
--- A typical usage of S'Definite might be algorithm selection in a
--- generic I/O package, e.g., the use of fixed-length or variable-length
--- records depending on whether the actual is definite or indefinite.
--- In such situations, S'Definite would appear in if conditions or other
--- contexts requiring a boolean expression. This test checks S'Definite
--- in such usage contexts but, for brevity, omits any surrounding
--- usage code.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51B00.A
--- -> CC51B03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC51B00; -- Indefinite subtype declarations.
-package CC51B03_0 is
-
- --
- -- Formal private type cases:
- --
-
- generic
- type Formal (<>) is private; -- Formal has unknown
- package PrivateFormalUnknownDiscriminants is -- discriminant part.
- function Is_Definite return Boolean;
- end PrivateFormalUnknownDiscriminants;
-
-
- --
- -- Formal derived type cases:
- --
-
- generic
- type Formal (<>) is new FC51B00.Vector -- Formal has an unknown disc.
- with private; -- part; ancestor is tagged.
- package TaggedAncestorUnknownDiscriminants is
- function Is_Definite return Boolean;
- end TaggedAncestorUnknownDiscriminants;
-
-
-end CC51B03_0;
-
-
- --==================================================================--
-
-
-package body CC51B03_0 is
-
- package body PrivateFormalUnknownDiscriminants is
- function Is_Definite return Boolean is
- begin
- if Formal'Definite then -- Attribute used in "if"
- -- ...Execute algorithm #1... -- condition inside subprogram.
- return True;
- else
- -- ...Execute algorithm #2...
- return False;
- end if;
- end Is_Definite;
- end PrivateFormalUnknownDiscriminants;
-
-
- package body TaggedAncestorUnknownDiscriminants is
- function Is_Definite return Boolean is
- begin
- return Formal'Definite; -- Attribute used in return
- end Is_Definite; -- statement inside subprogram.
- end TaggedAncestorUnknownDiscriminants;
-
-
-end CC51B03_0;
-
-
- --==================================================================--
-
-
-with FC51B00;
-package CC51B03_1 is
-
- subtype Spin_Type is Natural range 0 .. 3;
-
- type Extended_Vector (Spin : Spin_Type) is -- Tagged type with
- new FC51B00.Vector with null record; -- discriminant (indefinite).
-
-
-end CC51B03_1;
-
-
- --==================================================================--
-
-
-with FC51B00; -- Indefinite subtype declarations.
-with CC51B03_0; -- Generic package declarations.
-with CC51B03_1;
-
-with Report;
-procedure CC51B03 is
-
- --
- -- Instances for formal private type with unknown discriminants:
- --
-
- package PrivateFormal_UndiscriminatedTaggedActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector);
-
- package PrivateFormal_ClassWideActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class);
-
- package PrivateFormal_DiscriminatedTaggedActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair);
-
- package PrivateFormal_DiscriminatedUndefaultedRecordActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square);
-
-
- subtype Length is Natural range 0 .. 20;
- type Message (Len : Length := 0) is record -- Record type with defaulted
- Text : String (1 .. Len); -- discriminant (definite).
- end record;
-
- package PrivateFormal_DiscriminatedDefaultedRecordActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (Message);
-
-
- --
- -- Instances for formal derived tagged type with unknown discriminants:
- --
-
- package DerivedFormal_UndiscriminatedTaggedActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector);
-
- package DerivedFormal_ClassWideActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class);
-
- package DerivedFormal_DiscriminatedTaggedActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector);
-
-
-begin
- Report.Test ("CC51B03", "Check that S'Definite returns true if the " &
- "actual corresponding to S is definite, and false otherwise");
-
-
- if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for undiscriminated tagged actual");
- end if;
-
- if PrivateFormal_ClassWideActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for class-wide actual");
- end if;
-
- if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for discriminated tagged actual");
- end if;
-
- if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong result " &
- "for record actual with undefaulted discriminants");
- end if;
-
- if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong result " &
- "for record actual with defaulted discriminants");
- end if;
-
-
- if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for undiscriminated tagged actual");
- end if;
-
- if DerivedFormal_ClassWideActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for class-wide actual");
- end if;
-
- if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for discriminated tagged actual");
- end if;
-
-
- Report.Result;
-end CC51B03;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a
deleted file mode 100644
index 63c68c0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a
+++ /dev/null
@@ -1,262 +0,0 @@
--- CC51D01.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 an instance, each implicit declaration of a user-defined
--- subprogram of a formal private extension declares a view of the
--- corresponding primitive subprogram of the ancestor, and that if the
--- tag in a call is statically determined to be that of the formal type,
--- the body executed will be that corresponding to the actual type.
---
--- Check subprograms declared within a generic formal package. Check for
--- the case where the actual type passed to the formal private extension
--- is a specific tagged type. Check for several types in the same class.
---
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a package
--- which declares a tagged type and a type derived from it. Declare an
--- operation for the root tagged type and override it for the derived
--- type. Derive a type from this derived type, but do not override the
--- operation. Declare a generic subprogram which operates on lists of
--- elements of tagged types. Provide the generic subprogram with two
--- formal parameters: (1) a formal derived tagged type which represents a
--- list element type, and (2) a generic formal package with the list
--- abstraction package as template. Use the formal derived type as the
--- generic formal actual part for the formal package. Within the generic
--- subprogram, call the operation of the root tagged type. In the main
--- program, instantiate the generic list package and the generic
--- subprogram with the root tagged type and each derivative, then call
--- each instance with an object of the appropriate type.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51D00.A
--- -> CC51D01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from
--- main subprogram to package CC51D01_0. Removed
--- case passing class-wide actual to instance.
--- Updated test description and modified comments.
---
---!
-
-package CC51D01_0 is -- This package simulates support for a personnel
- -- database.
-
- type SSN_Type is new String (1 .. 9);
-
- type Blind_ID_Type is tagged record -- Root type of
- SSN : SSN_Type; -- class.
- -- ... Other components.
- end record;
-
- procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
-
- -- ... Other operations.
-
-
- type Name_Type is new String (1 .. 9);
-
- type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
- Name : Name_Type := "Doe "; -- of root type.
- -- ... Other components.
- end record;
-
- -- Inherits Update_ID from parent.
-
- procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
- -- implementation.
-
-
- type Ranked_ID_Type is new Named_ID_Type with record
- Level : Integer := 0; -- Indirect derivative
- -- ... Other components. -- of root type.
- end record;
-
- -- Inherits Update_ID from parent.
-
-end CC51D01_0;
-
-
- --==================================================================--
-
-
-package body CC51D01_0 is
-
- -- The implementations of Update_ID are purely artificial; the validity of
- -- their implementations in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- procedure Update_ID (Item : in out Blind_ID_Type) is
- begin
- Item.SSN := "111223333";
- end Update_ID;
-
-
- procedure Update_ID (Item : in out Named_ID_Type) is
- begin
- Item.SSN := "444556666";
- -- ... Other stuff.
- end Update_ID;
-
-end CC51D01_0;
-
-
- --==================================================================--
-
-
--- --
--- Formal package used here. --
--- --
-
-with FC51D00; -- Generic list abstraction.
-with CC51D01_0; -- Tagged type declarations.
-generic -- This procedure simulates a generic operation for types
- -- in the class rooted at Blind_ID_Type.
- type Elem_Type is new CC51D01_0.Blind_ID_Type with private;
- with package List_Mgr is new FC51D00 (Elem_Type);
-procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
-
-
- --==================================================================--
-
-
--- The implementation of CC51D01_1 is purely artificial; the validity
--- of its implementation in the context of the abstraction is irrelevant
--- to the feature being tested.
---
--- The expected behavior here is as follows: for each actual type corresponding
--- to Elem_Type, the call to Update_ID should invoke the actual type's
--- implementation, which updates the object's SSN field. Write_Element then
--- adds the object to the list.
-
-procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
- Element : Elem_Type := E; -- Can't update IN parameter.
-begin
- Update_ID (Element); -- Executes actual type's version.
- List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version.
-end CC51D01_1;
-
-
- --==================================================================--
-
-
-with FC51D00; -- Generic list abstraction.
-with CC51D01_0; -- Tagged type declarations.
-with CC51D01_1; -- Generic operation.
-
-with Report;
-procedure CC51D01 is
-
- use CC51D01_0; -- All types & ops
- -- directly visible.
-
- -- Begin test code declarations: -----------------------
-
- TC_Expected_1 : Blind_ID_Type := (SSN => "111223333");
- TC_Expected_2 : Named_ID_Type := ("444556666", "Doe ");
- TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0);
-
- TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
- TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
- TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0);
-
- -- End test code declarations. -------------------------
-
-
- -- Begin instantiations and list declarations: ---------
-
- -- At this point in an application, the generic list package would be
- -- instantiated for one of the visible tagged types. Next, the generic
- -- subprogram would be instantiated for the same tagged type and the
- -- preceding list package instance.
- --
- -- In order to cover all the important cases, this test instantiates several
- -- packages and subprograms (probably more than would typically appear
- -- in user code).
-
- -- Support for lists of blind IDs:
-
- package Blind_Lists is new FC51D00 (Blind_ID_Type);
- procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists);
- Blind_List : Blind_Lists.List_Type;
-
-
- -- Support for lists of named IDs:
-
- package Named_Lists is new FC51D00 (Named_ID_Type);
- procedure Update_and_Write is new -- Overloads subprog
- CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type.
- List_Mgr => Named_Lists);
- Named_List : Named_Lists.List_Type;
-
-
- -- Support for lists of ranked IDs:
-
- package Ranked_Lists is new FC51D00 (Ranked_ID_Type);
- procedure Update_and_Write is new -- Overloads.
- CC51D01_1 (Elem_Type => Ranked_ID_Type,
- List_Mgr => Ranked_Lists);
- Ranked_List : Ranked_Lists.List_Type;
-
- -- End instantiations and list declarations. -----------
-
-
-begin
- Report.Test ("CC51D01", "Formal private extension, specific tagged " &
- "type actual: body of primitive subprogram executed is " &
- "that of actual type. Check for subprograms declared in " &
- "a formal package");
-
-
- Update_and_Write (Blind_List, TC_Initial_1);
-
- if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
- Report.Failed ("Wrong result for root tagged type");
- end if;
-
-
- Update_and_Write (Named_List, TC_Initial_2);
-
- if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then
- Report.Failed ("Wrong result for type derived directly from root");
- end if;
-
-
- Update_and_Write (Ranked_List, TC_Initial_3);
-
- if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then
- Report.Failed ("Wrong result for type derived indirectly from root");
- end if;
-
-
- Report.Result;
-end CC51D01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d02.a b/gcc/testsuite/ada/acats/tests/cc/cc51d02.a
deleted file mode 100644
index 5205563..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51d02.a
+++ /dev/null
@@ -1,244 +0,0 @@
--- CC51D02.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 an instance, each implicit declaration of a user-defined
--- subprogram of a formal private extension declares a view of the
--- corresponding primitive subprogram of the ancestor, and that if the
--- tag in a call is statically determined to be that of the formal type,
--- the body executed will be that corresponding to the actual type.
---
--- Check subprograms declared within a generic formal package. Check for
--- the case where the actual type passed to the formal private extension
--- is a class-wide type. Check for several types in the same class.
---
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a package
--- which declares a tagged type and a derivative. Declare an operation
--- for the root tagged type and override it for the derivative. Declare
--- a generic subprogram which operates on lists of elements of tagged
--- types. Provide the generic subprogram with two formal parameters: (1)
--- a formal derived tagged type which represents a list element type, and
--- (2) a generic formal package with the list abstraction package as
--- template. Use the formal derived type as the generic formal actual
--- part for the formal package. Within the generic subprogram, call the
--- operation of the root tagged type. In the main program, instantiate
--- the generic list package and the generic subprogram with the class-wide
--- type for the root tagged type.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51D00.A
--- -> CC51D02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2
--- from specific to class-wide. Eliminated (illegal)
--- assignment step prior to comparison of
--- TC_Expected_X with item on stack.
---
---!
-
-package CC51D02_0 is -- This package simulates support for a personnel
- -- database.
-
- type SSN_Type is new String (1 .. 9);
-
- type Blind_ID_Type is tagged record -- Root type of
- SSN : SSN_Type; -- class.
- -- ... Other components.
- end record;
-
- procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
-
- -- ... Other operations.
-
-
- type Name_Type is new String (1 .. 9);
-
- type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
- Name : Name_Type := "Doe "; -- of root type.
- -- ... Other components.
- end record;
-
- -- Inherits Update_ID from parent.
-
- procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
- -- implementation.
-
-end CC51D02_0;
-
-
- --==================================================================--
-
-
-package body CC51D02_0 is
-
- -- The implementations of Update_ID are purely artificial; the validity of
- -- their implementations in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- procedure Update_ID (Item : in out Blind_ID_Type) is
- begin
- Item.SSN := "111223333";
- end Update_ID;
-
-
- procedure Update_ID (Item : in out Named_ID_Type) is
- begin
- Item.SSN := "444556666";
- -- ... Other stuff.
- end Update_ID;
-
-end CC51D02_0;
-
-
- --==================================================================--
-
-
--- --
--- Formal package used here. --
--- --
-
-with FC51D00; -- Generic list abstraction.
-with CC51D02_0; -- Tagged type declarations.
-generic -- This procedure simulates a generic operation for types
- -- in the class rooted at Blind_ID_Type.
- type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private;
- with package List_Mgr is new FC51D00 (Elem_Type);
-procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
-
-
- --==================================================================--
-
-
--- The implementation of CC51D02_1 is purely artificial; the validity
--- of its implementation in the context of the abstraction is irrelevant
--- to the feature being tested.
---
--- The expected behavior here is as follows: for each actual type corresponding
--- to Elem_Type, the call to Update_ID should invoke the actual type's
--- implementation (based on the tag of the actual), which updates the object's
--- SSN field. Write_Element then adds the object to the list.
-
-procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
- Element : Elem_Type := E; -- Can't update IN parameter.
- -- Initialization of unconstrained variable.
-begin
- Update_ID (Element); -- Executes actual type's version
- -- (for this test, this will be a
- -- dispatching call).
- List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version
- -- (for this test, this will be a
- -- class-wide operation).
-end CC51D02_1;
-
-
- --==================================================================--
-
-
-with FC51D00; -- Generic list abstraction.
-with CC51D02_0; -- Tagged type declarations.
-with CC51D02_1; -- Generic operation.
-
-with Report;
-procedure CC51D02 is
-
- use CC51D02_0; -- All types & ops
- -- directly visible.
-
- -- Begin test code declarations: -----------------------
-
- TC_Expected_1 : Blind_ID_Type'Class :=
- Blind_ID_Type'(SSN => "111223333");
- TC_Expected_2 : Blind_ID_Type'Class :=
- Named_ID_Type'("444556666", "Doe ");
-
-
- TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
- TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
- TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2;
-
- -- End test code declarations. -------------------------
-
-
- package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class);
-
- procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class,
- ID_Class_Lists);
-
- Blind_List : ID_Class_Lists.List_Type;
- Named_List : ID_Class_Lists.List_Type;
- Maimed_List : ID_Class_Lists.List_Type;
-
-
-begin
- Report.Test ("CC51D02", "Formal private extension, class-wide actual: " &
- "body of primitive subprogram executed is that of actual " &
- "type. Check for subprograms declared in formal package");
-
-
- Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual.
-
- if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then
- Report.Failed ("Result for root type actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
- Report.Failed ("Wrong result for root type actual");
- end if;
-
-
- Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual.
-
- if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then
- Report.Failed ("Result for derived type actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then
- Report.Failed ("Wrong result for derived type actual");
- end if;
-
-
- -- In the subtest below, an object of a class-wide type (TC_Initial_3) is
- -- passed to Update_and_Write. It has been initialized with an object of
- -- type Named_ID_Type, so the result should be identical to
- -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that
- -- a new list of Named IDs is used (Maimed_List). This is to assure test
- -- validity, since Named_List has already been updated by a previous
- -- subtest.
-
- Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual.
-
- if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then
- Report.Failed ("Result for class-wide actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then
- Report.Failed ("Wrong result for class-wide actual");
- end if;
-
-
- Report.Result;
-end CC51D02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54001.a b/gcc/testsuite/ada/acats/tests/cc/cc54001.a
deleted file mode 100644
index eb297d0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54001.a
+++ /dev/null
@@ -1,184 +0,0 @@
--- CC54001.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 general access-to-constant type may be passed as an
--- actual to a generic formal access-to-constant type.
---
--- TEST DESCRIPTION:
--- The generic implements a stack of access objects as an array. The
--- designated type of the formal access type is itself a formal private
--- type declared in the same generic formal part.
---
--- The generic is instantiated with an unconstrained subtype of String,
--- which results in a stack which can accommodate strings of varying
--- lengths (ragged array). Furthermore, the access objects to be pushed
--- onto the stack are created both statically and dynamically, utilizing
--- allocators and the 'Access attribute.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54001_1.
---
---!
-
-generic
- Size : in Positive;
- type Element_Type (<>) is private;
- type Element_Ptr is access constant Element_Type;
-package CC54001_0 is -- Generic stack of pointers.
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr);
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr);
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. (Size + 1);
- type Stack_Type is array (Index) of Element_Ptr; -- Last element unused.
-
- Top : Index := 1;
-
-end CC54001_0;
-
-
- --===================================================================--
-
-
-package body CC54001_0 is
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr) is
- begin
- Stack(Top) := Elem_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr) is
- begin
- Top := Top - 1; -- Artificial: no Constraint_Error protection.
- Elem_Ptr := Stack(Top);
- end Pop;
-
-end CC54001_0;
-
-
- --===================================================================--
-
-
-with CC54001_0; -- Generic stack of pointers.
-pragma Elaborate (CC54001_0);
-
-package CC54001_1 is
-
- subtype Message is String;
- type Message_Ptr is access constant Message;
-
- Message_Count : constant := 4;
-
- Message_0 : aliased constant Message := "Hello";
- Message_1 : aliased constant Message := "Doctor";
- Message_2 : aliased constant Message := "Name";
- Message_3 : aliased constant Message := "Continue";
-
-
- package Stack_of_Messages is new CC54001_0
- (Element_Type => Message,
- Element_Ptr => Message_Ptr,
- Size => Message_Count);
-
- Message_Stack : Stack_Of_Messages.Stack_Type;
-
-
- procedure Create_Message_Stack;
-
-end CC54001_1;
-
-
- --===================================================================--
-
-
-package body CC54001_1 is
-
- procedure Create_Message_Stack is
- -- Push access objects onto stack. Note that some are statically
- -- allocated, and some are dynamically allocated (using an aliased
- -- object to initialize).
- begin
- Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
- Stack_Of_Messages.Push (Message_Stack,
- new Message'(Message_1)); -- Dynamic.
- Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
- Stack_Of_Messages.Push (Message_Stack, -- Dynamic.
- new Message'(Message_3));
- end Create_Message_Stack;
-
-end CC54001_1;
-
-
- --===================================================================--
-
-
-with CC54001_1;
-
-with Report;
-procedure CC54001 is
-
- package Messages renames CC54001_1.Stack_Of_Messages;
-
- Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;
-
-begin
- Report.Test ("CC54001", "Check that a general access-to-constant type " &
- "may be passed as an actual to a generic formal " &
- "access-to-constant type");
-
- CC54001_1.Create_Message_Stack;
-
- Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the
- Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they
- Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed.
- Messages.Pop (CC54001_1.Message_Stack, Msg0);
-
- if Msg0.all /= CC54001_1.Message_0 or else
- Msg1.all /= CC54001_1.Message_1 or else
- Msg2.all /= CC54001_1.Message_2 or else
- Msg3.all /= CC54001_1.Message_3
- then
- Report.Failed ("Items popped off of stack do not match those pushed");
- end if;
-
- Report.Result;
-end CC54001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54002.a b/gcc/testsuite/ada/acats/tests/cc/cc54002.a
deleted file mode 100644
index 623f25d..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54002.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- CC54002.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 general access-to-variable type may be passed as an
--- actual to a generic formal general access-to-variable type. Check that
--- designated objects may be read and updated through the access value.
---
--- TEST DESCRIPTION:
--- The generic implements a List of access objects as an array, which
--- is itself a component of a record. The designated type of the formal
--- access type is a formal private type declared in the same generic
--- formal part.
---
--- The access objects to be placed in the List are created both
--- statically and dynamically, utilizing allocators and the 'Access
--- attribute.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54002_1.
---
---!
-
-generic
- Size : in Positive;
- type Element_Type (<>) is private;
- type Element_Ptr is access all Element_Type;
-package CC54002_0 is -- Generic list of pointers.
-
- subtype Index is Positive range 1 .. (Size + 1);
-
- type List_Array is array (Index) of Element_Ptr;
-
- type List_Type is record
- Elements : List_Array;
- Next : Index := 1; -- Next available "slot" in list.
- end record;
-
-
- procedure Put (List : in out List_Type;
- Elem_Ptr : in Element_Ptr;
- Location : in Index);
-
- procedure Get (List : in out List_Type;
- Elem_Ptr : out Element_Ptr;
- Location : in Index);
-
- -- ... Other operations.
-
-end CC54002_0;
-
-
- --===================================================================--
-
-
-package body CC54002_0 is
-
- procedure Put (List : in out List_Type;
- Elem_Ptr : in Element_Ptr;
- Location : in Index) is
- begin
- List.Elements(Location) := Elem_Ptr;
- end Put;
-
-
- procedure Get (List : in out List_Type;
- Elem_Ptr : out Element_Ptr;
- Location : in Index) is
- begin -- Artificial: no provision for getting "empty" element.
- Elem_Ptr := List.Elements(Location);
- end Get;
-
-end CC54002_0;
-
-
- --===================================================================--
-
-
-with CC54002_0; -- Generic List of pointers.
-pragma Elaborate (CC54002_0);
-
-package CC54002_1 is
-
- subtype Lengths is Natural range 0 .. 50;
-
- type Subscriber (NLen, ALen: Lengths := 50) is record
- Name : String(1 .. NLen);
- Address : String(1 .. ALen);
- -- ... Other components.
- end record;
-
- type Subscriber_Ptr is access all Subscriber; -- General access-to-
- -- variable type.
-
- package District_Subscription_Lists is new CC54002_0
- (Element_Type => Subscriber,
- Element_Ptr => Subscriber_Ptr,
- Size => 100);
-
- District_01_Subscribers : District_Subscription_Lists.List_Type;
-
-
- New_Subscriber_01 : aliased CC54002_1.Subscriber :=
- (12, 23, "Brown, Silas", "King's Pyland, Dartmoor");
-
- New_Subscriber_02 : aliased CC54002_1.Subscriber :=
- (16, 23, "Hatherly, Victor", "16A Victoria St. London");
-
-end CC54002_1;
-
--- No body for CC54002_1.
-
-
- --===================================================================--
-
-
-with CC54002_1;
-
-with Report;
-procedure CC54002 is
-
- Mod_Subscriber_01 : constant CC54002_1.Subscriber :=
- (12, 23, "Brown, Silas", "Mapleton, Dartmoor ");
-
- TC_Actual_01, TC_Actual_02 : CC54002_1.Subscriber_Ptr;
-
-
- use type CC54002_1.Subscriber; -- "/=" directly visible.
-
-begin
- Report.Test ("CC54002", "Check that a general access-to-variable type " &
- "may be passed as an actual to a generic formal " &
- "access-to-variable type");
-
-
- -- Add elements to the list:
-
- CC54002_1.District_Subscription_Lists.Put -- Element created statically.
- (List => CC54002_1.District_01_Subscribers,
- Elem_Ptr => CC54002_1.New_Subscriber_01'Access,
- Location => 1);
-
- CC54002_1.District_Subscription_Lists.Put -- Element created dynamically.
- (List => CC54002_1.District_01_Subscribers,
- Elem_Ptr => new CC54002_1.Subscriber'(CC54002_1.New_Subscriber_02),
- Location => 2);
-
-
- -- Manipulation of the objects on the list is performed below directly
- -- through the access objects. Although such manipulation is artificial
- -- from the perspective of this usage model, it is not artificial in
- -- general and is necessary in order to test the objective.
-
-
- -- Modify the first list element through the access object:
-
- CC54002_1.District_01_Subscribers.Elements(1).Address := -- Update
- "Mapleton, Dartmoor "; -- Implicit dereference. -- through the
- -- access
- -- object.
- -- Retrieve elements of the list:
-
- CC54002_1.District_Subscription_Lists.Get
- (CC54002_1.District_01_Subscribers,
- TC_Actual_01,
- 1);
-
- CC54002_1.District_Subscription_Lists.Get
- (CC54002_1.District_01_Subscribers,
- TC_Actual_02,
- 2);
-
- -- Verify list contents in two ways: 1st verify the directly-dereferenced
- -- access objects against the dereferenced access objects returned by Get;
- -- 2nd verify them against objects the expected values:
-
- -- Read
- -- through the
- -- access
- -- objects.
-
- if CC54002_1.District_01_Subscribers.Elements(1).all /= TC_Actual_01.all
- or else
- CC54002_1.District_01_Subscribers.Elements(2).all /= TC_Actual_02.all
- then
- Report.Failed ("Wrong results returned by Get");
-
- elsif CC54002_1.District_01_Subscribers.Elements(1).all /=
- Mod_Subscriber_01
- or
- CC54002_1.District_01_Subscribers.Elements(2).all /=
- CC54002_1.New_Subscriber_02
- then
- Report.Failed ("List elements do not have expected values");
- end if;
-
- Report.Result;
-end CC54002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54003.a b/gcc/testsuite/ada/acats/tests/cc/cc54003.a
deleted file mode 100644
index d8aaeaf..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54003.a
+++ /dev/null
@@ -1,234 +0,0 @@
--- CC54003.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 general access-to-subprogram type may be passed as an
--- actual to a generic formal access-to-subprogram type. Check that
--- designated subprograms may be called by dereferencing the access
--- values.
---
--- TEST DESCRIPTION:
--- The generic implements a stack of access-to-subprogram objects as an
--- array. The profile of the access-to-subprogram formal corresponds to
--- a function which accepts a parameter of some type and returns an
--- object of the same type.
---
--- For this test, the functions for which access values will be pushed
--- onto the stack accept a parameter of type access-to-string, lengthen
--- the pointed-to string, then return an access object pointing to this
--- lengthened string.
---
--- The instance declares a function Execute_Stack which executes each
--- subprogram on the stack in sequence. This function accepts some initial
--- access-to-string, then returns an access object pointing to the
--- lengthened string resulting from the execution of the stacked
--- subprograms. Access-to-string objects are used rather than strings
--- themselves because the initial string "grows" during each iteration.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54003_2.
---
---!
-
-generic
-
- Size : in Positive;
-
- type Item_Type (<>) is private;
- type Item_Ptr is access Item_Type;
-
- type Function_Ptr is access function (Item : Item_Ptr)
- return Item_Ptr;
-
-package CC54003_0 is -- Generic stack of pointers.
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Func_Ptr : in Function_Ptr);
-
- function Execute_Stack (Stack : Stack_Type;
- Initial_Input : Item_Ptr) return Item_Ptr;
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. (Size + 1);
- type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused.
-
- Top : Index := 1; -- Top refers to the next available slot.
-
-end CC54003_0;
-
-
- --===================================================================--
-
-
-package body CC54003_0 is
-
- procedure Push (Stack : in out Stack_Type;
- Func_Ptr : in Function_Ptr) is
- begin
- Stack(Top) := Func_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- -- Call each subprogram on the stack in sequence. For the first call, pass
- -- Initial_Input. For succeeding calls, pass the result of the previous
- -- call.
-
- function Execute_Stack (Stack : Stack_Type;
- Initial_Input : Item_Ptr) return Item_Ptr is
- Result : Item_Ptr := Initial_Input;
- begin
- for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E
- Result := Stack(I)(Result); -- protection.
- end loop;
- return Result;
- end Execute_Stack;
-
-end CC54003_0;
-
-
- --===================================================================--
-
-
-package CC54003_1 is
-
- subtype Message is String;
- type Message_Ptr is access Message;
-
- function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr;
- function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr;
-
- -- ...Other operations.
-
-end CC54003_1;
-
-
- --===================================================================--
-
-
-package body CC54003_1 is
-
- function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is
- Sender : constant String := "Dummy: "; -- Artificial; in a real
- -- application Sender might
- New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function.
- begin
- return new Message'(New_Msg);
- end Add_Prefix;
-
-
- function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is
- Time : constant String := " (12:03pm)"; -- Artificial; in a real
- -- application Time might be a
- New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function.
- begin
- return new Message'(New_Msg);
- end Add_Suffix;
-
-end CC54003_1;
-
-
- --===================================================================--
-
-
-with CC54003_0; -- Generic stack of pointers.
-pragma Elaborate (CC54003_0);
-
-with CC54003_1; -- Message abstraction.
-
-package CC54003_2 is
-
- type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr)
- return CC54003_1.Message_Ptr;
-
- Maximum_Ops : constant := 4; -- Arbitrary.
-
- package Stack_of_Ops is new CC54003_0
- (Item_Type => CC54003_1.Message,
- Item_Ptr => CC54003_1.Message_Ptr,
- Function_Ptr => Operation_Ptr,
- Size => Maximum_Ops);
-
- Operation_Stack : Stack_Of_Ops.Stack_Type;
-
-
- procedure Create_Operation_Stack;
-
-end CC54003_2;
-
- --===================================================================--
-
-
-package body CC54003_2 is
-
- procedure Create_Operation_Stack is
- begin
- Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access);
- Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access);
- end Create_Operation_Stack;
-
-end CC54003_2;
-
-
- --===================================================================--
-
-
-with CC54003_1; -- Message abstraction.
-with CC54003_2; -- Message-operation stack.
-
-with Report;
-procedure CC54003 is
-
- package Msg_Ops renames CC54003_2.Stack_Of_Ops;
-
- Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there");
- Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)";
-
-begin
- Report.Test ("CC54003", "Check that a general access-to-subprogram type " &
- "may be passed as an actual to a generic formal " &
- "access-to-subprogram type");
-
- CC54003_2.Create_Operation_Stack;
-
- declare
- Actual : CC54003_1.Message_Ptr :=
- Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg);
- begin
- if Actual.all /= Expected then
- Report.Failed ("Wrong result from dereferenced subprogram execution");
- end if;
- end;
-
- Report.Result;
-end CC54003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54004.a b/gcc/testsuite/ada/acats/tests/cc/cc54004.a
deleted file mode 100644
index 0023b3a..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54004.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- CC54004.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 designated type of a generic formal pool-specific
--- access type may be class-wide. Check that calls to primitive
--- subprograms in the instance dispatch to the appropriate bodies when
--- the controlling operand is a dereference of an object of the access-
--- to-class-wide type.
---
--- TEST DESCRIPTION:
--- A hierarchy of types is declared in two packages. The root type of
--- the class is declared as abstract in a separate package. It possesses
--- an abstract primitive subprogram Handle. A concrete type extends the
--- root type in a second package with a component of an enumeration type.
--- A second type extends this extension in the same package. Both
--- derivatives override the root type's primitive subprogram with a
--- non-abstract subprogram.
---
--- The generic implements a heterogeneous stack of access-to-class-wide
--- objects in the root type's class. A subprogram declared in the
--- generic calls Handle using dereferences of each of the class-wide
--- objects on the stack as operand. Each call to Handle should dispatch
--- to the appropriate body based on the tag of the operand. The
--- overriding versions of Handle each set the component of the type to
--- a different value. The value of the component is checked to verify
--- that the calls dispatched correctly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54004_3.
---
---!
-
-package CC54004_0 is
-
- -- The types and operations defined here are artificial. The component
- -- TC_Code is the only component required for testing purposes.
-
- type TC_Code_Type is (None, Low, Medium);
-
- type Alert is abstract tagged record -- Abstract type.
- TC_Code : TC_Code_Type; -- Testing flag.
- end record;
-
- procedure Handle (A : in out Alert); -- Non-abstract primitive
- -- subprogram.
- -- ...Other operations.
-
- type Alert_Ptr is access Alert'Class; -- Access-to-class-wide
- -- type.
-end CC54004_0;
-
-
- --===================================================================--
-
-
-package body CC54004_0 is
-
- procedure Handle (A : in out Alert) is
- begin
- A.TC_Code := None;
- end Handle;
-
-end CC54004_0;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-use CC54004_0;
-package CC54004_1 is
-
- type Low_Alert is new CC54004_0.Alert with record
- C1 : String (1 .. 5) := "Dummy";
- -- ...Other components.
- end record;
-
- procedure Handle (A : in out Low_Alert); -- Overrides parent's
- -- operations.
- --...Other operations.
-
-
- type Medium_Alert is new Low_Alert with record
- C : Integer := 6;
- -- ...Other components.
- end record;
-
- procedure Handle (A : in out Medium_Alert); -- Overrides parent's
- -- operations.
- --...Other operations.
-
-end CC54004_1;
-
-
- --===================================================================--
-
-package body CC54004_1 is
-
- procedure Handle (A : in out Low_Alert) is
- begin
- A.TC_Code := Low;
- end Handle;
-
- procedure Handle (A : in out Medium_Alert) is
- begin
- A.TC_Code := Medium;
- end Handle;
-
-end CC54004_1;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-generic
- type Element_Type is abstract new CC54004_0.Alert with private;
- type Element_Ptr is access Element_Type'Class;
-package CC54004_2 is
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr);
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr);
-
- procedure Process_Stack (Stack : in out Stack_Type);
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. 5;
- type Stack_Type is array (Index) of Element_Ptr;
-
- Top : Index := 1;
-
-end CC54004_2;
-
-
- --===================================================================--
-
-
-package body CC54004_2 is
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr) is
- begin
- Stack(Top) := Elem_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr)is
- begin
- Top := Top - 1; -- Artificial: no Constraint_Error protection.
- Elem_Ptr := Stack(Top);
- end Pop;
-
-
- -- Call Handle for each element on the stack. Since the dereferenced access
- -- object is of a class-wide type, all calls to Handle are dispatching. The
- -- version of Handle called will be that declared for the type
- -- corresponding to the tag of the operand.
-
- procedure Process_Stack (Stack : in out Stack_Type) is
- begin -- Artificial: no Constraint_Error protection.
- for I in reverse Index'First .. (Top - 1) loop
- Handle (Stack(I).all); -- Call dispatches based on
- end loop; -- tag of operand.
- end Process_Stack;
-
-end CC54004_2;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-with CC54004_1;
-with CC54004_2;
-pragma Elaborate (CC54004_2);
-
-package CC54004_3 is
-
- package Alert_Stacks is new CC54004_2 (Element_Type => CC54004_0.Alert,
- Element_Ptr => CC54004_0.Alert_Ptr);
-
- -- All overriding versions of Handle visible at the point of instantiation.
-
- Alert_List : Alert_Stacks.Stack_Type;
-
- procedure TC_Create_Alert_Stack;
-
-end CC54004_3;
-
-
- --===================================================================--
-
-
-package body CC54004_3 is
-
- procedure TC_Create_Alert_Stack is
- begin
- Alert_Stacks.Push (Alert_List, new CC54004_1.Low_Alert);
- Alert_Stacks.Push (Alert_List, new CC54004_1.Medium_Alert);
- end TC_Create_Alert_Stack;
-
-end CC54004_3;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-with CC54004_1;
-with CC54004_3;
-
-with Report;
-procedure CC54004 is
- TC_Low_Ptr, TC_Med_Ptr : CC54004_0.Alert_Ptr;
- TC_Low_Actual : CC54004_1.Low_Alert;
- TC_Med_Actual : CC54004_1.Medium_Alert;
-
- use type CC54004_0.TC_Code_Type;
-begin
- Report.Test ("CC54004", "Check that the designated type of a generic " &
- "formal pool-specific access type may be class-wide");
-
-
- -- Create stack of elements:
-
- CC54004_3.TC_Create_Alert_Stack;
-
-
- -- Commence dispatching operations on stack elements:
-
- CC54004_3.Alert_Stacks.Process_Stack (CC54004_3.Alert_List);
-
-
- -- Pop "handled" alerts off stack:
-
- CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Med_Ptr);
- CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Low_Ptr);
-
-
- -- Verify results:
-
- if TC_Low_Ptr.all not in CC54004_1.Low_Alert or else
- TC_Med_Ptr.all not in CC54004_1.Medium_Alert
- then
- Report.Failed ("Class-wide objects do not have expected tags");
-
- -- The explicit dereference of the "Pop"ed pointers results in views of
- -- the designated objects, the nominal subtypes of which are class-wide.
- -- In order to be able to reference the component TC_Code, these views
- -- must be converted to a specific type possessing that component.
-
- elsif CC54004_1.Low_Alert(TC_Low_Ptr.all).TC_Code /= CC54004_0.Low or
- CC54004_1.Medium_Alert(TC_Med_Ptr.all).TC_Code /= CC54004_0.Medium
- then
- Report.Failed ("Calls did not dispatch to expected operations");
- end if;
-
- Report.Result;
-end CC54004;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70001.a b/gcc/testsuite/ada/acats/tests/cc/cc70001.a
deleted file mode 100644
index 65681b0..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70001.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- CC70001.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 template for a generic formal package may be a child
--- package, and that a child instance which is an instance of the
--- template may be passed as an actual to the formal package. Check that
--- the visible part of the generic formal package includes the first list
--- of basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type. Declare a generic child package of
--- this package which defines additional list operations. Declare a
--- generic subprogram which operates on lists of elements of discrete
--- types. Provide the generic subprogram with three formal parameters:
--- (1) a formal discrete type which represents a list element type, (2)
--- a generic formal package with the parent list generic as template, and
--- (3) a generic formal package with the child list generic as template.
--- Use the formal discrete type as the generic formal actual part for the
--- parent formal package. In the main program, declare an instance of
--- parent, then declare an instance of the child which is itself a child
--- the parent's instance. Pass these instances as actuals to the generic
--- subprogram instance.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected syntax of formal
--- package declaration.
--- 27 Feb 97 PWB.CTA Added an elaboration pragma.
---!
-
-generic
- type Element_Type is private; -- List elems may be of any nonlimited type.
-package CC70001_0 is -- List abstraction.
-
- type List_Type is limited private;
-
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return Boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-private
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end CC70001_0;
-
-
- --==================================================================--
-
-
-package body CC70001_0 is
-
- function End_Of_List (L : List_Type) return Boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end CC70001_0;
-
-
- --==================================================================--
-
-
--- Child must be generic since parent is generic. A formal parameter for
--- "element type" can not be provided here, because then the type of list
--- element assumed by these new operations would be different from that
--- defined by the list type declared in the parent.
-
-generic
-package CC70001_0.CC70001_1 is -- Additional list operations.
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Type; E : out Element_Type);
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Type; E : in Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Type; E : in Element_Type);
-
-end CC70001_0.CC70001_1;
-
-
- --==================================================================--
-
-
-package body CC70001_0.CC70001_1 is
-
- procedure Read_Element (L : in out List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
-
-
- procedure Write_Element (L : in out List_Type; E : in Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
-
-
- procedure Add_Element (L : in out List_Type; E : in Element_Type) is
- New_Node : Node_Pointer := new Node_Type'(E, null);
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-end CC70001_0.CC70001_1;
-
-
- --==================================================================--
-
-
-with CC70001_0.CC70001_1; -- Generic list abstraction + additional operations.
-generic
-
- -- Import the list abstraction defined in CC70001_0, as well as the
- -- additional operations defined in CC70001_0.CC70001_1. Declare a formal
- -- discrete type. Restrict this generic procedure to operate only on lists
- -- of discrete elements by passing the formal discrete type as an actual
- -- parameter to the formal (parent) package.
-
- type Elem_Type is (<>); -- Discrete types only.
- with package List_Mgr is new CC70001_0 (Elem_Type);
- with package List_Ops is new List_Mgr.CC70001_1 (<>);
-
-procedure CC70001_2 (L : in out List_Mgr.List_Type);
-
-
- --==================================================================--
-
-
-procedure CC70001_2 (L : in out List_Mgr.List_Type) is
-begin
- List_Mgr.Reset (L);
- while not List_Mgr.End_Of_List (L) loop
- List_Ops.Write_Element (L, Elem_Type'First);
- end loop;
-end CC70001_2;
-
-
- --==================================================================--
-
-
-package CC70001_3 is
-
- type Points is range 0 .. 10;
-
- -- ... Various other types used by the application.
-
-end CC70001_3;
-
-
--- No body for CC70001_3;
-
-
- --==================================================================--
-
-
--- Declare instances of the generic list packages for the discrete type.
--- In order to establish that the type passed as an actual to the parent
--- generic (CC70001_0) is the one utilized by the child generic (CC70001_1),
--- the instance of the child must itself be declared as a child of the
--- instance of the parent. Since only library units may have or be children,
--- both instances must be library units.
-
-with CC70001_0; -- Generic list abstraction.
-with CC70001_3; -- Package containing discrete type declaration.
-pragma Elaborate (CC70001_0);
-package CC70001_4 is new CC70001_0 (CC70001_3.Points);
-
-with CC70001_0.CC70001_1; -- Generic extension to list abstraction.
-with CC70001_4;
-package CC70001_4.CC70001_5 is new CC70001_4.CC70001_1;
-
-
- --==================================================================--
-
-
-with CC70001_2; -- Generic "zeroing" op for lists of discrete types.
-with CC70001_3; -- Types for application.
-with CC70001_4.CC70001_5; -- Discrete list abstraction + additional ops.
-
-with Report;
-procedure CC70001 is
-
- package Lists_Of_Scores renames CC70001_4;
- package Score_Ops renames CC70001_4.CC70001_5;
-
- Scores : Lists_Of_Scores.List_Type; -- List of points.
-
- procedure Reset_All_Scores is new CC70001_2 -- Operation on lists of
- (Elem_Type => CC70001_3.Points, -- points.
- List_Mgr => Lists_Of_Scores,
- List_Ops => Score_Ops);
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of CC70001_3.Points;
-
- TC_Initial_Values : constant TC_Score_Array := (2, 4, 6);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6.
- Score_Ops.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_of_Scores.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Score_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70001", "Check that the template for a generic formal " &
- "package may be a child package, and that a child instance " &
- "which is an instance of the template may be passed as an " &
- "actual to the formal package. Check that the visible part " &
- "of the generic formal package includes the first list of " &
- "basic declarative items of the package specification");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Reset_All_Scores (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70002.a b/gcc/testsuite/ada/acats/tests/cc/cc70002.a
deleted file mode 100644
index 3e4d9c4..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70002.a
+++ /dev/null
@@ -1,241 +0,0 @@
--- CC70002.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 formal package actual part may specify actual parameters
--- for a generic formal package. Check that these actual parameters may
--- be formal types, formal objects, and formal subprograms. Check that
--- the visible part of the generic formal package includes the first list
--- of basic declarative items of the package specification, and that if
--- the formal package actual part is (<>), it also includes the generic
--- formal part of the template for the formal package.
---
--- TEST DESCRIPTION:
--- Declare a generic package which defines a "signature" for mathematical
--- groups. Declare a second generic package which defines a
--- two-dimensional matrix abstraction. Declare a third generic package
--- which provides mathematical group operations for two-dimensional
--- matrices. Provide this third generic with two formal parameters: (1)
--- a generic formal package with the second generic as template and a
--- (<>) actual part, and (2) a generic formal package with the first
--- generic as template and an actual part that takes a formal type,
--- object, and subprogram from the first formal package as actuals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Mathematical group signature.
-
- type Group_Type is private;
-
- Identity : in Group_Type;
-
- with function Operation (Left, Right : Group_Type) return Group_Type;
--- with function Inverse... (omitted for brevity).
-
-package CC70002_0 is
-
- function Power (Left : Group_Type; Right : Integer) return Group_Type;
-
- -- ... Other group operations.
-
-end CC70002_0;
-
-
- --==================================================================--
-
-
-package body CC70002_0 is
-
- -- The implementation of Power is purely artificial; the validity of its
- -- implementation in the context of the abstraction is irrelevant to the
- -- feature being tested.
-
- function Power (Left : Group_Type; Right : Integer) return Group_Type is
- Result : Group_Type := Identity;
- begin
- Result := Operation (Result, Left); -- All this really does is add
- return Result; -- one to each matrix element.
- end Power;
-
-end CC70002_0;
-
-
- --==================================================================--
-
-
-generic -- 2D matrix abstraction.
- type Element_Type is range <>;
-
- type Abscissa is range <>;
- type Ordinate is range <>;
-
- type Matrix_2D is array (Abscissa, Ordinate) of Element_Type;
-package CC70002_1 is
-
- Add_Ident : constant Matrix_2D := (Abscissa => (others => 1));
- -- Artificial for
- -- testing purposes.
- -- ... Other identity matrices.
-
-
- function "+" (A, B : Matrix_2D) return Matrix_2D;
-
- -- ... Other operations.
-
-end CC70002_1;
-
-
- --==================================================================--
-
-
-package body CC70002_1 is
-
- function "+" (A, B : Matrix_2D) return Matrix_2D is
- C : Matrix_2D;
- begin
- for I in Abscissa loop
- for J in Ordinate loop
- C(I,J) := A(I,J) + B(I,J);
- end loop;
- end loop;
- return C;
- end "+";
-
-end CC70002_1;
-
-
- --==================================================================--
-
-
-with CC70002_0; -- Mathematical group signature.
-with CC70002_1; -- 2D matrix abstraction.
-
-generic -- Mathematical 2D matrix addition group.
-
- with package Matrix_Ops is new CC70002_1 (<>);
-
- -- Although the restriction of the formal package below to signatures
- -- describing addition groups, and then only for 2D matrices, is rather
- -- artificial in the context of this "application," the passing of types,
- -- objects, and subprograms as actuals to a formal package is not.
-
- with package Math_Sig is new CC70002_0
- (Group_Type => Matrix_Ops.Matrix_2D,
- Identity => Matrix_Ops.Add_Ident,
- Operation => Matrix_Ops."+");
-
-package CC70002_2 is
-
- -- Add two matrices that are to be multiplied by coefficients:
- -- [ ] = CA*[ ] + CB*[ ].
-
- function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D;
- CA : Integer;
- B : Matrix_Ops.Matrix_2D;
- CB : Integer)
- return Matrix_Ops.Matrix_2D;
-
- -- ...Other operations.
-
-end CC70002_2;
-
-
- --==================================================================--
-
-
-package body CC70002_2 is
-
- function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D;
- CA : Integer;
- B : Matrix_Ops.Matrix_2D;
- CB : Integer)
- return Matrix_Ops.Matrix_2D is
- Left, Right : Matrix_Ops.Matrix_2D;
- begin
- Left := Math_Sig.Power (A, CA); -- Multiply 1st array by its coeff.
- Right := Math_Sig.Power (B, CB); -- Multiply 2nd array by its coeff.
- return (Matrix_Ops."+" (Left, Right));-- Add these two arrays.
- end Add_Matrices_With_Coefficients;
-
-end CC70002_2;
-
-
- --==================================================================--
-
-
-with CC70002_0; -- Mathematical group signature.
-with CC70002_1; -- 2D matrix abstraction.
-with CC70002_2; -- Mathematical 2D matrix addition group.
-
-with Report;
-procedure CC70002 is
-
- subtype Cell_Type is Positive range 1 .. 3;
- subtype Category_Type is Positive range 1 .. 2;
-
- type Data_Points is new Natural range 0 .. 100;
-
- type Table_Type is array (Cell_Type, Category_Type) of Data_Points;
-
- package Data_Table_Support is new CC70002_1 (Data_Points,
- Cell_Type,
- Category_Type,
- Table_Type);
-
- package Data_Table_Addition_Group is new CC70002_0
- (Group_Type => Table_Type,
- Identity => Data_Table_Support.Add_Ident,
- Operation => Data_Table_Support."+");
-
- package Table_Add_Ops is new CC70002_2
- (Data_Table_Support, Data_Table_Addition_Group);
-
-
- Scores_Table : Table_Type := ( ( 12, 0),
- ( 21, 33),
- ( 49, 9) );
- Expected : Table_Type := ( ( 26, 2),
- ( 44, 68),
- ( 100, 20) );
-
-begin
- Report.Test ("CC70002", "Check that a generic formal package actual " &
- "part may specify formal objects, formal subprograms, " &
- "and formal types");
-
- Scores_Table := Table_Add_Ops.Add_Matrices_With_Coefficients
- (Scores_Table, 2,
- Scores_Table, 1);
-
- if (Scores_Table /= Expected) then
- Report.Failed ("Incorrect result for multi-dimensional array");
- end if;
-
- Report.Result;
-end CC70002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70003.a b/gcc/testsuite/ada/acats/tests/cc/cc70003.a
deleted file mode 100644
index d2309fc..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70003.a
+++ /dev/null
@@ -1,212 +0,0 @@
--- CC70003.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 actual passed to a formal package may be a formal
--- access-to-subprogram type. Check that the visible part of the generic
--- formal package includes the first list of basic declarative items of
--- the package specification.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a generic
--- package which supports the execution of lists of operations. Provide
--- the generic package with two formal parameters: (1) a formal access-
--- to-function type, and (2) a generic formal package with the list
--- abstraction package as template. Within a procedure declared in the
--- list-execution package, utilize information about the profile of
--- the functions in the list. Declare a package which declares functions
--- matching the profile of the formal access-to-subprogram type. In the
--- main program, create a list of pointers to the functions declared in
--- the package, instantiate the list abstraction and list-execution
--- packages, and use the list-execution procedure to call each of the
--- functions in the list in sequence.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type is private;
-package CC70003_0 is -- This package simulates a generic list abstraction.
-
- -- The definition of List_Type below is purely artificial; its validity
- -- in the context of the abstraction is irrelevant to the feature being
- -- tested.
-
- type Element_Ptr is access Element_Type;
-
- subtype List_Size is Natural range 1 .. 2;
- type List_Type is array (List_Size) of Element_Ptr;
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type;
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type);
-
- -- ... Other list operations for Element_Type.
-
-end CC70003_0;
-
-
- --==================================================================--
-
-
-package body CC70003_0 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type is
- begin
- return L(I).all;
- end View_Element;
-
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type) is
- begin
- L(I) := new Element_Type'(E);
- end Write_Element;
-
-end CC70003_0;
-
-
- --==================================================================--
-
-
-with CC70003_0; -- Generic list abstraction.
-generic
- type Elem_Type is access function (F : Float) return Float;
- with package List_Mgr is new CC70003_0 (Elem_Type);
-package CC70003_1 is -- This package simulates support for executing lists
- -- of operations.
-
- procedure Execute_List (L : List_Mgr.List_Type; F : in out Float);
-
- -- ... Other operations.
-
-end CC70003_1;
-
-
- --==================================================================--
-
-
-package body CC70003_1 is
-
- procedure Execute_List (L : List_Mgr.List_Type; F : in out Float) is
- begin
- for I in L'Range loop
- F := List_Mgr.View_Element(I, L)(F); -- Execute next operation in
- end loop; -- list with current value of
- end Execute_List; -- F as operand.
-
-
-end CC70003_1;
-
-
- --==================================================================--
-
-
-package CC70003_2 is
-
- function Sine (F : Float) return Float;
- function Exp (F : Float) return Float;
-
- -- ... Other math functions.
-
-end CC70003_2;
-
-
- --==================================================================--
-
-
-package body CC70003_2 is
-
- -- The implementations of the functions below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Sine (F : Float) return Float is
- begin
- return (-0.15);
- end Sine;
-
- function Exp (F : Float) return Float is
- begin
- if (F = 0.0) then
- return (-0.69);
- else
- return (2.0); -- This branch should be taken.
- end if;
- end Exp;
-
-end CC70003_2;
-
-
- --==================================================================--
-
-
-with CC70003_0; -- Generic list abstraction.
-with CC70003_1; -- Generic operation-list abstraction.
-with CC70003_2; -- Math library.
-
-with Report;
-procedure CC70003 is
-
- type Math_Op is access function (F : Float) return Float;
-
- package Math_Op_Lists is new CC70003_0 (Math_Op);
- package Math_Op_List_Support is new CC70003_1 (Math_Op, Math_Op_Lists);
-
- Sin_Ptr : Math_Op := CC70003_2.Sine'Access;
- Exp_Ptr : Math_Op := CC70003_2.Exp'Access;
-
- Op_List : Math_Op_Lists.List_Type;
-
- Operand : Float := 0.0;
- Expected : Float := 2.0;
-
-
-begin
- Report.Test ("CC70003", "Check that the actual passed to a formal " &
- "package may be a formal access-to-subprogram type");
-
- Math_Op_Lists.Write_Element (1, Op_List, Sin_Ptr);
- Math_Op_Lists.Write_Element (2, Op_List, Exp_Ptr);
-
- Math_Op_List_Support.Execute_List (Op_List, Operand);
-
- if (Operand /= Expected) then
- Report.Failed ("Incorrect results from indirect function calls");
- end if;
-
- Report.Result;
-end CC70003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a01.a b/gcc/testsuite/ada/acats/tests/cc/cc70a01.a
deleted file mode 100644
index ac92f43..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70a01.a
+++ /dev/null
@@ -1,208 +0,0 @@
--- CC70A01.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 visible part of a generic formal package includes the
--- first list of basic declarative items of the package specification.
--- Check for a generic package which declares a formal package with (<>)
--- as its actual part.
---
--- TEST DESCRIPTION:
--- The "first list of basic declarative items" of a package specification
--- is the visible part of the package. Thus, the declarations in the
--- visible part of the actual instance corresponding to a formal
--- package are available in the generic which declares the formal package.
---
--- Declare a generic package which simulates a complex integer abstraction
--- (foundation code).
---
--- Declare a second, library-level generic package which utilizes the
--- first generic package as a generic formal package (with a (<>)
--- actual_part). In the second generic package, declare objects, types,
--- and operations in terms of the objects, types, and operations declared
--- in the first generic package.
---
--- In the main program, instantiate the first generic package, then
--- instantiate the second generic package and pass the first instance
--- to it as a generic actual parameter. Check that the operations in
--- the second instance perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70A00; -- Generic complex integer operations.
-
-generic -- Generic complex matrix operations.
- with package Complex_Package is new FC70A00 (<>);
-package CC70A01_0 is
-
- type Complex_Matrix_Type is -- 1st index is matrix
- array (Positive range <>, Positive range <>) -- row, 2nd is column.
- of Complex_Package.Complex_Type;
- Dimension_Mismatch : exception;
-
-
- function Identity_Matrix (Size : Positive) -- Create identity matrix
- return Complex_Matrix_Type; -- of specified size.
-
- function "*" (Left : Complex_Matrix_Type; -- Multiply two complex
- Right : Complex_Matrix_Type) -- matrices.
- return Complex_Matrix_Type;
-
-end CC70A01_0;
-
-
- --==================================================================--
-
-
-package body CC70A01_0 is -- Generic complex matrix operations.
-
- use Complex_Package;
-
- --==============================================--
-
- function Inner_Product (Left, Right : Complex_Matrix_Type;
- Row, Column : Positive) -- Compute inner product
- return Complex_Package.Complex_Type is -- for matrix-multiply.
-
- Result : Complex_Type := Zero;
- subtype Vector_Size is Positive range Left'Range(2);
-
- begin -- Inner_Product.
- for I in Vector_Size loop
- Result := Result + -- Complex_Package."+".
- (Left(Row, I) * Right(I, Column)); -- Complex_Package."*".
- end loop;
- return (Result);
- end Inner_Product;
-
- --==============================================--
-
- function Identity_Matrix (Size : Positive) return Complex_Matrix_Type is
- Result : Complex_Matrix_Type (1 .. Size, 1 .. Size) :=
- (others => (others => Zero)); -- Zeroes everywhere...
- begin
- for I in 1 .. Size loop
- Result (I, I) := One; -- Ones on the diagonal.
- end loop;
- return (Result);
- end Identity_Matrix;
-
- --==============================================--
-
- function "*" (Left : Complex_Matrix_Type; Right : Complex_Matrix_Type)
- return Complex_Matrix_Type is
-
- subtype Rows is Positive range Left'Range(1);
- subtype Columns is Positive range Right'Range(2);
-
- Result : Complex_Matrix_Type(Rows, Columns);
- begin
- if Left'Length(2) /= Right'Length(1) then -- # columns of Left must
- -- match # rows of Right.
- raise Dimension_Mismatch;
- else
- for I in Rows loop
- for J in Columns loop
- Result(I, J) := Inner_Product (Left, Right, I, J);
- end loop;
- end loop;
- return (Result);
- end if;
- end "*";
-
-end CC70A01_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with FC70A00; -- Generic complex integer operations.
-with CC70A01_0; -- Generic complex matrix operations.
-
-procedure CC70A01 is
-
- type My_Integer is range -100 .. 100;
-
- package My_Complex_Package is new FC70A00 (My_Integer);
- package My_Matrix_Package is new CC70A01_0 (My_Complex_Package);
-
- use My_Complex_Package, -- All user-defined
- My_Matrix_Package; -- operators directly
- -- visible.
-
- subtype Matrix_2x2 is Complex_Matrix_Type (1 .. 2, 1 .. 2);
- subtype Matrix_2x3 is Complex_Matrix_Type (1 .. 2, 1 .. 3);
-
- function C (Real, Imag : My_Integer) return Complex_Type renames Complex;
-
-begin -- Main program.
-
- Report.Test ("CC70A01", "Check that the visible part of a generic " &
- "formal package includes the first list of basic " &
- "declarative items of the package specification. Check " &
- "for a generic package where formal package has (<>) " &
- "actual part");
-
- declare
- Identity_2x2 : Matrix_2x2 := Identity_Matrix (Size => 2);
- Operand_2x3 : Matrix_2x3 := ( ( C(1, 2), C(3, 6), C(5, 1) ),
- ( C(0, 3), C(7, 9), C(3, 4) ) );
- Result_2x3 : Matrix_2x3 := ( others => ( others => Zero ) );
- begin
-
- begin -- Block #1.
- Result_2x3 := Identity_2x2 * Operand_2x3; -- Should return
- -- Operand_2x3.
- if (Result_2x3 /= Operand_2x3) then
- Report.Failed ("Incorrect results from matrix multiplication");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Block #1");
- end; -- Block #1.
-
-
- begin -- Block #2.
- Result_2x3 := Operand_2x3 * Identity_2x2; -- Can't multiply 2x3
- -- by 2x2.
- Report.Failed ("Exception Dimension_Mismatch not raised");
- exception
- when Dimension_Mismatch =>
- null;
- when others =>
- Report.Failed ("Unexpected exception raised - Block #2");
- end; -- Block #2.
-
- end;
-
- Report.Result;
-
-end CC70A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a02.a b/gcc/testsuite/ada/acats/tests/cc/cc70a02.a
deleted file mode 100644
index 3601ce4..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70a02.a
+++ /dev/null
@@ -1,193 +0,0 @@
--- CC70A02.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 visible part of a generic formal package includes the
--- first list of basic declarative items of the package specification.
--- Check for a generic subprogram which declares a formal package with
--- (<>) as its actual part.
---
--- TEST DESCRIPTION:
--- The "first list of basic declarative items" of a package specification
--- is the visible part of the package. Thus, the declarations in the
--- visible part of the actual instance corresponding to a formal
--- package are available in the generic which declares the formal package.
---
--- Declare a generic package which simulates a complex integer abstraction
--- (foundation code).
---
--- Declare a second generic package which defines a "signature" for
--- mathematical groups. Declare a generic function within a package
--- which utilizes the second generic package as a generic formal package
--- (with a (<>) actual_part).
---
--- In the main program, instantiate the first generic package, then
--- instantiate the second generic package with objects, types, and
--- operations declared in the first instance.
---
--- Instantiate the generic function and pass the second instance
--- to it as a generic actual parameter. Check that the instance of the
--- generic function performs as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Mathematical group signature.
-
- type Group_Type is private;
-
- Identity : in Group_Type;
-
- with function Operation (Left, Right : Group_Type) return Group_Type;
- with function Inverse (Right : Group_Type) return Group_Type;
-
-package CC70A02_0 is end;
-
--- No body for CC70A02_0.
-
-
- --==================================================================--
-
-
-with CC70A02_0; -- Mathematical group signature.
-
-package CC70A02_1 is -- Mathematical group operations.
-
- -- --
- -- Generic formal package used here --
- -- --
-
- generic -- Powers for mathematical groups.
- with package Group is new CC70A02_0 (<>);
- function Power (Left : Group.Group_Type; Right : Integer)
- return Group.Group_Type;
-
-
-end CC70A02_1;
-
-
- --==================================================================--
-
-
-package body CC70A02_1 is -- Mathematical group operations.
-
-
-
- function Power (Left : Group.Group_Type; Right : Integer)
- return Group.Group_Type is
- Result : Group.Group_Type := Group.Identity;
- begin
- for I in 1 .. abs(Right) loop -- Repeat group operations
- Result := Group.Operation (Result, Left); -- the specified number of
- end loop; -- times.
-
- if Right < 0 then -- If specified power is
- return Group.Inverse (Result); -- negative, return the
- else -- inverse of the result.
- return Result; -- If it is zero, return
- end if; -- the identity.
- end Power;
-
-
-end CC70A02_1;
-
-
- --==================================================================--
-
-
-with Report;
-
-with FC70A00; -- Complex integer abstraction.
-with CC70A02_0; -- Mathematical group signature.
-with CC70A02_1; -- Mathematical group operations.
-
-procedure CC70A02 is
-
- -- Declare an instance of complex integers:
-
- type My_Integer is range -100 .. 100;
- package Complex_Integers is new FC70A00 (My_Integer);
-
-
- -- Define an addition group for complex integers:
-
- package Complex_Addition_Group is new CC70A02_0
- (Group_Type => Complex_Integers.Complex_Type, -- For complex integers...
- Identity => Complex_Integers.Zero, -- Additive identity.
- Operation => Complex_Integers."+", -- Additive operation.
- Inverse => Complex_Integers."-"); -- Additive inverse.
-
- function Complex_Multiplication is new -- Multiplication of a
- CC70A02_1.Power(Complex_Addition_Group); -- complex integer by a
- -- constant.
-
-
- -- Define a multiplication group for complex integers:
-
- package Complex_Multiplication_Group is new CC70A02_0
- (Group_Type => Complex_Integers.Complex_Type, -- For complex integers...
- Identity => Complex_Integers.One, -- Multiplicative identity.
- Operation => Complex_Integers."*", -- Multiplicative oper.
- Inverse => Complex_Integers.Reciprocal); -- Multiplicative inverse.
-
- function Complex_Exponentiation is new -- Exponentiation of a
- CC70A02_1.Power(Complex_Multiplication_Group); -- complex integer by a
- -- constant.
-
- use Complex_Integers;
-
-
-begin -- Main program.
-
- Report.Test ("CC70A02", "Check that the visible part of a generic " &
- "formal package includes the first list of basic " &
- "declarative items of the package specification. Check " &
- "for a generic subprogram where formal package has (<>) " &
- "actual part");
-
- declare
- Mult_Operand : constant Complex_Type := Complex ( -4, 9);
- Exp_Operand : constant Complex_Type := Complex ( 0, -7);
-
- Expected_Mult_Result : constant Complex_Type := Complex ( 28, -63);
- Expected_Exp_Result : constant Complex_Type := Complex (-49, 0);
- begin
-
- if Complex_Multiplication (Mult_Operand, -7) /= Expected_Mult_Result then
- Report.Failed ("Incorrect results from complex multiplication");
- end if;
-
- if Complex_Exponentiation (Exp_Operand, 2) /= Expected_Exp_Result then
- Report.Failed ("Incorrect results from complex exponentiation");
- end if;
-
- end;
-
- Report.Result;
-
-end CC70A02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b01.a b/gcc/testsuite/ada/acats/tests/cc/cc70b01.a
deleted file mode 100644
index 6c514e1..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70b01.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- CC70B01.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 formal package actual part may specify actual parameters
--- for a generic formal package. Check that a use clause in the generic
--- formal part provides direct visibility of declarations within the
--- generic formal package. Check that the scope of such a use clause
--- extends to the generic subprogram body. Check that the visible part of
--- the generic formal package includes the first list of basic
--- declarative items of the package specification.
---
--- Check the case where the formal package is declared in a generic
--- subprogram.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a generic
--- subprogram which operates on lists of elements of discrete types.
--- Provide the generic subprogram with two formal parameters: (1) a
--- formal discrete type which represents a list element type, and (2) a
--- generic formal package with the list abstraction package as template.
--- Use the formal discrete type as the generic formal actual part for the
--- formal package. Include a use clause for the formal package in the
--- generic subprogram formal part.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70B00.A
--- CC70B01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Declare a generic subprogram which performs an operation on lists of
--- discrete objects.
-
-with FC70B00; -- Generic list abstraction.
-generic
-
- -- Import the list abstraction defined in FC70B00. To ensure that only
- -- list abstraction instances defining lists of *discrete* elements will be
- -- accepted as actuals to this generic, declare a formal discrete type and
- -- pass it as an actual parameter to the formal package.
- --
- -- Only instances declared for the same discrete type as that used to
- -- instantiate this generic subprogram will be accepted.
-
- type Elem_Type is (<>); -- Discrete types only.
- with package List_Mgr is new FC70B00 (Elem_Type);
-
- use List_Mgr; -- Use clause for formal package.
-
-procedure CC70B01_0 (L : in out List_Type); -- List_Mgr.List_Type directly
- -- visible.
-
-
- --==================================================================--
-
-
-procedure CC70B01_0 (L : in out List_Type) is -- Declarations in List_Mgr
-begin -- still directly visible.
- Reset (L);
- while not End_Of_List (L) loop
- Write_Element (L, Elem_Type'First); -- This statement assumes
- end loop; -- Elem_Type is discrete.
-end CC70B01_0;
-
-
- --==================================================================--
-
-
-with FC70B00; -- Generic list abstraction.
-with CC70B01_0; -- Generic "zeroing" operation for lists of discrete types.
-
-with Report;
-procedure CC70B01 is
-
- type Points is range 0 .. 10; -- Discrete type.
- package Lists_of_Scores is new FC70B00 (Points); -- List-of-points
- -- abstraction.
- Scores : Lists_of_Scores.List_Type; -- List of points.
-
- procedure Reset_All_Scores is new -- Operation on lists of
- CC70B01_0 (Points, Lists_of_Scores); -- points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_Initial_Values : constant TC_Score_Array := (2, 4, 6);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6.
- Lists_of_Scores.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_of_Scores.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Lists_of_Scores.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70B01", "Check that a library-level generic subprogram " &
- "may have a formal package as a formal parameter, and that " &
- "the generic formal actual part may specify explicit actual " &
- "parameters. Check that a use clause is legal in the " &
- "generic formal part");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Reset_All_Scores (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70B01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b02.a b/gcc/testsuite/ada/acats/tests/cc/cc70b02.a
deleted file mode 100644
index d27eea8..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70b02.a
+++ /dev/null
@@ -1,222 +0,0 @@
--- CC70B02.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 formal package actual part may specify actual parameters
--- for a generic formal package. Check that such an actual parameter may
--- be a formal parameter of a previously declared formal package
--- (with a (<>) actual part). Check that a use clause in the generic
--- formal part provides direct visibility of declarations within the
--- generic formal package, including formal parameters (if the formal
--- package has a (<>) actual part). Check that the scope of such a use
--- clause extends to the generic subprogram body. Check that the visible
--- part of the generic formal package includes the first list of basic
--- declarative items of the package specification.
---
--- Check the case where the formal package is declared in a generic
--- package.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a second
--- generic package which declares operations on discrete types. Declare
--- a third generic package which combines the abstractions of the first
--- two generics and declares operations on lists of elements of discrete
--- types. Provide the third generic package with two formal parameters:
--- (1) a generic formal package with the discrete operation package as
--- template, and (2) a generic formal package with the list abstraction
--- package as template. Use the formal discrete type of the discrete
--- operations generic as the generic formal actual part for the second
--- formal package. Include a use clause for the first formal package in
--- the third generic package formal part.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70B00.A
--- CC70B02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Discrete_Type is (<>); -- Discrete types only.
-package CC70B02_0 is -- Discrete type operations.
-
- procedure Double (Object : in out Discrete_Type);
-
- -- ... Other operations on discrete objects.
-
-end CC70B02_0;
-
-
- --==================================================================--
-
-
-package body CC70B02_0 is
-
- procedure Double (Object : in out Discrete_Type) is
- Doubled_Position : Integer := Discrete_Type'Pos (Object) * 2;
- begin
- -- ... Error-checking code omitted for brevity.
- Object := Discrete_Type'Val (Doubled_Position);
- end Double;
-
-end CC70B02_0;
-
-
- --==================================================================--
-
-
-with CC70B02_0; -- Discrete type operations.
-with FC70B00; -- List abstraction.
-generic
-
- -- Import both the discrete-operation and list abstractions. To ensure that
- -- only list abstraction instances defining lists of *discrete* elements
- -- will be accepted as actuals to this generic, pass the formal discrete
- -- type from the discrete-operation abstraction as an actual parameter to
- -- the list-abstraction formal package.
- --
- -- Only list instances declared for the same discrete type as that used
- -- to instantiate the discrete-operation package will be accepted.
-
- with package Discrete_Ops is new CC70B02_0 (<>);
-
- use Discrete_Ops; -- Discrete_Ops directly visible.
-
- with package List_Mgr is new FC70B00 (Discrete_Type); -- Discrete_Type is
- -- formal parameter
- -- of template for
- -- Discrete_Ops.
-package CC70B02_1 is -- Discrete list operations.
-
- procedure Double_List (L : in out List_Mgr.List_Type);
-
- -- ... Other operations on lists of discrete objects.
-
-end CC70B02_1;
-
-
- --==================================================================--
-
-
-package body CC70B02_1 is
-
- procedure Double_List (L : in out List_Mgr.List_Type) is
- Element : Discrete_Type; -- Formal part of Discrete_Ops template
- begin -- is directly visible here.
- List_Mgr.Reset (L);
- while not List_Mgr.End_Of_List (L) loop
- List_Mgr.View_Element (L, Element);
- Double (Element);
- List_Mgr.Write_Element (L, Element);
- end loop;
- end Double_List;
-
-end CC70B02_1;
-
-
- --==================================================================--
-
-
-with FC70B00; -- Generic list abstraction.
-with CC70B02_0; -- Generic discrete type operations.
-with CC70B02_1; -- Generic discrete list operations.
-
-with Report;
-procedure CC70B02 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Points_Ops is new CC70B02_0 (Points); -- Points-type operations.
- package Lists_of_Points is new FC70B00 (Points); -- Points lists.
- package Points_List_Ops is new -- Points-list operations.
- CC70B02_1 (Points_Ops, Lists_Of_Points);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_Initial_Values : constant TC_Score_Array := (23, 15, 0);
- TC_Final_Values : constant TC_Score_Array := (46, 30, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Lists_Of_Points.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_Of_Points.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Lists_Of_Points.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70B02", "Check that a library-level generic package " &
- "may have a formal package as a formal parameter, and that " &
- "the generic formal actual part may specify explicit actual " &
- "parameters (including a formal parameter of a previously " &
- "declared formal package). Check that a use clause is legal " &
- "in the generic formal part");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Points_List_Ops.Double_List (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70B02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c01.a b/gcc/testsuite/ada/acats/tests/cc/cc70c01.a
deleted file mode 100644
index f22ad01..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70c01.a
+++ /dev/null
@@ -1,187 +0,0 @@
--- CC70C01.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 generic formal package is an instance. Specifically,
--- check that a generic formal package may be passed as an actual
--- parameter in an instantiation of a generic package. Check that the
--- visible part of the generic formal package includes the first list of
--- basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- A generic formal package is a package, and is an instance.
---
--- Declare a list type in a generic package for lists of elements of any
--- nonlimited type (foundation code). Declare a second generic package
--- which declares operations for the list type, and parameterize it with
--- a generic formal package with the list-type package as template
--- (foundation code). Declare a third generic package which declares
--- additional operations for the list type, and parameterize it just like
--- the second generic package. Declare an instance of the second generic
--- in the spec of the third generic, passing the formal package as the
--- actual.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70C00.A
--- CC70C01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70C00_0; -- List abstraction.
-with FC70C00_1; -- Basic list operations.
-generic
- with package Lists is new FC70C00_0 (<>);
-package CC70C01_0 is -- Additional list operations.
-
- -- Instantiate a generic package (FC70C00_1) with a generic formal package
- -- (Lists). This ensures that the package passed as an actual corresponding
- -- to Lists is the same one passed as an actual to FC70C00_1. Thus, all list
- -- operations from both FC70C00_1 and this package operate on lists of the
- -- same element type.
-
- package Basic_List_Ops is new FC70C00_1 (Lists);
-
-
- End_of_List_Reached : exception;
-
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type);
-
-end CC70C01_0;
-
-
- --==================================================================--
-
-
-package body CC70C01_0 is
-
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type) is
- begin
- if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous
- raise End_Of_List_Reached; -- generic package.
- else
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end if;
- end Read_Element;
-
-
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type) is
- New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null);
- use type Lists.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
-end CC70C01_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- Generic list abstraction.
-with CC70C01_0; -- Additional generic list operations.
-
-with Report;
-procedure CC70C01 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Lists_of_Points is new FC70C00_0 (Points); -- Points lists.
-
- package Points_List_Ops is new -- Points-list ops.
- CC70C01_0 (Lists_Of_Points);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_List_Values : constant TC_Score_Array := (23, 15, 0);
-
- TC_Correct_List_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Points_List_Ops.Add_Element (L, TC_List_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin
- Points_List_Ops.Basic_List_Ops.Reset (L);
- for I in TC_Score_Array'Range loop
- Points_List_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
-
- Report.Test ("CC70C01", "Check that a generic formal package may be " &
- "passed as an actual in an instantiation of a generic " &
- "package");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values);
-
- if not TC_Correct_List_Values then
- Report.Failed ("List contains incorrect values");
- end if;
-
- Report.Result;
-
-end CC70C01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c02.a b/gcc/testsuite/ada/acats/tests/cc/cc70c02.a
deleted file mode 100644
index f479193..0000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70c02.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- CC70C02.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 generic formal package is an instance. Specifically,
--- check that a generic formal package may be passed as an actual
--- parameter to another generic formal package. Check that the
--- visible part of the generic formal package includes the first list of
--- basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- A generic formal package is a package, and is an instance.
---
--- Declare a list type in a generic package for lists of elements of any
--- nonlimited type (foundation code). Declare a second generic package
--- which declares operations for the list type, and parameterize it with
--- a generic formal package with the list-type package as template
--- (foundation code). Declare a third generic package which declares
--- additional operations for the list type, and parameterize it with two
--- generic formal packages, one with the list-type package as template,
--- the other with the second generic package as template. Use the first
--- formal package as the generic formal actual part for the second formal
--- package.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70C00.A
--- CC70C02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70C00_0; -- List abstraction.
-with FC70C00_1; -- Basic list operations.
-generic
-
- -- Import both the list-type abstraction defined in FC70C00_0 and the basic
- -- list operations defined in FC70C00_1. To ensure that only basic operation
- -- instances for lists of the same element type as that used to instantiate
- -- the list type are accepted as actuals to this generic, pass the list-type
- -- formal package as an actual parameter to the list-operation formal
- -- package.
-
- with package Lists is new FC70C00_0 (<>);
- with package Basic_List_Ops is new FC70C00_1 (Lists);
-package CC70C02_0 is -- Additional list operations.
-
- End_of_List_Reached : exception;
-
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type);
-
-end CC70C02_0;
-
-
- --==================================================================--
-
-
-package body CC70C02_0 is
-
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type) is
- begin
- if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous
- raise End_Of_List_Reached; -- generic package.
- else
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end if;
- end Read_Element;
-
-
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type) is
- New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null);
- use type Lists.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
-end CC70C02_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- Generic list type abstraction.
-with FC70C00_1; -- Generic list operations.
-with CC70C02_0; -- Additional generic list operations.
-
-with Report;
-procedure CC70C02 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Lists_of_Points is new FC70C00_0 (Points); -- Points lists.
-
- package Basic_Point_Ops is new -- Basic points-list ops.
- FC70C00_1 (Lists_Of_Points);
-
- package Points_List_Ops is new -- More points-list ops.
- CC70C02_0 (Lists => Lists_Of_Points,
- Basic_List_Ops => Basic_Point_Ops);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_List_Values : constant TC_Score_Array := (23, 15, 0);
-
- TC_Correct_List_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Points_List_Ops.Add_Element (L, TC_List_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin
- Basic_Point_Ops.Reset (L);
- for I in TC_Score_Array'Range loop
- Points_List_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
-
- Report.Test ("CC70C02", "Check that a generic formal package may be " &
- "passed as an actual to another formal package");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values);
-
- if not TC_Correct_List_Values then
- Report.Failed ("List contains incorrect values");
- end if;
-
- Report.Result;
-
-end CC70C02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10001.a b/gcc/testsuite/ada/acats/tests/cd/cd10001.a
deleted file mode 100644
index 6b44067..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd10001.a
+++ /dev/null
@@ -1,300 +0,0 @@
--- CD10001.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 representation items may contain nonstatic expressions
--- in the case that each expression in the representation item is a
--- name that statically denotes a constant declared before the entity.
---
---
--- TEST DESCRIPTION:
--- For each of the specific items in the objective, this test checks
--- an example of each of the categories of representation specification
--- that are applicable to that objective, to wit:
--- address clause ....................... Expressions need not be static
--- alignment clause ..................... Expressions must be static
--- bit order clause ..................... Not tested
--- component size clause ................ Expressions must be static
--- enumeration representation clause .... Expressions must be static
--- external tag clause .................. Expressions must be static
--- Import, Export and Convention pragmas Not tested
--- input clause ......................... Not tested
--- output clause ........................ Not tested
--- Pack pragma .......................... Not tested
--- read clause .......................... Not tested
--- record representation clause ......... Expressions must be static
--- size clause .......................... Expressions must be static
--- small clause ......................... Expressions must be static
--- storage pool clause .................. Not tested
--- storage size clause .................. Expressions must be static
--- write clause ......................... Not tested
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute.
---
--- For implementations not validating against Annex C:
--- if this test compiles without error messages at compilation,
--- it must bind and execute.
---
--- PASS/FAIL CRITERIA:
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute, report PASSED, and complete normally,
--- otherwise the test FAILS
---
--- For implementations not validating against Annex C:
--- PASSING behavior is:
--- this test executes, reports PASSED, and completes normally
--- or
--- this test executes and reports NOT_APPLICABLE
--- or
--- this test produces at least one error message at compilation, and
--- the error message is associated with one of the items marked:
--- -- N/A => ERROR.
---
--- All other behaviors are FAILING.
---
-
--- CHANGE HISTORY:
--- 11 JUL 95 SAIC Initial version
--- 10 MAR 97 PWB.CTA Made Nonstatic_Entity nonstatic; changed
--- Tenths'Small from 1.0/32.0 to 1.0/10.0,
--- as expected by the later check; improved
--- internal documentation.
--- 16 FEB 98 EDS Modified test documentation.
--- 24 NOV 98 RLB Changed Tenths'Small to 1.0/32.0, as this is
--- necessary so that all implementations can
--- process this test. (3.5.9(21) means non-binary
--- smalls are optional.)
--- 11 MAR 99 RLB Merged versions. Most EDS changes removed (as
--- they made the test less applicable than the ACAA
--- version).
---!
-
------------------------------------------------------------------ CD10001_0
-
-with System;
-with System.Storage_Elements;
-with Impdef;
-with SPPRT13;
-package CD10001_0 is
-
- -- a few types and objects to work with.
-
- type Int is range -2048 .. 2047;
- My_Int : Int := 1024;
-
- type Enumeration is (First, Second, Third, Fourth, Fifth);
-
- -- a few names that statically denote constants:
-
- Nonstatic_Entity : constant System.Address := -- Non-static
- System.Storage_Elements."+"
- ( SPPRT13.Variable_Address,
- System.Storage_Elements.Storage_Offset'(0) );
-
- Tag_String : constant String := Impdef.External_Tag_Value; -- Static
- -- Check to ensure that Tag_String is static
- Tag_String_Length : constant := Tag_String'Length;
-
- A_Reasonable_Size_Value : constant := System.Storage_Unit; -- Static
-
- Zero : constant := 0; -- Static
- One : constant := 1; -- Static
- Two : constant := 2; -- Static
- Three : constant := 3; -- Static
- Four : constant := 4; -- Static
- Five : constant := 5; -- Static
-
- K : constant Int := My_Int; -- Non-Static
-
--- Check that representation items containing nonstatic expressions are
--- supported in the case that the representation item is a name that
--- statically denotes a constant declared before the entity.
---
--- address clause
--- Expression must be static - RM 13.3(12)
-
- Object_Address : Enumeration;
- for Object_Address'Address use Nonstatic_Entity; -- N/A => ERROR.
-
--- alignment clause
--- Expression must be static - RM 13.3(25)
-
- Object_Alignment : Enumeration;
- for Object_Alignment'Alignment use One; -- N/A => ERROR.
-
--- bit order clause
--- no interesting test can be specified
-
--- component size clause
--- Expression must be static - RM 13.3(69)
-
- type Array_With_Components is array(1..10) of Enumeration;
- for Array_With_Components'Component_Size
- use A_Reasonable_Size_Value; -- N/A => ERROR.
-
--- enumeration representation clause
--- Expressions must be static - RM 13.4(6)
-
- type Enumeration_1 is (First, Second, Third);
- for Enumeration_1 use (First => One, Second => Two, Third => Three);
-
--- external tag clause
--- Expression must be static - RM 13.3(75)
-
- type Some_Tagged_Type is tagged null record;
- for Some_Tagged_Type'External_Tag use Tag_String; -- N/A => ERROR.
-
--- Import, Export and Convention pragmas
--- no interesting test can be specified
-
--- input clause
--- no interesting test can be specified
-
--- output clause
--- no interesting test can be specified
-
--- Pack pragma
--- no interesting test can be specified
-
--- read clause
--- no interesting test can be specified
-
--- record representation clause
--- Expressions must be static - RM 13.3(10)
-
- type Record_To_Layout is record
- Bit_0 : Boolean;
- Bit_1 : Boolean;
- end record;
- for Record_To_Layout use record -- N/A => ERROR.
- Bit_0 at Zero range Zero..Zero; -- N/A => ERROR.
- Bit_1 at Zero range Four..Four; -- N/A => ERROR.
- end record; -- N/A => ERROR.
-
--- size clause
--- Expression must be static - RM 13.3(41)
-
- Object_Size : Enumeration;
- for Object_Size'Size use A_Reasonable_Size_Value; -- N/A => ERROR.
-
--- small clause
--- Expression must be static - RM 3.5.10(2)
-
- type Tenths is delta 0.1 range 0.0..10.0;
- for Tenths'Small use 1.0 / (Two ** Five); -- N/A => ERROR.
-
--- storage pool clause
--- Not tested
-
--- storage size clause
--- Expression may be non-static - RM 13.11(15)
- type Reference is access Record_To_Layout;
- for Reference'Storage_Size use Four * K; -- N/A => ERROR.
-
-
--- write clause
--- no interesting test can be specified
-
- procedure TC_Check_Values;
-
-end CD10001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body CD10001_0 is
-
- use type System.Address;
-
- procedure Assert( Truth : Boolean; Message: String ) is
- begin
- if not Truth then
- TCTouch.Implementation_Check( Message );
- end if;
- end Assert;
-
- procedure TC_Check_Values is
- Record_Object : Record_To_Layout;
- begin
-
- Assert(Object_Address'Address = Nonstatic_Entity,
- "Object not at specified address");
-
- Assert(Object_Alignment'Alignment >= One,
- "Object not at specified alignment");
-
- Assert(Array_With_Components'Component_Size = A_Reasonable_Size_Value,
- "Array Components not specified size");
-
--- I don't see how to reliably check this one:
---
--- type Enumeration_1 is (First, Second, Third);
--- for Enumeration_1 use (First => One, Second => Two, Third => Three);
-
- Assert(Some_Tagged_Type'External_Tag = Tag_String,
- "External_Tag not specified value");
- Assert(Record_Object.Bit_0'First_Bit = Zero,
- "Record object First_Bit not zero");
-
- Assert(Record_Object.Bit_1'Last_Bit = Four,
- "Record object Last_Bit not four");
-
- Assert(Object_Size'Size = A_Reasonable_Size_Value,
- "Object size not specified value");
-
- Assert(Tenths'Small = 1.0 / Two ** Five,
- "Tenths small not specified value");
-
- Assert(Reference'Storage_Size = 4096, -- Four * K,
- "Reference storage size not specified value");
-
- end TC_Check_Values;
-
-end CD10001_0;
-
-------------------------------------------------------------------- CD10001
-
-with Report;
-with CD10001_0;
-
-procedure CD10001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD10001", "Check that representation items containing " &
- "nonstatic expressions are supported in the " &
- "case that the representation item is a name " &
- "that statically denotes a constant declared " &
- "before the entity" );
-
- CD10001_0.TC_Check_Values;
-
- Report.Result;
-
-end CD10001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10002.a b/gcc/testsuite/ada/acats/tests/cd/cd10002.a
deleted file mode 100644
index fc56d42..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd10002.a
+++ /dev/null
@@ -1,1198 +0,0 @@
--- CD10002.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 operational items are allowed in some contexts where
--- representation items are not:
---
--- 1 - Check that the name of an incompletely defined type can be used
--- when specifying an operational item. (RM95/TC1 7.3(5)).
---
--- 2 - Check that operational items can be specified for a descendant of
--- a generic formal untagged type. (RM95/TC1 13.1(10)).
---
--- 3 - Check that operational items can be specified for a derived
--- untagged type even if the parent type is a by-reference type or
--- has user-defined primitive subprograms. (RM95/TC1 13.1(11/1)).
---
--- (Defect Report 8652/0009, as reflected in Technical Corrigendum 1).
---
--- CHANGE HISTORY:
--- 19 JAN 2001 PHL Initial version.
--- 3 DEC 2001 RLB Reformatted for ACATS.
--- 3 OCT 2002 RLB Corrected incorrect type derivations.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-package CD10002_0 is
-
- type Kinds is (Read, Write, Input, Output);
- type Counts is array (Kinds) of Natural;
-
- generic
- type T is private;
- package Nonlimited_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Nonlimited_Stream_Ops;
-
- generic
- type T (<>) is limited private; -- Should be self-initializing.
- C : in out T;
- package Limited_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Limited_Stream_Ops;
-
-end CD10002_0;
-
-
-package body CD10002_0 is
-
- package body Nonlimited_Stream_Ops is
- Cnts : Counts := (others => 0);
- X : T; -- Initialized by Write/Output.
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- X := Item;
- Cnts (Write) := Cnts (Write) + 1;
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return X;
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- Item := X;
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- X := Item;
- Cnts (Output) := Cnts (Output) + 1;
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Nonlimited_Stream_Ops;
-
- package body Limited_Stream_Ops is
- Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Write) := Cnts (Write) + 1;
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return C;
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Output) := Cnts (Output) + 1;
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Limited_Stream_Ops;
-
-end CD10002_0;
-
-
-with Ada.Streams;
-use Ada.Streams;
-package CD10002_1 is
-
- type Dummy_Stream is new Root_Stream_Type with null record;
- procedure Read (Stream : in out Dummy_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
- procedure Write (Stream : in out Dummy_Stream;
- Item : Stream_Element_Array);
-
-end CD10002_1;
-
-
-with Report;
-use Report;
-package body CD10002_1 is
-
- procedure Read (Stream : in out Dummy_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- Failed ("Unexpected call to the Read operation of Dummy_Stream");
- end Read;
-
- procedure Write (Stream : in out Dummy_Stream;
- Item : Stream_Element_Array) is
- begin
- Failed ("Unexpected call to the Write operation of Dummy_Stream");
- end Write;
-
-end CD10002_1;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-package CD10002_Deriv is
-
- -- Parent has user-defined subprograms.
-
- type T1 is new Boolean;
- function Is_Odd (X : Integer) return T1;
-
- type T2 is
- record
- F : Float;
- end record;
- procedure Print (X : T2);
-
- type T3 is array (Boolean) of Duration;
- function "+" (L, R : T3) return T3;
-
- -- Parent is by-reference. No need to check the case where the parent
- -- is tagged, because the defect report only deals with untagged types.
-
- task type T4 is
- end T4;
-
- protected type T5 is
- end T5;
-
- type T6 (D : access Integer := new Integer'(2)) is limited null record;
-
- type T7 is array (Character) of T6;
-
- package P is
- type T8 is limited private;
- private
- type T8 is new T5;
- end P;
-
- type Nt1 is new T1;
- type Nt2 is new T2;
- type Nt3 is new T3;
- type Nt4 is new T4;
- type Nt5 is new T5;
- type Nt6 is new T6;
- type Nt7 is new T7;
- type Nt8 is new P.T8;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt1'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2);
- function Input (Stream : access Root_Stream_Type'Class) return Nt2;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3);
- function Input (Stream : access Root_Stream_Type'Class) return Nt3;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4);
- function Input (Stream : access Root_Stream_Type'Class) return Nt4;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5);
- function Input (Stream : access Root_Stream_Type'Class) return Nt5;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6);
- function Input (Stream : access Root_Stream_Type'Class) return Nt6;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7);
- function Input (Stream : access Root_Stream_Type'Class) return Nt7;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8);
- function Input (Stream : access Root_Stream_Type'Class) return Nt8;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8);
-
- for Nt1'Write use Write;
- for Nt1'Read use Read;
- for Nt1'Output use Output;
- for Nt1'Input use Input;
-
- for Nt2'Write use Write;
- for Nt2'Read use Read;
- for Nt2'Output use Output;
- for Nt2'Input use Input;
-
- for Nt3'Write use Write;
- for Nt3'Read use Read;
- for Nt3'Output use Output;
- for Nt3'Input use Input;
-
- for Nt4'Write use Write;
- for Nt4'Read use Read;
- for Nt4'Output use Output;
- for Nt4'Input use Input;
-
- for Nt5'Write use Write;
- for Nt5'Read use Read;
- for Nt5'Output use Output;
- for Nt5'Input use Input;
-
- for Nt6'Write use Write;
- for Nt6'Read use Read;
- for Nt6'Output use Output;
- for Nt6'Input use Input;
-
- for Nt7'Write use Write;
- for Nt7'Read use Read;
- for Nt7'Output use Output;
- for Nt7'Input use Input;
-
- for Nt8'Write use Write;
- for Nt8'Read use Read;
- for Nt8'Output use Output;
- for Nt8'Input use Input;
-
- -- All these variables are self-initializing.
- C4 : Nt4;
- C5 : Nt5;
- C6 : Nt6;
- C7 : Nt7;
- C8 : Nt8;
-
- package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base);
- package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2);
- package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3);
- package Nt4_Ops is new CD10002_0.Limited_Stream_Ops (Nt4, C4);
- package Nt5_Ops is new CD10002_0.Limited_Stream_Ops (Nt5, C5);
- package Nt6_Ops is new CD10002_0.Limited_Stream_Ops (Nt6, C6);
- package Nt7_Ops is new CD10002_0.Limited_Stream_Ops (Nt7, C7);
- package Nt8_Ops is new CD10002_0.Limited_Stream_Ops (Nt8, C8);
-
-end CD10002_Deriv;
-
-
-package body CD10002_Deriv is
-
- function Is_Odd (X : Integer) return T1 is
- begin
- return True;
- end Is_Odd;
- procedure Print (X : T2) is
- begin
- null;
- end Print;
- function "+" (L, R : T3) return T3 is
- begin
- return (False => L (False) + R (True), True => L (True) + R (False));
- end "+";
- task body T4 is
- begin
- null;
- end T4;
- protected body T5 is
- end T5;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base
- renames Nt1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base)
- renames Nt1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2)
- renames Nt2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt2
- renames Nt2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2)
- renames Nt2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2)
- renames Nt2_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3)
- renames Nt3_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt3
- renames Nt3_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3)
- renames Nt3_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3)
- renames Nt3_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4)
- renames Nt4_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt4
- renames Nt4_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4)
- renames Nt4_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4)
- renames Nt4_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5)
- renames Nt5_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt5
- renames Nt5_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5)
- renames Nt5_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5)
- renames Nt5_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6)
- renames Nt6_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt6
- renames Nt6_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6)
- renames Nt6_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6)
- renames Nt6_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt7
- renames Nt7_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7)
- renames Nt7_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8)
- renames Nt8_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt8
- renames Nt8_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8)
- renames Nt8_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8)
- renames Nt8_Ops.Output;
-
-end CD10002_Deriv;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-generic
- type T1 is (<>);
- type T2 is range <>;
- type T3 is mod <>;
- type T4 is digits <>;
- type T5 is delta <>;
- type T6 is delta <> digits <>;
- type T7 is access T3;
- type T8 is new Boolean;
- type T9 is private;
- type T10 (<>) is limited private; -- Should be self-initializing.
- C10 : in out T10;
- type T11 is array (T1) of T2;
-package CD10002_Gen is
-
- -- Direct descendants.
- type Nt1 is new T1;
- type Nt2 is new T2;
- type Nt3 is new T3;
- type Nt4 is new T4;
- type Nt5 is new T5;
- type Nt6 is new T6;
- type Nt7 is new T7;
- type Nt8 is new T8;
- type Nt9 is new T9;
- type Nt10 is new T10;
- type Nt11 is new T11;
-
- -- Indirect descendants (only pick two, a limited one and a non-limited
- -- one).
- type Nt12 is new Nt10;
- type Nt13 is new Nt11;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt1'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt2'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt3'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt4'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt5'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt6'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7);
- function Input (Stream : access Root_Stream_Type'Class) return Nt7;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt8'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9);
- function Input (Stream : access Root_Stream_Type'Class) return Nt9;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10);
- function Input (Stream : access Root_Stream_Type'Class) return Nt10;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11);
- function Input (Stream : access Root_Stream_Type'Class) return Nt11;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12);
- function Input (Stream : access Root_Stream_Type'Class) return Nt12;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13);
- function Input (Stream : access Root_Stream_Type'Class) return Nt13;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13);
-
- for Nt1'Write use Write;
- for Nt1'Read use Read;
- for Nt1'Output use Output;
- for Nt1'Input use Input;
-
- for Nt2'Write use Write;
- for Nt2'Read use Read;
- for Nt2'Output use Output;
- for Nt2'Input use Input;
-
- for Nt3'Write use Write;
- for Nt3'Read use Read;
- for Nt3'Output use Output;
- for Nt3'Input use Input;
-
- for Nt4'Write use Write;
- for Nt4'Read use Read;
- for Nt4'Output use Output;
- for Nt4'Input use Input;
-
- for Nt5'Write use Write;
- for Nt5'Read use Read;
- for Nt5'Output use Output;
- for Nt5'Input use Input;
-
- for Nt6'Write use Write;
- for Nt6'Read use Read;
- for Nt6'Output use Output;
- for Nt6'Input use Input;
-
- for Nt7'Write use Write;
- for Nt7'Read use Read;
- for Nt7'Output use Output;
- for Nt7'Input use Input;
-
- for Nt8'Write use Write;
- for Nt8'Read use Read;
- for Nt8'Output use Output;
- for Nt8'Input use Input;
-
- for Nt9'Write use Write;
- for Nt9'Read use Read;
- for Nt9'Output use Output;
- for Nt9'Input use Input;
-
- for Nt10'Write use Write;
- for Nt10'Read use Read;
- for Nt10'Output use Output;
- for Nt10'Input use Input;
-
- for Nt11'Write use Write;
- for Nt11'Read use Read;
- for Nt11'Output use Output;
- for Nt11'Input use Input;
-
- for Nt12'Write use Write;
- for Nt12'Read use Read;
- for Nt12'Output use Output;
- for Nt12'Input use Input;
-
- for Nt13'Write use Write;
- for Nt13'Read use Read;
- for Nt13'Output use Output;
- for Nt13'Input use Input;
-
- type Null_Record is null record;
-
- package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base);
- package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2'Base);
- package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3'Base);
- package Nt4_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt4'Base);
- package Nt5_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt5'Base);
- package Nt6_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt6'Base);
- package Nt7_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt7);
- package Nt8_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt8'Base);
- package Nt9_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt9);
- package Nt11_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt11);
- package Nt13_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt13);
-
- function Get_Nt10_Counts return CD10002_0.Counts;
- function Get_Nt12_Counts return CD10002_0.Counts;
-
-end CD10002_Gen;
-
-
-package body CD10002_Gen is
-
- use CD10002_0;
-
- Nt10_Cnts : Counts := (others => 0);
- Nt12_Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base
- renames Nt1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base)
- renames Nt1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base)
- renames Nt2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base
- renames Nt2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2'Base)
- renames Nt2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base)
- renames Nt2_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base)
- renames Nt3_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base
- renames Nt3_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3'Base)
- renames Nt3_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base)
- renames Nt3_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base)
- renames Nt4_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base
- renames Nt4_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4'Base)
- renames Nt4_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base)
- renames Nt4_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base)
- renames Nt5_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base
- renames Nt5_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5'Base)
- renames Nt5_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base)
- renames Nt5_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base)
- renames Nt6_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base
- renames Nt6_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6'Base)
- renames Nt6_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base)
- renames Nt6_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt7
- renames Nt7_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7)
- renames Nt7_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base)
- renames Nt8_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base
- renames Nt8_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8'Base)
- renames Nt8_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base)
- renames Nt8_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9)
- renames Nt9_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt9
- renames Nt9_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9)
- renames Nt9_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9)
- renames Nt9_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10) is
- begin
- Nt10_Cnts (Write) := Nt10_Cnts (Write) + 1;
- end Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt10 is
- begin
- Nt10_Cnts (Input) := Nt10_Cnts (Input) + 1;
- return Nt10 (C10);
- end Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10) is
- begin
- Nt10_Cnts (Read) := Nt10_Cnts (Read) + 1;
- end Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10) is
- begin
- Nt10_Cnts (Output) := Nt10_Cnts (Output) + 1;
- end Output;
- function Get_Nt10_Counts return CD10002_0.Counts is
- begin
- return Nt10_Cnts;
- end Get_Nt10_Counts;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11)
- renames Nt11_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt11
- renames Nt11_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11)
- renames Nt11_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11)
- renames Nt11_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12) is
- begin
- Nt12_Cnts (Write) := Nt12_Cnts (Write) + 1;
- end Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt12 is
- begin
- Nt12_Cnts (Input) := Nt12_Cnts (Input) + 1;
- return Nt12 (C10);
- end Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12) is
- begin
- Nt12_Cnts (Read) := Nt12_Cnts (Read) + 1;
- end Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12) is
- begin
- Nt12_Cnts (Output) := Nt12_Cnts (Output) + 1;
- end Output;
- function Get_Nt12_Counts return CD10002_0.Counts is
- begin
- return Nt12_Cnts;
- end Get_Nt12_Counts;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13)
- renames Nt13_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt13
- renames Nt13_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13)
- renames Nt13_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13)
- renames Nt13_Ops.Output;
-
-end CD10002_Gen;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-package CD10002_Priv is
-
- External_Tag_1 : constant String := "Isaac Newton";
- External_Tag_2 : constant String := "Albert Einstein";
-
- type T1 is tagged private;
- type T2 is tagged
- record
- C : T1;
- end record;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T1);
- function Input (Stream : access Root_Stream_Type'Class) return T1;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T1);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T2);
- function Input (Stream : access Root_Stream_Type'Class) return T2;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T2);
-
- for T1'Write use Write;
- for T1'Input use Input;
-
- for T2'Read use Read;
- for T2'Output use Output;
- for T2'External_Tag use External_Tag_2;
-
- function Get_T1_Counts return CD10002_0.Counts;
- function Get_T2_Counts return CD10002_0.Counts;
-
-private
-
- for T1'Read use Read;
- for T1'Output use Output;
- for T1'External_Tag use External_Tag_1;
-
- for T2'Write use Write;
- for T2'Input use Input;
-
- type T1 is tagged null record;
-
- package T1_Ops is new CD10002_0.Nonlimited_Stream_Ops (T1);
- package T2_Ops is new CD10002_0.Nonlimited_Stream_Ops (T2);
-
-end CD10002_Priv;
-
-
-package body CD10002_Priv is
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T1)
- renames T1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return T1
- renames T1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1)
- renames T1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T1)
- renames T1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T2)
- renames T2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return T2
- renames T2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2)
- renames T2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T2)
- renames T2_Ops.Output;
-
- function Get_T1_Counts return CD10002_0.Counts renames T1_Ops.Get_Counts;
- function Get_T2_Counts return CD10002_0.Counts renames T2_Ops.Get_Counts;
-end CD10002_Priv;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with Report;
-use Report;
-with System;
-with CD10002_0;
-with CD10002_1;
-with CD10002_Deriv;
-with CD10002_Gen;
-with CD10002_Priv;
-procedure CD10002 is
-
- package Deriv renames CD10002_Deriv;
- generic package Gen renames CD10002_Gen;
- package Priv renames CD10002_Priv;
-
- type Stream_Ops is (Read, Write, Input, Output);
- type Counts is array (Stream_Ops) of Natural;
-
- S : aliased CD10002_1.Dummy_Stream;
-
-begin
- Test ("CD10002",
- "Check that operational items are allowed in some contexts " &
- "where representation items are not");
-
- Test_Priv:
- declare
- X1 : Priv.T1;
- X2 : Priv.T2;
- use CD10002_0;
- begin
- Comment
- ("Check that the name of an incompletely defined type can be " &
- "used when specifying an operational item");
-
- -- Partial view of a private type.
- Priv.T1'Write (S'Access, X1);
- Priv.T1'Read (S'Access, X1);
- Priv.T1'Output (S'Access, X1);
- X1 := Priv.T1'Input (S'Access);
-
- if Priv.Get_T1_Counts /= (1, 1, 1, 1) then
- Failed ("Incorrect calls to the stream attributes for Priv.T1");
- elsif Priv.T1'External_Tag /= Priv.External_Tag_1 then
- Failed ("Incorrect external tag for Priv.T1");
- end if;
-
- -- Incompletely defined but not private.
- Priv.T2'Write (S'Access, X2);
- Priv.T2'Read (S'Access, X2);
- Priv.T2'Output (S'Access, X2);
- X2 := Priv.T2'Input (S'Access);
-
- if Priv.Get_T2_Counts /= (1, 1, 1, 1) then
- Failed ("Incorrect calls to the stream attributes for Priv.T2");
- elsif Priv.T2'External_Tag /= Priv.External_Tag_2 then
- Failed ("Incorrect external tag for Priv.T2");
- end if;
-
- end Test_Priv;
-
- Test_Gen:
- declare
-
- type Modular is mod System.Max_Binary_Modulus;
- type Decimal is delta 1.0 digits 1;
- type Access_Modular is access Modular;
- type R9 is null record;
- type R10 (D : access Integer) is limited null record;
- type Arr is array (Character) of Integer;
-
- C10 : R10 (new Integer'(19));
-
- package Inst is new Gen (T1 => Character,
- T2 => Integer,
- T3 => Modular,
- T4 => Float,
- T5 => Duration,
- T6 => Decimal,
- T7 => Access_Modular,
- T8 => Boolean,
- T9 => R9,
- T10 => R10,
- C10 => C10,
- T11 => Arr);
-
- X1 : Inst.Nt1 := 'a';
- X2 : Inst.Nt2 := 0;
- X3 : Inst.Nt3 := 0;
- X4 : Inst.Nt4 := 0.0;
- X5 : Inst.Nt5 := 0.0;
- X6 : Inst.Nt6 := 0.0;
- X7 : Inst.Nt7 := null;
- X8 : Inst.Nt8 := Inst.False;
- X9 : Inst.Nt9 := (null record);
- X10 : Inst.Nt10 (D => new Integer'(5));
- Y10 : Integer;
- X11 : Inst.Nt11 := (others => 0);
- X12 : Inst.Nt12 (D => new Integer'(7));
- Y12 : Integer;
- X13 : Inst.Nt13 := (others => 0);
- use CD10002_0;
- begin
- Comment ("Check that operational items can be specified for a " &
- "descendant of a generic formal untagged type");
-
- Inst.Nt1'Write (S'Access, X1);
- Inst.Nt1'Read (S'Access, X1);
- Inst.Nt1'Output (S'Access, X1);
- X1 := Inst.Nt1'Input (S'Access);
-
- if Inst.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt1");
- end if;
-
- Inst.Nt2'Write (S'Access, X2);
- Inst.Nt2'Read (S'Access, X2);
- Inst.Nt2'Output (S'Access, X2);
- X2 := Inst.Nt2'Input (S'Access);
-
- if Inst.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt2");
- end if;
-
- Inst.Nt3'Write (S'Access, X3);
- Inst.Nt3'Read (S'Access, X3);
- Inst.Nt3'Output (S'Access, X3);
- X3 := Inst.Nt3'Input (S'Access);
-
- if Inst.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt3");
- end if;
-
- Inst.Nt4'Write (S'Access, X4);
- Inst.Nt4'Read (S'Access, X4);
- Inst.Nt4'Output (S'Access, X4);
- X4 := Inst.Nt4'Input (S'Access);
-
- if Inst.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt4");
- end if;
-
- Inst.Nt5'Write (S'Access, X5);
- Inst.Nt5'Read (S'Access, X5);
- Inst.Nt5'Output (S'Access, X5);
- X5 := Inst.Nt5'Input (S'Access);
-
- if Inst.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt5");
- end if;
-
- Inst.Nt6'Write (S'Access, X6);
- Inst.Nt6'Read (S'Access, X6);
- Inst.Nt6'Output (S'Access, X6);
- X6 := Inst.Nt6'Input (S'Access);
-
- if Inst.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt6");
- end if;
-
- Inst.Nt7'Write (S'Access, X7);
- Inst.Nt7'Read (S'Access, X7);
- Inst.Nt7'Output (S'Access, X7);
- X7 := Inst.Nt7'Input (S'Access);
-
- if Inst.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt7");
- end if;
-
- Inst.Nt8'Write (S'Access, X8);
- Inst.Nt8'Read (S'Access, X8);
- Inst.Nt8'Output (S'Access, X8);
- X8 := Inst.Nt8'Input (S'Access);
-
- if Inst.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt8");
- end if;
-
- Inst.Nt9'Write (S'Access, X9);
- Inst.Nt9'Read (S'Access, X9);
- Inst.Nt9'Output (S'Access, X9);
- X9 := Inst.Nt9'Input (S'Access);
-
- if Inst.Nt9_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt9");
- end if;
-
- Inst.Nt10'Write (S'Access, X10);
- Inst.Nt10'Read (S'Access, X10);
- Inst.Nt10'Output (S'Access, X10);
- Y10 := Inst.Nt10'Input (S'Access).D.all;
-
- if Inst.Get_Nt10_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt10");
- end if;
-
- Inst.Nt11'Write (S'Access, X11);
- Inst.Nt11'Read (S'Access, X11);
- Inst.Nt11'Output (S'Access, X11);
- X11 := Inst.Nt11'Input (S'Access);
-
- if Inst.Nt11_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt11");
- end if;
-
- Inst.Nt12'Write (S'Access, X12);
- Inst.Nt12'Read (S'Access, X12);
- Inst.Nt12'Output (S'Access, X12);
- Y12 := Inst.Nt12'Input (S'Access).D.all;
-
- if Inst.Get_Nt12_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt12");
- end if;
-
- Inst.Nt13'Write (S'Access, X13);
- Inst.Nt13'Read (S'Access, X13);
- Inst.Nt13'Output (S'Access, X13);
- X13 := Inst.Nt13'Input (S'Access);
-
- if Inst.Nt13_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt13");
- end if;
- end Test_Gen;
-
- Test_Deriv:
- declare
- X1 : Deriv.Nt1 := Deriv.False;
- X2 : Deriv.Nt2 := (others => 0.0);
- X3 : Deriv.Nt3 := (others => 0.0);
- X4 : Deriv.Nt4;
- Y4 : Boolean;
- X5 : Deriv.Nt5;
- Y5 : System.Address;
- X6 : Deriv.Nt6;
- Y6 : Integer;
- X7 : Deriv.Nt7;
- Y7 : Integer;
- X8 : Deriv.Nt8;
- Y8 : Integer;
- use CD10002_0;
- begin
- Comment ("Check that operational items can be specified for a " &
- "derived untagged type even if the parent type is a " &
- "by-reference type, or has user-defined primitive " &
- "subprograms");
-
- Deriv.Nt1'Write (S'Access, X1);
- Deriv.Nt1'Read (S'Access, X1);
- Deriv.Nt1'Output (S'Access, X1);
- X1 := Deriv.Nt1'Input (S'Access);
-
- if Deriv.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt1");
- end if;
-
- Deriv.Nt2'Write (S'Access, X2);
- Deriv.Nt2'Read (S'Access, X2);
- Deriv.Nt2'Output (S'Access, X2);
- X2 := Deriv.Nt2'Input (S'Access);
-
- if Deriv.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt2");
- end if;
-
- Deriv.Nt3'Write (S'Access, X3);
- Deriv.Nt3'Read (S'Access, X3);
- Deriv.Nt3'Output (S'Access, X3);
- X3 := Deriv.Nt3'Input (S'Access);
-
- if Deriv.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt3");
- end if;
-
- Deriv.Nt4'Write (S'Access, X4);
- Deriv.Nt4'Read (S'Access, X4);
- Deriv.Nt4'Output (S'Access, X4);
- Y4 := Deriv.Nt4'Input (S'Access)'Terminated;
-
- if Deriv.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt4");
- end if;
-
- Deriv.Nt5'Write (S'Access, X5);
- Deriv.Nt5'Read (S'Access, X5);
- Deriv.Nt5'Output (S'Access, X5);
- Y5 := Deriv.Nt5'Input (S'Access)'Address;
-
- if Deriv.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt5");
- end if;
-
- Deriv.Nt6'Write (S'Access, X6);
- Deriv.Nt6'Read (S'Access, X6);
- Deriv.Nt6'Output (S'Access, X6);
- Y6 := Deriv.Nt6'Input (S'Access).D.all;
-
- if Deriv.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt6");
- end if;
-
- Deriv.Nt7'Write (S'Access, X7);
- Deriv.Nt7'Read (S'Access, X7);
- Deriv.Nt7'Output (S'Access, X7);
- Y7 := Deriv.Nt7'Input (S'Access) ('a').D.all;
-
- if Deriv.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt7");
- end if;
-
- Deriv.Nt8'Write (S'Access, X8);
- Deriv.Nt8'Read (S'Access, X8);
- Deriv.Nt8'Output (S'Access, X8);
- Y8 := Deriv.Nt8'Input (S'Access)'Size;
-
- if Deriv.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt8");
- end if;
- end Test_Deriv;
-
- Result;
-end CD10002;
-
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada
deleted file mode 100644
index 905675a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- CD1009A.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR AN INTEGER TYPE DECLARED IN
--- THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 09/18/87 CREATED ORIGINAL TEST.
--- DHH 03/31/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED
--- CHECK FOR REPRESENTATION CLAUSES, AND CHANGED
--- SPECIFIED_SIZE TO 5.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1009A IS
-BEGIN
- TEST ("CD1009A", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR AN INTEGER " &
- "TYPE DECLARED IN THE VISIBLE PART OF THE " &
- "SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := 5;
-
- TYPE CHECK_TYPE_1 IS RANGE -8 .. 7;
- FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE;
- TYPE PACK_ARY IS ARRAY(1 .. 6) OF CHECK_TYPE_1;
- PRAGMA PACK (PACK_ARY);
- OBJ1 : PACK_ARY := (OTHERS => -7);
-
- TYPE CHECK_TYPE_2 IS RANGE -8 .. 7;
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- OBJ2 : CHECK_TYPE_2 := -7;
- PROCEDURE CHECK1 IS NEW LENGTH_CHECK (CHECK_TYPE_1);
- PROCEDURE CHECK2 IS NEW LENGTH_CHECK (CHECK_TYPE_2);
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK1 (OBJ1(IDENT_INT(1)), 5, "CHECK_TYPE_1");
- CHECK2 (OBJ2, 5, "CHECK_TYPE_2");
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE");
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE");
- END IF;
- END;
-
- RESULT;
-END CD1009A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada
deleted file mode 100644
index 2cbc9e7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- CD1009B.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION TYPE DECLARED
--- IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009B IS
-BEGIN
- TEST ("CD1009B", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR AN " &
- "ENUMERATION TYPE DECLARED IN THE VISIBLE " &
- "PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
-
- TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3);
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
-
- TYPE CHECK_TYPE_2 IS (A0, A1, A2, A3);
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
- X : CHECK_TYPE_1 := A0;
- Y : CHECK_TYPE_2 := A2;
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT'SIZE IS TOO SMALL --" &
- CHECK_TYPE_1'IMAGE(X));
- END IF;
-
- IF Y'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT'SIZE IS TOO SMALL --" &
- CHECK_TYPE_2'IMAGE(Y));
- END IF;
-
- END;
-
- RESULT;
-END CD1009B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada
deleted file mode 100644
index 738235f..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD1009D.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED IN
--- THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009D IS
-BEGIN
- TEST ("CD1009D", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A " &
- "FIXED POINT TYPE DECLARED IN THE VISIBLE " &
- "PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0;
-
- SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE;
-
- TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
-
- TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- X: CHECK_TYPE_1 := 0.5;
- Y: CHECK_TYPE_2 := 0.5;
-
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE IS TOO SMALL -- " &
- "VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) );
- END IF;
-
- IF Y'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE IS TOO SMALL -- " &
- "VALUE IS" & INTEGER'IMAGE ( INTEGER(Y) ) );
- END IF;
-
- END;
-
- RESULT;
-END CD1009D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada
deleted file mode 100644
index 4524358..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- CD1009E.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR A ONE-DIMENSIONAL ARRAY TYPE
--- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009E IS
-BEGIN
- TEST ("CD1009E", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A " &
- "ONE-DIMENSIONAL ARRAY TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 5;
-
- TYPE CHECK_TYPE_1 IS ARRAY (1 ..5) OF INTEGER;
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- X : CHECK_TYPE_1 := (OTHERS => IDENT_INT(1));
-
- TYPE CHECK_TYPE_2 IS ARRAY (1 ..5) OF INTEGER;
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- Y : CHECK_TYPE_2 := (OTHERS => IDENT_INT(5));
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "FIRST VALUE IS" &
- INTEGER'IMAGE( X( IDENT_INT(1) ) ) );
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
- END IF;
-
- IF Y'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " &
- "FIRST VALUE IS" &
- INTEGER'IMAGE( Y( IDENT_INT(1) ) ) );
- END IF;
- END;
-
- RESULT;
-END CD1009E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada
deleted file mode 100644
index 8bcde28..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CD1009F.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR A TWO-DIMENSIONAL ARRAY TYPE
--- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009F IS
-BEGIN
- TEST ("CD1009F", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A " &
- "TWO-DIMENSIONAL ARRAY TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 25;
-
- TYPE CHECK_TYPE_1 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER;
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- X : CHECK_TYPE_1 := ( OTHERS =>
- ( OTHERS => IDENT_INT(1) ) );
-
- TYPE CHECK_TYPE_2 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER;
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- Y : CHECK_TYPE_2 := ( OTHERS =>
- ( OTHERS => IDENT_INT(5) ) );
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "REPRESENTATIVE VALUE IS" &
- INTEGER'IMAGE( X( IDENT_INT(1), IDENT_INT(2) ) ) );
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
- END IF;
-
- IF Y'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " &
- INTEGER'IMAGE( Y( IDENT_INT(1), IDENT_INT(2) ) ) );
- END IF;
- END;
-
- RESULT;
-END CD1009F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada
deleted file mode 100644
index 1a1426b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- CD1009G.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE DECLARED IN
--- THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009G IS
-BEGIN
- TEST ("CD1009G", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A " &
- "RECORD TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE;
-
- TYPE CHECK_TYPE_1 IS
- RECORD
- I : INTEGER;
- END RECORD;
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- X : CHECK_TYPE_1 := ( I => IDENT_INT (1) );
-
- TYPE CHECK_TYPE_2 IS
- RECORD
- I : INTEGER;
- END RECORD;
- PRIVATE
- FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- Y : CHECK_TYPE_2 := ( I => IDENT_INT (5) );
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "VALUE IS" & INTEGER'IMAGE( IDENT_INT( X.I) ) );
- END IF;
-
- IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
- END IF;
-
- IF Y'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " &
- "VALUE IS" & INTEGER'IMAGE( IDENT_INT(Y.I) ) );
- END IF;
- END;
-
- RESULT;
-END CD1009G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada
deleted file mode 100644
index 35cccb5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- CD1009H.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE
--- PART OF A PACKAGE FOR A PRIVATE TYPE DECLARED IN THE VISIBLE
--- PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 09/18/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009H IS
-BEGIN
- TEST ("CD1009H", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR A PRIVATE " &
- "TYPE DECLARED IN THE VISIBLE PART OF THE " &
- "SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
-
- TYPE CHECK_TYPE_1 IS PRIVATE;
- C1 : CONSTANT CHECK_TYPE_1;
- FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING;
- PRIVATE
- TYPE CHECK_TYPE_1 IS RANGE 0 .. 7;
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- C1 : CONSTANT CHECK_TYPE_1 := CHECK_TYPE_1(IDENT_INT(1));
- END PACK;
-
- USE PACK;
- X : CHECK_TYPE_1 := C1;
-
- PACKAGE BODY PACK IS
- FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING IS
- BEGIN
- RETURN INTEGER'IMAGE ( INTEGER (A) );
- END IMAGE;
- END PACK;
-
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "VALUE IS" & IMAGE(X));
- END IF;
-
- END;
-
- RESULT;
-END CD1009H;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada
deleted file mode 100644
index ba35fed..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- CD1009I.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE
--- PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE DECLARED IN THE
--- VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 09/18/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK FOR
--- REPRESENTATION CLAUSES AND CHANGED THE TEST
--- EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1009I IS
-BEGIN
- TEST ("CD1009I", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR A LIMITED-" &
- "PRIVATE TYPE DECLARED IN THE VISIBLE PART " &
- "OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := 5;
-
- TYPE CHECK_TYPE_1 IS LIMITED PRIVATE;
- PRIVATE
- TYPE CHECK_TYPE_1 IS RANGE -8 .. 7;
- FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE;
- OBJ_CHECK : CHECK_TYPE_1 := -7;
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE_1);
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_1 (OBJ_CHECK, 5, "CHECK_TYPE_1");
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE");
- END IF;
- END;
-
- RESULT;
-END CD1009I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada
deleted file mode 100644
index dcae459..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CD1009J.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
--- VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ACCESS TYPE
--- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/07/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009J IS
-BEGIN
- TEST ("CD1009J", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN " &
- "ACCESS TYPE DECLARED IN THE VISIBLE PART OF " &
- "THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10;
-
- TYPE CHECK_TYPE_1 IS ACCESS INTEGER;
- FOR CHECK_TYPE_1'STORAGE_SIZE
- USE SPECIFIED_SIZE;
-
- TYPE CHECK_TYPE_2 IS ACCESS INTEGER;
- PRIVATE
- FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
- END IF;
-
- IF CHECK_TYPE_2'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL");
- END IF;
- END;
-
- RESULT;
-END CD1009J;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst
deleted file mode 100644
index 02a824a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst
+++ /dev/null
@@ -1,94 +0,0 @@
--- CD1009K.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.
---*
--- OBJECTIVE:
--- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
--- VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TASK TYPE DECLARED IN
--- THE VISIBLE PART OF THE SAME PACKAGE.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- VCL 10/08/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
--- TMB 02/29/96 EFFECT OF SETTING 'STORAGE_SIZE IS IMPLEMENTATION
--- DEPENDENT.
--- ONLY GUARANTEE WHEN EXAMINING 'STORAGE_SIZE IS THAT
--- IT IS NOT NEGATIVE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009K IS
-BEGIN
- TEST ("CD1009K", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " &
- "TASK TYPE DECLARED IN THE VISIBLE PART OF " &
- "THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TASK TYPE CHECK_TYPE_1 IS
- END CHECK_TYPE_1;
-
- FOR CHECK_TYPE_1'STORAGE_SIZE
- USE SPECIFIED_SIZE;
-
- TASK TYPE CHECK_TYPE_2 IS
- END CHECK_TYPE_2;
-
- PRIVATE
- FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- PACKAGE BODY PACK IS
- TASK BODY CHECK_TYPE_1 IS
- I : INTEGER;
- BEGIN
- NULL;
- END CHECK_TYPE_1;
-
- TASK BODY CHECK_TYPE_2 IS
- I : INTEGER;
- BEGIN
- NULL;
- END CHECK_TYPE_2;
-
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < 0 THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
- END IF;
-
- IF CHECK_TYPE_2'STORAGE_SIZE < 0 THEN
- FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL");
- END IF;
- END;
-
- RESULT;
-END CD1009K;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada
deleted file mode 100644
index 61bca0d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- CD1009L.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 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE OR
--- PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED
--- IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/08/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CHANGED
--- COMMENT FROM FLOATING POINT TO FIXED POINT.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009L IS
-BEGIN
- TEST ("CD1009L", "A 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A " &
- "FIXED POINT TYPE DECLARED IN THE VISIBLE " &
- "PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE SPECIFIED IS DELTA 2.0 ** (-2) RANGE 0.0 .. 1.0;
-
- SPECIFIED_SMALL : CONSTANT := SPECIFIED'SMALL;
-
- TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
- FOR CHECK_TYPE_1'SMALL
- USE SPECIFIED_SMALL;
-
- TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
- PRIVATE
- FOR CHECK_TYPE_2'SMALL USE SPECIFIED_SMALL;
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'SMALL /= SPECIFIED_SMALL THEN
- FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_1'SMALL");
- END IF;
-
- IF CHECK_TYPE_2'SMALL /= SPECIFIED_SMALL THEN
- FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_2'SMALL");
- END IF;
- END;
-
- RESULT;
-END CD1009L;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada
deleted file mode 100644
index 7e1932a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- CD1009M.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN
--- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION
--- TYPE DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/08/87 CREATED ORIGINAL TEST.
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1009M IS
-BEGIN
- TEST ("CD1009M", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " &
- "GIVEN IN THE VISIBLE OR PRIVATE PART OF A " &
- "PACKAGE FOR AN ENUMERATION TYPE DECLARED IN " &
- "THE VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8);
- FOR CHECK_TYPE_1 USE (A0 => 0,
- A2 => 1,
- A4 => 2,
- A8 => 3);
-
- TYPE CHECK_TYPE_2 IS (A0, A2, A4, A8);
- TYPE INT1 IS RANGE 0 .. 3;
- FOR INT1'SIZE USE CHECK_TYPE_1'SIZE;
-
- TYPE INT2 IS RANGE 2 .. 8;
-
- PRIVATE
- FOR CHECK_TYPE_2 USE (A0 => 2,
- A2 => 4,
- A4 => 6,
- A8 => 8);
- FOR INT2'SIZE USE CHECK_TYPE_2'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1);
- PROCEDURE CHECK_2 IS NEW ENUM_CHECK(CHECK_TYPE_2, INT2);
-
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_1 (A4, 2, "CHECK_TYPE_1");
- CHECK_2 (A8, 8, "CHECK_TYPE_2");
- END PACK;
-
- USE PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD1009M;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada
deleted file mode 100644
index 9ebcaa1..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CD1009N.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN
--- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE
--- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/08/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
--- CHECKS FOR FAILURE.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009N IS
-BEGIN
- TEST ("CD1009N", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
- "IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " &
- "FOR A RECORD TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE CHECK_TYPE_1 IS
- RECORD
- I1 : INTEGER RANGE 0 .. 255;
- B1 : BOOLEAN;
- B2 : BOOLEAN;
- I2 : INTEGER RANGE 0 .. 15;
- END RECORD;
- FOR CHECK_TYPE_1 USE
- RECORD
- I1 AT 0 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- B1 AT 1 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- B2 AT 2 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- I2 AT 3 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- END RECORD;
-
- TYPE CHECK_TYPE_2 IS
- RECORD
- I1 : INTEGER RANGE 0 .. 255;
- B1 : BOOLEAN;
- B2 : BOOLEAN;
- I2 : INTEGER RANGE 0 .. 15;
- END RECORD;
-
- PRIVATE
- FOR CHECK_TYPE_2 USE
- RECORD
- I1 AT 0 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- B1 AT 1 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- B2 AT 2 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- I2 AT 3 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- END RECORD;
- END PACK;
-
- USE PACK;
-
- R1 : CHECK_TYPE_1;
-
- R2 : CHECK_TYPE_2;
- BEGIN
- IF R1.I1'FIRST_BIT /= 0 OR
- R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I1'POSITION /= 0 THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
- END IF;
-
- IF R1.B1'FIRST_BIT /= 0 OR
- R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
- END IF;
-
- IF R1.B2'FIRST_BIT /= 0 OR
- R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
- END IF;
-
- IF R1.I2'FIRST_BIT /= 0 OR
- R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
- END IF;
-
-
- IF R2.I1'FIRST_BIT /= 0 OR
- R2.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
- R2.I1'POSITION /= 0 THEN
- FAILED ("INCORRECT REPRESENTATION FOR R2.I1");
- END IF;
-
- IF R2.B1'FIRST_BIT /= 0 OR
- R2.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R2.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R2.B1");
- END IF;
-
- IF R2.B2'FIRST_BIT /= 0 OR
- R2.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R2.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R2.B2");
- END IF;
-
- IF R2.I2'FIRST_BIT /= 0 OR
- R2.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
- R2.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R2.I2");
- END IF;
- END;
-
- RESULT;
-END CD1009N;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada
deleted file mode 100644
index 4317a0d05..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- CD1009O.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART
--- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION
--- IS AN INTEGER TYPE, DECLARED IN THE VISIBLE PART OF THE SAME
--- PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/08/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009O IS
-BEGIN
- TEST ("CD1009O", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE " &
- "PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " &
- "WHOSE FULL DECLARATION IS AN INTEGER " &
- "TYPE, DECLARED IN THE VISIBLE PART OF THE " &
- "SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS RANGE 0 .. 7;
-
- PRIVATE
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- X : CHECK_TYPE_1 := CHECK_TYPE_1 (IDENT_INT(1));
-
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "VALUE IS" & CHECK_TYPE_1'IMAGE(X));
- END IF;
-
- END;
-
- RESULT;
-END CD1009O;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada
deleted file mode 100644
index 3dcc29a6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CD1009P.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART
--- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION
--- IS AN ENUMERATION TYPE, DECLARED IN THE VISIBLE PART OF THE SAME
--- PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/09/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009P IS
-BEGIN
- TEST ("CD1009P", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
- "PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " &
- "WHOSE FULL DECLARATION IS AN ENUMERATION " &
- "TYPE, DECLARED IN THE VISIBLE PART OF THE " &
- "SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3);
-
- PRIVATE
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'SIZE > SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS TOO LARGE");
- END IF;
- END;
-
- RESULT;
-END CD1009P;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada
deleted file mode 100644
index e6c88d8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- CD1009Q.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE
--- PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION
--- IS A FIXED POINT TYPE, DECLARED IN THE VISIBLE PART OF THE SAME
--- PACKAGE.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/21/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009Q IS
-BEGIN
- TEST ("CD1009Q", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR A AN " &
- "INCOMPLETE TYPE, WHOSE FULL DECLARATION IS A " &
- "FIXED POINT TYPE, DECLARED IN THE VISIBLE " &
- "PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0;
-
- SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 2.0;
- PRIVATE
- FOR CHECK_TYPE_1'SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
-
- X : CHECK_TYPE_1 := CHECK_TYPE_1 ( IDENT_INT (1) );
- BEGIN
- IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
- END IF;
-
- IF X'SIZE < SPECIFIED_SIZE THEN
- FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
- "VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) );
- END IF;
-
- END;
-
- RESULT;
-END CD1009Q;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada
deleted file mode 100644
index fe2bd21..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada
+++ /dev/null
@@ -1,64 +0,0 @@
--- CD1009R.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
--- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL
--- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART OF
--- THE SAME PACKAGE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/21/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009R IS
-BEGIN
- TEST ("CD1009R", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " &
- "TYPE, WHOSE FULL TYPE DECLARATION IS AN " &
- "ACCESS TYPE, DECLARED IN THE VISIBLE PART OF " &
- "THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS ACCESS INTEGER;
- PRIVATE
- FOR CHECK_TYPE_1'STORAGE_SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
- END IF;
- END;
-
- RESULT;
-END CD1009R;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada
deleted file mode 100644
index ef67765..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- CD1009S.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE
--- PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE
--- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART
--- OF THE SAME PACKAGE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- VCL 10/09/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009S IS
-BEGIN
- TEST ("CD1009S", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, " &
- "WHOSE FULL TYPE DECLARATION IS AN ACCESS " &
- "TYPE, DECLARED IN THE VISIBLE PART OF THE " &
- "SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10;
-
- TYPE CHECK_TYPE_1 IS PRIVATE;
-
- PROCEDURE P;
- PRIVATE
- TYPE CHECK_TYPE_1 IS ACCESS INTEGER;
- FOR CHECK_TYPE_1'STORAGE_SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- PACKAGE BODY PACK IS
- PROCEDURE P IS
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " &
- "SMALL");
- END IF;
- END P;
- END PACK;
-
- USE PACK;
- BEGIN
- P;
- END;
-
- RESULT;
-END CD1009S;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst
deleted file mode 100644
index 1ed4b53..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst
+++ /dev/null
@@ -1,77 +0,0 @@
--- CD1009T.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.
---*
--- OBJECTIVE:
--- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
--- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL
--- TYPE DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE
--- PART OF THE SAME PACKAGE.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- VCL 10/21/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009T IS
-BEGIN
- TEST ("CD1009T", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " &
- "TYPE, WHOSE FULL TYPE DECLARATION IS A " &
- "TASK TYPE, DECLARED IN THE VISIBLE PART OF " &
- "THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TASK TYPE CHECK_TYPE_1 IS END CHECK_TYPE_1;
- PRIVATE
- FOR CHECK_TYPE_1'STORAGE_SIZE
- USE SPECIFIED_SIZE;
- END PACK;
-
- PACKAGE BODY PACK IS
- TASK BODY CHECK_TYPE_1 IS
- I : INTEGER;
- BEGIN
- NULL;
- END CHECK_TYPE_1;
- END PACK;
-
- USE PACK;
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
- END IF;
- END;
-
- RESULT;
-END CD1009T;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst
deleted file mode 100644
index de803d4..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD1009U.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.
---*
--- OBJECTIVE:
--- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE
--- PART OF A PACKAGE FOR A LIMITED PRIVATE TYPE, WHOSE FULL TYPE
--- DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE PART OF THE
--- SAME PACKAGE.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- VCL 10/09/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009U IS
-BEGIN
- TEST ("CD1009U", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
- "PRIVATE PART OF A PACKAGE FOR A LIMITED " &
- "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " &
- "A TASK TYPE, DECLARED IN THE VISIBLE PART OF " &
- "THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TYPE CHECK_TYPE_1 IS LIMITED PRIVATE;
-
- PROCEDURE P;
- PRIVATE
- TASK TYPE CHECK_TYPE_1 IS
- END CHECK_TYPE_1;
-
- FOR CHECK_TYPE_1'STORAGE_SIZE USE SPECIFIED_SIZE;
- END PACK;
-
- PACKAGE BODY PACK IS
- PROCEDURE P IS
- BEGIN
- IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
- FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " &
- "SMALL");
- END IF;
- END P;
-
- TASK BODY CHECK_TYPE_1 IS
- I : INTEGER;
- BEGIN
- NULL;
- END CHECK_TYPE_1;
- END PACK;
-
- USE PACK;
- BEGIN
- P;
- END;
-
- RESULT;
-END CD1009U;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada
deleted file mode 100644
index 945e236..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD1009V.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN
--- THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE
--- FULL TYPE DECLARATION IS AN ENUMERATION TYPE DECLARED IN THE
--- VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/21/87 CREATED ORIGINAL TEST.
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1009V IS
-BEGIN
- TEST ("CD1009V", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " &
- "GIVEN IN THE PRIVATE PART OF A " &
- "PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL " &
- "TYPE DECLARATION IS AN ENUMERATION TYPE, " &
- "DECLARED IN THE VISIBLE PART OF THE SAME " &
- "PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8);
- PRIVATE
-
- FOR CHECK_TYPE_1 USE (A0 => 9,
- A2 => 13,
- A4 => 15,
- A8 => 18);
- TYPE INT1 IS RANGE 9 .. 18;
- FOR INT1'SIZE USE CHECK_TYPE_1'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1);
-
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_1 (A2, 13, "CHECK_TYPE_1");
- END PACK;
-
- USE PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD1009V;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada
deleted file mode 100644
index ef06e43..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CD1009W.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN
--- THE PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL
--- TYPE DECLARATION IS AN ENUMERATION TYPE, DECLARED IN THE
--- VISIBLE PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/09/87 CREATED ORIGINAL TEST.
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1009W IS
-BEGIN
- TEST ("CD1009W", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " &
- "GIVEN IN THE PRIVATE PART OF A PACKAGE FOR " &
- "A PRIVATE TYPE, WHOSE FULL TYPE DECLARATION " &
- "IS AN ENUMERATION TYPE, DECLARED IN " &
- "THE VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- TYPE CHECK_TYPE_1 IS PRIVATE;
- PRIVATE
- TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8);
- FOR CHECK_TYPE_1 USE (A0 => 0,
- A2 => 2,
- A4 => 4,
- A8 => 16);
- TYPE INT1 IS RANGE 0 .. 16;
- FOR INT1'SIZE USE CHECK_TYPE_1'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1);
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_1 (A8, 16, "CHECK_TYPE_1");
- END PACK;
-
- USE PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD1009W;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada
deleted file mode 100644
index 045be94..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- CD1009X.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN
--- IN THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE
--- FULL TYPE DECLARATION IS A RECORD TYPE DECLARED IN THE VISIBLE
--- PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/21/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
--- CHECKS FOR FAILURE.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009X IS
-BEGIN
- TEST ("CD1009X", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
- "IN THE PRIVATE PART OF A PACKAGE FOR AN " &
- "INCOMPLETE TYPE, WHOSE FULL TYPE DECLARATION " &
- "IS A RECORD TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE CHECK_TYPE_1;
- TYPE ACC IS ACCESS CHECK_TYPE_1;
-
- TYPE CHECK_TYPE_1 IS
- RECORD
- I1 : INTEGER RANGE 0 .. 255;
- B1 : BOOLEAN;
- B2 : BOOLEAN;
- I2 : INTEGER RANGE 0 .. 15;
- END RECORD;
- PRIVATE
- FOR CHECK_TYPE_1 USE
- RECORD
- I1 AT 0 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- B1 AT 1 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- B2 AT 2 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- I2 AT 3 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- END RECORD;
- END PACK;
-
- USE PACK;
-
- R1 : CHECK_TYPE_1;
- BEGIN
- IF R1.I1'FIRST_BIT /= 0 OR
- R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I1'POSITION /= 0 THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
- END IF;
-
- IF R1.B1'FIRST_BIT /= 0 OR
- R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
- END IF;
-
- IF R1.B2'FIRST_BIT /= 0 OR
- R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
- END IF;
-
- IF R1.I2'FIRST_BIT /= 0 OR
- R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
- END IF;
- END;
-
- RESULT;
-END CD1009X;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada
deleted file mode 100644
index 1300c17..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CD1009Y.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE
--- PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE
--- DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE PART
--- OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/09/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
--- CHECKS FOR FAILURE.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009Y IS
-BEGIN
- TEST ("CD1009Y", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
- "IN THE PRIVATE PART OF A PACKAGE FOR A " &
- "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " &
- "A RECORD TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE CHECK_TYPE_1 IS PRIVATE;
-
- PROCEDURE P;
- PRIVATE
- TYPE CHECK_TYPE_1 IS
- RECORD
- I1 : INTEGER RANGE 0 .. 255;
- B1 : BOOLEAN;
- B2 : BOOLEAN;
- I2 : INTEGER RANGE 0 .. 15;
- END RECORD;
- FOR CHECK_TYPE_1 USE
- RECORD
- I1 AT 0 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- B1 AT 1 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- B2 AT 2 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- I2 AT 3 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- END RECORD;
- END PACK;
-
- PACKAGE BODY PACK IS
- PROCEDURE P IS
- R1 : CHECK_TYPE_1;
- BEGIN
- IF R1.I1'FIRST_BIT /= 0 OR
- R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I1'POSITION /= 0 THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
- END IF;
-
- IF R1.B1'FIRST_BIT /= 0 OR
- R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B1'POSITION /= 1 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
- END IF;
-
- IF R1.B2'FIRST_BIT /= 0 OR
- R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B2'POSITION /= 2 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
- END IF;
-
- IF R1.I2'FIRST_BIT /= 0 OR
- R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I2'POSITION /= 3 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
- END IF;
- END P;
- END PACK;
-
- USE PACK;
-
- BEGIN
- P;
- END;
-
- RESULT;
-END CD1009Y;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada
deleted file mode 100644
index 61e6b13..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CD1009Z.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE
--- PRIVATE PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE, WHOSE
--- FULL TYPE DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE
--- PART OF THE SAME PACKAGE.
-
--- HISTORY:
--- VCL 10/09/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
--- CHECKS FOR FAILURE.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD1009Z IS
-BEGIN
- TEST ("CD1009Z", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
- "IN THE PRIVATE PART OF A PACKAGE FOR A " &
- "LIMITED PRIVATE TYPE, WHOSE FULL TYPE " &
- "DECLARATION IS A RECORD TYPE DECLARED IN THE " &
- "VISIBLE PART OF THE SAME PACKAGE");
- DECLARE
- PACKAGE PACK IS
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE CHECK_TYPE_1 IS LIMITED PRIVATE;
-
- PROCEDURE P;
- PRIVATE
- TYPE CHECK_TYPE_1 IS
- RECORD
- I1 : INTEGER RANGE 0 .. 255;
- B1 : BOOLEAN;
- B2 : BOOLEAN;
- I2 : INTEGER RANGE 0 .. 15;
- END RECORD;
- FOR CHECK_TYPE_1 USE
- RECORD
- I1 AT 0 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- B1 AT 1 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- B2 AT 2 * UNITS_PER_INTEGER
- RANGE 0 .. BOOLEAN'SIZE - 1;
- I2 AT 3 * UNITS_PER_INTEGER
- RANGE 0 .. INTEGER'SIZE - 1;
- END RECORD;
- END PACK;
-
- PACKAGE BODY PACK IS
- PROCEDURE P IS
- R1 : CHECK_TYPE_1;
- BEGIN
- IF R1.I1'FIRST_BIT /= 0 OR
- R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I1'POSITION /= 0 THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
- END IF;
-
- IF R1.B1'FIRST_BIT /= 0 OR
- R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B1'POSITION /= 1 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
- END IF;
-
- IF R1.B2'FIRST_BIT /= 0 OR
- R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
- R1.B2'POSITION /= 2 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
- END IF;
-
- IF R1.I2'FIRST_BIT /= 0 OR
- R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
- R1.I2'POSITION /= 3 * UNITS_PER_INTEGER
- THEN
- FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
- END IF;
- END P;
- END PACK;
-
- USE PACK;
-
- BEGIN
- P;
- END;
-
- RESULT;
-END CD1009Z;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada
deleted file mode 100644
index 1b4bf23..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD1C03A.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 SIZE OF A DERIVED TYPE IS INHERITED FROM THE
--- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A SIZE
--- CLAUSE.
-
--- HISTORY:
--- JET 09/16/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK ON
--- REPRESENTATION CLAUSES, AND CHANGED THE TEST
--- EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1C03A IS
-
- SPECIFIED_SIZE : CONSTANT := 5;
-
- TYPE PARENT_TYPE IS RANGE -8 .. 7;
-
- FOR PARENT_TYPE'SIZE USE SPECIFIED_SIZE;
- PT : PARENT_TYPE := -7;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- DT : DERIVED_TYPE := -7;
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_TYPE);
- PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (PARENT_TYPE);
-
-BEGIN
-
- TEST("CD1C03A", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " &
- "INHERITED FROM THE PARENT IF THE SIZE OF " &
- "THE PARENT WAS DETERMINED BY A SIZE CLAUSE");
-
- IF PARENT_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("PARENT_TYPE'SIZE /= " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE));
- END IF;
-
- IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE /= " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'SIZE));
- END IF;
-
- IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DT'SIZE));
- END IF;
-
- CHECK_1 (DT, 5, "DERIVED_TYPE");
- CHECK_2 (PT, 5, "PARENT_TYPE");
- RESULT;
-
-END CD1C03A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada
deleted file mode 100644
index 5536ead..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CD1C03B.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 SIZE OF A DERIVED TYPE IS INHERITED FROM THE
--- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A PRAGMA
--- PACK.
-
--- HISTORY:
--- JET 09/16/87 CREATED ORIGINAL TEST.
--- PWB 03/27/89 MODIFIED COMPARISON OF OBJECT SIZE TO PARENT SIZE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C03B IS
-
- TYPE ENUM IS (E1, E2, E3);
-
- TYPE NORMAL_TYPE IS ARRAY (1 .. 100) OF ENUM;
-
- TYPE PARENT_TYPE IS ARRAY (1 .. 100) OF ENUM;
- PRAGMA PACK (PARENT_TYPE);
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
- X : DERIVED_TYPE := (OTHERS => ENUM'FIRST);
-
-BEGIN
-
- TEST("CD1C03B", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " &
- "INHERITED FROM THE PARENT IF THE SIZE OF " &
- "THE PARENT WAS DETERMINED BY A PRAGMA PACK");
-
- IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN
- COMMENT ("PRAGMA PACK HAD NO EFFECT ON THE SIZE OF " &
- "PARENT_TYPE, WHICH IS" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE));
- ELSIF PARENT_TYPE'SIZE > IDENT_INT (NORMAL_TYPE'SIZE) THEN
- FAILED ("PARENT_TYPE'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(NORMAL_TYPE'SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE));
- END IF;
-
- IF DERIVED_TYPE'SIZE > IDENT_INT (PARENT_TYPE'SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'SIZE));
- END IF;
-
- IF X'SIZE < DERIVED_TYPE'SIZE THEN
- FAILED ("OBJECT SIZE TOO LARGE. FIRST VALUE IS " &
- ENUM'IMAGE ( X(1) ) );
- END IF;
-
- RESULT;
-
-END CD1C03B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada
deleted file mode 100644
index 9e37bb4..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CD1C03C.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 COLLECTION SIZE OF A DERIVED TYPE IS
--- INHERITED FROM THE PARENT IF THE COLLECTION SIZE OF
--- THE PARENT WAS DETERMINED BY A COLLECTION SIZE CLAUSE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/16/87 CREATED ORIGINAL TEST.
--- RJW 02/10/88 RENAMED FROM CD1C03C.TST. REMOVED MACRO -
--- ACC_SIZE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C03C IS
-
- SPECIFIED_SIZE : CONSTANT := 512;
-
- TYPE PARENT_TYPE IS ACCESS STRING;
-
- FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
-BEGIN
-
- TEST("CD1C03C", "CHECK THAT THE COLLECTION SIZE OF A " &
- "DERIVED TYPE IS INHERITED FROM THE PARENT " &
- "IF THE COLLECTION SIZE OF THE PARENT WAS " &
- "DETERMINED BY A COLLECTION SIZE CLAUSE");
-
- IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE " &
- "LESS THAN SPECIFIED_SIZE. " &
- "ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE));
- END IF;
-
- IF DERIVED_TYPE'STORAGE_SIZE /=
- IDENT_INT (PARENT_TYPE'STORAGE_SIZE) THEN
- FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD BE " &
- "EQUAL TO PARENT_TYPE'STORAGE_SIZE. " &
- "ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE));
- END IF;
-
- RESULT;
-
-END CD1C03C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst b/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst
deleted file mode 100644
index 8b706c5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst
+++ /dev/null
@@ -1,82 +0,0 @@
--- CD1C03E.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.
---*
--- OBJECTIVE:
--- CHECK THAT THE STORAGE SIZE OF A DERIVED TASK TYPE IS
--- INHERITED FROM THE PARENT IF THE STORAGE SIZE OF THE
--- PARENT WAS DETERMINED BY A TASK STORAGE SIZE CLAUSE.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- JET 09/16/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C03E IS
-
- SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- TASK TYPE PARENT_TYPE IS
- ENTRY E;
- END PARENT_TYPE;
-
- FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- TASK BODY PARENT_TYPE IS
- BEGIN
- ACCEPT E DO
- COMMENT ("ENTRY E ACCEPTED");
- END E;
- END PARENT_TYPE;
-
-BEGIN
-
- TEST("CD1C03E", "CHECK THAT THE STORAGE SIZE OF A DERIVED " &
- "TASK TYPE IS INHERITED FROM THE PARENT IF " &
- "THE STORAGE SIZE OF THE PARENT WAS " &
- "DETERMINED BY A TASK STORAGE SIZE CLAUSE");
-
- IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT_TYPE'STORAGE_SIZE));
- END IF;
-
- IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE));
- END IF;
-
- RESULT;
-
-END CD1C03E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada
deleted file mode 100644
index 3686710..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD1C03F.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 VALUE OF 'SMALL FOR A DERIVED FIXED POINT TYPE
--- IS INHERITED FROM THE PARENT IF THE VALUE OF 'SMALL FOR THE
--- PARENT WAS DETERMINED BY A 'SMALL SPECIFICATION CLAUSE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C03F IS
-
- SPECIFIED_SMALL : CONSTANT := 0.25;
-
- TYPE FLT IS NEW FLOAT;
-
- TYPE PARENT_TYPE IS DELTA 1.0 RANGE 0.0 .. 100.0;
-
- FOR PARENT_TYPE'SMALL USE SPECIFIED_SMALL;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- FUNCTION IDENT_FLT (F : FLT) RETURN FLT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN F;
- ELSE
- RETURN 0.0;
- END IF;
- END;
-
-BEGIN
-
- TEST("CD1C03F", "CHECK THAT THE VALUE OF 'SMALL FOR A " &
- "DERIVED FIXED POINT TYPE IS INHERITED " &
- "FROM THE PARENT IF THE VALUE OF 'SMALL " &
- "FOR THE PARENT WAS DETERMINED BY A 'SMALL " &
- "SPECIFICATION CLAUSE");
-
- IF PARENT_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN
- FAILED ("PARENT_TYPE'SMALL SHOULD BE EQUAL TO " &
- "THE SPECIFIED VALUE");
- END IF;
-
- IF DERIVED_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN
- FAILED ("DERIVED_TYPE'SMALL SHOULD BE EQUAL TO " &
- "THE SPECIFIED VALUE");
- END IF;
-
- RESULT;
-
-END CD1C03F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada
deleted file mode 100644
index 898b68a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- CD1C03G.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 SIZE OF A DERIVED ENUMERATION TYPE IS
--- INHERITED FROM THE PARENT IF THE SIZE OF THE PARENT WAS
--- DETERMINED BY AN ENUMERATION REPRESENTATION CLAUSE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C03G IS
-
- TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW);
-
- TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW);
-
- FOR PARENT_TYPE USE
- (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259);
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
-BEGIN
-
- TEST("CD1C03G", "CHECK THAT THE SIZE OF A DERIVED ENUMERATION " &
- "TYPE IS INHERITED FROM THE PARENT IF THE " &
- "SIZE OF THE PARENT WAS DETERMINED BY AN " &
- "ENUMERATION REPRESENTATION CLAUSE");
-
- IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN
- COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " &
- "REPRESENTATION CLAUSE");
- END IF;
-
- IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " &
- "PARENT_TYPE");
- END IF;
-
- RESULT;
-
-END CD1C03G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada
deleted file mode 100644
index ad84e91..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CD1C03H.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 RECORD SIZE AND THE COMPONENT POSITIONS AND
--- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE
--- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY A
--- RECORD REPRESENTATION CLAUSE.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD1C03H IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE E_TYPE IS (RED, BLUE, GREEN);
-
- TYPE PARENT_TYPE IS
- RECORD
- I : INTEGER RANGE 0 .. 127 := 127;
- C : CHARACTER := 'S';
- B : BOOLEAN := FALSE;
- E : E_TYPE := BLUE;
- END RECORD;
-
- FOR PARENT_TYPE USE
- RECORD
- C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
- B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1;
- I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1;
- E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
- END RECORD;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- P_REC : PARENT_TYPE;
- REC : DERIVED_TYPE;
-
-BEGIN
-
- TEST("CD1C03H", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " &
- "POSITIONS AND SIZES OF A DERIVED RECORD " &
- "TYPE ARE INHERITED FROM THE PARENT IF THOSE " &
- "ASPECTS OF THE PARENT WERE DETERMINED BY " &
- "A RECORD REPRESENTATION CLAUSE");
-
- IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " &
- "PARENT_TYPE");
- END IF;
-
- IF REC.I'SIZE /= P_REC.I'SIZE OR
- REC.C'SIZE /= P_REC.C'SIZE OR
- REC.B'SIZE /= P_REC.B'SIZE OR
- REC.E'SIZE /= P_REC.E'SIZE THEN
- FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " &
- "INHERITED FROM PARENT_TYPE");
- END IF;
-
- REC := (12, 'T', TRUE, RED);
-
- IF (REC.I /= 12) OR (REC.C /= 'T') OR
- (NOT REC.B) OR (REC.E /= RED) THEN
- FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " &
- "INCORRECT");
- END IF;
-
- IF REC.I'POSITION /= P_REC.I'POSITION OR
- REC.C'POSITION /= P_REC.C'POSITION OR
- REC.B'POSITION /= P_REC.B'POSITION OR
- REC.E'POSITION /= P_REC.E'POSITION THEN
- FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR
- REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR
- REC.B'FIRST_BIT /= P_REC.B'FIRST_BIT OR
- REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN
- FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR
- REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR
- REC.B'LAST_BIT /= P_REC.B'LAST_BIT OR
- REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN
- FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- RESULT;
-
-END CD1C03H;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada
deleted file mode 100644
index 25ad2e0..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CD1C03I.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 RECORD SIZE AND THE COMPONENT POSITIONS AND
--- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE
--- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY THE
--- PRAGMA PACK.
-
--- HISTORY:
--- JET 09/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD1C03I IS
-
- TYPE E_TYPE IS (RED, BLUE, GREEN);
-
- TYPE PARENT_TYPE IS
- RECORD
- B1: BOOLEAN := TRUE;
- I : INTEGER RANGE 0 .. 127 := 127;
- C : CHARACTER := 'S';
- B2: BOOLEAN := FALSE;
- E : E_TYPE := BLUE;
- END RECORD;
-
- PRAGMA PACK (PARENT_TYPE);
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- P_REC : PARENT_TYPE;
- REC : DERIVED_TYPE;
-
-BEGIN
-
- TEST("CD1C03I", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " &
- "POSITIONS AND SIZES OF A DERIVED RECORD " &
- "TYPE ARE INHERITED FROM THE PARENT IF THOSE " &
- "ASPECTS OF THE PARENT WERE DETERMINED BY " &
- "THE PRAGMA PACK");
-
- IF DERIVED_TYPE'SIZE /= PARENT_TYPE'SIZE THEN
- FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " &
- "PARENT_TYPE");
- END IF;
-
- IF REC.I'SIZE /= P_REC.I'SIZE OR
- REC.C'SIZE /= P_REC.C'SIZE OR
- REC.B1'SIZE /= P_REC.B1'SIZE OR
- REC.B2'SIZE /= P_REC.B2'SIZE OR
- REC.E'SIZE /= P_REC.E'SIZE THEN
- FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " &
- "INHERITED FROM PARENT_TYPE");
- END IF;
-
- REC := (FALSE, 12, 'T', TRUE, RED);
-
- IF (REC.I /= 12) OR (REC.C /= 'T') OR
- REC.B1 OR (NOT REC.B2) OR (REC.E /= RED) THEN
- FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " &
- "INCORRECT");
- END IF;
-
- IF REC.I'POSITION /= P_REC.I'POSITION OR
- REC.C'POSITION /= P_REC.C'POSITION OR
- REC.B1'POSITION /= P_REC.B1'POSITION OR
- REC.B2'POSITION /= P_REC.B2'POSITION OR
- REC.E'POSITION /= P_REC.E'POSITION THEN
- FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR
- REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR
- REC.B1'FIRST_BIT /= P_REC.B1'FIRST_BIT OR
- REC.B2'FIRST_BIT /= P_REC.B2'FIRST_BIT OR
- REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN
- FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR
- REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR
- REC.B1'LAST_BIT /= P_REC.B1'LAST_BIT OR
- REC.B2'LAST_BIT /= P_REC.B2'LAST_BIT OR
- REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN
- FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "NOT INHERITED FROM PARENT_TYPE");
- END IF;
-
- RESULT;
-
-END CD1C03I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada
deleted file mode 100644
index 2c04b1e..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CD1C04A.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 SIZE CLAUSE CAN BE GIVEN FOR A DERIVED TYPE, A
--- DERIVED PRIVATE TYPE, AND A DERIVED LIMITED PRIVATE TYPE EVEN
--- IF THE SIZE IS INHERITED FROM THE PARENT, AND THAT THE SIZE
--- CLAUSES FOR THE DERIVED TYPES OVERRIDE THE PARENTS'.
-
--- HISTORY:
--- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
--- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/16/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C04A IS
-
- SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
-
- TYPE PARENT_TYPE IS RANGE 0 .. 100;
-
- FOR PARENT_TYPE'SIZE USE INTEGER'SIZE;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- FOR DERIVED_TYPE'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE PRIVATE_PARENT IS PRIVATE;
- TYPE LIM_PRIV_PARENT IS LIMITED PRIVATE;
- PRIVATE
- TYPE PRIVATE_PARENT IS RANGE 0 .. 100;
- FOR PRIVATE_PARENT'SIZE USE INTEGER'SIZE;
- TYPE LIM_PRIV_PARENT IS RANGE 0 .. 100;
- FOR LIM_PRIV_PARENT'SIZE USE INTEGER'SIZE;
- END P;
-
- USE P;
-
- TYPE DERIVED_PRIVATE_TYPE IS NEW PRIVATE_PARENT;
-
- FOR DERIVED_PRIVATE_TYPE'SIZE USE SPECIFIED_SIZE;
-
- TYPE DERIVED_LIM_PRIV_TYPE IS NEW LIM_PRIV_PARENT;
-
- FOR DERIVED_LIM_PRIV_TYPE'SIZE USE SPECIFIED_SIZE;
-
- DT : DERIVED_TYPE := 100;
- DPT : DERIVED_PRIVATE_TYPE;
- DLPT : DERIVED_LIM_PRIV_TYPE;
-
-BEGIN
-
- TEST("CD1C04A", "CHECK THAT A SIZE CLAUSE CAN BE GIVEN FOR " &
- "A DERIVED TYPE, A DERIVED PRIVATE TYPE, AND " &
- "A DERIVED LIMITED PRIVATE TYPE EVEN IF THE " &
- "SIZE IS INHERITED FROM THE PARENT, AND THAT " &
- "THE SIZE CLAUSES FOR THE DERIVED TYPES " &
- "OVERRIDE THE PARENTS'");
-
- IF PARENT_TYPE'SIZE /= IDENT_INT (INTEGER'SIZE) THEN
- FAILED ("PARENT_TYPE'SIZE SHOULD BE " &
- INTEGER'IMAGE(INTEGER'SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT_TYPE'SIZE));
- END IF;
-
- IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE SHOULD BE " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'SIZE));
- END IF;
-
- IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DT'SIZE));
- END IF;
-
- IF PRIVATE_PARENT'SIZE < IDENT_INT (INTEGER'SIZE) THEN
- FAILED ("PRIVATE_PARENT'SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(INTEGER'SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PRIVATE_PARENT'SIZE));
- END IF;
-
- IF DERIVED_PRIVATE_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_PRIVATE_TYPE'SIZE SHOULD BE " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_PRIVATE_TYPE'SIZE));
- END IF;
-
- IF DPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DPT'SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DPT'SIZE));
- END IF;
-
- IF LIM_PRIV_PARENT'SIZE /= IDENT_INT (INTEGER'SIZE) THEN
- FAILED ("LIM_PRIV_PARENT'SIZE SHOULD BE" &
- INTEGER'IMAGE(INTEGER'SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(LIM_PRIV_PARENT'SIZE));
- END IF;
-
- IF DERIVED_LIM_PRIV_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_LIM_PRIV_TYPE'SIZE SHOULD BE " &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_LIM_PRIV_TYPE'SIZE));
- END IF;
-
- IF DLPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DLPT'SIZE SHOULD NOT BE LESS THAN" &
- INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DLPT'SIZE));
- END IF;
-
- RESULT;
-
-END CD1C04A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada
deleted file mode 100644
index 9e95b54..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- CD1C04D.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN
--- FOR A DERIVED ENUMERATION TYPE EVEN IF THE REPRESENTATION IS
--- INHERITED FROM THE PARENT, AND THAT THE CLAUSE FOR THE DERIVED
--- TYPE OVERRIDES THAT OF THE PARENT.
-
--- HISTORY:
--- JET 09/21/87 CREATED ORIGINAL TEST.
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD1C04D IS
-
- TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW);
-
- TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW);
-
- FOR PARENT_TYPE USE
- (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259);
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- FOR DERIVED_TYPE USE
- (RED => 16, BLUE => 17, GREEN => 18, YELLOW => 19);
-
- TYPE INT1 IS RANGE 16 .. 19;
- FOR INT1'SIZE USE DERIVED_TYPE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(DERIVED_TYPE, INT1);
-
-BEGIN
-
- TEST("CD1C04D", "CHECK THAT AN ENUMERATION REPRESENTATION " &
- "CLAUSE CAN BE GIVEN FOR A DERIVED ENUMERATION " &
- "TYPE EVEN IF THE REPRESENTATION IS INHERITED " &
- "FROM THE PARENT, AND THAT THE CLAUSE FOR THE " &
- "DERIVED TYPE OVERRIDES THAT OF THE PARENT");
-
- IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN
- COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " &
- "REPRESENTATION CLAUSE");
- END IF;
-
- IF DERIVED_TYPE'SIZE >= IDENT_INT (PARENT_TYPE'SIZE) THEN
- COMMENT ("THE SPECIFICATION OF SMALLER VALUES FOR THE " &
- "REPRESENTATION OF DERIVED_TYPE DID NOT " &
- "REDUCE THE SIZE OF DERIVED_TYPE");
- END IF;
-
- CHECK_1 (DERIVED_TYPE'(GREEN), 18, "DERIVED_TYPE");
-
- RESULT;
-
-END CD1C04D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada
deleted file mode 100644
index 21c7a7e..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- CD1C04E.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR
--- A DERIVED RECORD TYPE EVEN IF THE REPRESENTATION IS INHERITED
--- FROM THE PARENT, AND THAT THE REPRESENTATION CLAUSE FOR THE
--- DERIVED TYPE OVERRIDES THAT OF THE PARENT TYPE.
-
--- HISTORY:
--- PWB 03/25/89 DELETED CHECKS OF COMPONENT'SIZE; CHANGED
--- EXTENSION FROM '.ADA' TO '.DEP'.
--- JET 09/21/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD1C04E IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE E_TYPE IS (RED, BLUE, GREEN);
-
- TYPE PARENT_TYPE IS
- RECORD
- I : INTEGER RANGE 0 .. 127 := 127;
- C : CHARACTER := 'S';
- B : BOOLEAN := FALSE;
- E : E_TYPE := BLUE;
- END RECORD;
-
- FOR PARENT_TYPE USE
- RECORD
- C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
- B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1;
- I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1;
- E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
- END RECORD;
-
- TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
-
- FOR DERIVED_TYPE USE
- RECORD
- C AT 1 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1;
- B AT 3 * UNITS_PER_INTEGER RANGE 1 .. BOOLEAN'SIZE + 1;
- I AT 5 * UNITS_PER_INTEGER RANGE 1 .. INTEGER'SIZE/2 + 1;
- E AT 7 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1;
- END RECORD;
-
- P_REC : PARENT_TYPE;
- REC : DERIVED_TYPE;
-
-BEGIN
-
- TEST("CD1C04E", "CHECK THAT A RECORD REPRESENTATION CLAUSE " &
- "CAN BE GIVEN FOR A DERIVED RECORD TYPE EVEN " &
- "IF THE REPRESENTATION IS INHERITED FROM " &
- "THE PARENT, AND THAT THE REPRESENTATION " &
- "CLAUSE FOR THE DERIVED TYPE OVERRIDES THAT " &
- "OF THE PARENT TYPE");
-
- IF DERIVED_TYPE'SIZE = IDENT_INT (PARENT_TYPE'SIZE) THEN
- FAILED ("DERIVED_TYPE'SIZE WAS INHERITED FROM " &
- "PARENT_TYPE");
- END IF;
-
- REC := (12, 'T', TRUE, RED);
-
- IF (REC.I /= 12) OR (REC.C /= 'T') OR
- (NOT REC.B) OR (REC.E /= RED) THEN
- FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " &
- "INCORRECT");
- END IF;
-
- IF REC.I'POSITION = P_REC.I'POSITION OR
- REC.C'POSITION = P_REC.C'POSITION OR
- REC.B'POSITION = P_REC.B'POSITION OR
- REC.E'POSITION = P_REC.E'POSITION THEN
- FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " &
- "INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'FIRST_BIT = P_REC.I'FIRST_BIT OR
- REC.C'FIRST_BIT = P_REC.C'FIRST_BIT OR
- REC.B'FIRST_BIT = P_REC.B'FIRST_BIT OR
- REC.E'FIRST_BIT = P_REC.E'FIRST_BIT THEN
- FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "INHERITED FROM PARENT_TYPE");
- END IF;
-
- IF REC.I'LAST_BIT = P_REC.I'LAST_BIT OR
- REC.C'LAST_BIT = P_REC.C'LAST_BIT OR
- REC.B'LAST_BIT = P_REC.B'LAST_BIT OR
- REC.E'LAST_BIT = P_REC.E'LAST_BIT THEN
- FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
- "INHERITED FROM PARENT_TYPE");
- END IF;
-
- RESULT;
-
-END CD1C04E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst b/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst
deleted file mode 100644
index fff91a3..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst
+++ /dev/null
@@ -1,100 +0,0 @@
--- CD1C06A.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.
---*
--- OBJECTIVE:
--- CHECK THAT THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE
--- IS NOT EVALUATED AGAIN WHEN A DERIVED TYPE INHERITS THE
--- STORAGE SIZE OF THE PARENT.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY:
--- JET 09/21/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD1C06A IS
-
- I : INTEGER := 0;
-
- SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
- FUNCTION COUNT_SIZE RETURN INTEGER IS
- BEGIN
- I := I + 1;
- RETURN SPECIFIED_SIZE * I;
- END;
-
-BEGIN
-
- TEST("CD1C06A", "CHECK THAT THE EXPRESSION IN A TASK STORAGE " &
- "SIZE CLAUSE IS NOT EVALUATED AGAIN WHEN A " &
- "DERIVED TYPE INHERITS THE STORAGE SIZE OF " &
- "THE PARENT");
-
- DECLARE
-
- TASK TYPE PARENT IS
- ENTRY E;
- END PARENT;
-
- FOR PARENT'STORAGE_SIZE USE COUNT_SIZE;
-
- TYPE DERIVED_TYPE IS NEW PARENT;
-
- TASK BODY PARENT IS
- BEGIN
- ACCEPT E DO
- COMMENT ("ENTRY E ACCEPTED");
- END E;
- END PARENT;
-
- BEGIN
- IF PARENT'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("PARENT'STORAGE_SIZE SHOULD NOT BE " &
- "LESS THAN" & INTEGER'IMAGE (SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(PARENT'STORAGE_SIZE));
- END IF;
-
- IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE " &
- "LESS THAN" & INTEGER'IMAGE(SPECIFIED_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE));
- END IF;
-
- IF I > IDENT_INT (1) THEN
- FAILED ("THE EXPRESSION FOR THE STORAGE SIZE " &
- "SPECIFICATION WAS EVALUATED MORE THAN ONCE");
- END IF;
-
- END;
-
- RESULT;
-
-END CD1C06A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd20001.a b/gcc/testsuite/ada/acats/tests/cd/cd20001.a
deleted file mode 100644
index 21f9738..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd20001.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- CD20001.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 for packed records the components are packed as tightly
--- as possible subject to the Size of the component subtypes.
--- Specifically check that Boolean objects are packed one to a bit.
---
--- Check that the Component_Size for a packed array type is less than
--- or equal to the smallest of those factors of the word size that are
--- greater than or equal to the Size of the component subtype.
---
--- TEST DESCRIPTION:
--- This test defines and packs several types, and checks that the sizes
--- of the resulting objects is as expected.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Strengthened for 2.1
--- 29 JAN 98 EDS Deleted check that Component_Size is really a
--- factor of Word_Size.
---!
-
------------------------------------------------------------------ CD20001_0
-
-with System;
-package CD20001_0 is
-
- type Wordlong_Bool_Array is array(1..System.Word_Size) of Boolean;
- pragma Pack(Wordlong_Bool_Array); -- ANX-C RQMT
-
- type Def_Rep_Components is range 0..2**(System.Storage_Unit-2);
-
- type Spec_Rep_Components is range 0..2**(System.Storage_Unit-2);
- for Spec_Rep_Components'Size use System.Storage_Unit; -- ANX-C RQMT
-
- type Packed_Array_Def_Components is array(1..32) of Def_Rep_Components;
- pragma Pack(Packed_Array_Def_Components); -- ANX-C RQMT
-
- type Packed_Array_Spec_Components is array(1..32) of Spec_Rep_Components;
- pragma Pack(Packed_Array_Spec_Components); -- ANX-C RQMT
-
- procedure TC_Check_Values;
-
-end CD20001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CD20001_0 is
-
- procedure TC_Check_Values is
- My_Word : Wordlong_Bool_Array := (others => False);
-
- Cited_Unit : Spec_Rep_Components := 0;
-
- Packed_Array : Packed_Array_Def_Components := (others => 0);
-
- Cited_Packed : Packed_Array_Spec_Components := (others => 0);
-
- begin
- TCTouch.Assert( My_Word'Size = System.Word_Size,
- "pragma Pack on array of Booleans does not pack one Boolean per bit" );
-
- TCTouch.Assert( My_Word'Component_Size = 1,
- "size of Boolean array component not 1 bit");
-
- TCTouch.Assert( Cited_Unit'Size = System.Storage_Unit,
- "Object specified to be Storage_Unit bits not " &
- "Storage_Unit bits in size");
-
- TCTouch.Assert( Packed_Array'Component_Size <= System.Storage_Unit,
- "Packed array component expected to be less than or " &
- "equal to Storage_Unit bits in size is greater than " &
- "Storage_Unit bits in size");
-
- TCTouch.Assert( Cited_Packed'Component_Size = System.Storage_Unit,
- "Array component specified to be Storage_Unit " &
- "bits not Storage_Unit bits in size");
-
- end TC_Check_Values;
-
-end CD20001_0;
-
------------------------------------------------------------------ CD20001_1
-
-with System;
-package CD20001_1 is
-
- type Bits_2 is range 0..2**2-1;
- for Bits_2'Size use 2; -- ANX-C RQMT
-
- type Bits_3 is range 0..2**3-1;
- for Bits_3'Size use 3; -- ANX-C RQMT
-
- type Bits_7 is range 0..2**7-1;
- for Bits_7'Size use 7; -- ANX-C RQMT
-
- type Bits_8 is range 0..2**8-1;
- for Bits_8'Size use 8; -- ANX-C RQMT
-
- type Bits_9 is range 0..2**9-1;
- for Bits_9'Size use 9; -- ANX-C RQMT
-
- type Bits_15 is range 0..2**15-1;
- for Bits_15'Size use 15; -- ANX-C RQMT
-
- type Pact_Aray_2 is array(0..31) of Bits_2;
- pragma Pack( Pact_Aray_2 ); -- ANX-C RQMT
-
- type Pact_Aray_3 is array(0..31) of Bits_3;
- pragma Pack( Pact_Aray_3 ); -- ANX-C RQMT
-
- type Pact_Aray_7 is array(0..31) of Bits_7;
- pragma Pack( Pact_Aray_7 ); -- ANX-C RQMT
-
- type Pact_Aray_8 is array(0..31) of Bits_8;
- pragma Pack( Pact_Aray_8 ); -- ANX-C RQMT
-
- type Pact_Aray_9 is array(0..31) of Bits_9;
- pragma Pack( Pact_Aray_9 ); -- ANX-C RQMT
-
- type Pact_Aray_15 is array(0..31) of Bits_15;
- pragma Pack( Pact_Aray_15 ); -- ANX-C RQMT
-
-
- procedure TC_Check_Values;
-
-end CD20001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CD20001_1 is
-
- function Next_Factor ( Value : Positive ) return Integer is
- -- Returns the factor of Word_Size that is next larger than Value.
- -- If Value is greater than Word_Size, then returns Word_Size.
- Test : Integer := Value;
- Found : Boolean := False;
- begin -- Next_Factor
- while not Found and Test <= System.Word_Size loop
- if System.Word_Size mod Test = 0 then
- Found := True;
- else
- Test := Test + 1;
- end if;
- end loop;
- if Found then
- return Test;
- else
- return System.Word_Size;
- end if;
- end Next_Factor;
-
- procedure TC_Check_Values is
- begin
-
- if Pact_Aray_2'Component_Size > Next_Factor ( Bits_2'Size ) then
- Report.Failed
- ( "2 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_2'Component_Size <= Pact_Aray_2'Size,
- "2 bit Component_Size greater than array size" );
-
- if Pact_Aray_3'Component_Size > Next_Factor ( Bits_3'Size ) then
- Report.Failed
- ( "3 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_3'Component_Size <= Pact_Aray_3'Size,
- "3 bit Component_Size greater than array size" );
-
- if Pact_Aray_7'Component_Size > Next_Factor ( Bits_7'Size ) then
- Report.Failed
- ( "7 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_7'Component_Size <= Pact_Aray_7'Size,
- "7 bit Component_Size greater than array size" );
-
- if Pact_Aray_8'Component_Size > Next_Factor ( Bits_8'Size ) then
- Report.Failed
- ( "8 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_8'Component_Size <= Pact_Aray_8'Size,
- "8 bit Component_Size greater than array size" );
-
- if System.Word_Size > 8 then
-
- if Pact_Aray_9'Component_Size > Next_Factor ( Bits_9'Size ) then
- Report.Failed
- ( "9 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_9'Component_Size <= Pact_Aray_9'Size,
- "9 bit Component_Size greater than array size" );
-
- if Pact_Aray_15'Component_Size > Next_Factor ( Bits_15'Size ) then
- Report.Failed
- ( "15 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_15'Component_Size <= Pact_Aray_15'Size,
- "15 bit Component_Size greater than array size" );
-
- end if;
-
- end TC_Check_Values;
-
-end CD20001_1;
-
-------------------------------------------------------------------- CD20001
-
-with Report;
-with CD20001_0;
-with CD20001_1;
-
-procedure CD20001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD20001", "Check that packed records are packed as tightly " &
- "as possible. Check that Boolean objects are " &
- "packed one to a bit. " &
- "Check that the Component_Size for a packed " &
- "array type is the value which is less than or " &
- "equal to the Size of the component type, " &
- "rounded up to the nearest factor of word_size" );
-
- CD20001_0.TC_Check_Values;
-
- CD20001_1.TC_Check_Values;
-
- Report.Result;
-
-end CD20001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada
deleted file mode 100644
index 6f42d39..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada
+++ /dev/null
@@ -1,215 +0,0 @@
--- CD2A21A.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 07/28/87 CREATED ORIGINAL TEST.
--- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- JRL 03/26/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALLED TO 'FAILED'.
-PROCEDURE CD2A21A IS
-
- BASIC_SIZE : CONSTANT := INTEGER'SIZE/2;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF NOT ((CI0 < IDENT (ONE)) AND
- (IDENT (CI2) > IDENT (CIO1)) AND
- (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1");
- END IF;
-
- IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR
- CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1");
- END IF;
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A21A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN ENUMERATION TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- PROC (ZERO, TWO, C1, C2, C2);
- CHECK_1 (TWO, INTEGER'SIZE/2, "CHECK_TYPE");
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (C0 NOT IN IDENT (ONE) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2");
- END IF;
-
- IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3");
- END IF;
-
- IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4");
- END IF;
-
- IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4");
- END IF;
-
- RESULT;
-END CD2A21A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada
deleted file mode 100644
index 0fc6fb1..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- CD2A21C.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 SIZE SPECIFICATION CAN BE GIVEN FOR AN ENUMERATION
--- TYPE:
--- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE
--- DECLARED IN THE VISIBLE PART;
--- FOR A DERIVED ENUMERATION TYPE;
--- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS
--- AN ENUMERATION TYPE.
-
--- HISTORY:
--- PWB 06/17/87 CREATED ORIGINAL TEST.
--- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- JRL 03/26/92 REMOVED TESTING OF NONOBJECTIVE TYPES.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A21C IS
-
- TYPE BASIC_ENUM IS (A, B, C, D, E);
- SPECIFIED_SIZE : CONSTANT := BASIC_ENUM'SIZE;
-
- MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
-
- TYPE DERIVED_ENUM IS NEW BASIC_ENUM;
- FOR DERIVED_ENUM'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE ENUM_IN_P IS (A1, B1, C1, D1, E1, F1, G1);
- FOR ENUM_IN_P'SIZE USE SPECIFIED_SIZE;
- TYPE PRIVATE_ENUM IS PRIVATE;
- TYPE ALT_ENUM_IN_P IS (A2, B2, C2, D2, E2, F2, G2);
- PRIVATE
- TYPE PRIVATE_ENUM IS (A3, B3, C3, D3, E3, F3, G3);
- FOR ALT_ENUM_IN_P'SIZE USE SPECIFIED_SIZE;
- END P;
-
- TYPE DERIVED_PRIVATE_ENUM IS NEW P.PRIVATE_ENUM;
- FOR DERIVED_PRIVATE_ENUM'SIZE USE SPECIFIED_SIZE;
-
- USE P;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_ENUM);
- PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (ENUM_IN_P);
- PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_ENUM_IN_P);
-
-BEGIN
-
- TEST("CD2A21C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN " &
- "IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " &
- "FOR ENUMERATION TYPES DECLARED IN THE VISIBLE " &
- "PART, AND FOR DERIVED ENUMERATION " &
- "TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " &
- "DECLARATIONS ARE AS ENUMERATION TYPES");
-
- CHECK_1 (C, SPECIFIED_SIZE, "DERIVED_ENUM");
- CHECK_2 (C1, SPECIFIED_SIZE, "ENUM_IN_P");
- CHECK_3 (C2, SPECIFIED_SIZE, "ALT_ENUM_IN_P");
-
- IF DERIVED_ENUM'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_ENUM'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_ENUM'SIZE));
- END IF;
-
- IF ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(ENUM_IN_P'SIZE));
- END IF;
-
- IF ALT_ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ALT_ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(ALT_ENUM_IN_P'SIZE));
- END IF;
-
- IF DERIVED_PRIVATE_ENUM'SIZE /= MINIMUM_SIZE THEN
-
- FAILED ("DERIVED_PRIVATE_ENUM'SIZE SHOULD NOT BE GREATER " &
- "THAN " & INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_PRIVATE_ENUM'SIZE));
- END IF;
-
- RESULT;
-
-END CD2A21C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada
deleted file mode 100644
index c241ea3..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- CD2A21E.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- ENUMERATION TYPE, THEN SUCH A TYPE CAN
--- BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC PROCEDURE.
-
--- HISTORY:
--- JET 08/18/87 CREATED ORIGINAL TEST.
--- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE
--- SPECIFICATION IS OBEYED.
--- LDC 10/03/90 ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION,
--- AND EXPLICIT CONVERSION.
--- JRL 03/26/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A21E IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := INTEGER'SIZE / 2;
-
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A21E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN ENUMERATION TYPE, " &
- "THEN SUCH A TYPE CAN BE " &
- "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " &
- "PROCEDURE");
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- C3 : GPARM;
-
- CHECKVAR : CHECK_TYPE;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- CHECKVAR := IDENT (C0);
-
- CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE");
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (IDENT(C0) NOT IN IDENT (C1) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE");
- END IF;
-
- CHECKVAR := CHECK_TYPE'VALUE ("ONE");
- C3 := GPARM(CHECKVAR);
- IF C3 /= IDENT(C1) THEN
- FAILED ("INCORRECT VALUE FOR CONVERSION");
- END IF;
-
- CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM");
-
-
- IF CHECK_TYPE'(C2) /= IDENT(C2) THEN
- FAILED ("INCORRECT VALUE FOR QUALIFICATION");
- END IF;
-
- C3 := CHECK_TYPE'VALUE ("TWO");
- IF C3 /= IDENT(C2) THEN
- FAILED ("INCORRECT VALUE FOR ASSIGNMENT");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-
-END CD2A21E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada
deleted file mode 100644
index 37564d8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada
+++ /dev/null
@@ -1,213 +0,0 @@
--- CD2A22A.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 SIZE SPECIFICATION INDICATING THE SMALLEST SIZE
--- APPROPRIATE FOR A SIGNED REPRESENTATION IS GIVEN FOR AN
--- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 07/28/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A22A IS
-
- BASIC_SIZE : CONSTANT := 3;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF NOT ((CI0 < IDENT (ONE)) AND
- (IDENT (CI2) > IDENT (CIO1)) AND
- (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1");
- END IF;
-
- IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR
- CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1");
- END IF;
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A22A", "CHECK THAT IF A SIZE SPECIFICATION " &
- "INDICATING THE SMALLEST SIZE APPROPRIATE " &
- "FOR A SIGNED REPRESENTATION IS GIVEN " &
- "FOR AN ENUMERATION TYPE, THEN OPERATIONS " &
- "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " &
- "BY THE REPRESENTATION CLAUSE");
-
- PROC (ZERO, TWO, C1, C2, C2);
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (C0 NOT IN IDENT (ONE) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2");
- END IF;
-
- IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3");
- END IF;
-
- IF CHREC.COMP1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP1'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4");
- END IF;
-
- IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4");
- END IF;
-
- RESULT;
-END CD2A22A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada
deleted file mode 100644
index 2ed878c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- CD2A22E.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 SIZE CLAUSE SPECIFYING THE SMALLEST SIZE
--- APPROPRIATE FOR AN UNSIGNED REPRESENTATION IS GIVEN FOR AN
--- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A22E IS
-
- BASIC_SIZE : CONSTANT := 2;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF CIO1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CIO1'SIZE");
- END IF;
-
- IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND
- (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1");
- END IF;
-
- IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR
- CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1");
- END IF;
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A22E", "CHECK THAT IF A SIZE CLAUSE " &
- "SPECIFYING THE SMALLEST SIZE APPROPRIATE " &
- "FOR AN UNSIGNED REPRESENTATION IS GIVEN " &
- "FOR AN ENUMERATION TYPE, THEN OPERATIONS " &
- "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " &
- "BY THE REPRESENTATION CLAUSE");
-
- PROC (ZERO, TWO, C1, C2, C2);
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND
- (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (TWO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2");
- END IF;
-
- IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3");
- END IF;
-
- IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3");
- END IF;
-
- IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4");
- END IF;
-
- RESULT;
-END CD2A22E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada
deleted file mode 100644
index 2dbe503..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- CD2A22I.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 SIZE CLAUSE SPECIFIES THE SMALLEST APPROPRIATE
--- SIZE FOR A SIGNED REPRESENTATION FOR AN ENUMERATION TYPE,
--- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN
--- INSTANTIATION.
-
--- HISTORY:
--- JET 08/13/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A22I IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := 3;
-
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A22I", "CHECK THAT IF A SIZE CLAUSE SPECIFIES THE " &
- "SMALLEST APPROPRIATE SIZE FOR A SIGNED " &
- "REPRESENTATION FOR AN ENUMERATION TYPE, THEN " &
- "THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN " &
- "AN INSTANTIATION");
-
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (C0 NOT IN IDENT (C1) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-
-END CD2A22I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada
deleted file mode 100644
index 89737c7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- CD2A22J.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- ENUMERATION TYPE, THEN SUCH A TYPE OF THE SMALLEST APPROPRIATE
--- UNSIGNED SIZE CAN BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC
--- PROCEDURE.
-
--- HISTORY:
--- JET 08/13/87 CREATED ORIGINAL TEST.
--- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A22J IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := 2;
-
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A22J", "CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN " &
- "FOR AN ENUMERATION TYPE, THEN SUCH A TYPE OF " &
- "THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE " &
- "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " &
- "PROCEDURE");
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
- BEGIN -- GENPROC.
- CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((C0 < IDENT (C1)) AND
- (IDENT (C2) > IDENT (C1)) AND
- (C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (C0) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-END CD2A22J;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada
deleted file mode 100644
index 2526f71..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada
+++ /dev/null
@@ -1,221 +0,0 @@
--- CD2A23A.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 WHEN A SIZE SPECIFICATION AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT AFFECTED
--- BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 07/28/87 CREATED ORIGINAL TEST.
--- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A23A IS
-
- BASIC_SIZE : CONSTANT := INTEGER'SIZE/2;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND
- (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1");
- END IF;
-
- IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR
- CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1");
- END IF;
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A23A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " &
- "AN ENUMERATION REPRESENTATION CLAUSE ARE " &
- "GIVEN FOR AN ENUMERATION TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
- PROC (ZERO, TWO, C1, C2, C2);
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND
- (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (TWO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2");
- END IF;
-
- IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3");
- END IF;
-
- IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3");
- END IF;
-
- IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4");
- END IF;
-
-
- RESULT;
-
-END CD2A23A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada
deleted file mode 100644
index 234c711..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- CD2A23E.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 WHEN A SIZE SPECIFICATION AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL PARAMETER TO A
--- GENERIC PROCEDURE.
-
--- HISTORY:
--- JET 08/18/87 CREATED ORIGINAL TEST.
--- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE
--- SPECIFICATION IS OBEYED.
--- LDC 10/03/90 ADDED EXCEPTION HANDER FOR CHECK OF 'SUCC, 'PRED,
--- ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION,
--- AND EXPLICIT CONVERSION.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A23E IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := 8;
-
- FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, TWO => 5);
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A23E", "CHECK THAT WHEN A SIZE SPECIFICATION AND AN " &
- "ENUMERATION REPRESENTATION CLAUSE ARE " &
- "GIVEN FOR AN ENUMERATION TYPE, " &
- "THEN SUCH A TYPE CAN BE " &
- "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " &
- "PROCEDURE");
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- C3 : GPARM;
-
- CHECKVAR : CHECK_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
-
- BEGIN -- GENPROC.
-
- CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
-
- CHECKVAR := IDENT (C0);
-
- CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE");
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT(C0) < IDENT (C1)) AND
- (IDENT(C2) > IDENT (C1)) AND
- (IDENT(C1) <= IDENT (C1)) AND
- (IDENT(C2) = IDENT (C2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (C0) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC");
- END IF;
-
- BEGIN
- IF CHECK_TYPE'SUCC (IDENT(C2)) /= IDENT (C1) THEN
- FAILED ("CONSTRAINT ERROR NOT RAISED FOR " &
- "CHECK_TYPE'SUCC");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF 3 /= IDENT_INT(3) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION -1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "CHECK_TYPE'SUCC");
- END;
-
- BEGIN
- IF CHECK_TYPE'PRED(IDENT(C0)) /= IDENT (C1) THEN
- FAILED ("CONSTRAINT ERROR NOT RAISED FOR " &
- "CHECK_TYPE'PRED");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF 3 /= IDENT_INT(3) THEN
- COMMENT ("DON'T OPTIMIZE EXCEPTION -2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "CHECK_TYPE'PRED");
- END;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE");
- END IF;
-
- CHECKVAR := CHECK_TYPE'VALUE ("ONE");
- C3 := GPARM(CHECKVAR);
- IF C3 /= IDENT(C1) THEN
- FAILED ("INCORRECT VALUE FOR CONVERSION");
- END IF;
-
- CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM");
-
-
- IF CHECK_TYPE'(C2) /= IDENT(C2) THEN
- FAILED ("INCORRECT VALUE FOR QUALIFICATION");
- END IF;
-
- C3 := CHECK_TYPE'VALUE ("TWO");
- IF C3 /= IDENT(C2) THEN
- FAILED ("INCORRECT VALUE FOR ASSIGNMENT");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-
-END CD2A23E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada
deleted file mode 100644
index 2ec5757..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada
+++ /dev/null
@@ -1,226 +0,0 @@
--- CD2A24A.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 WHEN A SIZE SPECIFICATION AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- THEN OPERATIONS ON VALUES OF SUCH A TYPE WITH THE SMALLEST
--- APPROPRIATE SIGNED SIZE ARE NOT AFFECTED BY THE
--- REPRESENTATION CLAUSE.
-
--- HISTORY:
--- JET 08/19/87 CREATED ORIGINAL TEST.
--- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
--- REPRESENTATION CLAUSE.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A24A IS
-
- BASIC_SIZE : CONSTANT := 4;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND
- (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1");
- END IF;
-
- IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR
- CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1");
- END IF;
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A24A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " &
- "AN ENUMERATION REPRESENTATION CLAUSE ARE " &
- "GIVEN FOR AN ENUMERATION TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE WITH " &
- "THE SMALLEST APPROPRIATE SIGNED SIZE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
- PROC (ZERO, TWO, C1, C2, C2);
-
- IF C1 /= ONE OR C2 /= TWO THEN
- FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE");
- END IF;
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND
- (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (TWO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2");
- END IF;
-
- IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3");
- END IF;
-
- IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3");
- END IF;
-
- IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4");
- END IF;
-
-
- RESULT;
-
-END CD2A24A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada
deleted file mode 100644
index fcb0087..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada
+++ /dev/null
@@ -1,220 +0,0 @@
--- CD2A24E.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 SIZE CLAUSE AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- AND THE SMALLEST SIZE APPROPRIATE FOR AN UNSIGNED REPRESENTATION
--- IS SPECIFIED, THEN OPERATIONS ON THE TYPE ARE NOT AFFECTED.
-
--- HISTORY:
--- JET 08/19/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A24E IS
-
- BASIC_SIZE : CONSTANT := 3;
-
- TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
-
- FOR CHECK_TYPE USE (ZERO => 3, ONE => 4,
- TWO => 5);
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- C0 : CHECK_TYPE := ZERO;
- C1 : CHECK_TYPE := ONE;
- C2 : CHECK_TYPE := TWO;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : CHECK_TYPE := ZERO;
- COMP1 : CHECK_TYPE := ONE;
- COMP2 : CHECK_TYPE := TWO;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN ONE;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
- CIO1, CIO2 : IN OUT CHECK_TYPE;
- CO2 : OUT CHECK_TYPE) IS
- BEGIN
- IF NOT ((CI0 < IDENT (ONE)) AND
- (IDENT (CI2) > IDENT (CIO1)) AND
- (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 1");
- END IF;
-
- IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1");
- END IF;
-
- IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR
- CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1");
- END IF;
-
-
- CO2 := TWO;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A24E", "CHECK THAT IF A SIZE CLAUSE AND AN ENUMERATION " &
- "REPRESENTATION CLAUSE ARE GIVEN FOR AN " &
- "ENUMERATION TYPE, AND THE SMALLEST SIZE " &
- "APPROPRIATE FOR AN UNSIGNED REPRESENTATION " &
- "IS SPECIFIED, THEN OPERATIONS ON THE TYPE " &
- "ARE NOT AFFECTED");
-
- PROC (ZERO, TWO, C1, C2, C2);
-
- IF C1 /= ONE OR C2 /= TWO THEN
- FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE");
- END IF;
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (C0 NOT IN IDENT (ONE) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2");
- END IF;
-
- IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
- END IF;
-
- IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
- (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
- (CHARRAY (1) <= IDENT (ONE)) AND
- (IDENT (TWO) = CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
- (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3");
- END IF;
-
- IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR
- CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3");
- END IF;
-
- IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3");
- END IF;
-
- IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
- (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
- (CHREC.COMP1 <= IDENT (ONE)) AND
- (IDENT (TWO) = CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
- (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4");
- END IF;
-
- IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4");
- END IF;
-
- RESULT;
-END CD2A24E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada
deleted file mode 100644
index 494516b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- CD2A24I.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 SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE
--- SIZE FOR A SIGNED REPRESENTATION) AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN
--- INSTANTIATION.
-
--- HISTORY:
--- JET 08/19/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A24I IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := 4;
-
- FOR BASIC_ENUM USE (ZERO => 3, ONE => 4,
- TWO => 5);
-
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A24I", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " &
- "SMALLEST APPROPRIATE SIZE FOR A SIGNED " &
- "REPRESENTATION) AND AN ENUMERATION " &
- "REPRESENTATION CLAUSE ARE GIVEN FOR AN " &
- "ENUMERATION TYPE, THEN THE TYPE CAN BE USED " &
- "AS AN ACTUAL PARAMETER IN AN INSTANTIATION");
-
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((C0 < IDENT (C1)) AND
- (IDENT (C2) > IDENT (C1)) AND
- (C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'FIRST /= IDENT (C0) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
- END IF;
-
- IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
- CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
- CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS");
- END IF;
-
- IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
- CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC");
- END IF;
-
- IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
- CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
- CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-
-END CD2A24I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada
deleted file mode 100644
index 2a9fd81..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- CD2A24J.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 SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE
--- SIZE FOR AN UNSIGNED REPRESENTATION) AND AN ENUMERATION
--- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
--- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN
--- INSTANTIATION.
-
--- HISTORY:
--- JET 08/19/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A24J IS
-
- TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
- BASIC_SIZE : CONSTANT := 3;
-
- FOR BASIC_ENUM USE (ZERO => 3, ONE => 4,
- TWO => 5);
- FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
-
-BEGIN
- TEST ("CD2A24J", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " &
- "SMALLEST APPROPRIATE SIZE FOR AN UNSIGNED " &
- "REPRESENTATION) AND AN ENUMERATION " &
- "REPRESENTATION CLAUSE ARE GIVEN FOR AN " &
- "ENUMERATION TYPE, THEN THE TYPE CAN BE USED " &
- "AS AN ACTUAL PARAMETER IN AN INSTANTIATION");
-
-
- DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS (<>);
- PROCEDURE GENPROC (C0, C1, C2: GPARM);
-
- PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
-
- SUBTYPE CHECK_TYPE IS GPARM;
-
- FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN CH;
- ELSE
- RETURN C1;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR C0'SIZE");
- END IF;
-
- IF NOT ((IDENT (C1) IN C1 .. C2) AND
- (C0 NOT IN IDENT (C1) .. C2)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS");
- END IF;
-
- IF CHECK_TYPE'LAST /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST");
- END IF;
-
- IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
- CHECK_TYPE'VAL (1) /= IDENT (C1) OR
- CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL");
- END IF;
-
- IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
- CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED");
- END IF;
-
- IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
- CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
- CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
-
- BEGIN
-
- NEWPROC (ZERO, ONE, TWO);
-
- END;
-
- RESULT;
-
-END CD2A24J;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada
deleted file mode 100644
index be8efa6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada
+++ /dev/null
@@ -1,266 +0,0 @@
--- CD2A31A.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- JET 08/06/87 CREATED ORIGINAL TEST.
--- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION
--- CLAUSE CHECK.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A31A IS
-
- BASIC_SIZE : CONSTANT := 9;
-
- TYPE INT IS RANGE -100 .. 100;
-
- FOR INT'SIZE USE BASIC_SIZE;
-
- I1 : INT := -100;
- I2 : INT := 0;
- I3 : INT := 100;
-
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT;
- INTARRAY : ARRAY_TYPE := (-100, 0, 100);
-
- TYPE REC_TYPE IS RECORD
- COMPN : INT := -100;
- COMPZ : INT := 0;
- COMPP : INT := 100;
- END RECORD;
-
- IREC : REC_TYPE;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT);
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (PIN, PIP : INT;
- PIOZ, PIOP : IN OUT INT;
- POP : OUT INT) IS
-
- BEGIN
- IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR PIN'SIZE");
- END IF;
-
- IF NOT ((PIN < IDENT (0)) AND
- (IDENT (PIP) > IDENT (PIOZ)) AND
- (PIOZ <= IDENT (1)) AND
- (IDENT (100) = PIP)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS - 1");
- END IF;
-
- IF NOT (((PIN + PIP) = PIOZ) AND
- ((PIP - PIOZ) = PIOP) AND
- ((PIOP * PIOZ) = PIOZ) AND
- ((PIOZ / PIN) = PIOZ) AND
- ((PIN ** 1) = PIN) AND
- ((PIN REM 9) = IDENT (-1)) AND
- ((PIP MOD 9) = IDENT (1))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 1");
- END IF;
-
- IF INT'VAL (-100) /= IDENT (PIN) OR
- INT'VAL (0) /= IDENT (PIOZ) OR
- INT'VAL (100) /= IDENT (PIOP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 1");
- END IF;
-
- IF INT'PRED (PIOZ) /= IDENT (-1) OR
- INT'PRED (PIP) /= IDENT (99) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 1");
- END IF;
-
- IF INT'VALUE ("-100") /= IDENT (PIN) OR
- INT'VALUE ("0") /= IDENT (PIOZ) OR
- INT'VALUE ("100") /= IDENT (PIOP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 1");
- END IF;
-
- POP := 100;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A31A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN INTEGER TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- CHECK_1 (I1, 9, "INT");
- PROC (-100, 100, I2, I3, I3);
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I1'SIZE");
- END IF;
-
- FOR I IN IDENT (I1) .. IDENT (I3) LOOP
- IF NOT (I IN I1 .. I3) OR
- (I NOT IN IDENT(-100) .. IDENT(100)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 2");
- END IF;
- END LOOP;
-
- IF NOT ((+I1 = I1) AND
- (-I3 = I1) AND
- (ABS I1 = I3)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 2");
- END IF;
-
- IF INT'FIRST /= IDENT (-100) THEN
- FAILED ("INCORRECT VALUE FOR INT'FIRST - 2");
- END IF;
-
- IF INT'POS (I1) /= IDENT_INT (-100) OR
- INT'POS (I2) /= IDENT_INT ( 0) OR
- INT'POS (I3) /= IDENT_INT ( 100) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 2");
- END IF;
-
- IF INT'SUCC (I1) /= IDENT (-99) OR
- INT'SUCC (I2) /= IDENT (1) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 2");
- END IF;
-
- IF INT'IMAGE (I1) /= IDENT_STR ("-100") OR
- INT'IMAGE (I2) /= IDENT_STR (" 0") OR
- INT'IMAGE (I3) /= IDENT_STR (" 100") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2");
- END IF;
-
- IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE");
- END IF;
-
- IF NOT ((INTARRAY(-1) < IDENT (0)) AND
- (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND
- (INTARRAY(0) <= IDENT (0)) AND
- (IDENT (100) = INTARRAY (1))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP
- IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR
- (I NOT IN IDENT(-100) .. IDENT(100)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
- END LOOP;
-
- IF NOT (((INTARRAY(-1) + INTARRAY( 1)) = INTARRAY( 0)) AND
- ((INTARRAY( 0) - INTARRAY( 1)) = INTARRAY(-1)) AND
- ((INTARRAY( 1) * INTARRAY( 0)) = INTARRAY( 0)) AND
- ((INTARRAY( 0) / INTARRAY(-1)) = INTARRAY( 0)) AND
- ((INTARRAY(-1) ** 1) = INTARRAY(-1)) AND
- ((INTARRAY(-1) REM 9) = IDENT (-1)) AND
- ((INTARRAY( 1) MOD 9) = IDENT ( 1))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 3");
- END IF;
-
- IF INT'POS (INTARRAY (-1)) /= IDENT_INT (-100) OR
- INT'POS (INTARRAY ( 0)) /= IDENT_INT ( 0) OR
- INT'POS (INTARRAY ( 1)) /= IDENT_INT ( 100) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 3");
- END IF;
-
- IF INT'SUCC (INTARRAY (-1)) /= IDENT (-99) OR
- INT'SUCC (INTARRAY ( 0)) /= IDENT (1) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 3");
- END IF;
-
- IF INT'IMAGE (INTARRAY (-1)) /= IDENT_STR ("-100") OR
- INT'IMAGE (INTARRAY ( 0)) /= IDENT_STR (" 0") OR
- INT'IMAGE (INTARRAY ( 1)) /= IDENT_STR (" 100") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3");
- END IF;
-
- IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE");
- END IF;
-
- IF NOT ((IREC.COMPN < IDENT (0)) AND
- (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND
- (IREC.COMPZ <= IDENT (0)) AND
- (IDENT (100) = IREC.COMPP)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP
- IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR
- (I NOT IN IDENT(-100) .. IDENT(100)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
- END LOOP;
-
- IF NOT ((+IREC.COMPN = IREC.COMPN) AND
- (-IREC.COMPP = IREC.COMPN) AND
- (ABS IREC.COMPN = IREC.COMPP)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 4");
- END IF;
-
- IF INT'VAL (-100) /= IDENT (IREC.COMPN) OR
- INT'VAL ( 0) /= IDENT (IREC.COMPZ) OR
- INT'VAL ( 100) /= IDENT (IREC.COMPP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 4");
- END IF;
-
- IF INT'PRED (IREC.COMPZ) /= IDENT (-1) OR
- INT'PRED (IREC.COMPP) /= IDENT (99) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 4");
- END IF;
-
- IF INT'VALUE ("-100") /= IDENT (IREC.COMPN) OR
- INT'VALUE ( "0") /= IDENT (IREC.COMPZ) OR
- INT'VALUE ( "100") /= IDENT (IREC.COMPP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 4");
- END IF;
-
- RESULT;
-END CD2A31A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada
deleted file mode 100644
index 2b01ed6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- CD2A31C.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 INTEGER 'SIZE SPECIFICATIONS CAN BE GIVEN:
--- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE
--- DECLARED IN THE VISIBLE PART;
--- FOR A DERIVED INTEGER TYPE;
--- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS
--- AN INTEGER TYPE;
--- FOR AN INTEGER TYPE IN A GENERIC UNIT.
-
--- HISTORY:
--- PWB 06/17/87 CREATED ORIGINAL TEST.
--- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION
--- CLAUSE CHECK AND INCLUDED TEST FOR INTEGER IN A
--- GENERIC UNIT.
--- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES.
--- DTN 06/17/92 REMOVED THE LENGTH CLAUSE FOR TYPE PRIVATE_INT.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A31C IS
-
- TYPE BASIC_INT IS RANGE -60 .. 80;
- SPECIFIED_SIZE : CONSTANT := 9;
-
- TYPE DERIVED_INT IS NEW BASIC_INT;
- FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE INT_IN_P IS RANGE -125 .. 125;
- FOR INT_IN_P'SIZE USE SPECIFIED_SIZE;
- TYPE PRIVATE_INT IS PRIVATE;
- TYPE ALT_INT_IN_P IS RANGE -125 .. 125;
- PRIVATE
- TYPE PRIVATE_INT IS RANGE -125 .. 125;
- FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE;
- END P;
-
- USE P;
- TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT;
- FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE;
- MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
-
--- SIZE SPECIFICATION GIVEN IN A GENERIC PROCEDURE.
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
- TYPE CHECK_INT IS RANGE -125 .. 125;
- FOR CHECK_INT'SIZE USE SPECIFIED_SIZE;
-
- PROCEDURE CHECK_4 IS NEW LENGTH_CHECK (CHECK_INT);
-
- BEGIN
-
- IF CHECK_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("GENERIC CHECK_INT'SIZE IS INCORRECT");
- END IF;
- CHECK_4 (-60, 9, "GENERIC CHECK_INT");
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_INT);
- PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (INT_IN_P);
- PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_INT_IN_P);
-
-BEGIN
-
- TEST("CD2A31C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN IN " &
- "VISIBLE OR PRIVATE PART OF PACKAGE FOR INTEGER " &
- "TYPE DECLARED IN VISIBLE PART, AND FOR " &
- "DERIVED INTEGER TYPES " &
- "AND DERIVED PRIVATE TYPES WHOSE FULL DECLARATIONS " &
- "ARE AS INTEGER TYPES");
-
- CHECK_1 (-60, 9, "DERIVED_INT");
- CHECK_2 (-60, 9, "INT_IN_P");
- CHECK_3 (-60, 9, "ALT_INT_IN_P");
-
- NEWPROC;
-
- IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_INT'SIZE INCORRECT");
- END IF;
-
- IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("INT_IN_P'SIZE INCORRECT");
- END IF;
-
- IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ALT_INT_IN_P'SIZE INCORRECT");
- END IF;
-
- IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_PRIVATE_INT'SIZE INCORRECT");
- END IF;
-
- RESULT;
-
-END CD2A31C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada
deleted file mode 100644
index b4ed17c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada
+++ /dev/null
@@ -1,139 +0,0 @@
--- CD2A31E.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- INTEGER TYPE, THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL
--- PARAMETER TO GENERIC PROCEDURES.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- BCB 10/18/88 MODIFIED HEADER AND ENTERED IN ACVC.
--- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 9, AND CHANGED 'SIZE CLAUSE
--- CHECKS.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2A31E IS
-
- TYPE BASIC_INT IS RANGE -100 .. 100;
- BASIC_SIZE : CONSTANT := 9;
-
- FOR BASIC_INT'SIZE USE BASIC_SIZE;
-
-BEGIN
-
- TEST ("CD2A31E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN INTEGER TYPE, THEN SUCH A TYPE " &
- "CAN BE PASSED AS AN ACTUAL PARAMETER TO " &
- "GENERIC PACKAGES AND PROCEDURES");
-
- DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS RANGE <>;
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- SUBTYPE INT IS GPARM;
-
- I1 : INT := -100;
- I2 : INT := 0;
- I3 : INT := 100;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I1'SIZE");
- END IF;
-
- IF NOT ((I1 < IDENT (0)) AND
- (IDENT (I3) > IDENT (I2)) AND
- (I2 <= IDENT (0)) AND
- (IDENT (100) = I3)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS");
- END IF;
-
- IF NOT (((I1 + I3) = I2) AND
- ((I2 - I3) = I1) AND
- ((I3 * I2) = I2) AND
- ((I2 / I1) = I2) AND
- ((I1 ** 1) = I1) AND
- ((I1 REM 9) = IDENT (-1)) AND
- ((I3 MOD 9) = IDENT (1))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS");
- END IF;
-
- IF INT'LAST /= IDENT (100) THEN
- FAILED ("INCORRECT VALUE FOR INT'LAST");
- END IF;
-
- IF INT'VAL (-100) /= IDENT (I1) OR
- INT'VAL (0) /= IDENT (I2) OR
- INT'VAL (100) /= IDENT (I3) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL");
- END IF;
-
- IF INT'PRED (I2) /= IDENT (-1) OR
- INT'PRED (I3) /= IDENT (99) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED");
- END IF;
-
- IF INT'VALUE ("-100") /= IDENT (I1) OR
- INT'VALUE (" 0") /= IDENT (I2) OR
- INT'VALUE (" 100") /= IDENT (I3) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT);
-
- BEGIN
-
- NEWPROC;
-
- END;
-
- RESULT;
-
-END CD2A31E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada
deleted file mode 100644
index 228b445..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada
+++ /dev/null
@@ -1,272 +0,0 @@
--- CD2A32A.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- WITH THE SMALLEST APPROPRIATE SIGNED SIZE ARE NOT
--- AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/10/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE
--- CHECKS AND ADDED REPRESENTAION CLAUSE CHECK.
--- RJW 03/28/90 REMOVED ERRONEOUS REFERENCES TO LENGTH_CHECK.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD2A32A IS
-
- BASIC_SIZE : CONSTANT := 7;
-
- TYPE INT IS RANGE -63 .. 63;
-
- FOR INT'SIZE USE BASIC_SIZE;
-
- I1 : INT := -63;
- I2 : INT := 0;
- I3 : INT := 63;
-
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT;
- PRAGMA PACK (ARRAY_TYPE);
- INTARRAY : ARRAY_TYPE := (-63, 0, 63);
-
- TYPE REC_TYPE IS RECORD
- COMPN : INT := -63;
- COMPZ : INT := 0;
- COMPP : INT := 63;
- END RECORD;
- PRAGMA PACK (REC_TYPE);
-
- IREC : REC_TYPE;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT);
-
-
- PROCEDURE PROC (PIN, PIP : INT;
- PIOZ, PIOP : IN OUT INT;
- POP : OUT INT) IS
-
- BEGIN
- IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR PIN'SIZE");
- END IF;
-
- FOR P1 IN IDENT (PIN) .. IDENT (PIOP) LOOP
- IF NOT (P1 IN PIN .. PIP) OR
- (P1 NOT IN IDENT(-63) .. IDENT(63)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 1");
- END IF;
- END LOOP;
-
- IF NOT ((+PIP = PIOP) AND
- (-PIN = PIP) AND
- (ABS PIN = PIOP)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 1");
- END IF;
-
- IF INT'VAL (-63) /= IDENT (PIN) OR
- INT'VAL (0) /= IDENT (PIOZ) OR
- INT'VAL (63) /= IDENT (PIOP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 1");
- END IF;
-
- IF INT'PRED (PIOZ) /= IDENT (-1) OR
- INT'PRED (PIP) /= IDENT (62) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 1");
- END IF;
-
- IF INT'VALUE ("-63") /= IDENT (PIN) OR
- INT'VALUE ("0") /= IDENT (PIOZ) OR
- INT'VALUE ("63") /= IDENT (PIOP) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 1");
- END IF;
-
- POP := 63;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A32A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN INTEGER TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE WITH " &
- "THE SMALLEST APPROPRIATE SIGNED SIZE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- CHECK_1 (I1, 7, "INT");
-
- PROC (-63, 63, I2, I3, I3);
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I1'SIZE");
- END IF;
-
- IF NOT ((I1 < IDENT (0)) AND
- (IDENT (I3) > IDENT (I2)) AND
- (I2 <= IDENT (0)) AND
- (IDENT (63) = I3)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
- END IF;
-
- IF NOT (((I1 + I3) = I2) AND
- ((I2 - I3) = I1) AND
- ((I3 * I2) = I2) AND
- ((I2 / I1) = I2) AND
- ((I1 ** 1) = I1) AND
- ((I1 REM 10) = IDENT (-3)) AND
- ((I3 MOD 10) = IDENT (3))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 2");
- END IF;
-
- IF INT'FIRST /= IDENT (-63) THEN
- FAILED ("INCORRECT VALUE FOR INT'FIRST - 2");
- END IF;
-
- IF INT'POS (I1) /= IDENT_INT (-63) OR
- INT'POS (I2) /= IDENT_INT ( 0) OR
- INT'POS (I3) /= IDENT_INT ( 63) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 2");
- END IF;
-
- IF INT'SUCC (I1) /= IDENT (-62) OR
- INT'SUCC (I2) /= IDENT (1) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 2");
- END IF;
-
- IF INT'IMAGE (I1) /= IDENT_STR ("-63") OR
- INT'IMAGE (I2) /= IDENT_STR (" 0") OR
- INT'IMAGE (I3) /= IDENT_STR (" 63") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2");
- END IF;
-
- IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE");
- END IF;
-
- IF NOT ((INTARRAY(-1) < IDENT (0)) AND
- (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND
- (INTARRAY(0) <= IDENT (0)) AND
- (IDENT (63) = INTARRAY (1))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP
- IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR
- (I NOT IN IDENT(-63) .. IDENT(63)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
- END LOOP;
-
- IF NOT ((+INTARRAY(-1) = INTARRAY(-1)) AND
- (-INTARRAY( 1) = INTARRAY(-1)) AND
- (ABS INTARRAY(-1) = INTARRAY(1))) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 3");
- END IF;
-
- IF INT'VAL (-63) /= IDENT (INTARRAY (-1)) OR
- INT'VAL ( 0) /= IDENT (INTARRAY ( 0)) OR
- INT'VAL ( 63) /= IDENT (INTARRAY ( 1)) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 3");
- END IF;
-
- IF INT'PRED (INTARRAY (0)) /= IDENT (-1) OR
- INT'PRED (INTARRAY (1)) /= IDENT (62) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 3");
- END IF;
-
- IF INT'VALUE ("-63") /= IDENT (INTARRAY (-1)) OR
- INT'VALUE ("0") /= IDENT (INTARRAY ( 0)) OR
- INT'VALUE ("63") /= IDENT (INTARRAY ( 1)) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 3");
- END IF;
-
- IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE");
- END IF;
-
- IF NOT ((IREC.COMPN < IDENT (0)) AND
- (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND
- (IREC.COMPZ <= IDENT (0)) AND
- (IDENT (63) = IREC.COMPP)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP
- IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR
- (I NOT IN IDENT(-63) .. IDENT(63)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
- END LOOP;
-
- IF NOT (((IREC.COMPN + IREC.COMPP) = IREC.COMPZ) AND
- ((IREC.COMPZ - IREC.COMPP) = IREC.COMPN) AND
- ((IREC.COMPP * IREC.COMPZ) = IREC.COMPZ) AND
- ((IREC.COMPZ / IREC.COMPN) = IREC.COMPZ) AND
- ((IREC.COMPN ** 1) = IREC.COMPN) AND
- ((IREC.COMPN REM 10) = IDENT (-3)) AND
- ((IREC.COMPP MOD 10) = IDENT ( 3))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 4");
- END IF;
-
- IF INT'POS (IREC.COMPN) /= IDENT_INT (-63) OR
- INT'POS (IREC.COMPZ) /= IDENT_INT ( 0) OR
- INT'POS (IREC.COMPP) /= IDENT_INT ( 63) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 4");
- END IF;
-
- IF INT'SUCC (IREC.COMPN) /= IDENT (-62) OR
- INT'SUCC (IREC.COMPZ) /= IDENT ( 1) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 4");
- END IF;
-
- IF INT'IMAGE (IREC.COMPN) /= IDENT_STR ("-63") OR
- INT'IMAGE (IREC.COMPZ) /= IDENT_STR (" 0") OR
- INT'IMAGE (IREC.COMPP) /= IDENT_STR (" 63") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 4");
- END IF;
-
- RESULT;
-END CD2A32A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada
deleted file mode 100644
index a8edaa6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- CD2A32C.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 SIZE SPECIFICATION FOR AN INTEGER TYPE OF THE
--- SMALLEST APPROPRIATE SIGNED SIZE CAN BE GIVEN:
--- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE
--- DECLARED IN THE VISIBLE PART;
--- FOR A DERIVED INTEGER TYPE;
--- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS
--- AN INTEGER TYPE;
--- FOR AN INTEGER TYPE IN A GENERIC UNIT.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE
--- CHECKS, ADDED REPRESENTAION CLAUSE CHECK, AND
--- ADDED CHECK ON INTEGER IN A GENERIC UNIT.
--- BCB 10/03/90 CHANGED FAILED MESSAGES FROM "SHOULD NOT BE GREATER
--- THAN" TO "MUST BE EQUAL TO".
--- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A32C IS
-
- TYPE BASIC_INT IS RANGE -63 .. 63;
- SPECIFIED_SIZE : CONSTANT := 7;
-
- TYPE DERIVED_INT IS NEW BASIC_INT;
- FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE INT_IN_P IS RANGE -63 .. 63;
- FOR INT_IN_P'SIZE USE SPECIFIED_SIZE;
- TYPE PRIVATE_INT IS PRIVATE;
- TYPE ALT_INT_IN_P IS RANGE -63 .. 63;
- PRIVATE
- TYPE PRIVATE_INT IS RANGE -63 .. 63;
- FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE;
- END P;
-
- USE P;
-
- GENERIC
- PACKAGE GENPACK IS
- TYPE GEN_CHECK_INT IS RANGE -63 .. 63;
- FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE;
- END GENPACK;
-
- PACKAGE NEWPACK IS NEW GENPACK;
-
- USE NEWPACK;
- TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT;
- FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE;
-
- MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
-
-BEGIN
-
- TEST("CD2A32C", "CHECK THAT A SIZE SPECIFICATION " &
- "FOR AN INTEGER TYPE OF THE SMALLEST " &
- "APPROPRIATE SIGNED SIZE CAN BE GIVEN: IN THE " &
- "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " &
- "TYPE DECLARED IN THE VISIBLE PART; FOR A " &
- "DERIVED INTEGER TYPE; FOR A DERIVED PRIVATE " &
- "TYPE WHOSE FULL DECLARATION IS AS AN INTEGER " &
- "TYPE; FOR AN INTEGER TYPE IN A GENERIC UNIT");
-
- IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_INT'SIZE MUST BE EQUAL TO" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_INT'SIZE));
- END IF;
-
- IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("INT_IN_P'SIZE MUST BE EQUAL TO" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(INT_IN_P'SIZE));
- END IF;
-
- IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ALT_INT_IN_P'SIZE MUST BE EQUAL TO" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(ALT_INT_IN_P'SIZE));
- END IF;
-
- IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_PRIVATE_INT'SIZE MUST BE EQUAL TO " &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE));
- END IF;
-
- IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("GEN_CHECK_INT'SIZE MUST BE EQUAL TO" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(GEN_CHECK_INT'SIZE));
- END IF;
-
- RESULT;
-
-END CD2A32C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada
deleted file mode 100644
index 621ea67..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada
+++ /dev/null
@@ -1,263 +0,0 @@
--- CD2A32E.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
--- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- WITH THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE NOT
--- AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON
--- 'SIZE CHECKS.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A32E IS
-
- BASIC_SIZE : CONSTANT := 7;
-
- TYPE INT IS RANGE 0 .. 126;
-
- FOR INT'SIZE USE BASIC_SIZE;
-
- I0 : INT := 0;
- I1 : INT := 63;
- I2 : INT := 126;
-
- TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE 0 .. 2) OF INT;
- INTARRAY : ARRAY_TYPE := (0, 63, 126);
-
- TYPE REC_TYPE IS RECORD
- COMP0 : INT := 0;
- COMP1 : INT := 63;
- COMP2 : INT := 126;
- END RECORD;
-
- IREC : REC_TYPE;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (PI0, PI2 : INT;
- PIO1, PIO2 : IN OUT INT;
- PO2 : OUT INT) IS
-
- BEGIN
- IF PI0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR PI0'SIZE");
- END IF;
-
- IF NOT ((PI0 < IDENT (1)) AND
- (IDENT (PI2) > IDENT (PIO1)) AND
- (PIO1 <= IDENT (63)) AND
- (IDENT (126) = PI2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS - 1");
- END IF;
-
- IF NOT (((PI0 + PI2) = PIO2) AND
- ((PI2 - PIO1) = PIO1) AND
- ((PIO1 * IDENT (2)) = PI2) AND
- ((PIO2 / PIO1) = IDENT (2)) AND
- ((PIO1 ** 1) = IDENT (63)) AND
- ((PIO2 REM 10) = IDENT (6)) AND
- ((PIO1 MOD 10) = IDENT (3))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 1");
- END IF;
-
- IF INT'POS (PI0) /= IDENT_INT (0) OR
- INT'POS (PIO1) /= IDENT_INT (63) OR
- INT'POS (PI2) /= IDENT_INT (126) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 1");
- END IF;
-
- IF INT'SUCC (PI0) /= IDENT (1) OR
- INT'SUCC (PIO1) /= IDENT (64) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 1");
- END IF;
-
- IF INT'IMAGE (PI0) /= IDENT_STR (" 0") OR
- INT'IMAGE (PIO1) /= IDENT_STR (" 63") OR
- INT'IMAGE (PI2) /= IDENT_STR (" 126") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 1");
- END IF;
-
- PO2 := 126;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A32E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
- "GIVEN FOR AN INTEGER TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE WITH " &
- "THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- PROC (0, 126, I1, I2, I2);
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I1'SIZE");
- END IF;
-
- FOR I IN IDENT (I0) .. IDENT (I2) LOOP
- IF NOT (I IN I0 .. I2) OR
- (I NOT IN IDENT(0) .. IDENT(126)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 2");
- END IF;
- END LOOP;
-
- IF NOT ((+I2 = I2) AND
- (-I1 = -63) AND
- (ABS I2 = I2)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 2");
- END IF;
-
- IF INT'VAL (0) /= IDENT (I0) OR
- INT'VAL (63) /= IDENT (I1) OR
- INT'VAL (126) /= IDENT (I2) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 2");
- END IF;
-
- IF INT'PRED (I1) /= IDENT (62) OR
- INT'PRED (I2) /= IDENT (125) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 2");
- END IF;
-
- IF INT'VALUE ("0") /= IDENT (I0) OR
- INT'VALUE ("63") /= IDENT (I1) OR
- INT'VALUE ("126") /= IDENT (I2) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 2");
- END IF;
-
- IF INTARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INTARRAY(1)'SIZE");
- END IF;
-
- IF NOT ((INTARRAY(0) < IDENT (1)) AND
- (IDENT (INTARRAY(2)) > IDENT (INTARRAY(1))) AND
- (INTARRAY(1) <= IDENT (63)) AND
- (IDENT (126) = INTARRAY(2))) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS - 3");
- END IF;
-
- FOR I IN IDENT (INTARRAY(0)) .. IDENT (INTARRAY(2)) LOOP
- IF NOT (I IN INTARRAY(0) .. INTARRAY(2)) OR
- (I NOT IN IDENT(0) .. IDENT(126)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
- END LOOP;
-
- IF NOT (((INTARRAY(0) + INTARRAY(2)) = INTARRAY(2)) AND
- ((INTARRAY(2) - INTARRAY(1)) = INTARRAY(1)) AND
- ((INTARRAY(1) * IDENT (2)) = INTARRAY(2)) AND
- ((INTARRAY(2) / INTARRAY(1)) = IDENT (2)) AND
- ((INTARRAY(1) ** 1) = IDENT (63)) AND
- ((INTARRAY(2) REM 10) = IDENT (6)) AND
- ((INTARRAY(1) MOD 10) = IDENT (3))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS - 3");
- END IF;
-
- IF INT'POS (INTARRAY(0)) /= IDENT_INT (0) OR
- INT'POS (INTARRAY(1)) /= IDENT_INT (63) OR
- INT'POS (INTARRAY(2)) /= IDENT_INT (126) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS - 3");
- END IF;
-
- IF INT'SUCC (INTARRAY(0)) /= IDENT (1) OR
- INT'SUCC (INTARRAY(1)) /= IDENT (64) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC - 3");
- END IF;
-
- IF INT'IMAGE (INTARRAY(0)) /= IDENT_STR (" 0") OR
- INT'IMAGE (INTARRAY(1)) /= IDENT_STR (" 63") OR
- INT'IMAGE (INTARRAY(2)) /= IDENT_STR (" 126") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3");
- END IF;
-
- IF IREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR IREC.COMP2'SIZE");
- END IF;
-
- IF NOT ((IREC.COMP0 < IDENT (1)) AND
- (IDENT (IREC.COMP2) > IDENT (IREC.COMP1)) AND
- (IREC.COMP1 <= IDENT (63)) AND
- (IDENT (126) = IREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS - 4");
- END IF;
-
- FOR I IN IDENT (IREC.COMP0) .. IDENT (IREC.COMP2) LOOP
- IF NOT (I IN IREC.COMP0 .. IREC.COMP2) OR
- (I NOT IN IDENT(0) .. IDENT(126)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
- END LOOP;
-
- IF NOT ((+IREC.COMP2 = IREC.COMP2) AND
- (-IREC.COMP1 = -63) AND
- (ABS IREC.COMP2 = IREC.COMP2)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS - 4");
- END IF;
-
- IF INT'VAL (0) /= IDENT (IREC.COMP0) OR
- INT'VAL (63) /= IDENT (IREC.COMP1) OR
- INT'VAL (126) /= IDENT (IREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL - 4");
- END IF;
-
- IF INT'PRED (IREC.COMP1) /= IDENT (62) OR
- INT'PRED (IREC.COMP2) /= IDENT (125) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED - 4");
- END IF;
-
- IF INT'VALUE ("0") /= IDENT (IREC.COMP0) OR
- INT'VALUE ("63") /= IDENT (IREC.COMP1) OR
- INT'VALUE ("126") /= IDENT (IREC.COMP2) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE - 4");
- END IF;
-
- RESULT;
-
-END CD2A32E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada
deleted file mode 100644
index c9d8466..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada
+++ /dev/null
@@ -1,131 +0,0 @@
--- CD2A32G.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 SIZE SPECIFICATION FOR AN INTEGER
--- TYPE OF THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE GIVEN:
--- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE
--- DECLARED IN THE VISIBLE PART;
--- FOR A DERIVED INTEGER TYPE;
--- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS
--- AN INTEGER TYPE;
--- FOR AN INTEGER TYPE GIVEN IN A GENERIC UNIT.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE
--- CHECKS, AND ADDED CHECK FOR 'SIZE IN A GENERIC
--- UNIT.
--- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A32G IS
-
- TYPE BASIC_INT IS RANGE 0 .. 126;
- SPECIFIED_SIZE : CONSTANT := 7;
-
- TYPE DERIVED_INT IS NEW BASIC_INT;
- FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE INT_IN_P IS RANGE 0 .. 126;
- FOR INT_IN_P'SIZE USE SPECIFIED_SIZE;
- TYPE PRIVATE_INT IS PRIVATE;
- TYPE ALT_INT_IN_P IS RANGE 0 .. 126;
- PRIVATE
- TYPE PRIVATE_INT IS RANGE 0 .. 126;
- FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE;
- END P;
-
- USE P;
-
- TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT;
- FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE;
-
- MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
- TYPE GEN_CHECK_INT IS RANGE 0 .. 126;
- FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE;
-
- BEGIN
-
- IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("GEN_CHECK_INT'SIZE SHOULD NOT BE GREATER " &
- "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(GEN_CHECK_INT'SIZE));
- END IF;
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC;
-
-BEGIN
-
- TEST("CD2A32G", "CHECK THAT SIZE SPECIFICATIONS OF THE SMALLEST " &
- "APPROPRIATE UNSIGNED SIZE CAN BE GIVEN " &
- "IN THE VISIBLE OR PRIVATE PART OF PACKAGE FOR " &
- "AN INTEGER TYPE DECLARED IN VISIBLE PART, " &
- "FOR DERIVED INTEGER " &
- "TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " &
- "DECLARATION IS AS AN INTEGER TYPE AND FOR AN " &
- "INTEGER TYPE GIVEN IN A GENERIC UNIT");
-
- IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_INT'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_INT'SIZE));
- END IF;
-
- IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(INT_IN_P'SIZE));
- END IF;
-
- IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ALT_INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
- INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(ALT_INT_IN_P'SIZE));
- END IF;
-
- IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN
- FAILED ("DERIVED_PRIVATE_INT'SIZE SHOULD NOT BE GREATER " &
- "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) &
- ". ACTUAL SIZE IS" &
- INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE));
- END IF;
-
- NEWPROC;
-
- RESULT;
-
-END CD2A32G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada
deleted file mode 100644
index d3439a7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- CD2A32I.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 WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE
--- SIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN
--- BE PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON
--- 'SIZE CHECKS.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A32I IS
-
- TYPE BASIC_INT IS RANGE -63 .. 63;
- BASIC_SIZE : CONSTANT := 7;
-
- FOR BASIC_INT'SIZE USE BASIC_SIZE;
-
-BEGIN
-
- TEST ("CD2A32I", "CHECK THAT WHEN A SIZE SPECIFICATION " &
- "OF THE SMALLEST APPROPRIATE SIGNED SIZE " &
- "IS GIVEN FOR AN INTEGER TYPE, " &
- "THE TYPE " &
- "CAN BE PASSED AS AN ACTUAL PARAMETER TO " &
- "GENERIC PROCEDURES");
-
- DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS RANGE <>;
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- SUBTYPE INT IS GPARM;
-
- I1 : INT := -63;
- I2 : INT := 0;
- I3 : INT := 63;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I1'SIZE");
- END IF;
-
- FOR I IN IDENT (I1) .. IDENT (I3) LOOP
- IF NOT (I IN I1 .. I3) OR
- (I NOT IN IDENT(-63) .. IDENT(63)) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS");
- END IF;
- END LOOP;
-
- IF NOT ((+I1 = I1) AND
- (-I3 = I1) AND
- (ABS I1 = I3)) THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " &
- "OPERATORS");
- END IF;
-
- IF INT'LAST /= IDENT (63) THEN
- FAILED ("INCORRECT VALUE FOR INT'LAST");
- END IF;
-
- IF INT'VAL (-63) /= IDENT (I1) OR
- INT'VAL (0) /= IDENT (I2) OR
- INT'VAL (63) /= IDENT (I3) THEN
- FAILED ("INCORRECT VALUE FOR INT'VAL");
- END IF;
-
- IF INT'PRED (I2) /= IDENT (-1) OR
- INT'PRED (I3) /= IDENT (62) THEN
- FAILED ("INCORRECT VALUE FOR INT'PRED");
- END IF;
-
- IF INT'VALUE ("-63") /= IDENT (I1) OR
- INT'VALUE (" 0") /= IDENT (I2) OR
- INT'VALUE (" 63") /= IDENT (I3) THEN
- FAILED ("INCORRECT VALUE FOR INT'VALUE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT);
-
- BEGIN
-
- NEWPROC;
-
- END;
-
- RESULT;
-
-END CD2A32I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada
deleted file mode 100644
index e8969b3..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- CD2A32J.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 WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE
--- UNSIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN BE
--- PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES.
-
--- HISTORY:
--- JET 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON
--- 'SIZE CHECKS.
--- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2A32J IS
-
- TYPE BASIC_INT IS RANGE 0 .. 126;
- BASIC_SIZE : CONSTANT := 7;
-
- FOR BASIC_INT'SIZE USE BASIC_SIZE;
-
-BEGIN
-
- TEST ("CD2A32J", "CHECK THAT WHEN A SIZE SPECIFICATION " &
- "OF THE SMALLEST APPROPRIATE UNSIGNED SIZE " &
- "IS GIVEN FOR AN INTEGER TYPE, THE TYPE " &
- "CAN BE PASSED AS AN ACTUAL PARAMETER TO " &
- "GENERIC PROCEDURES");
-
- DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE.
-
- GENERIC
- TYPE GPARM IS RANGE <>;
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- SUBTYPE INT IS GPARM;
-
- I0 : INT := 0;
- I1 : INT := 63;
- I2 : INT := 126;
-
- FUNCTION IDENT (I : INT) RETURN INT IS
- BEGIN
- IF EQUAL (0,0) THEN
- RETURN I;
- ELSE
- RETURN 0;
- END IF;
- END IDENT;
-
- BEGIN -- GENPROC.
-
- IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR INT'SIZE");
- END IF;
-
- IF I0'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR I0'SIZE");
- END IF;
-
- IF NOT ((I0 < IDENT (1)) AND
- (IDENT (I2) > IDENT (I1)) AND
- (I1 <= IDENT (63)) AND
- (IDENT (126) = I2)) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS");
- END IF;
-
- IF NOT (((I0 + I2) = I2) AND
- ((I2 - I1) = I1) AND
- ((I1 * IDENT (2)) = I2) AND
- ((I2 / I1) = IDENT (2)) AND
- ((I1 ** 1) = IDENT (63)) AND
- ((I2 REM 10) = IDENT (6)) AND
- ((I1 MOD 10) = IDENT (3))) THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
- "OPERATORS");
- END IF;
-
- IF INT'POS (I0) /= IDENT_INT (0) OR
- INT'POS (I1) /= IDENT_INT (63) OR
- INT'POS (I2) /= IDENT_INT (126) THEN
- FAILED ("INCORRECT VALUE FOR INT'POS");
- END IF;
-
- IF INT'SUCC (I0) /= IDENT (1) OR
- INT'SUCC (I1) /= IDENT (64) THEN
- FAILED ("INCORRECT VALUE FOR INT'SUCC");
- END IF;
-
- IF INT'IMAGE (I0) /= IDENT_STR (" 0") OR
- INT'IMAGE (I1) /= IDENT_STR (" 63") OR
- INT'IMAGE (I2) /= IDENT_STR (" 126") THEN
- FAILED ("INCORRECT VALUE FOR INT'IMAGE");
- END IF;
-
- END GENPROC;
-
- PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT);
-
- BEGIN
-
- NEWPROC;
-
- END;
-
- RESULT;
-
-END CD2A32J;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada
deleted file mode 100644
index f1ce288..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada
+++ /dev/null
@@ -1,193 +0,0 @@
--- CD2A51A.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 WHEN A SIZE SPECIFICATION IS GIVEN FOR A
--- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 08/12/87 CREATED ORIGINAL TEST.
--- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE
--- SO THAT IT IS NOT A POWER OF TWO.
--- WMC 03/31/92 ELIMINATED TEST REDUNDANCIES.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A51A IS
-
- BASIC_SIZE : CONSTANT := 9;
-
- TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0;
-
- TYPE CHECK_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0;
-
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
- CNEG1 : CHECK_TYPE := -3.5;
- CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- CPOS2 : CHECK_TYPE := 3.5;
- CZERO : CHECK_TYPE;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE :=
- (-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5);
-
- TYPE REC_TYPE IS RECORD
- COMPN1 : CHECK_TYPE := -3.5;
- COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- COMPP2 : CHECK_TYPE := 3.5;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN FX;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE;
- N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE;
- CZOUT : OUT CHECK_TYPE) IS
- BEGIN
-
- IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR
- IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "UNARY ADDING OPERATORS - 1");
- END IF;
-
- IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "ABSOLUTE VALUE OPERATORS - 1");
- END IF;
-
- CZOUT := 0.0;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A51A", "CHECK THAT WHEN A SIZE SPECICFICATION IS " &
- "GIVEN FOR A FIXED POINT TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE " &
- "NOT AFFECTED BY THE REPRESENTATION CLAUSE");
-
- PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO);
-
- IF IDENT (CZERO) /= 0.0 THEN
- FAILED ("INCORRECT VALUE FOR OUT PARAMETER");
- END IF;
-
- IF CHECK_TYPE'LAST < IDENT (3.9375) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST");
- END IF;
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF CHECK_TYPE'AFT /= BASIC_TYPE'AFT THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'AFT");
- END IF;
-
- IF CNEG1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CNEG1'SIZE");
- END IF;
-
- IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR
- CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2");
- END IF;
-
- IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR
- CNEG2 IN -0.25 .. 0.0 OR
- IDENT (CNEG2) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 2");
- END IF;
-
- IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE");
- END IF;
-
- IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3");
- END IF;
-
- IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 3");
- END IF;
-
- IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR
- CHARRAY (1) IN -0.25 .. 0.0 OR
- IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
-
- IF CHREC.COMPP1'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMPP1'SIZE");
- END IF;
-
- IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN
- -2.875 .. -2.8125 OR
- CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN
- 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN
- -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4");
- END IF;
-
- IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR
- CHREC.COMPN2 IN -0.25 .. 0.0 OR
- IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
-
- RESULT;
-
-END CD2A51A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada
deleted file mode 100644
index 15613b5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada
+++ /dev/null
@@ -1,217 +0,0 @@
--- CD2A53A.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 WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A
--- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE
--- NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C)
--- and which support decimal small values:
--- The test must compile, bind, execute, report PASSED, and
--- complete normally.
---
--- For other implementations:
--- This test may produce at least one error message at compilation,
--- and the error message is associated with one of the items marked:
--- -- N/A => ERROR.
--- The test will be recorded as Not_Applicable.
--- Otherwise, the test must execute and report PASSED.
---
--- All other behaviors are FAILING.
---
--- HISTORY:
--- BCB 08/24/87 CREATED ORIGINAL TEST.
--- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
--- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE
--- SO THAT IT IS NOT A POWER OF TWO.
--- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES.
--- RLB 11/24/98 Added Ada 95 applicability criteria.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A53A IS
- BASIC_SIZE : CONSTANT := 15;
- BASIC_SMALL : CONSTANT := 0.01;
-
- ZERO : CONSTANT := 0.0;
-
- TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0;
-
- FOR CHECK_TYPE'SMALL USE BASIC_SMALL; -- N/A => ERROR.
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE; -- N/A => ERROR.
-
- CNEG1 : CHECK_TYPE := -2.7;
- CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- CPOS2 : CHECK_TYPE := 2.7;
- CZERO : CHECK_TYPE;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE :=
- (-2.7, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 2.7);
-
- TYPE REC_TYPE IS RECORD
- COMPF : CHECK_TYPE := -2.7;
- COMPN : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- COMPP : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- COMPL : CHECK_TYPE := 2.7;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN FX;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CN1IN, CP1IN : CHECK_TYPE;
- CN2INOUT,CP2INOUT : IN OUT CHECK_TYPE;
- CZOUT : OUT CHECK_TYPE) IS
- BEGIN
-
- IF IDENT (CN1IN) + CP1IN NOT IN -2.04 .. -2.03 OR
- CP2INOUT - IDENT (CP1IN) NOT IN 2.03 .. 2.04 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "BINARY ADDING OPERATORS - 1");
- END IF;
-
- IF CHECK_TYPE (CN1IN * IDENT (CP1IN)) NOT IN
- -1.81 .. -1.78 OR
- CHECK_TYPE (IDENT (CN2INOUT) / CP2INOUT) NOT IN
- -0.13 .. -0.12 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "MULTIPLYING OPERATORS - 1");
- END IF;
-
- IF IDENT (CP1IN) NOT IN 0.66 .. 0.670 OR
- CN2INOUT IN -0.32 .. 0.0 OR
- IDENT (CN2INOUT) IN -1.0 .. -0.35 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 1");
- END IF;
-
- CZOUT := 0.0;
-
- END PROC;
-
-BEGIN
- TEST ("CD2A53A", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " &
- "ARE GIVEN FOR A FIXED POINT TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " &
- "AFFECTED BY THE REPRESENTATION CLAUSE");
-
- PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO);
-
- IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CNEG1'SIZE");
- END IF;
-
- IF IDENT (CZERO) /= ZERO THEN
- FAILED ("INCORRECT VALUE FOR OUT PARAMETER");
- END IF;
-
- IF CHECK_TYPE'FIRST > IDENT (-3.99) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
- END IF;
-
- IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
- END IF;
-
- IF CHECK_TYPE'SMALL /= BASIC_SMALL THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SMALL");
- END IF;
-
- IF CHECK_TYPE'FORE /= 2 THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FORE");
- END IF;
-
- IF +IDENT (CNEG2) NOT IN -0.34 .. -0.33 OR
- IDENT (-CPOS1) NOT IN -0.67 .. -0.66 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2");
- END IF;
-
- IF ABS IDENT (CNEG2) NOT IN 0.33 .. 0.34 OR
- IDENT (ABS CPOS1) NOT IN 0.66 .. 0.670 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 2");
- END IF;
-
- IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
- END IF;
-
- IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN
- -2.04 .. -2.03 OR
- CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN
- 2.03 .. 2.04 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN
- -1.81 .. -1.78 OR
- CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN
- -0.13 .. -0.12 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3");
- END IF;
-
- IF IDENT (CHARRAY (2)) NOT IN 0.66 .. 0.670 OR
- CHARRAY (1) IN -0.32 .. 0.0 OR
- IDENT (CHARRAY (1)) IN -1.0 .. -0.35 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
-
- IF CHREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE");
- END IF;
-
- IF +IDENT (CHREC.COMPN) NOT IN -0.34 .. -0.33 OR
- IDENT (-CHREC.COMPP) NOT IN -0.67 .. -0.66 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4");
- END IF;
-
- IF ABS IDENT (CHREC.COMPN) NOT IN 0.33 .. 0.34 OR
- IDENT (ABS CHREC.COMPP) NOT IN 0.66 .. 0.670 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 4");
- END IF;
-
- IF IDENT (CHREC.COMPP) NOT IN 0.66 .. 0.670 OR
- CHREC.COMPN IN -0.32 .. 0.0 OR
- IDENT (CHREC.COMPN) IN -1.0 .. -0.35 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
-
- RESULT;
-
-END CD2A53A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada
deleted file mode 100644
index a023967..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada
+++ /dev/null
@@ -1,235 +0,0 @@
--- CD2A53E.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 WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A
--- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
--- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE WHEN THE TYPE
--- IS PASSED AS A GENERIC ACTUAL PARAMETER.
-
--- HISTORY:
--- BCB 08/24/87 CREATED ORIGINAL TEST.
--- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND CHANGED
--- OPERATORS ON 'SIZE TESTS.
--- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES.
--- MRM 07/16/92 FIX ALIGNMENT OF BLOCK BODY
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A53E IS
-
- BASIC_SIZE : CONSTANT := INTEGER'SIZE/2;
- BASIC_SMALL : CONSTANT := 2.0 ** (-4);
- B : BOOLEAN;
-
- TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0;
- FOR CHECK_TYPE'SMALL USE BASIC_SMALL;
- FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
-
-BEGIN
-
- TEST ("CD2A53E", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " &
- "ARE GIVEN FOR A FIXED POINT TYPE, THEN " &
- "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " &
- "AFFECTED BY THE REPRESENTATION CLAUSE WHEN " &
- "THE TYPE IS PASSED AS A GENERIC ACTUAL " &
- "PARAMETER");
-
- DECLARE
-
- GENERIC
-
- TYPE FIXED_ELEMENT IS DELTA <>;
-
- FUNCTION FUNC RETURN BOOLEAN;
-
- FUNCTION FUNC RETURN BOOLEAN IS
-
- ZERO : CONSTANT := 0.0;
-
- TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0;
-
- CNEG1 : FIXED_ELEMENT := -3.5;
- CNEG2 : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0);
- CPOS1 : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0);
- CPOS2 : FIXED_ELEMENT := 3.5;
- CZERO : FIXED_ELEMENT;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF FIXED_ELEMENT;
- CHARRAY : ARRAY_TYPE :=
- (-3.5, FIXED_ELEMENT (-1.0/3.0), FIXED_ELEMENT
- (4.0/6.0), 3.5);
-
- TYPE REC_TYPE IS RECORD
- COMPF : FIXED_ELEMENT := -3.5;
- COMPN : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0);
- COMPP : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0);
- COMPL : FIXED_ELEMENT := 3.5;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (FX : FIXED_ELEMENT) RETURN
- FIXED_ELEMENT IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN FX;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (CN1IN, CP1IN : FIXED_ELEMENT;
- CN2INOUT,CP2INOUT : IN OUT FIXED_ELEMENT;
- CZOUT : OUT FIXED_ELEMENT)
- IS
- BEGIN
-
- IF +IDENT (CN2INOUT) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CP1IN) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "UNARY ADDING OPERATORS - 1");
- END IF;
-
- IF ABS IDENT (CN2INOUT) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CP1IN) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "ABSOLUTE VALUE OPERATORS - 1");
- END IF;
-
- CZOUT := 0.0;
-
- END PROC;
-
- BEGIN -- FUNC
-
- PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO);
-
- IF IDENT (CZERO) /= ZERO THEN
- FAILED ("INCORRECT VALUE FOR OUT PARAMETER");
- END IF;
-
- IF FIXED_ELEMENT'LAST < IDENT (3.9375) THEN
- FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'LAST");
- END IF;
-
- IF FIXED_ELEMENT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SIZE");
- END IF;
-
- IF FIXED_ELEMENT'SMALL /= BASIC_SMALL THEN
- FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SMALL");
- END IF;
-
- IF FIXED_ELEMENT'AFT /= 1 THEN
- FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'AFT");
- END IF;
-
- IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CNEG1'SIZE");
- END IF;
-
- IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR
- CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING " &
- "OPERATORS - 2");
- END IF;
-
- IF FIXED_ELEMENT (CNEG1 * IDENT (CPOS1)) NOT IN
- -2.4375 .. -2.1875 OR
- FIXED_ELEMENT (IDENT (CNEG2) / CPOS2) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING " &
- "OPERATORS - 2");
- END IF;
-
- IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR
- CNEG2 IN -0.25 .. 0.0 OR
- IDENT (CNEG2) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 2");
- END IF;
-
- IF CHARRAY(1)'SIZE < IDENT_INT(BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
- END IF;
-
- IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING " &
- "OPERATORS - 3");
- END IF;
-
- IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 3");
- END IF;
-
- IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR
- CHARRAY (1) IN -0.25 .. 0.0 OR
- IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 3");
- END IF;
-
- IF CHREC.COMPP'SIZE < IDENT_INT(BASIC_SIZE) THEN
- FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE");
- END IF;
-
- IF IDENT (CHREC.COMPF) + CHREC.COMPP NOT IN
- -2.875 .. -2.8125 OR
- CHREC.COMPL - IDENT (CHREC.COMPP) NOT IN
- 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING " &
- "OPERATORS - 4");
- END IF;
-
- IF FIXED_ELEMENT (CHREC.COMPF * IDENT (CHREC.COMPP))
- NOT IN -2.4375 .. -2.1875 OR
- FIXED_ELEMENT (IDENT (CHREC.COMPN) / CHREC.COMPL)
- NOT IN -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING " &
- "OPERATORS - 4");
- END IF;
-
- IF IDENT (CHREC.COMPP) NOT IN 0.625 .. 0.6875 OR
- CHREC.COMPN IN -0.25 .. 0.0 OR
- IDENT (CHREC.COMPN) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
- "OPERATORS - 4");
- END IF;
-
- RETURN TRUE;
-
- END FUNC;
-
- FUNCTION NEWFUNC IS NEW FUNC(CHECK_TYPE);
- BEGIN
- B := NEWFUNC;
- END;
-
- RESULT;
-
-END CD2A53E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst b/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst
deleted file mode 100644
index 26413da..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst
+++ /dev/null
@@ -1,101 +0,0 @@
--- CD2A83C.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.
---*
--- OBJECTIVE:
--- CHECK THAT SIZE AND COLLECTION SIZE SPECIFICATIONS
--- FOR AN ACCESS TYPE CAN BE GIVEN IN THE VISIBLE OR
--- PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN
--- THE VISIBLE PART.
-
--- HISTORY:
--- JET 09/01/87 CREATED ORIGINAL TEST.
--- DHH 04/11/89 CHANGED OPERATOR ON 'SIZE CHECKS AND REMOVED
--- APPLICABILITY CRITERIA.
-
--- $ACC_SIZE IS THE SIZE IN BITS FOR AN ACCESS VARIABLE WHOSE
--- DESIGNATED TYPE IS A STRING TYPE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A83C IS
-
- SPECIFIED_SIZE : CONSTANT := $ACC_SIZE;
- COLL_SIZE : CONSTANT := 256;
-
- TYPE CHECK_ACC IS ACCESS STRING;
-
- FOR CHECK_ACC'STORAGE_SIZE USE COLL_SIZE;
-
- FOR CHECK_ACC'SIZE USE SPECIFIED_SIZE;
-
- PACKAGE P IS
- TYPE ACC_IN_P IS ACCESS STRING;
- FOR ACC_IN_P'STORAGE_SIZE USE COLL_SIZE;
- FOR ACC_IN_P'SIZE USE SPECIFIED_SIZE;
- TYPE PRIVATE_ACC IS PRIVATE;
- TYPE ALT_ACC_IN_P IS ACCESS STRING;
- PRIVATE
- TYPE PRIVATE_ACC IS ACCESS STRING;
- FOR ALT_ACC_IN_P'STORAGE_SIZE USE COLL_SIZE;
- FOR ALT_ACC_IN_P'SIZE USE SPECIFIED_SIZE;
- END P;
-
- USE P;
-
- MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
-
-BEGIN
-
- TEST("CD2A83C", "CHECK THAT WHEN SIZE AND COLLECTION SIZE " &
- "SPECIFICATIONS FOR AN ACCESS TYPE, " &
- "CAN BE GIVEN IN " &
- "THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR " &
- "A TYPE DECLARED IN THE VISIBLE PART");
-
- IF CHECK_ACC'SIZE /= MINIMUM_SIZE THEN
- FAILED ("CHECK_ACC'SIZE /= SPECIFIED_SIZE");
- END IF;
-
- IF CHECK_ACC'STORAGE_SIZE < COLL_SIZE THEN
- FAILED ("CHECK_ACC'STORAGE_SIZE TOO SMALL");
- END IF;
-
- IF ACC_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ACC_IN_P'SIZE /= SPECIFIED_SIZE");
- END IF;
-
- IF ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN
- FAILED ("ACC_IN_P'STORAGE_SIZE TOO SMALL");
- END IF;
-
- IF ALT_ACC_IN_P'SIZE /= MINIMUM_SIZE THEN
- FAILED ("ALT_ACC_IN_P'SIZE /= SPECIFIED_SIZE");
- END IF;
-
- IF ALT_ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN
- FAILED ("ALT_ACC_IN_P'STORAGE_SIZE TOO SMALL");
- END IF;
-
- RESULT;
-
-END CD2A83C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst b/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst
deleted file mode 100644
index 09acce9..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst
+++ /dev/null
@@ -1,134 +0,0 @@
--- CD2A91C.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.
---*
--- OBJECTIVE:
--- CHECK THAT A SIZE SPECIFICATION FOR A TASK TYPE CAN BE GIVEN IN
--- THE VISIBLE OR PRIVATE PART OF A PACKAGE.
-
--- MACRO SUBSTITUTION:
--- $TASK_SIZE IS THE NUMBER OF BITS NEEDED BY THE IMPLEMENTATION TO
--- HOLD ANY POSSIBLE OBJECT OF THE TASK TYPE "BASIC_TYPE".
-
--- HISTORY:
--- BCB 09/08/87 CREATED ORIGINAL TEST.
--- RJW 05/12/89 MODIFIED CHECKS INVOLVING 'SIZE ATTRIBUTE.
--- REMOVED APPLICABILTY CRITERIA.
--- DTN 11/20/91 DELETED SUBPARTS (B and C).
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2A91C IS
-
- BASIC_SIZE : CONSTANT := $TASK_SIZE;
-
- VAL : INTEGER := 1;
-
- TASK TYPE BASIC_TYPE IS
- ENTRY HERE(NUM : IN OUT INTEGER);
- END BASIC_TYPE;
-
- FOR BASIC_TYPE'SIZE USE BASIC_SIZE;
-
- BASIC_TASK : BASIC_TYPE;
-
- PACKAGE P IS
- TASK TYPE TASK_IN_P IS
- ENTRY HERE(NUM : IN OUT INTEGER);
- END TASK_IN_P;
- FOR TASK_IN_P'SIZE USE BASIC_SIZE;
- TASK TYPE ALT_TASK_IN_P IS
- ENTRY HERE(NUM : IN OUT INTEGER);
- END ALT_TASK_IN_P;
- PRIVATE
- FOR ALT_TASK_IN_P'SIZE USE BASIC_SIZE;
- END P;
-
- USE P;
-
- ALT_TASK : ALT_TASK_IN_P;
- IN_TASK : TASK_IN_P;
-
- TASK BODY BASIC_TYPE IS
- BEGIN
- SELECT
- ACCEPT HERE(NUM : IN OUT INTEGER) DO
- NUM := 0;
- END HERE;
- OR
- TERMINATE;
- END SELECT;
- END BASIC_TYPE;
-
- PACKAGE BODY P IS
- TASK BODY TASK_IN_P IS
- BEGIN
- SELECT
- ACCEPT HERE(NUM : IN OUT INTEGER) DO
- NUM := 0;
- END HERE;
- OR
- TERMINATE;
- END SELECT;
- END TASK_IN_P;
- TASK BODY ALT_TASK_IN_P IS
- BEGIN
- SELECT
- ACCEPT HERE(NUM : IN OUT INTEGER) DO
- NUM := 0;
- END HERE;
- OR
- TERMINATE;
- END SELECT;
- END ALT_TASK_IN_P;
- END P;
-
-BEGIN
- TEST ("CD2A91C", "CHECK THAT A SIZE SPECIFICATION FOR A TASK " &
- "TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE " &
- "PART OF A PACKAGE");
-
- BASIC_TASK.HERE(VAL);
-
- IF VAL /= IDENT_INT (0) THEN
- FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 1");
- END IF;
-
- VAL := 1;
-
- ALT_TASK.HERE(VAL);
-
- IF VAL /= IDENT_INT (0) THEN
- FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 2");
- END IF;
-
- VAL := 1;
-
- IN_TASK.HERE(VAL);
-
- IF VAL /= IDENT_INT (0) THEN
- FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 3");
- END IF;
-
-
- RESULT;
-END CD2A91C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada
deleted file mode 100644
index 580bb8d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada
+++ /dev/null
@@ -1,214 +0,0 @@
--- CD2B11A.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 COLLECTION SIZE SPECIFICATION CAN BE GIVEN FOR AN
--- ACCESS TYPE, THEN OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT
--- AFFECTED.
-
--- HISTORY:
--- BCB 11/01/88 CREATED ORIGINAL TEST.
--- RJW 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
--- ADDED CHECK FOR UNCHECKED_DEALLOCATION.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-WITH UNCHECKED_DEALLOCATION;
-PROCEDURE CD2B11A IS
-
- BASIC_SIZE : CONSTANT := 1024;
-
- TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- TYPE ACC_TYPE IS ACCESS MAINTYPE;
- SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3);
-
- FOR ACC_TYPE'STORAGE_SIZE USE BASIC_SIZE;
-
- TYPE RECORD_TYPE IS RECORD
- COMP : ACC_TYPE;
- END RECORD;
-
- CHECK_TYPE1 : ACC_TYPE;
- CHECK_TYPE2 : ACC_TYPE;
- CHECK_TYPE3 : ACC_TYPE(1..3);
-
- CHECK_ARRAY : ARRAY (1..2) OF ACC_TYPE;
-
- CHECK_RECORD1 : RECORD_TYPE;
- CHECK_RECORD2 : RECORD_TYPE;
-
- CHECK_PARAM1 : ACC_TYPE;
- CHECK_PARAM2 : ACC_TYPE;
-
- CHECK_NULL : ACC_TYPE := NULL;
-
- PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS
-
- BEGIN
-
- IF (ACC1.ALL /= ACC2.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS " &
- "- 1");
- END IF;
-
- IF EQUAL (3,3) THEN
- ACC2 := ACC1;
- END IF;
-
- IF ACC2 /= ACC1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "-1");
- END IF;
-
- IF (ACC1 IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 1");
- END IF;
-
- END PROC;
-
-BEGIN
-
- TEST ("CD2B11A", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " &
- "CAN BE GIVEN FOR AN ACCESS TYPE, THEN " &
- "OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " &
- "NOT AFFECTED");
-
- CHECK_PARAM1 := NEW MAINTYPE'(25,35,45);
- CHECK_PARAM2 := NEW MAINTYPE'(25,35,45);
-
- PROC (CHECK_PARAM1,CHECK_PARAM2);
-
- IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN
- FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE");
- END IF;
-
- CHECK_TYPE1 := NEW MAINTYPE'(25,35,45);
- CHECK_TYPE2 := NEW MAINTYPE'(25,35,45);
- CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3);
-
- CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45);
- CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45);
-
- CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45);
- CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45);
-
- IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_TYPE2 := CHECK_TYPE1;
- END IF;
-
- IF CHECK_TYPE2 /= CHECK_TYPE1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
- END IF;
-
- IF (CHECK_TYPE1 IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2");
- END IF;
-
- IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_ARRAY (2) := CHECK_ARRAY (1);
- END IF;
-
- IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
- END IF;
-
- IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3");
- END IF;
-
- IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_RECORD2 := CHECK_RECORD1;
- END IF;
-
- IF CHECK_RECORD2 /= CHECK_RECORD1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
- END IF;
-
- IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4");
- END IF;
-
- IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST");
- END IF;
-
- IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST");
- END IF;
-
- DECLARE
- TYPE ACC_CHAR IS ACCESS CHARACTER;
- FOR ACC_CHAR'STORAGE_SIZE USE 128;
-
- LIMIT : INTEGER :=
- (ACC_CHAR'STORAGE_SIZE * SYSTEM.STORAGE_UNIT)/CHARACTER'SIZE;
-
- ACC_ARRAY : ARRAY (1 .. LIMIT + 1) OF ACC_CHAR;
- PLACE : INTEGER;
-
- PROCEDURE FREE IS
- NEW UNCHECKED_DEALLOCATION (CHARACTER, ACC_CHAR);
- BEGIN
- FOR I IN ACC_ARRAY'RANGE LOOP
- ACC_ARRAY (IDENT_INT (I)) :=
- NEW CHARACTER'
- (IDENT_CHAR ((CHARACTER'VAL (I MOD 128))));
- PLACE := I;
- END LOOP;
- FAILED ("NO EXCEPTION RAISED WHEN COLLECTION SIZE EXCEEDED");
- EXCEPTION
- WHEN STORAGE_ERROR =>
- BEGIN
- FOR I IN 1 .. PLACE LOOP
- IF I MOD 2 = 0 THEN
- FREE (ACC_ARRAY (IDENT_INT (I)));
- END IF;
- END LOOP;
-
- FOR I IN 1 .. PLACE LOOP
- IF I MOD 2 = 1 AND THEN
- IDENT_CHAR (ACC_ARRAY (I).ALL) /=
- CHARACTER'VAL (I MOD IDENT_INT (128)) THEN
- FAILED ("INCORRECT VALUE IN ARRAY");
- END IF;
- END LOOP;
- END;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- RESULT;
-END CD2B11A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada
deleted file mode 100644
index 770d8d8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada
+++ /dev/null
@@ -1,196 +0,0 @@
--- CD2B11B.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 COLLECTION SIZE IS SPECIFIED FOR AN
--- ACCESS TYPE IN A GENERIC UNIT, THEN OPERATIONS ON VALUES OF THE
--- ACCESS TYPE ARE NOT AFFECTED.
-
--- HISTORY:
--- BCB 09/23/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2B11B IS
-
- BASIC_SIZE : CONSTANT := 1024;
- B : BOOLEAN;
-
-BEGIN
-
- TEST ("CD2B11B", "CHECK THAT IF A COLLECTION SIZE IS SPECIFIED " &
- "FOR AN ACCESS TYPE, THEN " &
- "OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " &
- "NOT AFFECTED");
-
- DECLARE
-
- GENERIC
- FUNCTION FUNC RETURN BOOLEAN;
-
- FUNCTION FUNC RETURN BOOLEAN IS
-
- TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER;
- TYPE ACC_TYPE IS ACCESS MAINTYPE;
- SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3);
-
- FOR ACC_TYPE'STORAGE_SIZE
- USE BASIC_SIZE;
-
- TYPE RECORD_TYPE IS RECORD
- COMP : ACC_TYPE;
- END RECORD;
-
- CHECK_TYPE1 : ACC_TYPE;
- CHECK_TYPE2 : ACC_TYPE;
- CHECK_TYPE3 : ACC_TYPE(1..3);
-
- CHECK_ARRAY : ARRAY (1..3) OF ACC_TYPE;
-
- CHECK_RECORD1 : RECORD_TYPE;
- CHECK_RECORD2 : RECORD_TYPE;
-
- CHECK_PARAM1 : ACC_TYPE;
- CHECK_PARAM2 : ACC_TYPE;
-
- CHECK_NULL : ACC_TYPE := NULL;
-
- PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS
-
- BEGIN
-
- IF (ACC1.ALL /= ACC2.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED " &
- "OBJECTS - 1");
- END IF;
-
- IF EQUAL (3,3) THEN
- ACC2 := ACC1;
- END IF;
-
- IF ACC2 /= ACC1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
- "OPERATORS - 1");
- END IF;
-
- IF (ACC1 IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "MEMBERSHIP TEST - 1");
- END IF;
-
- END PROC;
-
- BEGIN -- FUNC.
-
- CHECK_PARAM1 := NEW MAINTYPE'(25,35,45);
- CHECK_PARAM2 := NEW MAINTYPE'(25,35,45);
-
- PROC (CHECK_PARAM1,CHECK_PARAM2);
-
- IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN
- FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE");
- END IF;
-
- CHECK_TYPE1 := NEW MAINTYPE'(25,35,45);
- CHECK_TYPE2 := NEW MAINTYPE'(25,35,45);
- CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3);
-
- CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45);
- CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45);
-
- CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45);
- CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45);
-
- IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_TYPE2 := CHECK_TYPE1;
- END IF;
-
- IF CHECK_TYPE2 /= CHECK_TYPE1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 2");
- END IF;
-
- IF (CHECK_TYPE1 IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2");
- END IF;
-
- IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_ARRAY (2) := CHECK_ARRAY (1);
- END IF;
-
- IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 3");
- END IF;
-
- IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3");
- END IF;
-
- IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN
- FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_RECORD2 := CHECK_RECORD1;
- END IF;
-
- IF CHECK_RECORD2 /= CHECK_RECORD1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
- "- 4");
- END IF;
-
- IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4");
- END IF;
-
- IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST");
- END IF;
-
- IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN
- FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST");
- END IF;
-
- RETURN TRUE;
-
- END FUNC;
-
- FUNCTION NEWFUNC IS NEW FUNC;
-
- BEGIN
- B := NEWFUNC;
- END;
-
- RESULT;
-END CD2B11B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada
deleted file mode 100644
index e620bad7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada
+++ /dev/null
@@ -1,54 +0,0 @@
--- CD2B11D.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 EXPRESSION IN A COLLECTION SIZE CLAUSE
--- FOR AN ACCESS TYPE NEED NOT BE STATIC.
-
--- HISTORY:
--- BCB 09/23/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2B11D IS
-
- TYPE CHECK_TYPE IS ACCESS INTEGER;
- FOR CHECK_TYPE'STORAGE_SIZE USE 256;
-
- TYPE ACC_TYPE IS ACCESS INTEGER;
- FOR ACC_TYPE'STORAGE_SIZE USE IDENT_INT (256);
-
-BEGIN
-
- TEST ("CD2B11D", "CHECK THAT THE EXPRESSION IN A COLLECTION " &
- "SIZE SPECIFICATION FOR AN ACCESS TYPE "&
- "NEED NOT BE STATIC");
-
- IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN
- FAILED ("INCORRECT VALUE FOR STORAGE_SIZE");
- END IF;
-
- RESULT;
-END CD2B11D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada
deleted file mode 100644
index b71f032..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD2B11E.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 EXPRESSION IN A COLLECTION SIZE CLAUSE
--- FOR AN ACCESS TYPE IN A GENERIC UNIT NEED NOT BE STATIC.
-
--- HISTORY:
--- BCB 09/23/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2B11E IS
-
- B : BOOLEAN;
-
-BEGIN
-
- TEST ("CD2B11E", "CHECK THAT THE EXPRESSION IN A COLLECTION " &
- "SIZE CLAUSE FOR AN ACCESS TYPE IN A " &
- "GENERIC UNIT NEED NOT BE STATIC");
-
- DECLARE
-
- GENERIC
- FUNCTION FUNC RETURN BOOLEAN;
-
- FUNCTION FUNC RETURN BOOLEAN IS
-
- TYPE TEST_TYPE IS ACCESS INTEGER;
- FOR TEST_TYPE'STORAGE_SIZE USE 256;
-
- TYPE ACC_TYPE IS ACCESS INTEGER;
- FOR ACC_TYPE'STORAGE_SIZE
- USE IDENT_INT (256);
-
- BEGIN -- FUNC.
-
- IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN
- FAILED ("INCORRECT VALUE FOR STORAGE_SIZE");
- END IF;
-
- RETURN TRUE;
-
- END FUNC;
-
- FUNCTION NEWFUNC IS NEW FUNC;
-
- BEGIN
- B := NEWFUNC;
- END;
-
- RESULT;
-END CD2B11E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada
deleted file mode 100644
index ad15645..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CD2B11F.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 COLLECTION SIZE SPECIFICATION IS GIVEN FOR AN
--- ACCESS TYPE WHOSE DESIGNATED TYPE IS A DISCRIMINATED RECORD, THEN
--- OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT AFFECTED.
-
--- HISTORY:
--- BCB 09/29/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD2B11F IS
-
- BASIC_SIZE : CONSTANT := 1024;
-
- TYPE RECORD_TYPE(DISC : INTEGER := 100) IS RECORD
- COMP1 : INTEGER;
- COMP2 : INTEGER;
- COMP3 : INTEGER;
- END RECORD;
-
- TYPE ACC_RECORD IS ACCESS RECORD_TYPE;
- FOR ACC_RECORD'STORAGE_SIZE USE BASIC_SIZE;
-
- CHECK_RECORD1 : ACC_RECORD;
- CHECK_RECORD2 : ACC_RECORD;
-
-BEGIN
-
- TEST ("CD2B11F", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " &
- "IS GIVEN FOR AN ACCESS TYPE WHOSE " &
- "DESIGNATED TYPE IS A DISCRIMINATED RECORD, " &
- "THEN OPERATIONS ON VALUES OF THE ACCESS TYPE " &
- "ARE NOT AFFECTED");
-
- CHECK_RECORD1 := NEW RECORD_TYPE;
- CHECK_RECORD1.COMP1 := 25;
- CHECK_RECORD1.COMP2 := 25;
- CHECK_RECORD1.COMP3 := 150;
-
- IF ACC_RECORD'STORAGE_SIZE < BASIC_SIZE THEN
- FAILED ("INCORRECT VALUE FOR RECORD TYPE ACCESS " &
- "STORAGE_SIZE");
- END IF;
-
- IF CHECK_RECORD1.DISC /= IDENT_INT (100) THEN
- FAILED ("INCORRECT VALUE FOR RECORD DISCRIMINANT");
- END IF;
-
- IF ((CHECK_RECORD1.COMP1 /= CHECK_RECORD1.COMP2) OR
- (CHECK_RECORD1.COMP1 = CHECK_RECORD1.COMP3)) THEN
- FAILED ("INCORRECT VALUE FOR RECORD COMPONENT");
- END IF;
-
- IF EQUAL (3,3) THEN
- CHECK_RECORD2 := CHECK_RECORD1;
- END IF;
-
- IF CHECK_RECORD2 /= CHECK_RECORD1 THEN
- FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATOR");
- END IF;
-
- RESULT;
-END CD2B11F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada
deleted file mode 100644
index 8e58d81..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CD2B15C.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 COLLECTION SIZE IS LARGE ENOUGH TO HOLD SOME
--- VALUES OF THE DESIGNATED TYPE, CHECK THAT "STORAGE_ERROR"
--- IS RAISED BY AN ALLOCATOR WHEN INSUFFICIENT STORAGE IS
--- AVAILABLE.
-
--- HISTORY:
--- DHH 09/23/87 CREATED ORIGINAL TEST.
--- PMW 09/19/88 MODIFIED WITHDRAWN TEST.
--- THS 03/21/90 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND
--- COMPLETELY REVISED THE TEST TO PREVENT OPTIMIZATION.
--- LDC 09/20/90 REMOVED UNUSED VARIABLE, CHANGED FAIL CALLS TO
--- COMMENT FOR 'STORAGE_SIZE /= TO SPECIFIED SIZE,
--- MOVED LOOP FOR CHECK VALUES TO EXCEPTION HANDLER.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD2B15C IS
-
- SPECIFIED_SIZE : CONSTANT := 1000;
-
- TYPE CHECK_TYPE IS ACCESS INTEGER;
- FOR CHECK_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE;
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / SYSTEM.STORAGE_UNIT;
-
- TYPE ACC_ARRAY_TYPE IS ARRAY
- (INTEGER RANGE 1 .. (CHECK_TYPE'STORAGE_SIZE /
- UNITS_PER_INTEGER) + 1) OF CHECK_TYPE;
- ACC_ARRAY : ACC_ARRAY_TYPE;
-
- PLACE_I_STOPPED : INTEGER := 0;
-
-BEGIN
-
- TEST ("CD2B15C", "IF THE COLLECTION SIZE IS LARGE " &
- "ENOUGH TO HOLD SOME VALUES OF " &
- "THE DESIGNATED TYPE, CHECK THAT " &
- "STORAGE_ERROR IS RAISED BY AN " &
- "ALLOCATOR WHEN INSUFFICIENT STORAGE " &
- "IS AVAILABLE");
-
- IF CHECK_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
- FAILED ("CHECK_TYPE'STORAGE_SIZE IS LESS THEN THE VALUE " &
- "SPECIFIED IN THE REPRESENTATION CLAUSE");
-
- ELSIF CHECK_TYPE'STORAGE_SIZE > 2 * IDENT_INT (SPECIFIED_SIZE) THEN
- COMMENT ("VALUE FOR CHECK_TYPE'STORAGE_SIZE IS MORE THEN " &
- "TWICE THE SPECIFIED VALUE IN THE REPRESENTATION " &
- "CLAUSE");
- END IF;
-
- BEGIN
-
- FOR I IN ACC_ARRAY'RANGE LOOP
- ACC_ARRAY (I) := NEW INTEGER'(IDENT_INT (I));
- PLACE_I_STOPPED := I;
- END LOOP;
-
- FAILED ("NO EXCEPTION RAISED WHEN RESERVED SPACE " &
- "EXCEEDED");
-
- EXCEPTION
- WHEN STORAGE_ERROR =>
- FOR I IN 1 .. PLACE_I_STOPPED LOOP
- IF ACC_ARRAY (I).ALL /= IDENT_INT (I) THEN
- FAILED ("INCORRECT VALUE FOR ACC_ARRAY (" &
- INTEGER'IMAGE (I) & ")");
- END IF;
- END LOOP;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN RESERVED SPACE " &
- "EXCEEDED");
- END;
-
- RESULT;
-
-END CD2B15C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada
deleted file mode 100644
index 6dc5141..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CD2B16A.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 A COLLECTION SIZE CLAUSE IS GIVEN FOR A PARENT ACCESS TYPE,
--- THEN THE DERIVED TYPE HAS THE SAME COLLECTION SIZE, WHETHER THE
--- DERIVED TYPE IS DECLARED BEFORE OR AFTER THE PARENT COLLECTION
--- SIZE SPECIFICATION.
-
--- HISTORY:
--- DHH 09/29/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD2B16A IS
-BEGIN
- TEST ("CD2B16A", "IF A COLLECTION SIZE IS GIVEN FOR A " &
- "PARENT ACCESS TYPE, THEN THE DERIVED TYPE HAS " &
- "THE SAME COLLECTION SIZE, WHETHER THE " &
- "DERIVED TYPE IS DECLARED BEFORE OR AFTER " &
- "THE PARENT COLLECTION SIZE SPECIFICATION");
-
- DECLARE
-
- COLLECTION_SIZE : CONSTANT :=128;
- TYPE V IS ARRAY(1..4) OF INTEGER;
-
- TYPE CELL IS
- RECORD
- VALUE : V;
- END RECORD;
-
- TYPE LINK IS ACCESS CELL;
- TYPE NEWLINK1 IS NEW LINK;
-
- FOR LINK'STORAGE_SIZE USE
- COLLECTION_SIZE;
-
- TYPE NEWLINK2 IS NEW LINK;
-
- BEGIN -- ACTIVE DECLARE
-
- IF LINK'STORAGE_SIZE < COLLECTION_SIZE THEN
- FAILED("STORAGE_SIZE SMALLER THAN STORAGE_SIZE " &
- "SPECIFIED WAS ALLOCATED");
- END IF;
-
- IF LINK'STORAGE_SIZE /= NEWLINK1'STORAGE_SIZE THEN
- FAILED("STORAGE_SIZE OF THE FIRST DERIVED TYPE" &
- "IS NOT THE SAME SIZE AS THAT OF THE " &
- "PARENT");
- END IF;
-
- IF LINK'STORAGE_SIZE /= NEWLINK2'STORAGE_SIZE THEN
- FAILED("STORAGE_SIZE OF THE SECOND DERIVED TYPE" &
- "IS NOT THE SAME SIZE AS THAT OF THE " &
- "PARENT");
- END IF;
-
- END; --ACTIVE DECLARE
-
- RESULT;
-END CD2B16A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst b/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst
deleted file mode 100644
index d4f326b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst
+++ /dev/null
@@ -1,140 +0,0 @@
---CD2C11A.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.
---*
--- OBJECTIVE:
--- IF A TASK STORAGE SIZE SPECIFICATION IS GIVEN FOR A TASK
--- TYPE, THEN OPERATIONS ON VALUES OF THE TASK TYPE ARE NOT
--- AFFECTED.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY
--- DHH 09/24/87 CREATED ORIGINAL TEST.
--- RJW 07/06/88 REVISED THE TEST TO REMOVE UNINITIALIZED 'IN OUT'
--- PARAMETER. CHANGED EXTENSION TO 'TST'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2C11A IS
-
- TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
-
-BEGIN
-
- TEST ("CD2C11A", "IF A TASK STORAGE SIZE SPECIFICATION IS " &
- "GIVEN FOR A TASK TYPE, THEN OPERATIONS " &
- "ON VALUES OF THE TASK TYPE ARE NOT AFFECTED");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE FLT IS DIGITS 1;
-
- TASK TYPE TTYPE IS
- ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER);
- ENTRY MULT(Y : IN FLT; Z : IN OUT FLT);
- END TTYPE;
-
-
- M : INTEGER := 81;
- N : INTEGER := 0;
- V,W : FLT RANGE 1.0..512.0 := 2.0;
-
- FOR TTYPE'STORAGE_SIZE USE TASK_STORAGE_SIZE;
-
- T : TTYPE;
-
- END PACK;
-
- PACKAGE BODY PACK IS
- FUNCTION IDENT_FLT(FT : FLT) RETURN FLT IS
- BEGIN
- IF EQUAL(5,5) THEN
- RETURN FT;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FLT;
-
- TASK BODY TTYPE IS
- ITEMP : INTEGER := 0;
- FTEMP : FLT := 0.0;
- BEGIN
- ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER) DO
- ITEMP := J;
- IF EQUAL(3,3) THEN
- K := ITEMP;
- ELSE
- K := 0;
- END IF;
- END ADD;
- ACCEPT MULT(Y : IN FLT; Z : IN OUT FLT) DO
- FTEMP := Y;
- IF EQUAL(3,3) THEN
- Z := FTEMP;
- ELSE
- Z := 0.0;
- END IF;
- END MULT;
- END TTYPE;
-
- PROCEDURE TEST_TASK(G : IN TTYPE;
- S : IN FLT; T : IN OUT FLT) IS
- R : FLT := 4.0;
- BEGIN
- IF NOT (G'CALLABLE) OR G'TERMINATED THEN
- FAILED("TASK INSIDE PROCEDURE IS SHOWING " &
- "WRONG VALUE FOR 'CALLABLE OR " &
- "'TERMINATED");
- END IF;
- G.MULT(S,T);
- END TEST_TASK;
-
- BEGIN
-
- IF TTYPE'STORAGE_SIZE < IDENT_INT(TASK_STORAGE_SIZE) THEN
- FAILED("ACTUAL 'STORAGE_SIZE USED IS SMALLER " &
- "THAN SIZE REQUESTED");
- END IF;
-
- T.ADD(M,N);
-
- IF M /= IDENT_INT(N) THEN
- FAILED("TASK CALL PARAMETERS NOT EQUAL");
- END IF;
-
- V := IDENT_FLT(13.0);
- TEST_TASK(T,V,W);
- IF V /= IDENT_FLT(W) THEN
- FAILED("TASK AS PARAMETER FAILED");
- END IF;
-
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD2C11A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst b/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst
deleted file mode 100644
index 2e5a5fe..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst
+++ /dev/null
@@ -1,87 +0,0 @@
---CD2C11D.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.
---*
--- OBJECTIVE:
--- CHECK THAT THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE NEED
--- NOT BE STATIC.
-
--- MACRO SUBSTITUTION:
--- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
--- THE ACTIVATION OF A TASK.
-
--- HISTORY
--- DHH 09/29/87 CREATED ORIGINAL TEST
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD2C11D IS
-
-BEGIN
-
- TEST ("CD2C11D","THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE " &
- "NEED NOT BE STATIC");
-
- DECLARE
-
- STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
- PACKAGE PACK IS
- TASK TYPE CHECK_TYPE;
-
- FOR CHECK_TYPE'STORAGE_SIZE USE
- STORAGE_SIZE;
- TASK TYPE TTYPE IS
- ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER);
- END TTYPE;
-
- FOR TTYPE'STORAGE_SIZE USE IDENT_INT(STORAGE_SIZE);
-
- END PACK;
-
- PACKAGE BODY PACK IS
-
- TASK BODY TTYPE IS
- BEGIN
- ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER);
- END TTYPE;
-
- TASK BODY CHECK_TYPE IS
- BEGIN
- NULL;
- END CHECK_TYPE;
-
- BEGIN
-
- IF TTYPE'STORAGE_SIZE < IDENT_INT(STORAGE_SIZE) THEN
- FAILED("STORAGE_SIZE SPECIFIED IS " &
- "GREATER THAN MEMORY ALLOCATED");
- END IF;
-
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD2C11D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada
deleted file mode 100644
index f44e8ef..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada
+++ /dev/null
@@ -1,214 +0,0 @@
--- CD2D11A.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 SMALL SPECIFICATION IS GIVEN FOR A
--- FIXED POINT TYPE, THEN ARITHMETIC OPERATIONS ON VALUES OF THE
--- TYPE ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
-
--- HISTORY:
--- BCB 09/01/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD2D11A IS
-
- BASIC_SMALL : CONSTANT := 2.0 ** (-4);
-
- TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0;
-
- TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0;
-
- FOR CHECK_TYPE'SMALL USE BASIC_SMALL;
-
- CNEG1 : CHECK_TYPE := -3.5;
- CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- CPOS2 : CHECK_TYPE := 3.5;
- CZERO : CHECK_TYPE;
-
- TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE;
- CHARRAY : ARRAY_TYPE :=
- (-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5);
-
- TYPE REC_TYPE IS RECORD
- COMPN1 : CHECK_TYPE := -3.5;
- COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
- COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
- COMPP2 : CHECK_TYPE := 3.5;
- END RECORD;
-
- CHREC : REC_TYPE;
-
- FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN FX;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-
- PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE;
- N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE;
- CZOUT : OUT CHECK_TYPE) IS
- BEGIN
-
- IF IDENT (N1_IN) + P1_IN NOT IN
- -2.875 .. -2.8125 OR
- P2_INOUT - IDENT (P1_IN) NOT IN
- 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "BINARY ADDING OPERATORS - 1");
- END IF;
-
- IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR
- IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "UNARY ADDING OPERATORS - 1");
- END IF;
-
- IF CHECK_TYPE (N1_IN * IDENT (P1_IN)) NOT IN
- -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (N2_INOUT) / P2_INOUT) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "MULTIPLYING OPERATORS - 1");
- END IF;
-
- IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR " &
- "ABSOLUTE VALUE OPERATORS - 1");
- END IF;
-
- CZOUT := 0.0;
-
- END PROC;
-
-BEGIN
- TEST ("CD2D11A", "CHECK THAT IF A SMALL SPECIFICATION IS " &
- "GIVEN FOR AN FIXED POINT TYPE, THEN " &
- "ARITHMETIC OPERATIONS ON VALUES OF THE " &
- "TYPE ARE NOT AFFECTED BY THE REPRESENTATION " &
- "CLAUSE");
-
- PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO);
-
- IF IDENT (CZERO) /= 0.0 THEN
- FAILED ("INCORRECT VALUE FOR OUT PARAMETER");
- END IF;
-
- IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR
- CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2");
- END IF;
-
- IF +IDENT (CNEG2) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CPOS1) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2");
- END IF;
-
- IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2");
- END IF;
-
- IF ABS IDENT (CNEG2) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CPOS1) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 2");
- END IF;
-
- IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR
- CNEG2 IN -0.25 .. 0.0 OR
- IDENT (CNEG2) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
- END IF;
-
- IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN
- -2.875 .. -2.8125 OR
- CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN
- 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3");
- END IF;
-
- IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3");
- END IF;
-
- IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN
- -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3");
- END IF;
-
- IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 3");
- END IF;
-
- IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR
- CHARRAY (1) IN -0.25 .. 0.0 OR
- IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
- END IF;
-
- IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN
- -2.875 .. -2.8125 OR
- CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN
- 2.8125 .. 2.875 THEN
- FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4");
- END IF;
-
- IF +IDENT (CHREC.COMPN2) NOT IN -0.375 .. -0.3125 OR
- IDENT (-CHREC.COMPP1) NOT IN -0.6875 .. -0.625 THEN
- FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4");
- END IF;
-
- IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN
- -2.4375 .. -2.1875 OR
- CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN
- -0.125 .. -0.0625 THEN
- FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4");
- END IF;
-
- IF ABS IDENT (CHREC.COMPN2) NOT IN 0.3125 .. 0.375 OR
- IDENT (ABS CHREC.COMPP1) NOT IN 0.625 .. 0.6875 THEN
- FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
- "OPERATORS - 4");
- END IF;
-
- IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR
- CHREC.COMPN2 IN -0.25 .. 0.0 OR
- IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN
- FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
- END IF;
-
- RESULT;
-END CD2D11A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada
deleted file mode 100644
index abb3f6b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CD2D13A.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 SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE
--- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED
--- IN THE VISIBLE PART.
-
--- HISTORY:
--- BCB 09/01/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; WITH TEXT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CD2D13A IS
-
- SPECIFIED_SMALL : CONSTANT := 2.0 ** (-4);
-
- PACKAGE P IS
- TYPE FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0;
- FOR FIXED_IN_P'SMALL USE SPECIFIED_SMALL;
- TYPE ALT_FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0;
- PRIVATE
- FOR ALT_FIXED_IN_P'SMALL USE SPECIFIED_SMALL;
- END P;
-
- USE P;
-
-BEGIN
-
- TEST("CD2D13A", "A SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A PACKAGE FOR A FIXED " &
- "POINT TYPE DECLARED IN THE VISIBLE PART");
-
- IF FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN
- FAILED ("INCORRECT VALUE FOR FIXED_IN_P'SMALL");
- END IF;
-
- IF ALT_FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN
- FAILED ("INCORRECT VALUE FOR ALT_FIXED_IN_P'SMALL");
- END IF;
-
- RESULT;
-
-END CD2D13A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30001.a b/gcc/testsuite/ada/acats/tests/cd/cd30001.a
deleted file mode 100644
index d65e145..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30001.a
+++ /dev/null
@@ -1,284 +0,0 @@
--- CD30001.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 X'Address produces a useful result when X is an aliased
--- object.
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
--- Check that X'Address produces a useful result when X is an entity
--- whose Address has been specified.
---
--- Check that aliased objects and subcomponents are allocated on storage
--- element boundaries. Check that objects and subcomponents of by
--- reference types are allocated on storage element boundaries.
---
--- Check that for an array X, X'Address points at the first component
--- of the array, and not at the array bounds.
---
--- TEST DESCRIPTION:
--- This test defines a data structure (an array of records) where each
--- aspect of the data structure is aliased. The test checks 'Address
--- for each "layer" of aliased objects.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Reinforced for 2.1
--- 16 FEB 98 EDS Modified documentation
---!
-
------------------------------------------------------------------ CD30001_0
-
-with SPPRT13;
-package CD30001_0 is
-
- -- Check that X'Address produces a useful result when X is an aliased
- -- object.
- -- Check that X'Address produces a useful result when X is an object of
- -- a by-reference type.
- -- Check that X'Address produces a useful result when X is an entity
- -- whose Address has been specified.
- -- (using the new form of "for X'Address use ...")
- --
- -- Check that aliased objects and subcomponents are allocated on storage
- -- element boundaries. Check that objects and subcomponents of by
- -- reference types are allocated on storage element boundaries.
-
- type Simple_Enum_Type is (Just, A, Little, Bit);
-
- type Data is record
- Aliased_Comp_1 : aliased Simple_Enum_Type;
- Aliased_Comp_2 : aliased Simple_Enum_Type;
- end record;
-
- type Array_W_Aliased_Comps is array(1..2) of aliased Data;
-
- Aliased_Object : aliased Array_W_Aliased_Comps;
-
- Specific_Object : aliased Array_W_Aliased_Comps;
- for Specific_Object'Address use SPPRT13.Variable_Address2; -- ANX-C RQMT.
-
- procedure TC_Check_Aliased_Addresses;
-
- procedure TC_Check_Specific_Addresses;
-
- procedure TC_Check_By_Reference_Types;
-
-end CD30001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-package body CD30001_0 is
-
- package Simple_Enum_Type_Ref_Conv is
- new System.Address_To_Access_Conversions(Simple_Enum_Type);
-
- package Data_Ref_Conv is new System.Address_To_Access_Conversions(Data);
-
- package Array_W_Aliased_Comps_Ref_Conv is
- new System.Address_To_Access_Conversions(Array_W_Aliased_Comps);
-
- use type System.Address;
- use type System.Storage_Elements.Integer_Address;
- use type System.Storage_Elements.Storage_Offset;
-
- procedure TC_Check_Aliased_Addresses is
- use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
- use type Data_Ref_Conv.Object_Pointer;
- use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
-
- begin
-
- -- Check the object Aliased_Object
-
- if Aliased_Object'Address not in System.Address then
- Report.Failed("Aliased_Object'Address not an address");
- end if;
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(Aliased_Object'Address)
- /= Aliased_Object'Unchecked_Access then
- Report.Failed
- ("'Unchecked_Access does not match expected address value");
- end if;
-
- -- Check the element Aliased_Object(1)
-
- if Data_Ref_Conv.To_Address( Aliased_Object(1)'Access )
- /= Aliased_Object(1)'Address then
- Report.Failed
- ("Array element 'Access does not match expected address value");
- end if;
-
- -- Check that Array'Address points at the first component...
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Address( Aliased_Object'Access )
- /= Aliased_Object(1)'Address then
- Report.Failed
- ("Address of array object does not equal address of first component");
- end if;
-
- -- Check the components of Aliased_Object(2)
-
- if Simple_Enum_Type_Ref_Conv.To_Address(
- Aliased_Object(2).Aliased_Comp_1'Unchecked_Access)
- not in System.Address then
- Report.Failed("Component 2 'Unchecked_Access not a valid address");
- end if;
-
- if Aliased_Object(2).Aliased_Comp_2'Address not in System.Address then
- Report.Failed("Component 2 not located at a valid address ");
- end if;
-
- end TC_Check_Aliased_Addresses;
-
- procedure TC_Check_Specific_Addresses is
- use type System.Address;
- use type System.Storage_Elements.Integer_Address;
- use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
- use type Data_Ref_Conv.Object_Pointer;
- use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
- begin
-
- -- Check the object Specific_Object
-
- if System.Storage_Elements.To_Integer(Specific_Object'Address)
- /= System.Storage_Elements.To_Integer(SPPRT13.Variable_Address2) then
- Report.Failed
- ("Specific_Object not at address specified in representation clause");
- end if;
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(SPPRT13.Variable_Address2)
- /= Specific_Object'Unchecked_Access then
- Report.Failed("Specific_Object'Unchecked_Access not expected value");
- end if;
-
- -- Check the element Specific_Object(1)
-
- if Data_Ref_Conv.To_Address( Specific_Object(1)'Access )
- /= Specific_Object(1)'Address then
- Report.Failed
- ("Specific Array element 'Access does not correspond to the "
- & "elements 'Address");
- end if;
-
- -- Check that Array'Address points at the first component...
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Address( Specific_Object'Access )
- /= Specific_Object(1)'Address then
- Report.Failed
- ("Address of array object does not equal address of first component");
- end if;
-
- -- Check the components of Specific_Object(2)
-
- if Simple_Enum_Type_Ref_Conv.To_Address(
- Specific_Object(1).Aliased_Comp_1'Access)
- not in System.Address then
- Report.Failed("Access value of first record component for object at " &
- "specific address not a valid address");
- end if;
-
- if Specific_Object(2).Aliased_Comp_2'Address not in System.Address then
- Report.Failed("Second record component for object at specific " &
- "address not located at a valid address");
- end if;
-
- end TC_Check_Specific_Addresses;
-
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
-
- type Tagged_But_Not_Exciting is tagged record
- A_Bit_Of_Data : Boolean;
- end record;
-
- Tagged_Object : Tagged_But_Not_Exciting;
-
- procedure Muck_With_Addresses( It : in out Tagged_But_Not_Exciting;
- Its_Address : in System.Address ) is
- begin
- if It'Address /= Its_Address then
- Report.Failed("Address of object passed by reference does not " &
- "match address of object passed" );
- end if;
- end Muck_With_Addresses;
-
- procedure TC_Check_By_Reference_Types is
- begin
- Muck_With_Addresses( Tagged_Object, Tagged_Object'Address );
- end TC_Check_By_Reference_Types;
-
-end CD30001_0;
-
-------------------------------------------------------------------- CD30001
-
-with Report;
-with CD30001_0;
-procedure CD30001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD30001",
- "Check that X'Address produces a useful result when X is " &
- "an aliased object, or an entity whose Address has been " &
- "specified" );
-
--- Check that X'Address produces a useful result when X is an aliased
--- object.
---
--- Check that aliased objects and subcomponents are allocated on storage
--- element boundaries. Check that objects and subcomponents of by
--- reference types are allocated on storage element boundaries.
-
- CD30001_0.TC_Check_Aliased_Addresses;
-
--- Check that X'Address produces a useful result when X is an entity
--- whose Address has been specified.
-
- CD30001_0.TC_Check_Specific_Addresses;
-
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
-
- CD30001_0.TC_Check_By_Reference_Types;
-
- Report.Result;
-
-end CD30001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30002.a b/gcc/testsuite/ada/acats/tests/cd/cd30002.a
deleted file mode 100644
index 7b6fff7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30002.a
+++ /dev/null
@@ -1,207 +0,0 @@
--- CD30002.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 implementation supports Alignments for subtypes and
--- objects specified as factors and multiples of the number of storage
--- elements per word, unless those values cannot be loaded and stored.
--- Check that the largest alignment returned by default is supported.
---
--- Check that the implementation supports Alignments supported by the
--- target linker for stand-alone library-level objects of statically
--- constrained subtypes.
---
--- TEST DESCRIPTION:
--- This test defines several types and objects, specifying various
--- alignments for them (as factors and multiples of the number of
--- storage elements per word). It then checks the alignments by
--- declaring some objects, and checking that the integer values of
--- their addresses is mod the specified alignment. This will not
--- prevent false passes where the lucky compiler gets it right by
--- chance, but will catch compilers that specifically do not obey
--- the alignment clauses.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 09 MAY 96 SAIC Strengthened for 2.1
--- 26 FEB 97 PWB.CTA Allowed for unexpected word sizes
--- 16 FEB 98 EDS Modified documentation.
--- 26 SEP 98 RLB Fixed value on line 130 so check and dec. match.
--- 30 OCT 98 RLB Split Multiple_Alignment and revised the
--- calculation to work on all targets.
--- 18 JAN 99 RLB Repaired again to work on targets where word size
--- equals storage unit.
---!
-
------------------------------------------------------------------ CD30002_0
-
-with Impdef;
-with System.Storage_Elements;
-package CD30002_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
- -- Must be 1 or greater.
-
- Multiple_Type_Alignment : constant :=
- Integer'Min ( Impdef.Max_Default_Alignment,
- 2 * S_Units_per_Word );
- -- Calculate a reasonable alignment, but not larger than the
- -- implementation is required to support.
-
- Multiple_Object_Alignment : constant :=
- Integer'Min ( Impdef.Max_Linker_Alignment,
- 2 * S_Units_per_Word );
- -- Calculate a reasonable object alignment, but not larger than
- -- the implementation is required to support.
-
- Small_Alignment : constant :=
- Integer'Max ( S_Units_per_Word / 2, 1);
- -- Calculate a reasonable small alignment, but not less than 1.
- -- (If S_Units_per_Word = 1, 1/2 => 0 which causes problems
- -- verifying alignment.)
-
- subtype Storage_Element is System.Storage_Elements.Storage_Element;
-
- type Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
- for Some_Stuff'Alignment
- use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
-
- Library_Level_Object : Some_Stuff;
- for Library_Level_Object'Alignment
- use Impdef.Max_Linker_Alignment; -- ANX-C RQMT.
-
- type Quarter is mod 4; -- two bits
- for Quarter'Alignment use Small_Alignment; -- ANX-C RQMT.
-
- type Half is mod 16; -- nibble
- for Half'Alignment use Multiple_Type_Alignment; -- ANX-C RQMT.
-
- type O_Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
-
- type O_Quarter is mod 4; -- two bits
-
- type O_Half is mod 16; -- nibble
-
-end CD30002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD30002_0
-
-------------------------------------------------------------------- CD30002
-
-with Report;
-with Impdef;
-with CD30002_0;
-with System.Storage_Elements;
-procedure CD30002 is
-
- My_Stuff : CD30002_0.Some_Stuff;
- -- Impdef.Max_Default_Alignment
-
- My_Quarter : CD30002_0.Quarter;
- -- CD30002_0.S_Units_per_Word / 2
-
- My_Half : CD30002_0.Half;
- -- CD30002_0.S_Units_per_Word * 2
-
- Stuff_Object : CD30002_0.O_Some_Stuff;
- for Stuff_Object'Alignment
- use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
-
- Quarter_Object : CD30002_0.O_Quarter;
- for Quarter_Object'Alignment
- use CD30002_0.Small_Alignment; -- ANX-C RQMT.
-
- Half_Object : CD30002_0.O_Half;
- for Half_Object'Alignment
- use CD30002_0.Multiple_Object_Alignment; -- ANX-C RQMT.
-
- subtype IntAdd is System.Storage_Elements.Integer_Address;
- use type System.Storage_Elements.Integer_Address;
-
- function A2I(Value: System.Address) return IntAdd renames
- System.Storage_Elements.To_Integer;
-
- NAC : constant String := " not aligned correctly";
-
-begin -- Main test procedure.
-
- Report.Test ("CD30002", "Check that the implementation supports " &
- "Alignments for subtypes and objects specified " &
- "as factors and multiples of the number of " &
- "storage elements per word, unless those values " &
- "cannot be loaded and stored. Check that the " &
- "largest alignment returned by default is " &
- "supported. Check that the implementation " &
- "supports Alignments supported by the target " &
- "linker for stand-alone library-level objects " &
- "of statically constrained subtypes" );
-
- if A2I(CD30002_0.Library_Level_Object'Address)
- mod Impdef.Max_Linker_Alignment /= 0 then
- Report.Failed("Library_Level_Object" & NAC);
- end if;
-
- if A2I(My_Stuff'Address) mod Impdef.Max_Default_Alignment /= 0 then
- Report.Failed("Max alignment subtype" & NAC);
- end if;
-
- if A2I(My_Quarter'Address) mod (CD30002_0.Small_Alignment) /= 0 then
- Report.Failed("Factor of words subtype" & NAC);
- end if;
-
- if A2I(My_Half'Address) mod (CD30002_0.Multiple_Type_Alignment) /= 0 then
- Report.Failed("Multiple of words subtype" & NAC);
- end if;
-
- if A2I(Stuff_Object'Address) mod Impdef.Max_Default_Alignment /= 0 then
- Report.Failed("Stuff alignment object" & NAC);
- end if;
-
- if A2I(Quarter_Object'Address)
- mod (CD30002_0.Small_Alignment) /= 0 then
- Report.Failed("Factor of words object" & NAC);
- end if;
-
- if A2I(Half_Object'Address) mod (CD30002_0.Multiple_Object_Alignment) /= 0 then
- Report.Failed("Multiple of words object" & NAC);
- end if;
-
- Report.Result;
-
-end CD30002;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30003.a b/gcc/testsuite/ada/acats/tests/cd/cd30003.a
deleted file mode 100644
index af41449..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30003.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CD30003.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 Size clause for an object is supported if the specified
--- size is at least as large as the subtype's size, and correspond to a
--- size in storage elements that is a multiple of the object's (non-zero)
--- Alignment. RM 13.3(43)
---
--- TEST DESCRIPTION:
--- This test defines several types and then asserts specific sizes for
--- the, it then checks that the size set is reported back.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Corrected and strengthened for 2.1
--- 14 FEB 97 PWB.CTA Changed 'Size specifications to multiples
--- of System.Storage_Unit; restricted 'Size spec
--- for enumeration object to max integer size.
--- 16 FEB 98 EDS Modify Documentation.
--- 25 JAN 99 RLB Repaired to properly set and check sizes.
--- 29 JAN 99 RLB Added Pack pragma needed for some implementations.
--- Corrected to support a Storage_Unit size < 8.
---!
-
-------------------------------------------------------------------- CD30003
-
-with Report;
-with System;
-procedure CD30003 is
-
- ---------------------------------------------------------------------------
- -- types and subtypes
- ---------------------------------------------------------------------------
-
- type Bit is mod 2**1;
- for Bit'Size use 1; -- ANX-C RQMT.
-
- type Byte is mod 2**8;
- for Byte'Size use 8; -- ANX-C RQMT.
-
- type Smallword is mod 2**8;
- for Smallword'size use 16; -- ANX-C RQMT.
-
- type Byte_Array is array(1..4) of Byte;
- pragma Pack(Byte_Array); -- ANX-C RQMT.
- -- size should be 32
-
- type Smallword_Array is array(1..4) of Smallword;
- pragma Pack(Smallword_Array); -- Required if Storage_Unit > 16. -- ANX-C RQMT.
-
- -- Use to calulate maximum required size:
- type Max_Modular is mod System.Max_Binary_Modulus;
- type Max_Integer is range System.Min_Int .. System.Max_Int;
- Enum_Size : constant := Integer'Min (32,
- Integer'Min (Max_Modular'Size, Max_Integer'Size));
- type Transmission_Data is ( Empty, Input, Output, IO, Control );
- for Transmission_Data'Size use Enum_Size; -- ANX-C RQMT.
-
- -- Sizes to try:
-
- -- The basic sizes are based on a "normal" Storage_Unit = 8 implementation.
- -- We then use formulas to insure that the specified sizes meet the
- -- the minimum level of support and AI-0051.
-
- Modular_Single_Size : constant := Integer'Min (((8 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
- -- Calulate an appropriate, legal, and required to be supported size to
- -- try, which is the size of Byte. Note that object sizes must be
- -- a multiple of the storage unit for the compiler.
-
- Modular_Double_Size : constant := Integer'Min (((16 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
-
- Modular_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
-
- Array_Quad_Size : constant := ((4 * 8 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Array_Octo_Size : constant := ((4 * 16 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Rounded_Enum_Size : constant := ((Enum_Size + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Enum_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit,
- Integer'Min (Max_Modular'Size, Max_Integer'Size));
-
-
- ---------------------------------------------------------------------------
- -- objects
- ---------------------------------------------------------------------------
-
- Bit_8 : Bit :=0;
- for Bit_8'Size use System.Storage_Unit; -- ANX-C RQMT.
-
- Bit_G : Bit :=0;
- for Bit_G'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Byte_8 : Byte :=0;
- for Byte_8'Size use Modular_Single_Size; -- ANX-C RQMT.
-
- Byte_G : Byte :=0;
- for Byte_G'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Smallword_1 : Smallword :=0;
- for Smallword_1'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Smallword_2 : Smallword :=0;
- for Smallword_2'Size use Modular_Quad_Size; -- ANX-C RQMT.
-
- Byte_Array_1 : Byte_Array := (others=>0);
- for Byte_Array_1'Size use Array_Quad_Size; -- ANX-C RQMT.
-
- Smallword_Array_1 : Smallword_Array := (others=>0);
- for Smallword_Array_1'Size use Array_Octo_Size; -- ANX-C RQMT.
-
- Transmission_Data_1 : aliased Transmission_Data := Empty;
-
- Transmission_Data_2 : Transmission_Data := Control;
- for Transmission_Data_2'Size use Enum_Quad_Size; -- ANX-C RQMT.
-
-begin -- Main test procedure.
-
- Report.Test ("CD30003", "Check that Size clauses are supported for " &
- "values at least as large as the subtypes " &
- "size, and correspond to a size in storage " &
- "elements that is a multiple of the objects " &
- "(non-zero) Alignment" );
-
- if Bit_8'Size /= System.Storage_Unit then
- Report.Failed("Expected Bit_8'Size =" & Integer'Image(System.Storage_Unit)
- & " , actually =" & Integer'Image(Bit_8'Size));
- end if;
-
- if Bit_G'Size /= Modular_Double_Size then
- Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size)
- & " , actually =" & Integer'Image(Bit_G'Size));
- end if;
-
- if Byte_8'Size /= Modular_Single_Size then
- Report.Failed("Expected Byte_8'Size =" & Integer'Image(Modular_Single_Size)
- & " , actually =" & Integer'Image(Byte_8'Size));
- end if;
-
- if Byte_G'Size /= Modular_Double_Size then
- Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size)
- & " , actually =" & Integer'Image(Byte_G'Size));
- end if;
-
- if Smallword_1'Size /= Modular_Double_Size then
- Report.Failed("Expected Smallword_1'Size =" &
- Integer'Image(Modular_Double_Size) &
- ", actually =" & Integer'Image(Smallword_1'Size));
- end if;
-
- if Smallword_2'Size /= Modular_Quad_Size then
- Report.Failed("Expected Smallword_2'Size =" &
- Integer'Image(Modular_Quad_Size) &
- ", actually =" & Integer'Image(Smallword_2'Size));
- end if;
-
- if Byte_Array_1'Size /= Array_Quad_Size then
- Report.Failed("Expected Byte_Array_1'Size =" &
- Integer'Image(Array_Quad_Size) &
- ", actually =" & Integer'Image(Byte_Array_1'Size));
- end if;
-
- if Smallword_Array_1'Size /= Array_Octo_Size then
- Report.Failed(
- "Expected Smallword_Array_1'Size =" &
- Integer'Image(Array_Octo_Size) &
- ", actually =" & Integer'Image(Smallword_Array_1'Size));
- end if;
-
- if Transmission_Data_1'Size /= Enum_Size and then
- Transmission_Data_1'Size /= Rounded_Enum_Size then
- Report.Failed(
- "Expected Transmission_Data_1'Size =" & Integer'Image(Rounded_Enum_Size) &
- ", actually =" & Integer'Image(Transmission_Data_1'Size));
- end if;
-
- if Transmission_Data_2'Size /= Enum_Quad_Size then
- Report.Failed(
- "Expected Transmission_Data_2'Size =" & Integer'Image(Enum_Quad_Size) &
- ", actually =" & Integer'Image(Transmission_Data_2'Size));
- end if;
-
- Report.Result;
-
-end CD30003;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30004.a b/gcc/testsuite/ada/acats/tests/cd/cd30004.a
deleted file mode 100644
index 1a1bcff..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30004.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- CD30004.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 unspecified Size of static discrete
--- subtypes is the number of bits needed to represent each value
--- belonging to the subtype using an unbiased representation, where
--- space for a sign bit is provided only in the event the subtype
--- contains negative values. Check that for first subtypes specified
--- Sizes are supported reflecting this representation. [ARM 95 13.3(55)].
---
--- TEST DESCRIPTION:
--- This test defines a few types that should have distinctly recognizable
--- sizes. A packed record which should result in very specific bits
--- sizes for it's components is used to check the first part of the
--- objective. The second part of the objective is checked by giving
--- sizes for a similar set of types.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 06 MAY 96 SAIC Revised for 2.1
--- 26 FEB 97 PWB.CTA Added pragma Pack for type Check_Record
--- 16 FEB 98 EDS Modified Documentation.
--- 06 JUL 99 RLB Repaired comments, removed junk test cases.
--- Added test cases to test that appropriate Size
--- clauses are allowed.
-
---!
------------------------------------------------------------------ CD30004_0
-
-package CD30004_0 is
-
--- Check that the unspecified Size of static discrete and fixed point
--- subtypes are the number of bits needed to represent each value
--- belonging to the subtype using an unbiased representation, where
--- space for a sign bit is provided only in the event the subtype
--- contains negative values. Check that for first subtypes specified
--- Sizes are supported reflecting this representation.
-
- type Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit );
-
- type Bits_3 is range 0..2**3-1;
-
- type Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp
-
- type Bits_14 is mod 2**14;
-
- type Check_Record is
- record
- B14 : Bits_14;
- B2 : Bits_2;
- B3 : Bits_3;
- B5 : Bits_5;
- C : Character;
- end record;
- pragma Pack ( Check_Record );
-
- procedure TC_Check_Values;
- procedure TC_Check_Specified_Sizes;
-
-end CD30004_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-with Report;
-with Impdef;
-package body CD30004_0 is
-
- procedure TC_Check_Values is
- begin
-
- if Bits_2'Size /= 2 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_2'Size not 2 bits");
- else -- Recommended levels of support are not binding.
- Report.Comment("Bits_2'Size not 2 bits");
- end if;
- end if;
-
- if Bits_14'Size /= 14 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_14'Size not 14 bits");
- else
- Report.Comment("Bits_14'Size not 14 bits");
- end if;
- end if;
-
- if Bits_3'Size /= 3 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_3'Size not 3 bits");
- else
- Report.Comment("Bits_3'Size not 3 bits");
- end if;
- end if;
-
- if Bits_5'Size /= 5 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_5'Size not 5 bits");
- else
- Report.Comment("Bits_5'Size not 5 bits");
- end if;
- end if;
-
- if Character'Size /= 8 then
- Report.Failed("Character'Size not 8 bits");
- end if;
-
- if Wide_Character'Size /= 16 then
- Report.Failed("Wide_Character'Size not 16 bits");
- end if;
-
- end TC_Check_Values;
-
- type Spec_Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit );
- for Spec_Bits_2'Size use 2; -- ANX-C RQMT.
-
- type Spec_Bits_3 is range 0..2**3-1;
- for Spec_Bits_3'Size use 3; -- ANX-C RQMT.
-
- type Spec_Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp
- for Spec_Bits_5'Size use 5; -- ANX-C RQMT.
-
- type Spec_Bits_14 is mod 2**14;
- for Spec_Bits_14'Size use 14; -- ANX-C RQMT.
-
- type Spec_Record is new Check_Record;
- for Spec_Record'Size use 64; -- ANX-C RQMT.
-
- procedure TC_Check_Specified_Sizes is
-
- begin
-
- if Spec_Record'Size /= 64 then
- Report.Failed("Spec_Record'Size not 64 bits");
- end if;
-
- if Spec_Bits_2'Size /= 2 then
- Report.Failed("Spec_Bits_2'Size not 2 bits");
- end if;
-
- if Spec_Bits_14'Size /= 14 then
- Report.Failed("Spec_Bits_14'Size not 14 bits");
- end if;
-
- if Spec_Bits_3'Size /= 3 then
- Report.Failed("Spec_Bits_3'Size not 3 bits");
- end if;
-
- if Spec_Bits_5'Size /= 5 then
- Report.Failed("Spec_Bits_5'Size not 5 bits");
- end if;
-
- end TC_Check_Specified_Sizes;
-
-end CD30004_0;
-
-------------------------------------------------------------------- CD30004
-
-with Report;
-with CD30004_0;
-
-procedure CD30004 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD30004", "Check that the unspecified Size of static " &
- "discrete and fixed point subtypes is the number of bits " &
- "needed to represent each value belonging to the subtype " &
- "using an unbiased representation, where space for a sign " &
- "bit is provided only in the event the subtype contains " &
- "negative values. Check that for first subtypes " &
- "specified Sizes are supported reflecting this " &
- "representation.");
-
- CD30004_0.TC_Check_Values;
-
- CD30004_0.TC_Check_Specified_Sizes;
-
- Report.Result;
-
-end CD30004;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd300050.am b/gcc/testsuite/ada/acats/tests/cd/cd300050.am
deleted file mode 100644
index 81b6e33..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd300050.am
+++ /dev/null
@@ -1,154 +0,0 @@
--- CD30005.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 Address clauses are supported for imported subprograms.
---
--- TEST DESCRIPTION:
--- This test imports a simple C function and specifies it's location.
---
--- The implementation may choose to implement
--- Impdef.CD30005_1_Foreign_Address so as to dynamically call a C
--- function that returns the appropriate address for the external
--- function identified by Impdef.CD30005_1_External_Name.
---
--- TEST FILES:
--- CD300050.AM
--- CD300051.C -- the C function: (included below for reference)
---
--- SPECIAL REQUIREMENTS:
--- The file CD300051.C must be compiled with a C compiler.
--- Implementation dialects of C may require alteration of the C program
--- syntax. The program is included here for reference:
---
--- int _cd30005_1( Value )
--- {
--- /* int Value */
---
--- return Value + 1;
--- }
---
--- Implementations may require special linkage commands to include the
--- C code.
---
--- APPLICABILITY CRITERIA:
--- This test is not applicable to implementations not providing an interface
--- to C language units. OTHERWISE:
---
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 30 APR 96 SAIC Added commentary for 2.1
--- 09 MAY 96 SAIC Changed reporting for 2.1
--- 04 NOV 96 SAIC Added use type System.Address
--- 16 FEB 98 EDS Modified documentation.
--- 29 JUN 98 EDS Modified main program name.
---!
-
------------------------------------------------------------------ CD30005_0
-
-with Impdef;
-package CD30005_0 is
-
--- Check that Address clauses are supported for imported subprograms.
-
- type External_Func_Ref is access function(N:Integer) return Integer;
- pragma Convention( C, External_Func_Ref );
-
-
- function CD30005_1( I: Integer ) return Integer;
-
- pragma Import( C, CD30005_1,
- Impdef.CD30005_1_External_Name ); -- N/A => ERROR.
-
- for CD30005_1'Address use
- Impdef.CD30005_1_Foreign_Address; -- ANX-C RQMT.
-
- procedure TC_Check_Imports;
-
-end CD30005_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-package body CD30005_0 is
-
- use type System.Address;
-
- procedure TC_Check_Imports is
- S : External_Func_Ref := CD30005_1'Access;
- I,K : Integer := 99;
- begin
-
- K := S.all(I);
- if K /= 100 then
- Report.Failed("C program returned" & Integer'Image(K));
- end if;
-
- I := CD30005_1( I );
- if I /= 100 then
- Report.Failed("C program returned" & Integer'Image(I));
- end if;
-
- if CD30005_1'Address /= Impdef.CD30005_1_Foreign_Address then
- Report.Failed("Address not that specified");
- end if;
-
- end TC_Check_Imports;
-
-end CD30005_0;
-
-------------------------------------------------------------------- CD300050
-
-with Report;
-with CD30005_0;
-
-procedure CD300050 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD30005",
- "Check that Address clauses are supported for imported " &
- "subprograms" );
-
--- Check that Address clauses are supported for imported subprograms.
-
- CD30005_0.TC_Check_Imports;
-
- Report.Result;
-
-end CD300050;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd300051.c b/gcc/testsuite/ada/acats/tests/cd/cd300051.c
deleted file mode 100644
index 86e60a0..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd300051.c
+++ /dev/null
@@ -1,57 +0,0 @@
-/*
--- CD30051.C
---
--- 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.
---*
---
--- FUNCTION NAME: _cd3005_1
---
--- FUNCTION DESCRIPTION:
--- This C function returns the sum of its parameter and 1 through
--- the function name. The parameter is unchanged.
---
--- INPUTS:
--- This function requires that one parameter, of type int, be passed
--- to it.
---
--- PROCESSING:
--- The function will calculate the sum of its parameter and 1
--- and return this value as the function result through the function
--- name.
---
--- OUTPUTS:
--- The sum of the parameter and 1 is returned through function name.
---
--- CHANGE HISTORY:
--- 12 Oct 95 SAIC Initial prerelease version.
--- 14 Feb 97 PWB.CTA Created this file from code appearing in
--- CD30005.A (as comments).
---!
-*/
- int _cd30005_1(int Value )
- {
- /* int Value */
-
- return Value + 1;
- }
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30011.a b/gcc/testsuite/ada/acats/tests/cd/cd30011.a
deleted file mode 100644
index 2cd96a4..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30011.a
+++ /dev/null
@@ -1,155 +0,0 @@
--- CD30011.A
-
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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.
---
--- Notice
---
--- The ACAA has created and maintains the Ada Conformity Assessment Test
--- Suite for the purpose of conformity assessments conducted in accordance
--- with the International Standard ISO/IEC 18009 - Ada: Conformity
--- assessment of a language processor. This test suite should not be used
--- to make claims of conformance unless used in accordance with
--- ISO/IEC 18009 and any applicable ACAA procedures.
---
---*
--- OBJECTIVE:
--- Check that a size specification can be given by an attribute definition
--- clause for an enumeration type:
--- * in the visible or private part of a package for a type declared
--- in the visible part;
--- * for a derived enumeration type;
--- * for a derived private type whose full declaration is an
--- enumeration type.
---
--- TEST DESCRIPTION:
--- This test was created from legacy tests CD1009B and CD2A31C. The
--- objective of CD1009B was also an objective of CD2A31C; the tests
--- were merged to eliminate duplication and add appropriate applicability
--- criteria.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- or implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 17 Jun 87 PWB Created original test CD2A21C.
--- 07 Oct 87 VCL Created original test CD1009B.
--- 17 Apr 89 DHH Changed extension from '.DEP' TO '.ADA', changed
--- operators on 'Size tests, and added check on
--- representation clause.
--- 26 Mar 92 JRL Removed testing of nonobjective types.
--- 29 Mar 17 RLB Created test from CD2A21C and CD1009B; reformatted
--- to "modern" standards, added applicability criteria.
-
-with Report; use Report;
-with Length_Check; -- CONTAINS A CALL TO 'Failed'.
-procedure CD30011 is
-
- type Basic_Enum is (A, B, C, D, E);
- Specified_Size : constant := Basic_Enum'Size;
-
- Minimum_Size : Integer := Report.Ident_Int (Specified_Size);
-
- type Derived_Enum is new Basic_Enum;
- for Derived_Enum'Size use Specified_Size; -- ANX-C RQMT.
-
- package P is
- type Enum_in_P is (A1, B1, C1, D1, E1, F1, G1);
- for Enum_in_P'Size use Specified_Size; -- ANX-C RQMT.
- type private_Enum is private;
- type Alt_Enum_in_P is (A2, B2, C2, D2, E2, F2, G2);
- private
- type private_Enum is (A3, B3, C3, D3, E3, F3, G3);
- for Alt_Enum_in_P'Size use Specified_Size; -- ANX-C RQMT.
- end P;
-
- type Derived_Private_Enum is new P.Private_Enum;
- for Derived_Private_Enum'Size use Specified_Size; -- ANX-C RQMT.
-
- use P;
-
- procedure Check_1 is new Length_Check (Derived_Enum);
- procedure Check_2 is new Length_Check (Enum_in_P);
- procedure Check_3 is new Length_Check (Alt_Enum_in_P);
-
- X : Enum_in_P := A1;
- Y : Alt_Enum_in_P := A2;
-
-begin
-
- Report.Test ("CD30011", "Check that 'Size attribute definition clauses " &
- "can be given in the visible or private part " &
- "of a package for enumeration types declared " &
- "declared in the visible part, and for derived " &
- "enumeration types and derived private types " &
- "whose full declarations are as enumeration types");
-
- Check_1 (C, Specified_Size, "Derived_Enum");
- Check_2 (C1, Specified_Size, "Enum_in_P");
- Check_3 (C2, Specified_Size, "Alt_Enum_in_P");
-
- if Derived_Enum'Size /= Minimum_Size then
- Failed ("Derived_Enum'Size should not be greater than" &
- Integer'Image (Minimum_Size) & ". Actual Size is" &
- Integer'Image (Derived_Enum'Size));
- end if;
-
- if Enum_in_P'Size /= Minimum_Size then
- Failed ("Enum_in_P'Size should not be greater than" &
- Integer'Image (Minimum_Size) & ". Actual Size is" &
- Integer'Image (Enum_in_P'Size));
- end if;
-
- if Alt_Enum_in_P'Size /= Minimum_Size then
- Failed ("Alt_Enum_in_P'Size should not be greater than" &
- Integer'Image (Minimum_Size) & ". Actual Size is" &
- Integer'Image (Alt_Enum_in_P'Size));
- end if;
-
- if Derived_Private_Enum'Size /= Minimum_Size then
-
- Failed ("Derived_Private_Enum'Size should not be greater " &
- "than " & Integer'Image (Minimum_Size) & ". Actual Size is" &
- Integer'Image (Derived_Private_Enum'Size));
- end if;
-
- if X'Size < Specified_Size then
- Failed ("Object'Size is too small --" &
- Enum_in_P'Image (X));
- end if;
-
- if Y'Size < Specified_Size then
- Failed ("Object'Size is too small --" &
- Alt_Enum_in_P'Image (Y));
- end if;
-
- Report.Result;
-
-end CD30011;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30012.a b/gcc/testsuite/ada/acats/tests/cd/cd30012.a
deleted file mode 100644
index a55dfbd..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30012.a
+++ /dev/null
@@ -1,173 +0,0 @@
--- CD30012.A
-
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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.
---
--- Notice
---
--- The ACAA has created and maintains the Ada Conformity Assessment Test
--- Suite for the purpose of conformity assessments conducted in accordance
--- with the International Standard ISO/IEC 18009 - Ada: Conformity
--- assessment of a language processor. This test suite should not be used
--- to make claims of conformance unless used in accordance with
--- ISO/IEC 18009 and any applicable ACAA procedures.
---
---*
--- OBJECTIVE:
--- Check that a size specification can be given by an attribute definition
--- clause for an integer type:
--- * in the visible or private part of a package for a type declared
--- in the visible part;
--- * for a derived integer type;
--- * for a derived private type whose full declaration is an
--- integer type.
---
--- TEST DESCRIPTION:
--- This test was created from legacy tests CD1009B and CD2A31C. The
--- objective of CD1009B was also an objective of CD30012; the tests
--- were merged to eliminate duplication and add appropriate applicability
--- criteria.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- or implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 17 Jun 87 PWB Created original test CD2A31C.
--- 09 Sep 87 VCL Created original test CD1009A.
--- 06 Apr 89 DHH Changed extension from '.DEP' TO '.ADA', changed
--- size clause value to 9, and added representation
--- clause check and included test for for integer in a
--- generic unit.
--- 27 Mar 92 JRL Removed testing of nonobjective types.
--- 17 Jun 92 DTN Removed the length clause for type Private_Int.
--- 29 Mar 17 RLB Created test from CD2A31C and CD1009A; reformatted
--- to "modern" standards, added applicability criteria,
--- removed nonobjective packed array.
-
-with Report; use Report;
-with Length_Check; -- Contains a call to 'Failed'.
-procedure CD30012 is
-
- type Basic_Int is range -60 .. 80;
- Specified_Size : constant := 9;
-
- type Derived_Int is new Basic_Int;
- for Derived_Int'Size use Specified_Size; -- ANX-C RQMT.
-
- package P is
- type Int_in_P is range -125 .. 125;
- for Int_in_P'Size use Specified_Size; -- ANX-C RQMT.
- type Private_Int is private;
- type Alt_Int_in_P is range -125 .. 125;
- private
- type Private_Int is range -125 .. 125;
- for Alt_Int_in_P'Size use Specified_Size; -- ANX-C RQMT.
- end P;
-
- use P;
- type Derived_Private_Int is new Private_Int;
- for Derived_Private_Int'Size use Specified_Size; -- ANX-C RQMT.
- Minimum_Size : Integer := Report.Ident_Int (Specified_Size);
-
- -- Size specification given in a generic procedure:
-
- generic
- procedure Genproc;
-
- procedure Genproc is
- type Check_Int is range -125 .. 125;
- for Check_Int'Size use Specified_Size; -- ANX-C RQMT.
-
- procedure Check_4 is new Length_Check (Check_Int);
-
- begin
-
- if Check_Int'Size /= Minimum_Size then
- Failed ("Generic Check_Int'Size is incorrect");
- end if;
- Check_4 (-60, 9, "generic Check_Int");
-
- end Genproc;
-
- procedure Newproc is new Genproc;
-
- procedure Check_1 is new Length_Check (Derived_Int);
- procedure Check_2 is new Length_Check (Int_in_P);
- procedure Check_3 is new Length_Check (Alt_Int_in_P);
-
- Obj1 : Int_in_P := 92;
- Obj2 : Alt_Int_in_P := 52;
-
-begin
-
- Report.Test ("CD30012", "Check that 'Size attribute definition clauses " &
- "can be given in the visible or private part " &
- "of a package for integer types declared " &
- "declared in the visible part, and for derived " &
- "integer types and derived private types " &
- "whose full declarations are as integer types");
-
- Check_1 (-60, 9, "Derived_Int");
- Check_2 (-60, 9, "Int_in_P");
- Check_3 (-60, 9, "Alt_Int_in_P");
- Check_2 (Obj1, 9, "Int_in_P");
- Check_3 (Obj2, 9, "Alt_Int_in_P");
-
- Newproc;
-
- if Derived_Int'Size /= Minimum_Size then
- Failed ("Derived_Int'Size incorrect");
- end if;
-
- if Int_in_P'Size /= Minimum_Size then
- Failed ("Int_in_P'Size incorrect");
- end if;
-
- if Alt_Int_in_P'Size /= Minimum_Size then
- Failed ("Alt_Int_in_P'Size incorrect");
- end if;
-
- if Derived_Private_Int'Size /= Minimum_Size then
- Failed ("Derived_Private_Int'Size incorrect");
- end if;
-
- if Obj1'Size < Specified_Size then
- Failed ("Object'Size is too small --" &
- Int_in_P'Image (Obj1));
- end if;
-
- if Obj2'Size < Specified_Size then
- Failed ("Object'Size is too small --" &
- Alt_Int_in_P'Image (Obj2));
- end if;
-
- Report.Result;
-
-end CD30012;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada
deleted file mode 100644
index ee37df8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- CD3014A.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 ENUMERATION TYPE WITH A REPRESENTATION CLAUSE CAN
--- BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN
--- GENERIC INSTANTIATIONS.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
--- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
--- REVISED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR
--- MESSAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD3014A IS
-
-BEGIN
-
- TEST ("CD3014A", "CHECK THAT AN ENUMERATION TYPE WITH A " &
- "REPRESENTATION CLAUSE CAN BE USED CORRECTLY " &
- "IN ORDERING RELATIONS, INDEXING ARRAYS, AND " &
- "IN GENERIC INSTANTIATIONS");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y');
-
- FOR HUE USE (RED => 8, BLUE => 9,
- YELLOW => 10, 'R' => 11,
- 'B' => 12, 'Y' => 13);
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
-
- TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED);
-
- FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16,
- YELLOW => 19, BLUE => 41, RED => 46);
-
- TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
- COLOR1,BASIC1 : HUE1;
- BARRAY1 : BASE1;
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END PACK;
-
- PACKAGE BODY PACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
- PROCEDURE PROC1 IS NEW CHANGE(HUE1);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- BASIC1 := RED;
- COLOR1 := HUE1'PRED(BASIC1);
- IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
- COLOR > 'B') OR
- NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND
- 'Y' <= COLOR1 AND COLOR1 > 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
- PROC1(BASIC1,COLOR1);
-
- IF COLOR /= RED OR COLOR1 /= RED THEN
- FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
- NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND
- BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND
- BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1)
- THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3014A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada
deleted file mode 100644
index 9e8af89..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CD3014C.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN IN
--- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN
--- THE VISIBLE PART.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST
--- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED
--- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR
--- REPRESENTATION CLAUSE.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS CALL TO 'FAILED'
-PROCEDURE CD3014C IS
-
-BEGIN
-
- TEST ("CD3014C", "CHECK THAT AN ENUMERATION " &
- "REPRESENTATION CLAUSE CAN BE GIVEN IN THE " &
- "VISIBLE OR PRIVATE PART OF A PACKAGE FOR " &
- "A TYPE DECLARED IN THE VISIBLE PART");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE HUE IS (RED,BLUE,YELLOW);
- TYPE NEWHUE IS (RED,BLUE,YELLOW);
-
- FOR HUE USE
- (RED => 8, BLUE => 16,
- YELLOW => 32);
- A : HUE := BLUE;
- PRIVATE
-
- FOR NEWHUE USE (RED => 8, BLUE => 16, YELLOW => 32);
-
- B : NEWHUE := RED;
-
- TYPE INT_HUE IS RANGE 8 .. 32;
- FOR INT_HUE'SIZE USE HUE'SIZE;
-
- TYPE INT_NEW IS RANGE 8 .. 32;
- FOR INT_NEW'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE);
- PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW);
-
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_HUE (RED, 8, "HUE");
- CHECK_NEW (YELLOW, 32, "NEWHUE");
- END PACK;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3014C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada
deleted file mode 100644
index 6ce3f4c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada
+++ /dev/null
@@ -1,135 +0,0 @@
--- CD3014D.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 ENUMERATION TYPE WITH A REPRESENTATION CLAUSE IN A
--- GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING RELATIONS,
--- INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
--- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
--- REVISED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR
--- MESSAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD3014D IS
-
-BEGIN
-
- TEST ("CD3014D", "CHECK THAT AN ENUMERATION TYPE WITH A " &
- "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " &
- "BE USED CORRECTLY IN ORDERING RELATIONS, " &
- "INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y');
-
- FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
-
- TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED);
-
- FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16,
- YELLOW => 19, BLUE => 41, RED => 46);
-
- TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
- COLOR1,BASIC1 : HUE1;
- BARRAY1 : BASE1;
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
- PROCEDURE PROC1 IS NEW CHANGE(HUE1);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- BASIC1 := RED;
- COLOR1 := HUE1'PRED(BASIC1);
- IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
- COLOR > 'B') OR
- NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND
- 'Y' <= COLOR1 AND COLOR1 > 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
- PROC1(BASIC1,COLOR1);
-
- IF COLOR /= RED OR COLOR1 /= RED THEN
- FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
- NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND
- BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND
- BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1)
- THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3014D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada
deleted file mode 100644
index 430cc4b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CD3014F.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN
--- IN THE VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A
--- TYPE DECLARED IN THE VISIBLE PART.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST
--- DHH 03/29/89 CHANGED FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
--- RJW 09/18/89 REMOVED THE COMMENT "-- N/A => ERROR.".
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3014F IS
-
-BEGIN
-
- TEST ("CD3014F", "CHECK THAT AN ENUMERATION REPRESENTATION " &
- "CLAUSE CAN BE GIVEN IN THE VISIBLE " &
- "OR PRIVATE PART OF A GENERIC PACKAGE FOR " &
- "A TYPE DECLARED IN THE VISIBLE PART");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y');
- TYPE NEWHUE IS (RED,BLUE,YELLOW,'R','B','Y');
-
- FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
- A : HUE := BLUE;
-
- TYPE INT1 IS RANGE 8 .. 13;
- FOR INT1'SIZE USE HUE'SIZE;
-
- PRIVATE
-
- FOR NEWHUE USE (RED => 2, BLUE => 4, YELLOW => 6,
- 'R' => 8, 'B' => 10, 'Y' => 12);
-
- B : NEWHUE := RED;
- TYPE INT2 IS RANGE 2 .. 12;
- FOR INT2'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1);
- PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2);
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
- BEGIN
- CHECK_1 ('B', 12, "HUE");
- CHECK_2 ('B', 10, "NEWHUE");
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3014F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada
deleted file mode 100644
index 34b930d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- CD3015A.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 DERIVED ENUMERATION TYPE CAN BE USED CORRECTLY IN
--- ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC
--- INSTANTIATIONS, WHEN THERE IS NO ENUMERATION CLAUSE FOR THE
--- PARENT.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
--- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
--- REVISED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE
--- ERROR MESSAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD3015A IS
-
-BEGIN
-
- TEST ("CD3015A", "CHECK THAT A DERIVED ENUMERATION TYPE CAN BE " &
- "USED CORRECTLY IN ORDERING RELATIONS, " &
- "INDEXING ARRAYS, AND IN GENERIC " &
- "INSTANTIATIONS, WHEN THERE IS NO ENUMERATION " &
- "CLAUSE FOR THE PARENT");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y');
-
- TYPE HUE IS NEW MAIN;
- FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
-
- TYPE HUE1 IS NEW MAIN;
- FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16,
- 'R' => 19, 'B' => 41, 'Y' => 46);
-
- TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
- COLOR1,BASIC1 : HUE1;
- BARRAY1 : BASE1;
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END PACK;
-
- PACKAGE BODY PACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
- PROCEDURE PROC1 IS NEW CHANGE(HUE1);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- BASIC1 := RED;
- COLOR1 := HUE1'SUCC(BASIC1);
- IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
- COLOR > 'B') OR
- NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND
- 'Y' > COLOR1 AND COLOR1 <= 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
- PROC1(BASIC1,COLOR1);
-
- IF COLOR /= RED OR COLOR1 /= RED THEN
- FAILED("VALUES IN PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
- NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND
- BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND
- BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6)
- THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada
deleted file mode 100644
index c4ed238..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- CD3015C.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED
--- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE
--- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE NO
--- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT.
-
--- HISTORY
--- DHH 10/01/87 CREATED ORIGINAL TEST
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3015C IS
-
-BEGIN
-
- TEST ("CD3015C", "CHECK THAT AN ENUMERATION " &
- "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " &
- "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " &
- "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " &
- "VISIBLE PART, WHERE NO ENUMERATION CLAUSE HAS " &
- "BEEN GIVEN FOR THE PARENT");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW);
-
- TYPE HUE IS NEW MAIN;
- TYPE NEWHUE IS NEW MAIN;
-
- FOR HUE USE (RED => 1, BLUE => 16, YELLOW => 32);
- PRIVATE
- FOR NEWHUE USE (RED => 16, BLUE => 17, YELLOW => 18);
-
- TYPE INT1 IS RANGE 1 .. 32;
- FOR INT1'SIZE USE HUE'SIZE;
-
- TYPE INT2 IS RANGE 16 .. 18;
- FOR INT2'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1);
- PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2);
- END PACK;
-
- PACKAGE BODY PACK IS
-
- BEGIN
- CHECK_1 (RED, 1, "HUE");
- CHECK_2 (YELLOW, 18, "NEWHUE");
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada
deleted file mode 100644
index f0de7be..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- CD3015E.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 WHEN THERE IS NO ENUMERATION CLAUSE FOR THE PARENT
--- TYPE IN A GENERIC UNIT, THE DERIVED TYPE CAN BE USED CORRECTLY
--- IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC
--- INSTANTIATIONS.
-
--- HISTORY
--- DHH 10/05/87 CREATED ORIGINAL TEST
--- DHH 03/30/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED
--- CHECK FOR REPRESENTATION CLAUSE.
--- RJW 03/20/90 MODIFIED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING ON FAILURE ERROR MESSAGE.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3015E IS
-
-BEGIN
-
- TEST ("CD3015E", "CHECK THAT WHEN THERE " &
- "IS NO ENUMERATION CLAUSE FOR THE PARENT " &
- "TYPE IN A GENERIC UNIT, THE " &
- "DERIVED TYPE CAN BE USED CORRECTLY IN " &
- "ORDERING RELATIONS, INDEXING ARRAYS, AND IN " &
- "GENERIC INSTANTIATIONS");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y');
-
- TYPE HUE IS NEW MAIN;
- FOR HUE USE
- (RED => 1, BLUE => 6,
- YELLOW => 11, 'R' => 16,
- 'B' => 22, 'Y' => 30);
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
- T : INTEGER := 1;
-
- TYPE INT1 IS RANGE 1 .. 30;
- FOR INT1'SIZE USE HUE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1);
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- IF (COLOR < BASIC OR
- BASIC >= 'R' OR
- 'Y' <= COLOR OR
- COLOR > 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
-
- IF COLOR /= RED THEN
- FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- FOR I IN HUE LOOP
- BARRAY(I) := IDENT_INT(T);
- T := T + 1;
- END LOOP;
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- CHECK_1 (YELLOW, 11, "HUE");
-
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada
deleted file mode 100644
index 61e93ec..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- CD3015F.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED
--- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A GENERIC
--- PACKAGE FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE
--- NO ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT.
-
--- HISTORY
--- DHH 10/01/87 CREATED ORIGINAL TEST
--- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED
--- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR
--- REPRESENTATION CLAUSE.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3015F IS
-
-BEGIN
-
- TEST ("CD3015F", "CHECK THAT AN " &
- "ENUMERATION REPRESENTATION CLAUSE FOR A " &
- "DERIVED TYPE CAN BE GIVEN IN THE VISIBLE OR " &
- "PRIVATE PART OF A GENERIC PACKAGE FOR A " &
- "DERIVED TYPE DECLARED IN THE VISIBLE PART, " &
- "WHERE NO ENUMERATION CLAUSE HAS BEEN GIVEN " &
- "FOR THE PARENT");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y');
-
- TYPE HUE IS NEW MAIN;
- TYPE NEWHUE IS NEW MAIN;
-
- FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
-
- PRIVATE
- FOR NEWHUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
-
- TYPE INT_HUE IS RANGE 8 .. 13;
- FOR INT_HUE'SIZE USE HUE'SIZE;
-
- TYPE INT_NEW IS RANGE 8 .. 13;
- FOR INT_NEW'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE);
- PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW);
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- BEGIN
- CHECK_HUE (RED, 8, "HUE");
- CHECK_HUE ('R', 11, "NEWHUE");
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada
deleted file mode 100644
index 9158dc6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada
+++ /dev/null
@@ -1,136 +0,0 @@
--- CD3015G.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 DERIVED ENUMERATION TYPE WITH A REPRESENTATION
--- CLAUSE CAN BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING
--- ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN THERE IS AN
--- ENUMERATION CLAUSE FOR THE PARENT.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
--- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
--- REVISED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE
--- ERROR MESSAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD3015G IS
-
-BEGIN
-
- TEST ("CD3015G", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " &
- "REPRESENTATION CLAUSE CAN BE USED CORRECTLY " &
- "IN ORDERING RELATIONS, INDEXING ARRAYS, AND " &
- "IN GENERIC INSTANTIATIONS WHEN THERE IS AN " &
- "ENUMERATION CLAUSE FOR THE PARENT");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y');
-
- FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3, 'R' => 4,
- 'B' => 5, 'Y' => 6);
-
- TYPE HUE IS NEW MAIN;
- FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10,
- 'R' => 11, 'B' => 12, 'Y' => 13);
-
- TYPE HUE1 IS NEW MAIN;
- FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16,
- 'R' => 19, 'B' => 41, 'Y' => 46);
-
- TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
- COLOR1,BASIC1 : HUE1;
- BARRAY1 : BASE1;
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END PACK;
-
- PACKAGE BODY PACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
- PROCEDURE PROC1 IS NEW CHANGE(HUE1);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- BASIC1 := RED;
- COLOR1 := HUE1'SUCC(BASIC1);
- IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
- COLOR > 'B') OR
- NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND
- 'Y' > COLOR1 AND COLOR1 <= 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
- PROC1(BASIC1,COLOR1);
-
- IF COLOR /= RED OR COLOR1 /= RED THEN
- FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
- NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND
- BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND
- BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6)
- THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada
deleted file mode 100644
index ad55709..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- CD3015H.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED
--- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE
--- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE AN
--- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT.
-
--- HISTORY
--- DHH 10/01/87 CREATED ORIGINAL TEST
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3015H IS
-
-BEGIN
-
- TEST ("CD3015H", "CHECK THAT AN ENUMERATION " &
- "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " &
- "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " &
- "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " &
- "VISIBLE PART, WHERE AN ENUMERATION CLAUSE HAS " &
- "BEEN GIVEN FOR THE PARENT");
-
- DECLARE
- PACKAGE PACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW);
- FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3);
-
- TYPE HUE IS NEW MAIN;
- TYPE NEWHUE IS NEW MAIN;
-
- FOR HUE USE
- (RED => 8, BLUE => 9, YELLOW => 10);
-
- PRIVATE
-
- FOR NEWHUE USE (RED => 6, BLUE => 11, YELLOW => 18);
-
- TYPE INT1 IS RANGE 8 .. 10;
- FOR INT1'SIZE USE HUE'SIZE;
-
- TYPE INT2 IS RANGE 6 .. 18;
- FOR INT2'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1);
- PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2);
-
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_1 (RED, 8, "HUE");
- CHECK_2 (YELLOW, 18, "NEWHUE");
- END PACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015H;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada
deleted file mode 100644
index c1cf45b0..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- CD3015I.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 DERIVED ENUMERATION TYPE WITH A REPRESENTATION
--- CLAUSE IN A GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING
--- RELATIONS, INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN
--- THERE IS AN ENUMERATION CLAUSE FOR THE PARENT.
-
--- HISTORY
--- DHH 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
--- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
--- REVISED CHECK FOR ARRAY INDEXING.
--- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE
--- ERROR MESSAGE.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD3015I IS
-
-BEGIN
-
- TEST ("CD3015I", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " &
- "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " &
- "BE USED CORRECTLY IN ORDERING RELATIONS, " &
- "INDEXING ARRAYS, AND IN GENERIC " &
- "INSTANTIATIONS WHEN THERE IS AN ENUMERATION " &
- "CLAUSE FOR THE PARENT");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y');
- FOR MAIN USE
- (RED => 1, BLUE => 2,
- YELLOW => 3, 'R' => 4,
- 'B' => 5, 'Y' => 6);
-
- TYPE HUE IS NEW MAIN;
- FOR HUE USE
- (RED => 8, BLUE => 9,
- YELLOW => 10, 'R' => 11,
- 'B' => 12, 'Y' => 13);
-
- TYPE BASE IS ARRAY(HUE) OF INTEGER;
- COLOR,BASIC : HUE;
- BARRAY : BASE;
-
- TYPE HUE1 IS NEW MAIN;
- FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16,
- 'R' => 19, 'B' => 41, 'Y' => 46);
-
- TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
- COLOR1,BASIC1 : HUE1;
- BARRAY1 : BASE1;
-
- GENERIC
- TYPE ENUM IS (<>);
- PROCEDURE CHANGE(X,Y : IN OUT ENUM);
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
- T : ENUM;
- BEGIN
- T := X;
- X := Y;
- Y := T;
- END CHANGE;
-
- PROCEDURE PROC IS NEW CHANGE(HUE);
- PROCEDURE PROC1 IS NEW CHANGE(HUE1);
-
- BEGIN
- BASIC := RED;
- COLOR := HUE'SUCC(BASIC);
- BASIC1 := RED;
- COLOR1 := HUE1'SUCC(BASIC1);
- IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
- COLOR > 'B') OR
- NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND
- 'Y' > COLOR1 AND COLOR1 <= 'B') THEN
- FAILED("ORDERING RELATIONS ARE INCORRECT");
- END IF;
-
- PROC(BASIC,COLOR);
- PROC1(BASIC1,COLOR1);
-
- IF COLOR /= RED OR COLOR1 /= RED THEN
- FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
- "GENERIC UNIT NOT CORRECT AFTER CALL");
- END IF;
-
- BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
- IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
-
- IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
- BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
- BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
- NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND
- BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND
- BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6)
- THEN
- FAILED("INDEXING ARRAY FAILURE");
- END IF;
-
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada
deleted file mode 100644
index a075f88..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- CD3015K.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 ENUMERATION
--- REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN THE
--- VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A DERIVED TYPE
--- DECLARED IN THE VISIBLE PART, WHERE AN ENUMERATION CLAUSE
--- HAS BEEN GIVEN FOR THE PARENT.
-
--- HISTORY
--- DHH 10/01/87 CREATED ORIGINAL TEST
--- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
--- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
-
-WITH REPORT; USE REPORT;
-WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
-PROCEDURE CD3015K IS
-
-BEGIN
-
- TEST ("CD3015K", "CHECK THAT AN ENUMERATION REPRESENTATION " &
- "CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN " &
- "THE VISIBLE OR PRIVATE PART OF A GENERIC " &
- "PACKAGE FOR A DERIVED TYPE DECLARED IN " &
- "THE VISIBLE PART, WHERE AN ENUMERATION " &
- "CLAUSE HAS BEEN GIVEN FOR THE PARENT");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- TYPE MAIN IS (RED,BLUE,YELLOW);
- FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3);
-
- TYPE HUE IS NEW MAIN;
- TYPE NEWHUE IS NEW MAIN;
-
- FOR HUE USE (RED => 8, BLUE => 11, YELLOW => 12);
-
- PRIVATE
-
- FOR NEWHUE USE (RED => 6, BLUE => 12, YELLOW => 18);
-
- TYPE INT1 IS RANGE 8 .. 12;
- FOR INT1'SIZE USE HUE'SIZE;
-
- TYPE INT2 IS RANGE 6 .. 18;
- FOR INT2'SIZE USE NEWHUE'SIZE;
-
- PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1);
- PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2);
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- BEGIN
- CHECK_1 (RED, 8, "HUE");
- CHECK_2 (YELLOW, 18, "NEWHUE");
- END GENPACK;
-
- PACKAGE P IS NEW GENPACK;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD3015K;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada
deleted file mode 100644
index 4bad83b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CD3021A.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 AGGREGATE IN AN ENUMERATION REPRESENTATION CLAUSE
--- IS NOT AMBIGUOUS EVEN IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY
--- TYPES WITH THE ENUMERATION TYPE AS THE INDEX SUBTYPE.
-
--- HISTORY:
--- BCB 09/30/87 CREATED ORIGINAL TEST.
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
--- CHECKS FOR FAILURE.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD3021A IS
-
- TYPE ENUM IS (A,B,C);
-
- TYPE ARR1 IS ARRAY(ENUM) OF INTEGER;
- TYPE ARR2 IS ARRAY(ENUM) OF INTEGER;
- TYPE ARR3 IS ARRAY(ENUM) OF INTEGER;
-
- FOR ENUM USE (A => 1,B => 2,C => 3);
-
- A1 : ARR1 := (A => 5,B => 6,C => 13);
- A2 : ARR2 := (A => 1,B => 2,C => 3);
- A3 : ARR3 := (A => 0,B => 1,C => 2);
-
-BEGIN
-
- TEST ("CD3021A", "CHECK THAT THE AGGREGATE IN AN ENUMERATION " &
- "REPRESENTATION CLAUSE IS NOT AMBIGUOUS EVEN " &
- "IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY " &
- "TYPES WITH THE ENUMERATION TYPE AS THE INDEX " &
- "SUBTYPE");
-
- IF (A1 /= (IDENT_INT (5), IDENT_INT (6), IDENT_INT (13))) OR
- (A2 /= (IDENT_INT (1), IDENT_INT (2), IDENT_INT (3))) OR
- (A3 /= (IDENT_INT (0), IDENT_INT (1), IDENT_INT (2))) THEN
- FAILED ("INCORRECT VALUES FOR ARRAYS");
- END IF;
-
- RESULT;
-END CD3021A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33001.a b/gcc/testsuite/ada/acats/tests/cd/cd33001.a
deleted file mode 100644
index 8255505..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd33001.a
+++ /dev/null
@@ -1,139 +0,0 @@
--- CD33001.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 Component_Sizes that are a factor of the word
--- size are supported.
---
--- Check that for such Component_Sizes arrays contain no gaps between
--- components.
---
--- TEST DESCRIPTION:
--- This test defines three array types and specifies their layouts
--- using representation specifications for the 'Component_Size and
--- pragma Packs for each. It then checks that the implied assumptions
--- about the resulting layout actually can be made.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 24 AUG 96 SAIC Additional 2.1 revisions
--- 17 FEB 97 PWB.CTA Corrected prefix of 'Component_Size to name
--- array object instead of array subtype
--- 16 FEB 98 EDS Modified documentation.
---!
-
------------------------------------------------------------------ CD33001_0
-
-with System;
-package CD33001_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
-
- type Nibble is mod 2**4;
-
- type Byte is mod 2**8;
-
- type Half_Stuff is array(Natural range <>) of Nibble;
- for Half_Stuff'Component_Size
- use System.Word_Size / 2; -- factor -- ANX-C RQMT.
- pragma Pack(Half_Stuff); -- ANX-C RQMT.
-
- type Word_Stuff is array(Natural range <>) of Byte;
- for Word_Stuff'Component_Size
- use System.Word_Size; -- ANX-C RQMT.
-
- type Address_Calculator is record
- Item_1 : Nibble;
- Item_2 : Nibble;
- end record;
-
- for Address_Calculator use record
- Item_1 at 0 range 0..3;
- Item_2 at 1 range 0..3;
- end record;
-
- -- given that Item_1 is specified to be at 'Position = 0 and
- -- Item_2 is specified to be at 'Position = 1
- -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1
-
-end CD33001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD33001_0
-
-------------------------------------------------------------------- CD33001
-
-with Report;
-with System.Storage_Elements;
-with CD33001_0;
-procedure CD33001 is
-
- use type System.Storage_Elements.Storage_Offset;
-
- A_Half : CD33001_0.Half_Stuff(0..15);
-
- A_Word : CD33001_0.Word_Stuff(0..15);
-
- procedure Unexpected( Message : String; Wanted, Got: Integer ) is
- begin
- Report.Failed( Message & " Wanted:"
- & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) );
- end Unexpected;
-
-begin -- Main test procedure.
-
- Report.Test ("CD33001", "Check that Component_Sizes that are factor of " &
- "the word size are supported. Check that for " &
- "such Component_Sizes arrays contain no gaps " &
- "between components" );
-
- if A_Half'Size /= A_Half'Component_Size * 16 then
- Unexpected("Half word Size",
- CD33001_0.Half_Stuff'Component_Size * 16,
- A_Half'Size );
- end if;
-
- if A_Word(1)'Size /= System.Word_Size then
- Unexpected("Word Size", System.Word_Size, A_Word(1)'Size );
- end if;
-
-
- Report.Result;
-
-end CD33001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33002.a b/gcc/testsuite/ada/acats/tests/cd/cd33002.a
deleted file mode 100644
index 5b3cdbd..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd33002.a
+++ /dev/null
@@ -1,140 +0,0 @@
--- CD33002.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 Component_Sizes that are multiples of the word
--- size are supported.
---
--- Check that for such Component_Sizes arrays contain no gaps between
--- components.
---
--- TEST DESCRIPTION:
--- This test defines three array types and specifies their layouts
--- using representation specifications for the 'Component_Size and
--- pragma Packs for each. It then checks that the implied assumptions
--- about the resulting layout actually can be made.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 24 AUG 96 SAIC Additional 2.1 revisions
--- 16 FEB 98 EDS Modify documentation.
---!
-
------------------------------------------------------------------ CD33002_0
-
-with System;
-package CD33002_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
-
- type Nibble is mod 2**4;
-
- type Byte is mod 2**8;
-
- type Word_Stuff is array(Natural range <>) of Byte;
- for Word_Stuff'Component_Size
- use System.Word_Size; -- ANX-C RQMT.
- pragma Pack(Word_Stuff); -- ANX-C RQMT.
-
- type Double_Stuff is array(Natural range <>) of Byte;
- for Double_Stuff'Component_Size
- use System.Word_Size * 2; -- multiple -- ANX-C RQMT.
-
- type Address_Calculator is record
- Item_1 : Nibble;
- Item_2 : Nibble;
- end record;
-
- for Address_Calculator use record
- Item_1 at 0 range 0..3;
- Item_2 at 1 range 0..3;
- end record;
-
- -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1
- -- it therefore follows that:
- -- Address_Calculator'Size = 2 * Addressable_Unit'Size
-
-end CD33002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD33002_0
-
-------------------------------------------------------------------- CD33002
-
-with Report;
-with TCTouch;
-with System.Storage_Elements;
-with CD33002_0;
-procedure CD33002 is
-
- use type System.Storage_Elements.Storage_Offset;
-
- A_Word : CD33002_0.Word_Stuff(0..15);
-
- A_Double : CD33002_0.Double_Stuff(0..15);
-
- procedure Unexpected( Message : String; Wanted, Got: Integer ) is
- begin
- Report.Failed ( Message & " Wanted:"
- & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) );
- end Unexpected;
-
-begin -- Main test procedure.
-
- Report.Test ("CD33002", "Check that Component_Sizes that are multiples "
- & "of the word size are supported. Check that for "
- & "such Component_Sizes arrays contain no gaps "
- & "between components" );
-
- if A_Word'Size /= CD33002_0.Word_Stuff'Component_Size * 16 then
- Unexpected("Word Size",
- CD33002_0.Word_Stuff'Component_Size * 16,
- A_Word'Size );
- end if;
-
- if A_Double'Size /= CD33002_0.Double_Stuff'Component_Size * 16 then
- Unexpected("Double word Size",
- CD33002_0.Double_Stuff'Component_Size * 16,
- A_Double'Size );
- end if;
-
-
- Report.Result;
-
-end CD33002;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd40001.a b/gcc/testsuite/ada/acats/tests/cd/cd40001.a
deleted file mode 100644
index 273271f..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd40001.a
+++ /dev/null
@@ -1,181 +0,0 @@
--- CD40001.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 Enumeration_Representation_Clauses are supported for
--- codes in the range System.Min_Int..System.Max_Int.
---
--- TEST DESCRIPTION:
--- This test defines several types, and checks that the range of the
--- enumeration clause is as expected.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 16 FEB 98 EDS Modified Documentation.
---!
-
-with System;
-with Ada.Unchecked_Conversion;
-package CD40001_0 is
-
- type Press_The_Bounds is ( Negative_Large, Positive_Large );
-
- for Press_The_Bounds use
- ( Negative_Large => System.Min_Int, -- ANX-C RQMT.
- Positive_Large => System.Max_Int ); -- ANX-C RQMT.
-
- type Add_The_Bounds is
- ( Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
-
- for Add_The_Bounds use
- ( Monday => System.Min_Int, -- ANX-C RQMT.
- Tuesday => System.Min_Int + 1, -- ANX-C RQMT.
- Wednesday => System.Min_Int + 2, -- ANX-C RQMT.
- Thursday => System.Min_Int + 3, -- ANX-C RQMT.
- Friday => System.Min_Int + 4, -- ANX-C RQMT.
- Saturday => System.Min_Int + 5 ); -- ANX-C RQMT.
-
- type Minus_The_Bounds is ( Jan, Feb, Mar, Apr);
-
- for Minus_The_Bounds use
- ( Apr => System.Max_Int, -- ANX-C RQMT.
- Mar => System.Max_Int - 1, -- ANX-C RQMT.
- Feb => System.Max_Int - 2, -- ANX-C RQMT.
- Jan => System.Max_Int - 3 ); -- ANX-C RQMT.
-
- type TC_Integer is range System.Min_Int..System.Max_Int;
-
- procedure TC_Check_Press;
-
- procedure TC_Check_Add;
-
- procedure TC_Check_Minus;
-
- function TC_Compare_Press is new Ada.Unchecked_Conversion
- (Press_The_Bounds, TC_Integer);
-
- function TC_Compare_Add is new Ada.Unchecked_Conversion
- (Add_The_Bounds, TC_Integer);
-
- function TC_Compare_Minus is new Ada.Unchecked_Conversion
- (Minus_The_Bounds, TC_Integer);
-
-end CD40001_0;
-
- --==================================================================--
-
-with Report;
-package body CD40001_0 is
-
- procedure TC_Check_Press is
- My_Press_First : Press_The_Bounds := Negative_Large;
- My_Press_Last : Press_The_Bounds := Positive_Large;
- begin
- if TC_Compare_Press (My_Press_First) /= System.Min_Int or
- TC_Compare_Press (My_Press_Last) /= System.Max_Int
- then
- Report.Failed
- ("Expected enumeration size of System.Min_Int and System.Max_Int " &
- "not available for this implementation");
- end if;
- end TC_Check_Press;
-
- ---------------------------------------------------------------------------
- procedure TC_Check_Add is
- My_Monday : Add_The_Bounds := Monday;
- My_Tuesday : Add_The_Bounds := Tuesday;
- My_Wednesday : Add_The_Bounds := Wednesday;
- My_Thursday : Add_The_Bounds := Thursday;
- My_Friday : Add_The_Bounds := Friday;
- My_Saturday : Add_The_Bounds := Saturday;
- begin
- if TC_Compare_Add (My_Monday) /= (System.Min_Int) or
- TC_Compare_Add (My_Thursday) /= (System.Min_Int + 3) or
- TC_Compare_Add (My_Wednesday) /= (System.Min_Int + 2) or
- TC_Compare_Add (My_Tuesday) /= (System.Min_Int + 1) or
- TC_Compare_Add (My_Saturday) /= (System.Min_Int + 5) or
- TC_Compare_Add (My_Friday) /= (System.Min_Int + 4)
- then
- Report.Failed
- ("Expected enumeration size of System.Min_Int, System.Min_Int + 1 " &
- "through System.Min_Int + 5 not available for this implementation");
- end if;
- end TC_Check_Add;
-
- ---------------------------------------------------------------------------
- procedure TC_Check_Minus is
- My_Jan : Minus_The_Bounds := Jan;
- My_Feb : Minus_The_Bounds := Feb;
- My_Mar : Minus_The_Bounds := Mar;
- My_Apr : Minus_The_Bounds := Apr;
- begin
- if TC_Compare_Minus (My_Jan) /= (System.Max_Int - 3) or
- TC_Compare_Minus (My_Feb) /= (System.Max_Int - 2) or
- TC_Compare_Minus (My_Mar) /= (System.Max_Int - 1) or
- TC_Compare_Minus (My_Apr) /= (System.Max_Int)
- then
- Report.Failed
- ("Expected enumeration size of System.Max_Int, System.Max_Int - 1 " &
- "through System.Max_Int - 3 not available for this implementation");
- end if;
- end TC_Check_Minus;
-
-end CD40001_0;
-
- --==================================================================--
-
-with Report;
-with CD40001_0;
-
-procedure CD40001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD40001", "Check that Enumeration_Representation_Clauses " &
- "are supported for codes in the range " &
- "System.Min_Int..System.Max_Int" );
-
- CD40001_0.TC_Check_Press;
-
- CD40001_0.TC_Check_Add;
-
- CD40001_0.TC_Check_Minus;
-
- Report.Result;
-
-end CD40001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada b/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada
deleted file mode 100644
index 936088d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada
+++ /dev/null
@@ -1,95 +0,0 @@
--- CD4031A.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 WHEN A RECORD REPRESENTATION CLAUSE IS GIVEN FOR A
--- VARIANT RECORD TYPE, THEN COMPONENTS BELONGING TO DIFFERENT
--- VARIANTS CAN BE GIVEN OVERLAPPING STORAGE.
-
--- HISTORY:
--- PWB 07/22/87 CREATED ORIGINAL TEST.
--- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND
--- ADDED CHECK FOR REPRESENTATION CLAUSE.
--- RJW 06/12/90 REMOVED REFERENCES TO LENGTH_CHECK. REVISED
--- COMMENTS.
--- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's
--- complement machines to represent all values in
--- the specified number of bits.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD4031A IS
-
- TYPE DISCRIMINAN IS RANGE -1 .. 1;
- TYPE INT IS RANGE -3 .. 3;
- TYPE LARGE_INT IS RANGE -7 .. 7;
-
- TYPE TEST_CLAUSE (DISC : DISCRIMINAN := 0) IS
- RECORD
- CASE DISC IS
- WHEN 0 =>
- INTEGER_COMP : LARGE_INT;
- WHEN OTHERS =>
- CH_COMP_1 : INT;
- CH_COMP_2 : INT;
- END CASE;
- END RECORD;
-
- FOR TEST_CLAUSE USE
- RECORD
- DISC AT 0
- RANGE 0 .. 1;
- INTEGER_COMP AT 0
- RANGE 2 .. 5;
- CH_COMP_1 AT 0
- RANGE 2 .. 4;
- CH_COMP_2 AT 0
- RANGE 5 .. 7;
- END RECORD;
-
- TYPE TEST_CL1 IS NEW TEST_CLAUSE(DISC => 0);
- TYPE TEST_CL2 IS NEW TEST_CLAUSE(DISC => 1);
- TEST_RECORD : TEST_CL1;
- TEST_RECORD1 : TEST_CL2;
-
- INTEGER_COMP_FIRST,
- CH_COMP_1_FIRST : INTEGER;
-
-BEGIN
- TEST ("CD4031A", "IN RECORD REPRESENTATION CLAUSES " &
- "FOR VARIANT RECORD TYPES, " &
- "COMPONENTS OF DIFFERENT VARIANTS " &
- "CAN BE GIVEN OVERLAPPING STORAGE");
-
- TEST_RECORD := (0, -7);
- INTEGER_COMP_FIRST := TEST_RECORD.INTEGER_COMP'FIRST_BIT;
-
- TEST_RECORD1 := (1, -3, -3);
- CH_COMP_1_FIRST := TEST_RECORD1.CH_COMP_1'FIRST_BIT;
-
- IF INTEGER_COMP_FIRST /= CH_COMP_1_FIRST THEN
- FAILED ("COMPONENTS DO NOT BEGIN AT SAME POINT");
- END IF;
-
- RESULT;
-END CD4031A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst b/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst
deleted file mode 100644
index d0e2fd6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst
+++ /dev/null
@@ -1,92 +0,0 @@
--- CD4041A.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.
---*
--- OBJECTIVE:
--- CHECK THAT AN ALIGNMENT CLAUSE CAN BE GIVEN FOR A RECORD
--- REPRESENTATION CLAUSE.
-
--- HISTORY:
--- RJW 08/25/87 CREATED ORIGINAL TEST.
--- DHH 03/30/89 CHANGED MOD 4 TO A MACRO VALUE AND CHANGED
--- EXTENSION FROM '.DEP' TO '.TST'.
-
--- MACRO SUBSTITUTION:
--- $ALIGNMENT IS THE VALUE USED TO ALIGN A RECORD ON A BOUNDARY
--- DEFINED BY THE IMPLEMENTATION.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD4041A IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE CHECK_CLAUSE IS RECORD
- INT_COMP : INTEGER;
- CHAR_COMP : CHARACTER;
- END RECORD;
-
- FOR CHECK_CLAUSE USE
- RECORD AT MOD $ALIGNMENT;
- INT_COMP AT 0
- RANGE 0..INTEGER'SIZE - 1;
- CHAR_COMP AT 1*UNITS_PER_INTEGER
- RANGE 0..CHARACTER'SIZE - 1;
- END RECORD;
-
- CHECK_RECORD : CHECK_CLAUSE := (1, 'A');
-
-BEGIN
- TEST ("CD4041A", "CHECK THAT AN ALIGNMENT CLAUSE CAN BE " &
- "GIVEN FOR A RECORD REPRESENTATION CLAUSE");
-
- IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'LAST_BIT /=
- IDENT_INT (CHARACTER'SIZE - 1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'POSITION /=
- IDENT_INT (UNITS_PER_INTEGER) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP");
- END IF;
-
- RESULT;
-END CD4041A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada
deleted file mode 100644
index 746f82b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- CD4051A.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR
--- DERIVED TYPES WHOSE PARENT TYPES ARE RECORD TYPES WITHOUT
--- DISCRIMINANTS.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- RJW 08/25/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD4051A IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE BASIC_CLAUSE IS RECORD
- INT_COMP : INTEGER;
- CHAR_COMP : CHARACTER;
- END RECORD;
-
- TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE;
-
- FOR CHECK_CLAUSE USE
- RECORD
- INT_COMP AT 0
- RANGE 0..INTEGER'SIZE - 1;
- CHAR_COMP AT 1*UNITS_PER_INTEGER
- RANGE 0..CHARACTER'SIZE - 1;
- END RECORD;
-
- CHECK_RECORD : CHECK_CLAUSE := (1, 'A');
-
-BEGIN
- TEST ("CD4051A", "CHECK THAT A RECORD REPRESENTATION " &
- "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " &
- "WHOSE PARENT TYPE IS IS A RECORD TYPE " &
- "WITHOUT DISCRIMINANTS");
-
- IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'LAST_BIT /=
- IDENT_INT (CHARACTER'SIZE - 1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'POSITION /=
- IDENT_INT (UNITS_PER_INTEGER) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP");
- END IF;
-
- RESULT;
-END CD4051A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada
deleted file mode 100644
index 1cd440f..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- CD4051B.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 RECORD REPRESENTATION CLAUSE WHICH CHANGES THE
--- ORDER OF THE COMPONENT STORAGE CAN BE GIVEN FOR A DERIVED TYPE
--- WHOSE PARENT TYPE IS A RECORD WITHOUT A DISCRIMINANT.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- RJW 08/25/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD4051B IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE BASIC_CLAUSE IS RECORD
- INT_COMP : INTEGER;
- CHAR_COMP : CHARACTER;
- END RECORD;
-
- TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE;
-
- FOR CHECK_CLAUSE USE
- RECORD
- INT_COMP AT 1*UNITS_PER_INTEGER
- RANGE 0..INTEGER'SIZE - 1;
- CHAR_COMP AT 0
- RANGE 0..CHARACTER'SIZE - 1;
- END RECORD;
-
- CHECK_RECORD : CHECK_CLAUSE := (1, 'A');
-
-BEGIN
- TEST ("CD4051B", "CHECK THAT A RECORD REPRESENTATION " &
- "CLAUSE WHICH CHANGES THE ORDER OF COMPONENT " &
- "STORAGE CAN BE GIVEN FOR A DERIVED TYPE " &
- "WHOSE PARENT TYPE IS IS A RECORD TYPE " &
- "WITHOUT DISCRIMINANTS");
-
- IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'POSITION /=
- IDENT_INT (UNITS_PER_INTEGER) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'LAST_BIT /=
- IDENT_INT (CHARACTER'SIZE - 1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'POSITION /=
- IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP");
- END IF;
-
- RESULT;
-END CD4051B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada
deleted file mode 100644
index ea97f1c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- CD4051C.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR
--- A DERIVED TYPE WHOSE PARENT TYPE IS A RECORD WITH A
--- DISCRIMINANT.
-
--- HISTORY:
--- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
--- RJW 08/25/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD4051C IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
- SYSTEM.STORAGE_UNIT;
-
- TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD
- INT_COMP : INTEGER;
- CHAR_COMP : CHARACTER;
- END RECORD;
-
- TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE;
-
- FOR CHECK_CLAUSE USE
- RECORD
- DISC AT 0
- RANGE 0..BOOLEAN'SIZE - 1;
- INT_COMP AT 1*UNITS_PER_INTEGER
- RANGE 0..INTEGER'SIZE - 1;
- CHAR_COMP AT 2*UNITS_PER_INTEGER
- RANGE 0..CHARACTER'SIZE - 1;
- END RECORD;
-
- CHECK_RECORD : CHECK_CLAUSE (TRUE) := (TRUE, 1, 'A');
-
-BEGIN
- TEST ("CD4051C", "CHECK THAT A RECORD REPRESENTATION " &
- "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " &
- "WHOSE PARENT TYPE IS IS A RECORD TYPE " &
- "WITH DISCRIMINANTS");
-
- IF CHECK_RECORD.DISC'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC");
- END IF;
-
- IF CHECK_RECORD.DISC'LAST_BIT /= BOOLEAN'SIZE - 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC");
- END IF;
-
- IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF DISC");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'LAST_BIT /=
- IDENT_INT (INTEGER'SIZE - 1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.INT_COMP'POSITION /=
- IDENT_INT (UNITS_PER_INTEGER) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'LAST_BIT /=
- IDENT_INT (CHARACTER'SIZE - 1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP");
- END IF;
-
- IF CHECK_RECORD.CHAR_COMP'POSITION /=
- IDENT_INT (2 * UNITS_PER_INTEGER) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP");
- END IF;
-
- RESULT;
-END CD4051C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada
deleted file mode 100644
index 5b83c33..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CD4051D.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR
--- A DERIVED SUBTYPE WHOSE PARENT TYPE IS A RECORD TYPE WITH
--- VARIANTS AND THE REPRESENTATION CLAUSE MENTIONS COMPONENTS THAT
--- DO NOT EXIST IN THE DERIVED SUBTYPE.
-
--- HISTORY:
--- RJW 08/25/87 CREATED ORIGINAL TEST.
--- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND
--- ADDED CHECK FOR REPRESENTATION CLAUSE.
--- RJW 10/26/89 REMOVED REFERENCES TO LENGTH_CHECK.
--- THS 09/18/90 MADE CALLS TO IDENT_INT TO DEFEAT OPTIMIZATION.
--- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's
--- complement machines to represent all values in
--- the specified number of bits.
-
-WITH REPORT; USE REPORT;
-WITH SYSTEM;
-PROCEDURE CD4051D IS
-
- TYPE INT IS RANGE -3 .. 3;
- TYPE LARGE_INT IS RANGE -7 .. 7;
-
- TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD
- BOOL_COMP : BOOLEAN;
- CASE DISC IS
- WHEN FALSE =>
- INT_COMP : LARGE_INT;
- WHEN TRUE =>
- CH_COMP_1 : INT;
- CH_COMP_2 : INT;
- END CASE;
- END RECORD;
-
- TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE (TRUE);
-
- FOR CHECK_CLAUSE USE
- RECORD
- DISC AT 0
- RANGE 0 .. 0;
- BOOL_COMP AT 0
- RANGE 1 .. 1;
- INT_COMP AT 0
- RANGE 2 .. 5;
- CH_COMP_1 AT 0
- RANGE 2 .. 4;
- CH_COMP_2 AT 0
- RANGE 5 .. 7;
- END RECORD;
-
- CHECK_RECORD : CHECK_CLAUSE := (TRUE, TRUE, -2, -2);
-
-BEGIN
- TEST ("CD4051D", "CHECK THAT A RECORD REPRESENTATION " &
- "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " &
- "WHOSE PARENT TYPE IS A RECORD TYPE " &
- "WITH VARIANTS AND WHERE THE RECORD " &
- "REPRESENTATION CLAUSE MENTIONS COMPONENTS " &
- "THAT DO NOT EXIST IN THE DERIVED SUBTYPE");
-
- IF CHECK_RECORD.DISC'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC");
- END IF;
-
- IF CHECK_RECORD.DISC'LAST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC");
- END IF;
-
- IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF DISC");
- END IF;
-
- IF CHECK_RECORD.BOOL_COMP'FIRST_BIT /= IDENT_INT (1) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF BOOL_COMP");
- END IF;
-
- IF CHECK_RECORD.BOOL_COMP'LAST_BIT /= IDENT_INT (1) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF BOOL_COMP");
- END IF;
-
- IF CHECK_RECORD.BOOL_COMP'POSITION /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF BOOL_COMP");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_1'FIRST_BIT /= IDENT_INT (2) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_1");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_1'LAST_BIT /= IDENT_INT (4) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_1");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_1'POSITION /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_1");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_2'FIRST_BIT /= IDENT_INT (5) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_2");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_2'LAST_BIT /= IDENT_INT (7) THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_2");
- END IF;
-
- IF CHECK_RECORD.CH_COMP_2'POSITION /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_2");
- END IF;
-
- RESULT;
-END CD4051D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada
deleted file mode 100644
index 04a7c1a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- CD5003A.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN FOR
--- A PACKAGE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH'
--- CLAUSE IS GIVEN FOR THE SPECIFICATION.
-
--- HISTORY:
--- RJW 10/13/88 CREATED ORIGINAL TEST.
--- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY
--- CRITERIA AND N/A ERROR MESSAGES.
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-WITH SYSTEM;
-PACKAGE CD5003A_PKG2 IS
- PROCEDURE REQUIRE_BODY;
-END CD5003A_PKG2;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CD5003A_PKG2 IS
- TEST_VAR : INTEGER;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- TEST ("CD5003A", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " &
- "NEED NOT BE GIVEN FOR A PACKAGE BODY " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE SPECIFICATION");
-
- TEST_VAR := IDENT_INT (3);
-
- IF TEST_VAR /= 3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
-END CD5003A_PKG2;
-
-WITH REPORT; USE REPORT;
-WITH CD5003A_PKG2; USE CD5003A_PKG2;
-WITH SPPRT13;
-PROCEDURE CD5003A IS
-BEGIN
-
- RESULT;
-END CD5003A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada
deleted file mode 100644
index 789edd5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CD5003B.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN FOR
--- A PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH'
--- CLAUSE IS GIVEN FOR THE PROCEDURE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/04/87 CREATED ORIGINAL TEST.
--- RJW 10/13/88 INITIALIZED THE VARIABLE "CHECK_VAR".
--- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY
--- CRITERIA AND N/A ERROR MESSAGES.
-
-WITH SYSTEM;
-PROCEDURE CD5003B;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CD5003B IS
- TYPE ENUM IS (A0, A1, A2, A3, A4, A5);
-
- TEST_VAR : ENUM := A0;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- FUNCTION IDENT_ENUM (P : ENUM) RETURN ENUM IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN A0;
- END IF;
- END IDENT_ENUM;
-
-BEGIN
- TEST ("CD5003B", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " &
- "NEED NOT BE GIVEN FOR A PROCEDURE BODY " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE PROCEDURE " &
- "SPECIFICATION");
-
- TEST_VAR := IDENT_ENUM (A3);
-
- IF TEST_VAR /= A3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
- RESULT;
-END CD5003B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada
deleted file mode 100644
index 9ea5ae5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- CD5003C.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS
--- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE
--- PACKAGE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/04/87 CREATED ORIGINAL TEST.
--- PWB 05/12/89 CHANGED TO ".ADA" TEST.
-
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CD5003C IS
- PACKAGE CD5003C_PACK2 IS END CD5003C_PACK2;
-
- PACKAGE BODY CD5003C_PACK2 IS SEPARATE;
-
- USE CD5003C_PACK2;
-BEGIN
- RESULT;
-END CD5003C;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-SEPARATE (CD5003C)
-PACKAGE BODY CD5003C_PACK2 IS
- TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER;
-
- TEST_VAR : ATYPE := (OTHERS => 0);
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN (OTHERS => 0);
- END IF;
- END IDENT;
-BEGIN
- TEST ("CD5003C", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " &
- "BE GIVEN FOR A PACKAGE BODY SUBUNIT " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE UNIT " &
- "CONTAINING THE PACKAGE SPECIFICATION");
-
-
- TEST_VAR := IDENT (ATYPE'(OTHERS => 3));
-
- IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-END CD5003C_PACK2;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada
deleted file mode 100644
index a5a8378..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CD5003D.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS
--- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING
--- THE PROCEDURE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-PACKAGE CD5003D_PACK2 IS
- PROCEDURE CD5003D_PROC2;
-END CD5003D_PACK2;
-
-WITH SYSTEM;
-PACKAGE BODY CD5003D_PACK2 IS
- PROCEDURE CD5003D_PROC2 IS SEPARATE;
-END CD5003D_PACK2;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-SEPARATE (CD5003D_PACK2)
-PROCEDURE CD5003D_PROC2 IS
- TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0;
-
- TEST_VAR : FIXD := 0.0;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FIXD;
-BEGIN
- TEST ("CD5003D", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " &
- "GIVEN FOR A PROCEDURE BODY SUBUNIT " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE UNIT " &
- "CONTAINING THE PROCEDURE SPECIFICATION");
-
- TEST_VAR := IDENT_FIXD (3.3);
-
- IF TEST_VAR /= 3.3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
- RESULT;
-END CD5003D_PROC2;
-
-WITH CD5003D_PACK2; USE CD5003D_PACK2;
-PROCEDURE CD5003D IS
-BEGIN
- CD5003D_PROC2;
-END CD5003D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada
deleted file mode 100644
index 8c157f8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD5003E.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A TASK BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS LONG
--- AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE TASK
--- SPECIFICATION.
-
--- HISTORY:
--- VCL 09/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-
-WITH SYSTEM;
-PROCEDURE CD5003E IS
- TASK TASK2 IS
- ENTRY TST;
- END TASK2;
- TASK BODY TASK2 IS SEPARATE;
-BEGIN
- TASK2.TST;
-END CD5003E;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-SEPARATE (CD5003E)
-TASK BODY TASK2 IS
- TEST_VAR : INTEGER := 0;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
-BEGIN
- ACCEPT TST DO
- TEST ("CD5003E", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " &
- "BE GIVEN FOR A TASK BODY SUBUNIT " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG " &
- "AS A 'WITH' CLAUSE IS GIVEN FOR THE " &
- "UNIT CONTAINING THE TASK SPECIFICATION");
-
- TEST_VAR := IDENT_INT (3);
-
- IF TEST_VAR /= 3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
- RESULT;
- END TST;
-END TASK2;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada
deleted file mode 100644
index 1e54c6d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- CD5003F.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A GENERIC PACKAGE BODY CONTAINING AN ADDRESS CLAUSE
--- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE GENERIC PACKAGE
--- SPECIFICATION.
-
--- HISTORY:
--- VCL 09/09/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-WITH SYSTEM;
-GENERIC
-PACKAGE CD5003F_PACK2 IS
- PROCEDURE REQUIRE_BODY;
-END CD5003F_PACK2;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CD5003F_PACK2 IS
- TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER;
-
- TEST_VAR : ATYPE := (OTHERS => 0);
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN (OTHERS => 0);
- END IF;
- END IDENT;
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- TEST ("CD5003F", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " &
- "BE GIVEN FOR A GENERIC PACKAGE BODY " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE GENERIC " &
- "PACKAGE SPECIFICATION");
-
- TEST_VAR := IDENT (ATYPE'(OTHERS => 3));
-
- IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-END CD5003F_PACK2;
-
-WITH CD5003F_PACK2;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CD5003F IS
- PACKAGE CD5003F_PACK3 IS NEW CD5003F_PACK2;
-BEGIN
- RESULT;
-END CD5003F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada
deleted file mode 100644
index 5789fec..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CD5003G.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A GENERIC PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE
--- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING
--- THE GENERIC PROCEDURE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/09/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM;
-PACKAGE CD5003G_PACK2 IS
- GENERIC
- PROCEDURE CD5003G_PROC2;
-END CD5003G_PACK2;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-PACKAGE BODY CD5003G_PACK2 IS
- PROCEDURE CD5003G_PROC2 IS
- TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0;
-
- TEST_VAR : FIXD := 0.0;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-
- FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT_FIXD;
- BEGIN
- TEST ("CD5003G", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " &
- "BE GIVEN FOR A GENERIC PROCEDURE BODY " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS " &
- "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " &
- "CONTAINING THE GENERIC PROCEDURE " &
- "SPECIFICATION");
-
- TEST_VAR := IDENT_FIXD (3.3);
-
- IF TEST_VAR /= 3.3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
- RESULT;
- END CD5003G_PROC2;
-END CD5003G_PACK2;
-
-
-WITH CD5003G_PACK2; USE CD5003G_PACK2;
-PROCEDURE CD5003G IS
- PROCEDURE PROC3 IS NEW CD5003G_PROC2;
-BEGIN
- PROC3;
-END CD5003G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada
deleted file mode 100644
index c041856..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CD5003H.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A GENERIC PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS
--- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT
--- CONTAINING THE GENERIC PACKAGE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/09/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-WITH SYSTEM;
-PACKAGE CD5003H_PACK3 IS
-
- PROCEDURE REQUIRE_BODY;
-
- GENERIC
- PACKAGE PACK4 IS END PACK4;
-END CD5003H_PACK3;
-
-PACKAGE BODY CD5003H_PACK3 IS
-
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-
- PACKAGE BODY PACK4 IS SEPARATE;
-END CD5003H_PACK3;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-SEPARATE (CD5003H_PACK3)
-PACKAGE BODY PACK4 IS
- TEST_VAR : INTEGER := 0;
- FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
- USE SYSTEM;
-BEGIN
- TEST ("CD5003H", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " &
- "GIVEN FOR A GENERIC PACKAGE BODY SUBUNIT " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS " &
- "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " &
- "CONTAINING THE GENERIC PACKAGE SPECIFICATION.");
-
- TEST_VAR := IDENT_INT (3);
-
- IF TEST_VAR /= 3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-END PACK4;
-
-WITH CD5003H_PACK3; USE CD5003H_PACK3;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CD5003H IS
- PACKAGE PACK5 IS NEW PACK4;
-BEGIN
- RESULT;
-END CD5003H;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada
deleted file mode 100644
index 7ea6dc7..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- CD5003I.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 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN
--- FOR A GENERIC PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS
--- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT
--- CONTAINING THE GENERIC PROCEDURE SPECIFICATION.
-
--- HISTORY:
--- VCL 09/09/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-PACKAGE CD5003I_PACK3 IS
- GENERIC
- PROCEDURE PROC2;
-END CD5003I_PACK3;
-
-WITH SYSTEM;
-PACKAGE BODY CD5003I_PACK3 IS
- PROCEDURE PROC2 IS SEPARATE;
-END CD5003I_PACK3;
-
-WITH SPPRT13;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (SPPRT13);
-PRAGMA ELABORATE (REPORT);
-SEPARATE (CD5003I_PACK3)
-PROCEDURE PROC2 IS
- TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0;
-
- TEST_VAR : FIXD;
- FOR TEST_VAR
- USE AT SPPRT13.VARIABLE_ADDRESS;
-
- USE SYSTEM;
-
- FUNCTION IDENT (P : FIXD) RETURN FIXD IS
- BEGIN
- IF EQUAL (3, 3) THEN
- RETURN P;
- ELSE
- RETURN 0.0;
- END IF;
- END IDENT;
-BEGIN
- TEST ("CD5003I", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " &
- "GIVEN FOR A GENERIC PROCEDURE BODY SUBUNIT " &
- "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " &
- "'WITH' CLAUSE IS GIVEN FOR THE UNIT " &
- "CONTAINING THE GENERIC PROCEDURE SPECIFICATION");
-
- TEST_VAR := IDENT (3.3);
-
- IF TEST_VAR /= 3.3 THEN
- FAILED ("INCORRECT VALUE FOR TEST_VAR");
- END IF;
-
- IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR TEST_VAR");
- END IF;
-
- RESULT;
-END PROC2;
-
-WITH CD5003I_PACK3; USE CD5003I_PACK3;
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CD5003I IS
- PROCEDURE PROC3 IS NEW PROC2;
-BEGIN
- PROC3;
-END CD5003I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada
deleted file mode 100644
index b586f0d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CD5011A.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
--- ENUMERATION TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM.
-
--- HISTORY:
--- PWB 08/06/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5011A IS
-
- TYPE ENUM IS (RED, BLUE, 'R', 'B');
-
- PROCEDURE MIX IS
- HUE : ENUM := RED;
- FOR HUE USE
- AT SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- IF EQUAL (3, 3) THEN
- HUE := BLUE;
- END IF;
- IF HUE /= BLUE THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN PROCEDURE");
- END IF;
- IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN PROCEDURE");
- END IF;
- END MIX;
-
- FUNCTION FIX RETURN BOOLEAN IS
- LETTER : ENUM := 'R';
- FOR LETTER USE AT
- SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- IF EQUAL (3, 3) THEN
- LETTER := 'B';
- END IF;
- IF LETTER /= ENUM'LAST THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN FUNCTION");
- END IF;
- IF LETTER'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN FUNCTION");
- END IF;
- RETURN EQUAL(3,3);
- END FIX;
-
-BEGIN
-
- TEST ("CD5011A", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ENUMERATION " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "SUBPROGRAM.");
-
- IF NOT FIX THEN
- FAILED ("FUNCTION FIX YIELDS WRONG VALUE");
- END IF;
-
- MIX;
- RESULT;
-
-END CD5011A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada
deleted file mode 100644
index 45b2490..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada
+++ /dev/null
@@ -1,69 +0,0 @@
--- CD5011C.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF
--- AN INTEGER TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY.
-
--- HISTORY:
--- JET 09/11/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011C IS
-
- PACKAGE CD5011C_PACKAGE IS
- END CD5011C_PACKAGE;
-
- PACKAGE BODY CD5011C_PACKAGE IS
-
- INT : INTEGER := 0;
- FOR INT USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- TEST ("CD5011C", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN INTEGER " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "PACKAGE BODY");
-
- IF EQUAL (3, 3) THEN
- INT := 5;
- END IF;
- IF INT /= IDENT_INT (5) THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN PACKAGE");
- END IF;
- IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE");
- END IF;
- END;
-
-BEGIN
-
- RESULT;
-
-END CD5011C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada
deleted file mode 100644
index 2806fb2..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- CD5011E.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- FLOATING POINT TYPE IN THE DECLARATIVE PART OF A BLOCK
--- STATEMENT.
-
--- HISTORY:
--- JET 09/11/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011E IS
-
-BEGIN
-
- TEST ("CD5011E", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A FLOATING POINT " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "BLOCK STATEMENT");
-
- DECLARE
-
- FP : FLOAT := 3.0;
- FOR FP USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- FP := 2.0;
- END IF;
-
- IF FP /= 2.0 THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK");
- END IF;
-
- IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK");
- END IF;
-
- END;
-
- RESULT;
-
-END CD5011E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada
deleted file mode 100644
index 1b63ba5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- CD5011G.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- FIXED POINT TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM.
-
--- HISTORY:
--- JET 09/11/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011G IS
-
- TYPE FIX_TYPE IS DELTA 0.125 RANGE 0.0 .. 10.0;
-
- PROCEDURE CD5011G_PROC IS
-
- FP : FIX_TYPE := 2.0;
- FOR FP USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- FP := 3.0;
- END IF;
-
- IF FP /= 3.0 THEN
- FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE");
- END IF;
-
- IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE");
- END IF;
-
- END CD5011G_PROC;
-
-BEGIN
- TEST ("CD5011G", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A FIXED POINT " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "SUBPROGRAM");
-
- CD5011G_PROC;
-
- RESULT;
-
-END CD5011G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada
deleted file mode 100644
index a0a8418..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- CD5011I.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF
--- AN ARRAY TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY.
-
--- HISTORY:
--- JET 09/11/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011I IS
-
- PACKAGE CD5011I_PACKAGE IS
- END CD5011I_PACKAGE;
-
- PACKAGE BODY CD5011I_PACKAGE IS
-
- INT : ARRAY (1 .. 10) OF INTEGER;
- FOR INT USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- TEST ("CD5011I", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ARRAY " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "PACKAGE BODY");
-
- FOR I IN INT'RANGE LOOP
- INT (I) := IDENT_INT (I);
- END LOOP;
-
- FOR I IN INT'RANGE LOOP
- IF INT (I) /= I THEN
- FAILED ("WRONG VALUE FOR ELEMENT" &
- INTEGER'IMAGE (I));
- END IF;
- END LOOP;
-
- IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE");
- END IF;
- END;
-
-BEGIN
-
- RESULT;
-
-END CD5011I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada
deleted file mode 100644
index 6c4a16a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- CD5011K.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- RECORD TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT.
-
--- HISTORY:
--- JET 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011K IS
-
-BEGIN
-
- TEST ("CD5011K", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A RECORD " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "BLOCK STATEMENT");
-
- DECLARE
-
- TYPE REC_TYPE IS RECORD
- I : INTEGER := 12;
- B : BOOLEAN := TRUE;
- END RECORD;
-
- REC : REC_TYPE;
- FOR REC USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- REC.I := 17;
- REC.B := FALSE;
- END IF;
-
- IF REC.I /= 17 OR REC.B THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK");
- END IF;
-
- IF REC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK");
- END IF;
-
- END;
-
- RESULT;
-
-END CD5011K;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada
deleted file mode 100644
index 25d6f85..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- CD5011M.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF
--- AN ACCESS TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM.
-
--- HISTORY:
--- JET 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011M IS
-
- TYPE ACC_TYPE IS ACCESS STRING;
-
- PROCEDURE CD5011M_PROC IS
-
- ACC : ACC_TYPE := NEW STRING'("THE QUICK BROWN FOX");
- FOR ACC USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- ACC := NEW STRING'("THE LAZY DOG");
- END IF;
-
- IF ACC.ALL /= IDENT_STR ("THE LAZY DOG") THEN
- FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE");
- END IF;
-
- IF ACC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE");
- END IF;
-
- END CD5011M_PROC;
-
-BEGIN
- TEST ("CD5011M", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ACCESS " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "SUBPROGRAM");
-
- CD5011M_PROC;
-
- RESULT;
-
-END CD5011M;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada
deleted file mode 100644
index 4b9bf5c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- CD5011Q.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- PRIVATE TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT.
-
--- HISTORY:
--- JET 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011Q IS
-
- PACKAGE P IS
- TYPE PRIV_TYPE IS PRIVATE;
- FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE;
- FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN;
- PRIVATE
- TYPE PRIV_TYPE IS NEW INTEGER;
- END P;
-
- PACKAGE BODY P IS
-
- FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE IS
- BEGIN
- RETURN PRIV_TYPE(I);
- END;
-
- FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN IS
- BEGIN
- RETURN (P = PRIV_TYPE(I));
- END;
-
- END P;
-
- USE P;
-
-BEGIN
-
- TEST ("CD5011Q", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A PRIVATE " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "BLOCK STATEMENT");
-
- DECLARE
-
- PRIV : PRIV_TYPE := INT_TO_PRIV (12);
- FOR PRIV USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- PRIV := INT_TO_PRIV (17);
-
- IF NOT EQUAL (PRIV, IDENT_INT (17)) THEN
- FAILED ("INCORRECT VALUE FOR VARIABLE OF PRIVATE TYPE");
- END IF;
-
- IF PRIV'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR VARIABLE OF " &
- "PRIVATE TYPE");
- END IF;
- END;
-
- RESULT;
-
-END CD5011Q;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada
deleted file mode 100644
index 2943892..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CD5011S.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM.
-
--- HISTORY:
--- JET 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-
-PROCEDURE CD5011S IS
-
- PACKAGE P IS
- TYPE LIMP_TYPE IS LIMITED PRIVATE;
- PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE);
- PRIVATE
- TYPE LIMP_TYPE IS ARRAY (1 .. 10) OF INTEGER;
- END P;
-
- PACKAGE BODY P IS
- PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE) IS
- BEGIN
- FOR I IN LIMP'RANGE LOOP
- LIMP (I) := IDENT_INT (I);
- END LOOP;
-
- FOR I IN LIMP'RANGE LOOP
- IF LIMP (I) /= I THEN
- FAILED ("INCORRECT VALUE FOR ELEMENT" &
- INTEGER'IMAGE (I));
- END IF;
- END LOOP;
- END TEST_LIMP;
- END P;
-
- USE P;
-
- PROCEDURE CD5011S_PROC IS
-
- LIMP : LIMP_TYPE;
- FOR LIMP USE
- AT SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- TEST_LIMP (LIMP);
-
- IF LIMP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE OF A LIMITED " &
- "PRIVATE TYPE");
- END IF;
- END;
-
-BEGIN
- TEST ("CD5011S", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A LIMITED " &
- "PRIVATE TYPE IN THE DECLARATIVE PART " &
- "OF A SUBPROGRAM");
-
- CD5011S_PROC;
-
- RESULT;
-
-END CD5011S;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada
deleted file mode 100644
index 05cb7ba..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CD5012A.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
--- ENUMERATION TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
-
--- HISTORY:
--- DHH 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012A IS
-
-BEGIN
-
- TEST ("CD5012A", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ENUMERATION " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "GENERIC SUBPROGRAM");
-
- DECLARE
- TYPE NON_CHAR IS (RED, BLUE, GREEN);
-
- COLOR : NON_CHAR;
- TEST_VAR : ADDRESS := COLOR'ADDRESS;
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- HUE : NON_CHAR := GREEN;
- FOR HUE USE AT
- SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- IF EQUAL (3, 3) THEN
- HUE := RED;
- END IF;
- IF HUE /= RED THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN " &
- "GENERIC PROCEDURE");
- END IF;
- IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE " &
- "IN GENERIC PROCEDURE");
- END IF;
- END GENPROC;
-
- PROCEDURE PROC IS NEW GENPROC;
- BEGIN
- PROC;
- END;
- RESULT;
-END CD5012A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada
deleted file mode 100644
index 455fe85..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CD5012B.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
--- INTEGER TYPE IN THE DECLARATIVE PART OF A GENERIC PACKAGE BODY.
-
--- HISTORY:
--- DHH 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012B IS
-
-BEGIN
-
- TEST ("CD5012B", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN INTEGER " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "GENERIC PACKAGE BODY");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
-
- INT2 : INTEGER :=2;
-
- FOR INT2 USE AT
- SPPRT13.VARIABLE_ADDRESS;
-
- BEGIN
- IF EQUAL (3, 3) THEN
- INT2 := 1;
- END IF;
- IF INT2 /= 1 THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN " &
- "A GENERIC PACKAGE BODY");
- END IF;
- IF INT2'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE " &
- "IN A GENERIC PACKAGE BODY");
- END IF;
- END GENPACK;
-
- PACKAGE PACK IS NEW GENPACK;
- BEGIN
- NULL;
- END;
- RESULT;
-END CD5012B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada
deleted file mode 100644
index bfcd2f5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD5012E.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- FIXED POINT TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
-
--- HISTORY:
--- DHH 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012E IS
-
-BEGIN
-
- TEST ("CD5012E", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A FIXED POINT " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "GENERIC SUBPROGRAM");
-
- DECLARE
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0;
-
- TESTFIX : FIXED := 0.0;
- FOR TESTFIX USE AT SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- IF EQUAL (3, 3) THEN
- TESTFIX := 1.0;
- END IF;
- IF TESTFIX /= 1.0 THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN " &
- "A GENERIC PROCEDURE");
- END IF;
- IF TESTFIX'ADDRESS /=
- SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE " &
- "IN A GENERIC PROCEDURE");
- END IF;
- END GENPROC;
-
- PROCEDURE PROC IS NEW GENPROC;
- BEGIN
- PROC;
- END;
- RESULT;
-END CD5012E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada
deleted file mode 100644
index 69fb2e8..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CD5012F.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
--- ARRAY TYPE IN THE DECLARATIVE PART OF A GENERIC
--- PACKAGE BODY.
-
--- HISTORY:
--- DHH 09/17/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012F IS
-
-BEGIN
-
- TEST ("CD5012F", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ARRAY " &
- "TYPE IN THE DECLARATIVE " &
- "PART OF A GENERIC PACKAGE BODY");
-
- DECLARE
-
- GENERIC
- PACKAGE GENPACK IS
-
- END GENPACK;
-
- PACKAGE BODY GENPACK IS
- ARRAY_VAR : ARRAY (0..4) OF INTEGER := (0,1,2,3,4);
-
- FOR ARRAY_VAR USE AT SPPRT13.VARIABLE_ADDRESS;
-
-
- BEGIN
- IF EQUAL (3, 3) THEN
- ARRAY_VAR := (4,3,2,1,0);
- END IF;
- IF ARRAY_VAR /= (4,3,2,1,0) THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN " &
- "A GENERIC PACKAGE BODY");
- END IF;
- IF ARRAY_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE " &
- "IN A GENERIC PACKAGE BODY");
- END IF;
- END GENPACK;
-
- PACKAGE PACK IS NEW GENPACK;
- BEGIN
- NULL;
- END;
- RESULT;
-END CD5012F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada
deleted file mode 100644
index 1be46d4..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CD5012I.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
--- ACCESS TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
-
--- HISTORY:
--- DHH 09/17/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012I IS
-
-BEGIN
-
- TEST ("CD5012I", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF AN ACCESS " &
- "TYPE IN THE DECLARATIVE PART OF A " &
- "GENERIC SUBPROGRAM");
-
- DECLARE
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- TYPE CELL;
- TYPE POINTER IS ACCESS CELL;
- TYPE CELL IS
- RECORD
- VALUE : INTEGER;
- NEXT : POINTER;
- END RECORD;
-
- C,PTR : POINTER := NULL;
-
- FOR PTR USE AT
- SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- PTR := NEW CELL'(0,NULL);
- C := PTR;
-
- IF EQUAL (3, 3) THEN
- PTR.VALUE := 1;
- PTR.NEXT := C;
- END IF;
- IF PTR.ALL /= (1,C) THEN
- FAILED ("WRONG VALUE FOR VARIABLE IN " &
- "A GENERIC PROCEDURE");
- END IF;
- IF PTR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR VARIABLE " &
- "IN A GENERIC PROCEDURE");
- END IF;
- END GENPROC;
-
- PROCEDURE PROC IS NEW GENPROC;
- BEGIN
- PROC;
- END;
- RESULT;
-END CD5012I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada
deleted file mode 100644
index 1cd3c21..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CD5012M.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
--- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A GENERIC
--- SUBPROGRAM.
-
--- HISTORY:
--- DHH 09/15/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH REPORT; USE REPORT;
-WITH SPPRT13;
-PROCEDURE CD5012M IS
-
-BEGIN
-
- TEST ("CD5012M", "AN ADDRESS CLAUSE CAN BE " &
- "GIVEN FOR A VARIABLE OF A LIMITED " &
- "PRIVATE TYPE IN THE DECLARATIVE " &
- "PART OF A GENERIC SUBPROGRAM");
-
- DECLARE
-
- PACKAGE P IS
- TYPE FIXED IS LIMITED PRIVATE;
-
- PRIVATE
- TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0;
- END P;
-
- USE P;
-
- GENERIC
- PROCEDURE GENPROC;
-
- PROCEDURE GENPROC IS
-
- TESTFIX : FIXED;
-
- FOR TESTFIX USE AT
- SPPRT13.VARIABLE_ADDRESS;
- BEGIN
- IF TESTFIX'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
- FAILED ("WRONG ADDRESS FOR LIMITED PRIVATE " &
- "TYPE VARIABLE IN GENERIC PROCEDURE");
- END IF;
- END GENPROC;
-
- PROCEDURE PROC IS NEW GENPROC;
- BEGIN
- PROC;
- END;
- RESULT;
-END CD5012M;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada
deleted file mode 100644
index ad7650e..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- CD5013A.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ENUMERATION TYPE,
--- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013A IS
-
- TYPE ENUM_TYPE IS (ONE,TWO,THREE,FOUR,FIVE,SIX);
-
- PACKAGE PACK IS
- CHECK_TYPE : ENUM_TYPE;
- FOR CHECK_TYPE USE AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013A", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE VISIBLE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF AN ENUMERATION TYPE, WHERE " &
- "THE VARIABLE IS DECLARED IN THE VISIBLE PART " &
- "OF THE SPECIFICATION");
-
- CHECK_TYPE := ONE;
- IF EQUAL(3,3) THEN
- CHECK_TYPE := THREE;
- END IF;
-
- IF CHECK_TYPE /= THREE THEN
- FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE");
- END IF;
-
- IF CHECK_TYPE'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE");
- END IF;
-
- RESULT;
-END CD5013A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada
deleted file mode 100644
index f00dfec..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- CD5013C.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER TYPE, WHERE
--- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013C IS
-
- TYPE INT_TYPE IS RANGE INTEGER'FIRST .. INTEGER'LAST;
-
- PACKAGE PACK IS
- CHECK_VAR : INT_TYPE;
- PRIVATE
- FOR CHECK_VAR USE AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013C", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE PRIVATE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF AN INTEGER TYPE, WHERE THE " &
- "VARIABLE IS DECLARED IN THE VISIBLE PART OF " &
- "THE SPECIFICATION");
-
- CHECK_VAR := 100;
- IF EQUAL(3,3) THEN
- CHECK_VAR := 10;
- END IF;
-
- IF CHECK_VAR /= 10 THEN
- FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE");
- END IF;
-
- RESULT;
-END CD5013C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada
deleted file mode 100644
index cb04cfd..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- CD5013E.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING POINT TYPE,
--- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013E IS
-
- TYPE FLT_TYPE IS DIGITS 5 RANGE -1.0 .. 1.0;
-
- PACKAGE PACK IS
- CHECK_VAR : FLT_TYPE;
- FOR CHECK_VAR USE AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013E", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE VISIBLE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF A FLOATING POINT TYPE, " &
- "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " &
- "PART OF THE SPECIFICATION");
-
- CHECK_VAR := 0.5;
- IF EQUAL(3,3) THEN
- CHECK_VAR := 0.0;
- END IF;
-
- IF CHECK_VAR /= 0.0 THEN
- FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE");
- END IF;
-
- RESULT;
-END CD5013E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada
deleted file mode 100644
index 355c682..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- CD5013G.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED POINT TYPE,
--- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013G IS
-
- TYPE FIX_TYPE IS DELTA 0.5 RANGE -7.5 .. 7.5;
-
- PACKAGE PACK IS
- CHECK_VAR : FIX_TYPE;
- PRIVATE
- FOR CHECK_VAR USE
- AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013G", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE PRIVATE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF A FIXED POINT TYPE, " &
- "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " &
- "PART OF THE SPECIFICATION");
-
- CHECK_VAR := 1.5;
- IF EQUAL(3,3) THEN
- CHECK_VAR := 5.0;
- END IF;
-
- IF CHECK_VAR /= 5.0 THEN
- FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE");
- END IF;
-
- RESULT;
-END CD5013G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada
deleted file mode 100644
index 7a405b2..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- CD5013I.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY TYPE, WHERE
--- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013I IS
-
- TYPE ARR_TYPE IS ARRAY(1..5) OF INTEGER;
-
- PACKAGE PACK IS
- CHECK_VAR : ARR_TYPE;
- FOR CHECK_VAR USE
- AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013I", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE VISIBLE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF AN ARRAY TYPE, WHERE THE " &
- "VARIABLE IS DECLARED IN THE VISIBLE PART OF " &
- "THE SPECIFICATION");
-
- CHECK_VAR := (1,2,3,4,5);
- IF EQUAL(3,3) THEN
- CHECK_VAR := (5,4,3,2,1);
- END IF;
-
- IF CHECK_VAR /= (5,4,3,2,1) THEN
- FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE");
- END IF;
-
- RESULT;
-END CD5013I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada
deleted file mode 100644
index 469abf4..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada
+++ /dev/null
@@ -1,78 +0,0 @@
--- CD5013K.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD TYPE, WHERE
--- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013K IS
-
- TYPE REC_TYPE IS RECORD
- BOOL : BOOLEAN;
- INT : INTEGER;
- END RECORD;
-
- PACKAGE PACK IS
- CHECK_VAR : REC_TYPE;
- PRIVATE
- FOR CHECK_VAR USE
- AT VARIABLE_ADDRESS;
- END PACK;
-
- PACKAGE BODY PACK IS
- BEGIN
- TEST ("CD5013K", "AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A RECORD " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN " &
- "THE VISIBLE PART OF THE SPECIFICATION");
-
- CHECK_VAR := (TRUE, IDENT_INT(5));
- IF EQUAL(3,3) THEN
- CHECK_VAR := (FALSE, IDENT_INT(10));
- END IF;
-
- IF CHECK_VAR /= (FALSE, IDENT_INT (10)) THEN
- FAILED ("INCORRECT VALUE FOR RECORD VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE");
- END IF;
- END PACK;
-
-BEGIN
-
- RESULT;
-END CD5013K;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada
deleted file mode 100644
index 2e48386..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada
+++ /dev/null
@@ -1,73 +0,0 @@
--- CD5013M.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS TYPE, WHERE
--- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013M IS
-
- TYPE ACC_TYPE IS ACCESS INTEGER;
-
- PACKAGE PACK IS
- CHECK_VAR : ACC_TYPE;
- FOR CHECK_VAR USE
- AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
-BEGIN
-
- TEST ("CD5013M", "AN ADDRESS CLAUSE CAN BE GIVEN IN " &
- "THE VISIBLE PART OF A PACKAGE SPECIFICATION " &
- "FOR A VARIABLE OF AN ACCESS TYPE, WHERE THE " &
- "VARIABLE IS DECLARED IN THE VISIBLE PART OF " &
- "THE SPECIFICATION");
-
- CHECK_VAR := NEW INTEGER'(100);
- IF EQUAL(3,3) THEN
- CHECK_VAR := NEW INTEGER'(25);
- END IF;
-
- IF CHECK_VAR.ALL /= 25 THEN
- FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE");
- END IF;
-
- RESULT;
-END CD5013M;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada
deleted file mode 100644
index c063fce..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CD5013O.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF
--- A PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE TYPE, WHERE
--- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
--- HISTORY:
--- BCB 09/16/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH REPORT; USE REPORT;
-WITH SPPRT13; USE SPPRT13;
-WITH SYSTEM; USE SYSTEM;
-
-PROCEDURE CD5013O IS
-
- PACKAGE P1 IS
- END P1;
-
- PACKAGE PACK IS
- TYPE F IS PRIVATE;
- PRIVATE
- TYPE F IS NEW INTEGER;
- CHECK_VAR : F;
- FOR CHECK_VAR USE AT VARIABLE_ADDRESS;
- END PACK;
-
- USE PACK;
-
- PACKAGE BODY P1 IS
- BEGIN
- TEST ("CD5013O", "AN ADDRESS CLAUSE CAN BE GIVEN" &
- " IN THE PRIVATE PART OF A PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A " &
- "PRIVATE TYPE, WHERE THE VARIABLE IS " &
- "DECLARED IN THE VISIBLE PART OF THE " &
- "SPECIFICATION");
- END P1;
-
- PACKAGE BODY PACK IS
- BEGIN
- CHECK_VAR := 100;
- IF EQUAL(3,3) THEN
- CHECK_VAR := 25;
- END IF;
-
- IF CHECK_VAR /= 25 THEN
- FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE");
- END IF;
-
- IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE");
- END IF;
- END PACK;
-
-BEGIN
-
- RESULT;
-END CD5013O;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada
deleted file mode 100644
index 0940177..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD5014A.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN
--- ENUMERATION TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE
--- PART OF THE SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014A IS
-
-BEGIN
-
- TEST ("CD5014A", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF AN " &
- "ENUMERATION TYPE, WHERE THE VARIABLE IS " &
- "DECLARED IN THE VISIBLE PART OF THE " &
- "SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE ENUM_TYPE IS (RED,BLUE,GREEN);
- ENUM_OBJ1 : ENUM_TYPE := RED;
- FOR ENUM_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- ENUM_OBJ1 := BLUE;
- END IF;
-
- IF ENUM_OBJ1 /= BLUE THEN
- FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE");
- END IF;
-
- IF ENUM_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada
deleted file mode 100644
index d09969f..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD5014C.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER
--- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014C IS
-
-BEGIN
-
- TEST ("CD5014C", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF AN INTEGER " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
- "VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE INTEGER_TYPE IS RANGE 0 .. 100;
- INTEGER_OBJ1 : INTEGER_TYPE := 50;
- PRIVATE
- FOR INTEGER_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- INTEGER_OBJ1 := 7;
- END IF;
-
- IF INTEGER_OBJ1 /= 7 THEN
- FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE");
- END IF;
-
- IF INTEGER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada
deleted file mode 100644
index 145e3aa..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD5014E.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING
--- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
--- OF THE SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 08/19/87 CREATED ORIGINAL TEST.
--- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014E IS
-
-BEGIN
-
- TEST ("CD5014E", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FLOATING " &
- "POINT TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE FLOAT_TYPE IS DIGITS SYSTEM.MAX_DIGITS
- RANGE 0.0 .. 100.0;
- FLOAT_OBJ1 : FLOAT_TYPE := 50.0;
- FOR FLOAT_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- FLOAT_OBJ1 := 5.0;
- END IF;
-
- IF FLOAT_OBJ1 /= 5.0 THEN
- FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE");
- END IF;
-
- IF FLOAT_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada
deleted file mode 100644
index 28ab399..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CD5014G.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED
--- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF
--- THE SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014G IS
-
-BEGIN
-
- TEST ("CD5014G", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FIXED " &
- "POINT TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE FIXED_TYPE IS DELTA 0.5 RANGE 0.0 .. 100.0;
- FIXED_OBJ1 : FIXED_TYPE := 50.0;
- PRIVATE
- FOR FIXED_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- FIXED_OBJ1 := 5.0;
- END IF;
-
- IF FIXED_OBJ1 /= 5.0 THEN
- FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE");
- END IF;
-
- IF FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada
deleted file mode 100644
index 23c2357..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CD5014I.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY
--- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014I IS
-
-BEGIN
-
- TEST ("CD5014I", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF AN ARRAY " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
- "VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE ARR_TYPE IS ARRAY (1..2) OF INTEGER;
- ARR_OBJ1 : ARR_TYPE := (5,10);
- FOR ARR_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- ARR_OBJ1 := (13,21);
- END IF;
-
- IF ARR_OBJ1 /= (13,21) THEN
- FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE");
- END IF;
-
- IF ARR_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014I;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada
deleted file mode 100644
index 1cee824..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CD5014K.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD
--- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014K IS
-
-BEGIN
-
- TEST ("CD5014K", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A RECORD " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
- "VISIBLE PART OF THE SPECIFICATION");
-
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE REC_TYPE IS RECORD
- VAL : INTEGER;
- END RECORD;
- REC_OBJ1 : REC_TYPE := (VAL => 10);
- PRIVATE
- FOR REC_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- REC_OBJ1.VAL := 100;
- END IF;
-
- IF REC_OBJ1.VAL /= 100 THEN
- FAILED ("INCORRECT VALUE FOR RECORD VARIABLE COMPONENT");
- END IF;
-
- IF REC_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014K;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada
deleted file mode 100644
index 8b0ec57..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CD5014M.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS
--- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF
--- THE SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014M IS
-
-BEGIN
-
- TEST ("CD5014M", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF AN ACCESS " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
- "VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE ACCESS_TYPE;
- TYPE POINTER_TYPE IS ACCESS ACCESS_TYPE;
- TYPE ACCESS_TYPE IS RECORD
- VAL1 : INTEGER;
- NEXT : POINTER_TYPE;
- END RECORD;
- POINTER_OBJ1 : POINTER_TYPE := NEW ACCESS_TYPE'(0,NULL);
- FOR POINTER_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- POINTER_OBJ1 := NEW ACCESS_TYPE'(10,NULL);
- END IF;
-
- IF POINTER_OBJ1.ALL /= (10,NULL) THEN
- FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE");
- END IF;
-
- IF POINTER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014M;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada
deleted file mode 100644
index e8018ca..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CD5014O.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE
--- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
--- SPECIFICATION.
-
-
--- HISTORY:
--- CDJ 07/24/87 CREATED ORIGINAL TEST.
--- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
--- MCH 04/03/90 ADDED INSTANTIATION.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014O IS
-
-BEGIN
-
- TEST ("CD5014O", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A PRIVATE " &
- "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
- "VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- PACKAGE PKG IS
- TYPE PRIVATE_TYPE IS PRIVATE;
- PRIVATE
- TYPE PRIVATE_TYPE IS RANGE 1 .. 20;
- PRIVATE_OBJ1 : PRIVATE_TYPE := 5;
- FOR PRIVATE_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- PRIVATE_OBJ1 := 9;
- END IF;
-
- IF PRIVATE_OBJ1 /= 9 THEN
- FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE");
- END IF;
-
- IF PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE INSTANTIATE IS NEW PKG;
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014O;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada
deleted file mode 100644
index 9eee00c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada
+++ /dev/null
@@ -1,86 +0,0 @@
--- CD5014T.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
--- DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
--- OF THE SPECIFICATION.
-
-
--- HISTORY:
--- BCB 10/08/87 CREATED ORIGINAL TEST.
-
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014T IS
-
-BEGIN
-
- TEST ("CD5014T", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FORMAL " &
- "DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- TYPE FORM_DISCRETE_TYPE IS (<>);
- PACKAGE PKG IS
- FORM_DISCRETE_OBJ1 : FORM_DISCRETE_TYPE :=
- FORM_DISCRETE_TYPE'FIRST;
- PRIVATE
- FOR FORM_DISCRETE_OBJ1 USE
- AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
-
- IF EQUAL(3,3) THEN
- FORM_DISCRETE_OBJ1 := FORM_DISCRETE_TYPE'LAST;
- END IF;
-
- IF FORM_DISCRETE_OBJ1 /= FORM_DISCRETE_TYPE'LAST THEN
- FAILED ("INCORRECT VALUE FOR FORMAL DISCRETE VARIABLE");
- END IF;
-
- IF FORM_DISCRETE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FORMAL DISCRETE " &
- "VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG(FORM_DISCRETE_TYPE => INTEGER);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014T;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada
deleted file mode 100644
index 237a37a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CD5014V.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
--- FIXED TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
--- OF THE SPECIFICATION.
-
-
--- HISTORY:
--- BCB 10/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014V IS
-
-BEGIN
-
- TEST ("CD5014V", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FORMAL " &
- "FIXED TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
- TYPE FIX IS DELTA 0.5 RANGE -30.00 .. 30.00;
-
- GENERIC
- TYPE FORM_FIXED_TYPE IS DELTA <>;
- PACKAGE PKG IS
- FORM_FIXED_OBJ1 : FORM_FIXED_TYPE := 5.0;
- FOR FORM_FIXED_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF EQUAL(3,3) THEN
- FORM_FIXED_OBJ1 := 20.0;
- END IF;
-
- IF FORM_FIXED_OBJ1 /= 20.0 THEN
- FAILED ("INCORRECT VALUE FOR FORMAL FIXED VARIABLE");
- END IF;
-
- IF FORM_FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FORMAL FIXED " &
- "VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG(FORM_FIXED_TYPE => FIX);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014V;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada
deleted file mode 100644
index fe6e2cb..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CD5014X.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
--- ARRAY TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
--- OF THE SPECIFICATION.
-
--- HISTORY:
--- BCB 10/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CD5014X IS
-
-BEGIN
-
- TEST ("CD5014X", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FORMAL " &
- "ARRAY TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- TYPE COLOR IS (RED,BLUE,GREEN);
- TYPE COLOR_TABLE IS ARRAY (COLOR) OF INTEGER;
-
- GENERIC
- TYPE INDEX IS (<>);
- TYPE FORM_ARRAY_TYPE IS ARRAY (INDEX) OF INTEGER;
- PACKAGE PKG IS
- FORM_ARRAY_OBJ1 : FORM_ARRAY_TYPE := (1,2,3);
- PRIVATE
- FOR FORM_ARRAY_OBJ1 USE AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
-
- IF EQUAL(3,3) THEN
- FORM_ARRAY_OBJ1 := (10,20,30);
- END IF;
-
- IF FORM_ARRAY_OBJ1 /= (10,20,30) THEN
- FAILED ("INCORRECT VALUE FOR FORMAL ARRAY VARIABLE");
- END IF;
-
- IF FORM_ARRAY_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FORMAL ARRAY " &
- "VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG(INDEX => COLOR,
- FORM_ARRAY_TYPE => COLOR_TABLE);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014X;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada
deleted file mode 100644
index 75c8ba6..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada
+++ /dev/null
@@ -1,74 +0,0 @@
--- CD5014Y.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
--- PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
--- OF THE SPECIFICATION.
-
--- HISTORY:
--- BCB 10/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014Y IS
-
-BEGIN
-
- TEST ("CD5014Y", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE VISIBLE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FORMAL " &
- "PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED " &
- "IN THE VISIBLE PART OF THE SPECIFICATION");
-
- DECLARE
-
- GENERIC
- TYPE FORM_PRIVATE_TYPE IS PRIVATE;
- PACKAGE PKG IS
- FORM_PRIVATE_OBJ1 : FORM_PRIVATE_TYPE;
- FOR FORM_PRIVATE_OBJ1 USE
- AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF FORM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FORMAL PRIVATE " &
- "VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG(FORM_PRIVATE_TYPE => INTEGER);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014Y;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada
deleted file mode 100644
index dee3291..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CD5014Z.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
--- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
--- LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE
--- VISIBLE PART OF THE SPECIFICATION.
-
--- HISTORY:
--- BCB 10/08/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM; USE SYSTEM;
-WITH SPPRT13; USE SPPRT13;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD5014Z IS
-
-BEGIN
-
- TEST ("CD5014Z", " AN ADDRESS CLAUSE CAN BE GIVEN " &
- "IN THE PRIVATE PART OF A GENERIC PACKAGE " &
- "SPECIFICATION FOR A VARIABLE OF A FORMAL " &
- "LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS " &
- "DECLARED IN THE VISIBLE PART OF THE " &
- "SPECIFICATION");
-
- DECLARE
-
- GENERIC
- TYPE FORM_LIM_PRIVATE_TYPE IS LIMITED PRIVATE;
- PACKAGE PKG IS
- FORM_LIM_PRIVATE_OBJ1 : FORM_LIM_PRIVATE_TYPE;
- PRIVATE
- FOR FORM_LIM_PRIVATE_OBJ1 USE
- AT VARIABLE_ADDRESS;
- END PKG;
-
- PACKAGE BODY PKG IS
- BEGIN
- IF FORM_LIM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
- FAILED ("INCORRECT ADDRESS FOR FORMAL LIMITED PRIVATE " &
- "VARIABLE");
- END IF;
- END PKG;
-
- PACKAGE PACK IS NEW PKG(FORM_LIM_PRIVATE_TYPE => INTEGER);
-
- BEGIN
- NULL;
- END;
-
- RESULT;
-END CD5014Z;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd70001.a b/gcc/testsuite/ada/acats/tests/cd/cd70001.a
deleted file mode 100644
index 4840095..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd70001.a
+++ /dev/null
@@ -1,201 +0,0 @@
---
--- CD70001.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 package System includes Max_Base_Digits, Address,
--- Null_Address, Word_Size, functions "<", "<=", ">", ">=", "="
--- (with Address parameters and Boolean results), Bit_Order,
--- Default_Bit_Order, Any_Priority, Interrupt_Priority,
--- and Default_Priority.
---
--- Check that package System.Storage_Elements includes all required
--- types and operations.
---
--- TEST DESCRIPTION:
--- The test checks for the existence of the names additional
--- to package system above those names tested for in 9Xbasic.
---
--- This test checks that the semantics provided in Storage_Elements
--- are present and operate marginally within expectations (to the best
--- extent possible in a portable implementation independent fashion).
---
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 27 JAN 96 SAIC Revised for 2.1; Allow negative address delta
---
---!
-
-with Report;
-with Ada.Text_IO;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD70001 is
- use System;
-
- procedure CD70 is
-
- type Int_Max is range Min_Int .. Max_Int;
-
- My_Int : Int_Max := System.Max_Base_Digits + System.Word_Size;
-
- An_Address : Address;
- An_Other_Address : Address := An_Address'Address;
-
- begin -- 7.0
-
-
- if Default_Bit_Order not in High_Order_First..Low_Order_First then
- Report.Failed ("Default_Bit_Order invalid");
- end if;
-
- if Bit_Order'Pos(High_Order_First) /= 0 then
- Report.Failed ("Bit_Order'Pos(High_Order_First) /= 0");
- end if;
-
- if Bit_Order'Pos(Low_Order_First) /= 1 then
- Report.Failed ("Bit_Order'Pos(Low_Order_First) /= 1");
- end if;
-
- An_Address := My_Int'Address;
-
- if An_Address = Null_Address then
- Report.Failed ("Null_Address matched a real address");
- end if;
-
-
- if An_Address'Address /= An_Other_Address then
- Report.Failed("Value set at elaboration not equal to itself");
- end if;
-
- if An_Address'Address > An_Other_Address
- and An_Address'Address < An_Other_Address then
- Report.Failed("Address is both greater and less!");
- end if;
-
- if not (An_Address'Address >= An_Other_Address
- and An_Address'Address <= An_Other_Address) then
- Report.Failed("Address comparisons wrong");
- end if;
-
-
- if Priority'First /= Any_Priority'First then
- Report.Failed ("Priority'First /= Any_Priority'First");
- end if;
-
- if Interrupt_Priority'First /= Priority'Last+1 then
- Report.Failed ("Interrupt_Priority'First /= Priority'Last+1");
- end if;
-
- if Interrupt_Priority'Last /= Any_Priority'Last then
- Report.Failed ("Interrupt_Priority'Last /= Any_Priority'Last");
- end if;
-
- if Default_Priority /= ((Priority'First + Priority'Last)/2) then
- Report.Failed ("Default_Priority wrong value");
- end if;
-
- end CD70;
-
- procedure CD71 is
- use System.Storage_Elements;
-
- Storehouse_1 : Storage_Array(0..127);
- Storehouse_2 : Storage_Array(0..127);
-
- House_Offset : Storage_Offset;
-
- begin -- 7.1
-
-
- if Storage_Count'First /= 0 then
- Report.Failed ("Storage_Count'First /= 0");
- end if;
-
- if Storage_Count'Last /= Storage_Offset'Last then
- Report.Failed ("Storage_Count'Last /= Storage_Offset'Last");
- end if;
-
-
- if Storage_Element'Size /= Storage_Unit then
- Report.Failed ("Storage_Element'Size /= Storage_Unit");
- end if;
-
- if Storage_Array'Component_Size /= Storage_Unit then
- Report.Failed ("Storage_Array'Element_Size /= Storage_Unit");
- end if;
-
- if Storage_Element'Last+1 /= 0 then
- Report.Failed ("Storage_Element not modular");
- end if;
-
-
- -- "+", "-"( Address, Storage_Offset) and inverse
-
- House_Offset := Storehouse_2'Address - Storehouse_1'Address;
- -- Address - Address = Offset
- -- Note that House_Offset may be a negative value
-
- if House_Offset + Storehouse_1'Address /= Storehouse_2'Address then
- -- Offset + Address = Address
- Report.Failed ("Storage arithmetic non-linear O+A");
- end if;
-
- if Storehouse_1'Address + House_Offset /= Storehouse_2'Address then
- -- Address + Offset = Address
- Report.Failed ("Storage arithmetic non-linear A+O");
- end if;
-
- if Storehouse_2'Address - House_Offset /= Storehouse_1'Address then
- -- Address - Offset = Address
- Report.Failed ("Storage arithmetic non-linear A-O");
- end if;
-
- if (Storehouse_2'Address mod abs(House_Offset) > abs(House_Offset)) then
- -- "mod"( Address, Storage_Offset)
- Report.Failed("Mod arithmetic");
- end if;
-
-
- if Storehouse_1'Address
- /= To_Address(To_Integer(Storehouse_1'Address)) then
- Report.Failed("To_Address, To_Integer not symmetric");
- end if;
-
- end CD71;
-
-
-begin -- Main test procedure.
-
- Report.Test ("CD70001", "Check package System" );
-
- CD70;
-
- CD71;
-
- Report.Result;
-
-end CD70001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada
deleted file mode 100644
index f278c0b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- CD7002A.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 VARIABLE OF TYPE ADDRESS CAN BE DECLARED IN A UNIT
--- WHICH HAS A WITH CLAUSE NAMING SYSTEM.
-
--- HISTORY:
--- DHH 08/31/88 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD7002A IS
-
- I : INTEGER;
-
- OBJECT : SYSTEM.ADDRESS := I'ADDRESS;
-
- SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS;
-
-BEGIN
- TEST ("CD7002A", "CHECK THAT A VARIABLE OF TYPE ADDRESS CAN BE " &
- "DECLARED IN A UNIT WHICH HAS A WITH CLAUSE " &
- "NAMING SYSTEM");
-
- IF NOT IDENT_BOOL(OBJECT IN MY_ADDRESS) THEN
- FAILED("INCORRECT RESULT");
- END IF;
-
- RESULT;
-END CD7002A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada b/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada
deleted file mode 100644
index c5edf4b..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- CD7007B.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 SUBTYPE 'PRIORITY' IS DECLARED WITHIN THE PACKAGE
--- SYSTEM AND IT IS A SUBTYPE OF 'INTEGER'.
-
--- HISTORY:
--- VCL 09/16/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-PROCEDURE CD7007B IS
-BEGIN
- TEST ("CD7007B", "THE SUBTYPE 'PRIORITY' IS DECLARED WITHIN " &
- "THE PACKAGE SYSTEM AND IT IS A SUBTYPE OF " &
- "'INTEGER'");
-
- DECLARE
- CHECK_VAR : SYSTEM.PRIORITY;
- BEGIN
- IF SYSTEM.PRIORITY'FIRST NOT IN
- INTEGER'FIRST .. INTEGER'LAST AND
- SYSTEM.PRIORITY'LAST NOT IN
- INTEGER'FIRST .. INTEGER'LAST THEN
- FAILED ("'SYSTEM.PRIORITY' IS NOT AN INTEGER SUBTYPE");
- END IF;
- END;
-
- RESULT;
-END CD7007B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada b/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada
deleted file mode 100644
index 9b56f2c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada
+++ /dev/null
@@ -1,53 +0,0 @@
--- CD7101D.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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM,
--- INTEGER'FIRST >= MIN_INT AND INTEGER'LAST <= MAX_INT.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7101D IS
-
-BEGIN
-
- TEST ("CD7101D", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " &
- "SYSTEM, INTEGER'FIRST >= MIN_INT AND INTEGER'" &
- "LAST <= MAX_INT");
-
- IF INTEGER'POS (INTEGER'FIRST) < SYSTEM.MIN_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
- END IF;
-
- IF INTEGER'POS (INTEGER'LAST) > SYSTEM.MAX_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
- END IF;
-
- RESULT;
-
-END CD7101D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep b/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep
deleted file mode 100644
index d2d430a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep
+++ /dev/null
@@ -1,62 +0,0 @@
--- CD7101E.DEP
-
--- 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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM,
--- SHORT_INTEGER'FIRST >= MIN_INT AND SHORT_INTEGER'LAST <= MAX_INT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO THOSE IMPLEMENTATIONS THAT
--- SUPPORT THE SHORT_INTEGER DATA TYPE.
-
--- IF THE SHORT_INTEGER TYPE IS NOT SUPPORTED THEN THE
--- DECLARATION OF "TEST_VAR" MUST BE REJECTED.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7101E IS
-
- TEST_VAR : SHORT_INTEGER := 0; -- N/A => ERROR.
-
-BEGIN
-
- TEST ("CD7101E", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " &
- "SYSTEM, SHORT_INTEGER'FIRST >= MIN_INT AND " &
- "SHORT_INTEGER'LAST <= MAX_INT");
-
- IF SHORT_INTEGER'POS (SHORT_INTEGER'FIRST) < SYSTEM.MIN_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
- END IF;
-
- IF SHORT_INTEGER'POS (SHORT_INTEGER'LAST) > SYSTEM.MAX_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
- END IF;
-
- RESULT;
-
-END CD7101E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep b/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep
deleted file mode 100644
index 4f1169e..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep
+++ /dev/null
@@ -1,62 +0,0 @@
--- CD7101F.DEP
-
--- 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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM,
--- LONG_INTEGER'FIRST >= MIN_INT AND LONG_INTEGER'LAST <= MAX_INT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT
--- THE LONG_INTEGER DATA TYPE.
-
--- IF THE LONG_INTEGER TYPE IS NOT SUPPORTED, THEN THE
--- DECLARATION OF "TEST_VAR" MUST BE REJECTED.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7101F IS
-
- TEST_VAR : LONG_INTEGER := 0; -- N/A => ERROR.
-
-BEGIN
-
- TEST ("CD7101F", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " &
- "SYSTEM, LONG_INTEGER'FIRST >= MIN_INT AND " &
- "LONG_INTEGER'LAST <= MAX_INT");
-
- IF LONG_INTEGER'POS (LONG_INTEGER'FIRST) < SYSTEM.MIN_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
- END IF;
-
- IF LONG_INTEGER'POS (LONG_INTEGER'LAST) > SYSTEM.MAX_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
- END IF;
-
- RESULT;
-
-END CD7101F;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst b/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst
deleted file mode 100644
index b91a34d..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst
+++ /dev/null
@@ -1,70 +0,0 @@
--- CD7101G.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.
---*
--- OBJECTIVE:
--- CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE SYSTEM AND
--- A PREDEFINED INTEGER TYPE I OTHER THAN INTEGER, SHORT_INTEGER,
--- AND LONG_INTEGER, I'FIRST >= MIN_INT AND I'LAST <= MAX_INT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT HAVE
--- A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER,
--- AND LONG_INTEGER.
-
--- IF NO SUCH TYPE EXISTS, THEN THE DECLARATION OF TEST_VAR
--- MUST BE REJECTED.
-
--- HISTORY:
--- JET 09/10/87 CREATED ORIGINAL TEST.
-
--- $NAME IS THE NAME OF A PREDEFINED INTEGER TYPE OTHER THAN
--- INTEGER, SHORT_INTEGER, AND LONG_INTEGER, IF ANY SUCH TYPE
--- EXISTS.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7101G IS
-
- TEST_VAR : $NAME := 0; -- N/A => ERROR.
-
-BEGIN
-
- TEST ("CD7101G", "CHECK THAT FOR MIN_INT AND MAX_INT IN " &
- "PACKAGE SYSTEM AND A PREDEFINED INTEGER " &
- "TYPE I OTHER THAN INTEGER, SHORT_INTEGER, " &
- "AND LONG_INTEGER, I'FIRST >= MIN_INT AND " &
- "I'LAST <= MAX_INT");
-
- IF $NAME'POS ($NAME'FIRST) < SYSTEM.MIN_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
- END IF;
-
- IF $NAME'POS ($NAME'LAST) > SYSTEM.MAX_INT THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
- END IF;
-
- RESULT;
-
-END CD7101G;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada b/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada
deleted file mode 100644
index f6da8a0..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- CD7103D.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 CONSTANT FINE_DELTA = 2.0 ** (- MAX_MANTISSA).
-
--- HISTORY:
--- BCB 09/10/87 CREATED ORIGINAL TEST.
-
--- DTN 11/21/91 DELETED SUBPART (A). CHANGED EXTENSION FROM '.TST' TO
--- '.ADA'.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7103D IS
-
- MANTISSA_VAL : CONSTANT := 2.0 ** (-SYSTEM.MAX_MANTISSA);
-
-BEGIN
-
- TEST ("CD7103D", "CHECK THAT THE CONSTANT FINE_DELTA " &
- "= 2.0 ** (- MAX_MANTISSA)");
-
- IF SYSTEM.FINE_DELTA /= MANTISSA_VAL THEN
- FAILED ("INCORRECT VALUE FOR SYSTEM.FINE_DELTA");
- END IF;
-
- RESULT;
-
-END CD7103D;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada
deleted file mode 100644
index 8e4f89a..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- CD7202A.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:
--- THE 'ADDRESS ATTRIBUTE CAN BE USED IN A COMPILATION UNIT EVEN IF
--- A WITH CLAUSE FOR PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT.
-
--- HISTORY:
--- DHH 08/31/88 CREATED ORIGINAL TEST.
-
-WITH SYSTEM;
-PACKAGE CD7202A_SYS IS
- SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS;
-END CD7202A_SYS;
-
-WITH CD7202A_SYS;
-WITH REPORT; USE REPORT;
-PROCEDURE CD7202A IS
-
- INT : INTEGER := 2;
-
- BOOL : BOOLEAN := (INT'ADDRESS IN CD7202A_SYS.MY_ADDRESS);
-
-BEGIN
- TEST ("CD7202A", "THE 'ADDRESS ATTRIBUTE CAN BE USED IN A" &
- " COMPILATION UNIT EVEN IF A WITH CLAUSE FOR " &
- "PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT");
-
- IF NOT IDENT_BOOL(BOOL) THEN
- FAILED("ADDRESS ATTRIBUTE INCORRECT");
- END IF;
-
- RESULT;
-END CD7202A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada b/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada
deleted file mode 100644
index 64114ad..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada
+++ /dev/null
@@ -1,88 +0,0 @@
--- CD7204B.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 THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT
--- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES
--- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE IS
--- NOT PRESENT.
-
--- HISTORY:
--- BCB 09/14/87 CREATED ORIGINAL TEST.
--- RJW 02/08/88 REVISED SO THAT TEST PASSES IF BOOLEAN'SIZE = 1.
--- RJW 05/31/90 CORRECTED COMPARISONS INVOLVING SIZES.
--- LDC 10/04/90 ADDED CHECK FOR 'POSITION.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7204B IS
-
- TYPE BASIC_REC IS RECORD
- CHECK_INT : INTEGER := 5;
- CHECK_BOOL : BOOLEAN := TRUE;
- END RECORD;
-
- CHECK_REC : BASIC_REC;
-
-BEGIN
-
- TEST ("CD7204B", "CHECK THAT THE PREFIX OF THE 'POSITION, " &
- "'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " &
- "DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " &
- "RETURN APPROPRIATE VALUES WHEN A RECORD " &
- "REPRESENTATION CLAUSE IS NOT PRESENT");
-
- IF CHECK_REC.CHECK_INT'FIRST_BIT >= CHECK_REC.CHECK_INT'LAST_BIT
- THEN FAILED ("INCORRECT VALUES FOR FIRST_BIT OR LAST_BIT " &
- "OF CHECK_INT");
- END IF;
-
- IF (CHECK_REC.CHECK_INT'LAST_BIT - CHECK_REC.CHECK_INT'FIRST_BIT
- + 1) < INTEGER'SIZE THEN
- FAILED ("INCORRECT SIZE FOR CHECK_INT");
- END IF;
-
- IF CHECK_REC.CHECK_BOOL'POSITION <= CHECK_REC.CHECK_INT'POSITION
- THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " &
- "OR CHECK_BOOL");
- END IF;
-
- IF CHECK_REC.CHECK_INT'POSITION >= CHECK_REC.CHECK_BOOL'POSITION
- THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " &
- "OR CHECK_BOOL - 2");
- END IF;
-
- IF CHECK_REC.CHECK_BOOL'FIRST_BIT > CHECK_REC.CHECK_BOOL'LAST_BIT
- THEN FAILED ("INCORRECT VALUE FOR FIRST_BIT OR LAST_BIT " &
- "OF CHECK_BOOL");
- END IF;
-
- IF (CHECK_REC.CHECK_BOOL'LAST_BIT - CHECK_REC.CHECK_BOOL'FIRST_BIT
- + 1) < BOOLEAN'SIZE THEN
- FAILED ("INCORRECT SIZE FOR CHECK_BOOL");
- END IF;
-
- RESULT;
-
-END CD7204B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada b/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada
deleted file mode 100644
index 77ca9bd..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- CD7204C.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 THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT
--- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES
--- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE
--- IS GIVEN.
-
--- HISTORY:
--- BCB 09/14/87 CREATED ORIGINAL TEST.
--- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-
-WITH SYSTEM;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CD7204C IS
-
- UNITS_PER_INTEGER : CONSTANT :=
- (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1)/SYSTEM.STORAGE_UNIT;
-
- TYPE BASIC_REC IS RECORD
- CHECK_INT : INTEGER;
- CHECK_CHAR : CHARACTER;
- END RECORD;
-
- FOR BASIC_REC USE
- RECORD
- CHECK_INT AT 0 RANGE 0..INTEGER'SIZE - 1;
- CHECK_CHAR AT 1*UNITS_PER_INTEGER
- RANGE 0..CHARACTER'SIZE - 1;
- END RECORD;
-
- CHECK_REC : BASIC_REC;
-
-BEGIN
-
- TEST ("CD7204C", "THE PREFIX OF THE 'POSITION, " &
- "'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " &
- "DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " &
- "RETURN APPROPRIATE VALUES WHEN A RECORD " &
- "REPRESENTATION CLAUSE IS GIVEN");
-
- IF CHECK_REC.CHECK_INT'POSITION /= 0 THEN
- FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_INT");
- END IF;
-
- IF CHECK_REC.CHECK_INT'FIRST_BIT /= IDENT_INT (0) THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_INT");
- END IF;
-
- IF CHECK_REC.CHECK_INT'LAST_BIT /= INTEGER'SIZE - 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_INT");
- END IF;
-
- IF CHECK_REC.CHECK_CHAR'POSITION /= IDENT_INT (UNITS_PER_INTEGER)
- THEN FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_CHAR");
- END IF;
-
- IF CHECK_REC.CHECK_CHAR'FIRST_BIT /= 0 THEN
- FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_CHAR");
- END IF;
-
- IF CHECK_REC.CHECK_CHAR'LAST_BIT /= IDENT_INT (CHARACTER'SIZE - 1)
- THEN FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_CHAR");
- END IF;
-
- RESULT;
-
-END CD7204C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a01.a b/gcc/testsuite/ada/acats/tests/cd/cd72a01.a
deleted file mode 100644
index 9c98cb0..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd72a01.a
+++ /dev/null
@@ -1,165 +0,0 @@
---
--- CD72A01.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 package System.Address_To_Access_Conversions may be
--- instantiated for various simple types.
---
--- Check that To_Pointer and To_Address are inverse operations.
---
--- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
--- X that allows Unchecked_Access.
---
--- Check that To_Pointer(Null_Address) returns null.
---
--- TEST DESCRIPTION:
--- This test checks that the semantics provided in
--- Address_To_Access_Conversions are present and operate
--- within expectations (to the best extent possible in a portable
--- implementation independent fashion).
---
--- The functions Address_To_Hex and Hex_To_Address test the invertability
--- of the To_Integer and To_Address functions, along with a great deal
--- of optimizer chaff and protection from the fact that type
--- Storage_Elements.Integer_Address may be either a modular or a signed
--- integer type.
---
--- This test has some interesting usage paradigms in that users
--- occasionally want to store address information in a transportable
--- fashion, and often resort to some textual representation of values.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 13 JUL 95 SAIC Initial version (CD72001)
--- 08 FEB 96 SAIC Revised (split) version for 2.1
--- 07 MAY 96 SAIC Additional subtest added for 2.1
--- 16 FEB 98 EDS Modified documentation.
---!
-
-with Report;
-with Impdef;
-with FD72A00;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD72A01 is
- use System;
- use FD72A00;
-
- package Number_ATAC is
- new System.Address_To_Access_Conversions(Number); -- ANX-C RQMT
-
- use type Number_ATAC.Object_Pointer;
-
- type Data is record
- One, Two: aliased Number;
- end record;
-
- package Data_ATAC is
- new System.Address_To_Access_Conversions(Data); -- ANX-C RQMT
-
- use type Data_ATAC.Object_Pointer;
-
- type Test_Cases is ( Addr_Type, Record_Type );
-
- type Naive_Dynamic_String is access String;
-
- type String_Store is array(Test_Cases) of Naive_Dynamic_String;
-
- The_Strings : String_Store;
-
- -- create several aliased objects with distinct values
-
- My_Number : aliased Number := Number'First;
- My_Data : aliased Data := (Number'First,Number'Last);
-
- use type System.Storage_Elements.Integer_Address;
-
-begin -- Main test procedure.
-
- Report.Test ("CD72A01", "Check package " &
- "System.Address_To_Access_Conversions " &
- "for simple types" );
-
- -- take several pointer objects, convert them to addresses, and store
- -- the address as a hexadecimal representation for later reconversion
-
- The_Strings(Addr_Type) := new String'(
- Address_To_Hex(Number_ATAC.To_Address(My_Number'Access)) );
-
- The_Strings(Record_Type) := new String'(
- Address_To_Hex(Data_ATAC.To_Address(My_Data'Access)) );
-
- -- now, reconvert the hexadecimal address values back to pointers,
- -- and check that the dereferenced pointer still designates the
- -- value placed at that location. The use of the intermediate
- -- string representation should foil even the cleverest of optimizers
-
- if Number_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Addr_Type))).all
- /= Number'First then
- Report.Failed("Number reconversion");
- end if;
-
- if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type))).all
- /= (Number'First,Number'Last) then
- Report.Failed("Data reconversion");
- end if;
-
- -- check that the resulting values are equal to the 'Unchecked_Access
- -- of the value
-
- if Number_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Addr_Type)))
- /= My_Number'Unchecked_Access then
- Report.Failed("Number Unchecked_Access");
- end if;
-
- if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type)))
- /= My_Data'Unchecked_Access then
- Report.Failed("Data Unchecked_Access");
- end if;
-
- if Number_ATAC.To_Pointer(System.Null_Address) /= null then
- Report.Failed("To_Pointer(Null_Address) /= null");
- end if;
-
- if Number_ATAC.To_Address(null) /= System.Null_Address then
- Report.Failed("To_Address(null) /= Null_Address");
- end if;
-
- Report.Result;
-
-end CD72A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a02.a b/gcc/testsuite/ada/acats/tests/cd/cd72a02.a
deleted file mode 100644
index f396edc..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd72a02.a
+++ /dev/null
@@ -1,225 +0,0 @@
--- CD72A02.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 package System.Address_To_Access_Conversions may be
--- instantiated for various composite types.
---
--- Check that To_Pointer and To_Address are inverse operations.
---
--- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
--- X that allows Unchecked_Access.
---
--- Check that To_Pointer(Null_Address) returns null.
---
--- TEST DESCRIPTION:
--- This test is identical to CD72A01 with the exception that it tests
--- the composite types where CD72A01 tests "simple" types.
---
--- This test checks that the semantics provided in
--- Address_To_Access_Conversions are present and operate
--- within expectations (to the best extent possible in a portable
--- implementation independent fashion).
---
--- The functions Address_To_Hex and Hex_To_Address test the invertability
--- of the To_Integer and To_Address functions, along with a great deal
--- of optimizer chaff and protection from the fact that type
--- Storage_Elements.Integer_Address may be either a modular or a signed
--- integer type.
---
--- This test has some interesting usage paradigms in that users
--- occasionally want to store address information in a transportable
--- fashion, and often resort to some textual representation of values.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 13 JUL 95 SAIC Initial version (CD72001)
--- 08 FEB 96 SAIC Split from CD72001 by reviewer request for 2.1
--- 12 NOV 96 SAIC Corrected typo in RM ref
--- 16 FEB 98 EDS Modified documentation.
--- 22 JAN 02 RLB Corrected test description.
---!
-
-with Report;
-with Impdef;
-with FD72A00;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD72A02 is
- use System;
- use FD72A00;
-
- type Tagged_Record is tagged record
- Value : Natural;
- end record;
-
- package Class_ATAC is
- new System.Address_To_Access_Conversions(Tagged_Record'Class);
- -- ANX-C RQMT
-
- use type Class_ATAC.Object_Pointer;
-
- task type TC_Task_Type is
- entry E;
- entry F;
- end TC_Task_Type;
-
- package Task_ATAC is
- new System.Address_To_Access_Conversions(TC_Task_Type);
- -- ANX-C RQMT
-
- use type Task_ATAC.Object_Pointer;
-
- task body TC_Task_Type is
- begin
- select
- accept E;
- or
- accept F;
- Report.Failed("Task rendezvoused on wrong path");
- end select;
- end TC_Task_Type;
-
- protected type TC_Protec is
- procedure E;
- procedure F;
- private
- Visited : Boolean := False;
- end TC_Protec;
-
- package Protected_ATAC is
- new System.Address_To_Access_Conversions(TC_Protec);
- -- ANX-C RQMT
-
- use type Protected_ATAC.Object_Pointer;
-
- protected body TC_Protec is
- procedure E is
- begin
- Visited := True;
- end E;
- procedure F is
- begin
- if not Visited then
- Report.Failed("Protected Object took wrong path");
- end if;
- end F;
- end TC_Protec;
-
- type Test_Cases is ( Tagged_Type, Task_Type, Protected_Type );
-
- type Naive_Dynamic_String is access String;
-
- type String_Store is array(Test_Cases) of Naive_Dynamic_String;
-
- The_Strings : String_Store;
-
- -- create several aliased objects with distinct values
-
- My_Rec : aliased Tagged_Record := (Value => Natural'Last);
- My_Task : aliased TC_Task_Type;
- My_Prot : aliased TC_Protec;
-
- use type System.Storage_Elements.Integer_Address;
-
-begin -- Main test procedure.
-
- Report.Test ("CD72A02", "Check package " &
- "System.Address_To_Access_Conversions " &
- "for composite types" );
-
- -- take several pointer objects, convert them to addresses, and store
- -- the address as a hexadecimal representation for later reconversion
-
- The_Strings(Tagged_Type) := new String'(
- Address_To_Hex(Class_ATAC.To_Address(My_Rec'Access)) );
-
- The_Strings(Task_Type) := new String'(
- Address_To_Hex(Task_ATAC.To_Address(My_Task'Access)) );
-
- The_Strings(Protected_Type) := new String'(
- Address_To_Hex(Protected_ATAC.To_Address(My_Prot'Access)) );
-
- -- now, reconvert the hexadecimal address values back to pointers,
- -- and check that the dereferenced pointer still designates the
- -- value placed at that location. The use of the intermediate
- -- string representation should foil even the cleverest of optimizers
-
- if Tagged_Record(Class_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Tagged_Type))).all)
- /= Tagged_Record'(Value => Natural'Last) then
- Report.Failed("Tagged_Record reconversion");
- end if;
-
- Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type))).E;
-
- begin
- select -- allow for task to have completed.
- My_Task.F; -- should not happen, will call Report.Fail in task
- else
- null; -- expected case, "Report.Pass;"
- end select;
- exception
- when Tasking_Error => null; -- task terminated, which is OK
- end;
-
- Protected_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Protected_Type))).E;
- My_Prot.F; -- checks that call to E occurred
-
-
- -- check that the resulting values are equal to the 'Unchecked_Access
- -- of the value
-
- if Class_ATAC.To_Pointer(Hex_To_Address(The_Strings(Tagged_Type)))
- /= My_Rec'Unchecked_Access then
- Report.Failed("Tagged_Record Unchecked_Access");
- end if;
-
- if Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type)))
- /= My_Task'Unchecked_Access then
- Report.Failed("Task Unchecked_Access");
- end if;
-
- if Protected_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Protected_Type)))
- /= My_Prot'Unchecked_Access then
- Report.Failed("Protected Unchecked_Access");
- end if;
-
- Report.Result;
-
-end CD72A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada
deleted file mode 100644
index 3241fca..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada
+++ /dev/null
@@ -1,52 +0,0 @@
--- CD7305A.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, FOR DIGITS 5, THAT MACHINE_RADIX, MACHINE_MANTISSA,
--- MACHINE_EMAX, AND MACHINE_EMIN HAVE THE CORRECT VALUES.
-
--- HISTORY:
--- DHH 09/15/88 CREATED ORIGINAL TEST.
--- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X.
-
-WITH REPORT; USE REPORT;
-PROCEDURE CD7305A IS
-
- TYPE T IS DIGITS 5;
-
- B : BOOLEAN := FALSE;
-
-BEGIN
- TEST ("CD7305A", "CHECK, FOR DIGITS 5, THAT MACHINE_RADIX, " &
- "MACHINE_MANTISSA, MACHINE_EMAX, AND " &
- "MACHINE_EMIN HAVE THE CORRECT VALUES");
-
-
- IF T'MACHINE_RADIX < 2 OR
- T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN
- FAILED ("INCORRECT 'MACHINE_RADIX");
- END IF;
-
- RESULT;
-END CD7305A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd90001.a b/gcc/testsuite/ada/acats/tests/cd/cd90001.a
deleted file mode 100644
index 3f3bd89..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd90001.a
+++ /dev/null
@@ -1,234 +0,0 @@
--- CD90001.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 Unchecked_Conversion is supported and is reversible in
--- the cases where:
--- Source'Size = Target'Size
--- Source'Alignment = Target'Alignment
--- Source and Target are both represented contiguously
--- Bit pattern in Source is a meaningful value of Target type
---
--- TEST DESCRIPTION:
--- This test declares an enumeration type with a representation
--- specification that should fit neatly into an 8 bit object; and a
--- modular type that should also be able to fit easily into 8 bits;
--- uses size representation clauses on both of them for 8 bit
--- representations. It then defines two instances of
--- Unchecked_Conversion; to convert both ways between the types.
--- Using several distinctive values, it checks that the conversions
--- are performed, and reversible.
--- As a second case, the above is performed with an integer type and
--- a packed array of booleans.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Changed Boolean to Character for 2.1
--- 27 JUL 96 SAIC Allowed for partial N/A to be PASS
--- 14 FEB 97 PWB.CTA Corrected "=" to "/=" in alignment check.
--- 16 FEB 98 EDS Modified documentation.
--- 21 DEC 05 RLB Corrected "=" to "/=" in other alignment check.
---!
-
------------------------------------------------------------------ CD90001_0
-
-with Report;
-with Unchecked_Conversion;
-package CD90001_0 is
-
- -- Case 1 : Modular <=> Enumeration
-
- type Eight_Bits is mod 2**8;
- for Eight_Bits'Size use 8;
-
- type User_Enums is ( One, Two, Four, Eight,
- Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight );
- for User_Enums'Size use 8;
-
- for User_Enums use
- ( One => 1, -- ANX-C RQMT.
- Two => 2, -- ANX-C RQMT.
- Four => 4, -- ANX-C RQMT.
- Eight => 8, -- ANX-C RQMT.
- Sixteen => 16, -- ANX-C RQMT.
- Thirty_Two => 32, -- ANX-C RQMT.
- Sixty_Four => 64, -- ANX-C RQMT.
- One_Twenty_Eight => 128 ); -- ANX-C RQMT.
-
- function EB_2_UE is new Unchecked_Conversion( Eight_Bits, User_Enums );
-
- function UE_2_EB is new Unchecked_Conversion( User_Enums, Eight_Bits );
-
- procedure TC_Check_Case_1;
-
- -- Case 2 : Integer <=> Packed Character array
-
- type Signed_16 is range -2**15+1 .. 2**15-1;
- -- +1, -1 allows for both 1's and 2's comp
-
- type Bits_16 is array(0..1) of Character;
- pragma Pack(Bits_16); -- ANX-C RQMT.
-
- function S16_2_B16 is new Unchecked_Conversion( Signed_16, Bits_16 );
-
- function B16_2_S16 is new Unchecked_Conversion( Bits_16, Signed_16 );
-
- procedure TC_Check_Case_2;
-
-end CD90001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CD90001_0 is
-
- Check_List : constant array(1..8) of Eight_Bits
- := ( 1, 2, 4, 8, 16, 32, 64, 128 );
-
- Check_Enum : constant array(1..8) of User_Enums
- := ( One, Two, Four, Eight,
- Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight );
-
- procedure TC_Check_Case_1 is
- Mod_Value : Eight_Bits;
- Enum_Val : User_Enums;
- begin
- for I in Check_List'Range loop
-
- if EB_2_UE(Check_List(I)) /= Check_Enum(I) then
- Report.Failed("EB => UE conversion failed");
- end if;
-
- if Check_List(I) /= UE_2_EB(Check_Enum(I)) then
- Report.Failed ("EU => EB conversion failed");
- end if;
-
- end loop;
- end TC_Check_Case_1;
-
- procedure TC_Check_Case_2 is
- S: Signed_16;
- T,U: Signed_16;
- B: Bits_16;
- C,D: Bits_16; -- allow for byte swapping
- begin
- --FDEC_BA98_7654_3210
- S := 2#0011_0000_0111_0111#;
- B := S16_2_B16( S );
- C := ( Character'Val(2#0011_0000#), Character'Val(2#0111_0111#) );
- D := ( Character'Val(2#0111_0111#), Character'Val(2#0011_0000#) );
-
- if (B /= C) and (B /= D) then
- Report.Failed("Int => Chararray conversion failed");
- end if;
-
- B := ( Character'Val(2#0011_1100#), Character'Val(2#0101_0101#) );
- S := B16_2_S16( B );
- T := 2#0011_1100_0101_0101#;
- U := 2#0101_0101_0011_1100#;
-
- if (S /= T) and (S /= U) then
- Report.Failed("Chararray => Int conversion failed");
- end if;
-
- end TC_Check_Case_2;
-
-end CD90001_0;
-
-------------------------------------------------------------------- CD90001
-
-with Report;
-with CD90001_0;
-
-procedure CD90001 is
-
- Eight_NA : Boolean := False;
- Sixteen_NA : Boolean := False;
-
-begin -- Main test procedure.
-
- Report.Test ("CD90001", "Check that Unchecked_Conversion is supported " &
- "and is reversible in appropriate cases" );
- Eight_Bit_Case:
- begin
- if CD90001_0.User_Enums'Size /= CD90001_0.Eight_Bits'Size then
- Report.Comment("The sizes of the 8 bit types used in this test "
- & "do not match" );
- Eight_NA := True;
- elsif CD90001_0.User_Enums'Alignment /= CD90001_0.Eight_Bits'Alignment then
- Report.Comment("The alignments of the 8 bit types used in this "
- & "test do not match" );
- Eight_NA := True;
- else
- CD90001_0.TC_Check_Case_1;
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised in 8 bit case");
- when others =>
- Report.Failed("Unexpected exception raised in 8 bit case");
- end Eight_Bit_Case;
-
- Sixteen_Bit_Case:
- begin
- if CD90001_0.Signed_16'Size /= CD90001_0.Bits_16'Size then
- Report.Comment("The sizes of the 16 bit types used in this test "
- & "do not match" );
- Sixteen_NA := True;
- elsif CD90001_0.Signed_16'Alignment /= CD90001_0.Bits_16'Alignment then
- Report.Comment("The alignments of the 16 bit types used in this "
- & "test do not match" );
- Sixteen_NA := True;
- else
- CD90001_0.TC_Check_Case_2;
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised in 16 bit case");
- when others =>
- Report.Failed("Unexpected exception raised in 16 bit case");
- end Sixteen_Bit_Case;
-
- if Eight_NA and Sixteen_NA then
- Report.Not_Applicable("No cases in this test apply");
- end if;
-
- Report.Result;
-
-end CD90001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd92001.a b/gcc/testsuite/ada/acats/tests/cd/cd92001.a
deleted file mode 100644
index d07ff48..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd92001.a
+++ /dev/null
@@ -1,229 +0,0 @@
--- CD92001.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 X denotes a scalar object, X'Valid
--- yields true if an only if the object denoted by X is normal and
--- has a valid representation.
---
--- TEST DESCRIPTION:
--- Using Unchecked_Conversion, Image and Value attributes, combined
--- with string manipulation, cause valid and invalid values to be
--- stored in various objects. Check their validity with the
--- attribute 'Valid. Invalid objects are created in a loop which
--- performs a simplistic check to ensure that the values being used
--- are indeed not valid, then assigns the value using an instance of
--- Unchecked_Conversion. The creation of the tables of valid values
--- is trivial.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- N/A => ERROR", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 10 MAY 95 SAIC Initial version
--- 07 MAY 96 SAIC Changed U_C to Ada.U_C for 2.1
--- 05 JAN 99 RLB Added Component_Size clauses to compensate
--- for the fact that there is no required size
--- for either the enumeration or modular components.
---!
-
-with Report;
-with Ada.Unchecked_Conversion;
-with System;
-procedure CD92001 is
-
- type Sparse_Enumerated is
- ( Help, Home, Page_Up, Del, EndK,
- Page_Down, Up, Left, Down, Right );
-
- for Sparse_Enumerated use ( Help => 2,
- Home => 4,
- Page_Up => 8,
- Del => 16,
- EndK => 32,
- Page_Down => 64,
- Up => 128,
- Left => 256,
- Down => 512,
- Right => 1024 );
-
- type Mod_10 is mod 10;
-
- type Default_Enumerated is ( Zero, One, Two, Three, Four,
- Five, Six, Seven, Eight, Nine,
- Clear, '=', '/', '*', '-',
- '+', Enter );
- for Default_Enumerated'Size use 8;
-
- Default_Enumerated_Count : constant := 17;
-
- type Mod_By_Enum_Items is mod Default_Enumerated_Count;
-
- type Mod_Same_Size_As_Sparse_Enum is mod 2**12;
- -- Sparse_Enumerated 'Size;
-
- type Mod_Same_Size_As_Def_Enum is mod 2**8;
- -- Default_Enumerated'Size;
-
- subtype Test_Width is Positive range 1..100;
-
- -- Note: There is no required relationship between 'Size and 'Component_Size,
- -- so we must use component_size clauses here.
- -- We use the following expressions to insure that the component size is a
- -- multiple of the Storage_Unit.
- Sparse_Component_Size : constant := ((Sparse_Enumerated'Size / System.Storage_Unit) +
- Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) *
- System.Storage_Unit;
- Default_Component_Size : constant := ((Default_Enumerated'Size / System.Storage_Unit) +
- Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) *
- System.Storage_Unit;
-
- type Sparse_Enum_Table is array(Test_Width) of Sparse_Enumerated;
- for Sparse_Enum_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR.
- type Def_Enum_Table is array(Test_Width) of Default_Enumerated;
- for Def_Enum_Table'Component_Size use Default_Component_Size; -- N/A => ERROR.
-
- type Sparse_Mod_Table is
- array(Test_Width) of Mod_Same_Size_As_Sparse_Enum;
- for Sparse_Mod_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR.
-
- type Default_Mod_Table is
- array(Test_Width) of Mod_Same_Size_As_Def_Enum;
- for Default_Mod_Table'Component_Size use Default_Component_Size; -- N/A => ERROR.
-
- function UC_Sparse_Mod_Enum is
- new Ada.Unchecked_Conversion( Sparse_Mod_Table, Sparse_Enum_Table );
-
- function UC_Def_Mod_Enum is
- new Ada.Unchecked_Conversion( Default_Mod_Table, Def_Enum_Table );
-
- Valid_Sparse_Values : Sparse_Enum_Table;
- Valid_Def_Values : Def_Enum_Table;
-
- Sample_Enum_Value_Table : Sparse_Mod_Table;
- Sample_Def_Value_Table : Default_Mod_Table;
-
-
- -- fill the Valid tables with valid values for conversion
- procedure Fill_Valid is
- K : Mod_10 := 0;
- P : Mod_By_Enum_Items := 0;
- begin
- for I in Test_Width loop
- Valid_Sparse_Values(I) := Sparse_Enumerated'Val( K );
- Valid_Def_Values(I) := Default_Enumerated'Val( Integer(P) );
- K := K +1;
- P := P +1;
- end loop;
- end Fill_Valid;
-
- -- fill the Sample tables with invalid values for conversion
- procedure Fill_Invalid is
- K : Mod_Same_Size_As_Sparse_Enum := 1;
- P : Mod_Same_Size_As_Def_Enum := 1;
- begin
- for I in Test_Width loop
- K := K +13;
- if K mod 2 = 0 then -- oops, that would be a valid value
- K := K +1;
- end if;
- if P = Mod_Same_Size_As_Def_Enum'Last
- or P < Default_Enumerated_Count then -- that would be valid
- P := Default_Enumerated_Count + 1;
- else
- P := P +1;
- end if;
- Sample_Enum_Value_Table(I) := K;
- Sample_Def_Value_Table(I) := P;
- end loop;
-
- Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table);
- Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table);
-
- end Fill_Invalid;
-
- -- fill the tables with second set of valid values for conversion
- procedure Refill_Valid is
- K : Mod_10 := 0;
- P : Mod_By_Enum_Items := 0;
-
- Table : Array(Mod_10) of Mod_Same_Size_As_Sparse_Enum
- := ( 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 );
-
- begin
- for I in Test_Width loop
- Sample_Enum_Value_Table(I) := Table(K);
- Sample_Def_Value_Table(I) := Mod_Same_Size_As_Def_Enum(P);
- K := K +1;
- P := P +1;
- end loop;
- Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table);
- Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table);
- end Refill_Valid;
-
- procedure Validate(Expect_Valid: Boolean) is
- begin -- here's where we actually use the tested attribute
-
- for K in Test_Width loop
- if Valid_Sparse_Values(K)'Valid /= Expect_Valid then
- Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid)
- & " for Sparse item " & Integer'Image(K) );
- end if;
- end loop;
-
- for P in Test_Width loop
- if Valid_Def_Values(P)'Valid /= Expect_Valid then
- Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid)
- & " for Default item " & Integer'Image(P) );
- end if;
- end loop;
-
- end Validate;
-
-begin -- Main test procedure.
-
- Report.Test ("CD92001", "Check object attribute: X'Valid" );
-
- Fill_Valid;
- Validate(True);
-
- Fill_Invalid;
- Validate(False);
-
- Refill_Valid;
- Validate(True);
-
- Report.Result;
-
-end CD92001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201a.ada b/gcc/testsuite/ada/acats/tests/cd/cda201a.ada
deleted file mode 100644
index b433f0c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cda201a.ada
+++ /dev/null
@@ -1,70 +0,0 @@
--- CDA201A.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR
--- CONVERSION BETWEEN INTEGER AND BOOLEAN ARRAY TYPES.
-
--- HISTORY:
--- JET 09/12/88 CREATED ORIGINAL TEST.
--- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
-
-WITH REPORT; USE REPORT;
-WITH UNCHECKED_CONVERSION;
-PROCEDURE CDA201A IS
-
- TYPE BOOL_ARR IS ARRAY (1..INTEGER'SIZE) OF BOOLEAN;
- PRAGMA PACK (BOOL_ARR);
-
- I : INTEGER;
- B : BOOL_ARR;
-
- FUNCTION INT_TO_BOOL IS NEW
- UNCHECKED_CONVERSION (INTEGER, BOOL_ARR);
-
- FUNCTION BOOL_TO_INT IS NEW UNCHECKED_CONVERSION(BOOL_ARR,INTEGER);
-
-BEGIN
- TEST ("CDA201A", "CHECK THAT UNCHECKED_CONVERSION CAN BE " &
- "INSTANTIATED FOR CONVERSION BETWEEN " &
- "INTEGER AND BOOLEAN ARRAY TYPES");
-
- I := BOOL_TO_INT((1..INTEGER'SIZE => IDENT_BOOL(TRUE)));
-
- IF INT_TO_BOOL(IDENT_INT(I)) /= (1..INTEGER'SIZE => TRUE) THEN
- FAILED("INCORRECT RESULT FROM ARRAY-INTEGER-ARRAY");
- END IF;
-
- B := INT_TO_BOOL(IDENT_INT(-1));
-
- FOR J IN B'RANGE LOOP
- B(J) := IDENT_BOOL(B(J));
- END LOOP;
-
- IF BOOL_TO_INT(B) /= -1 THEN
- FAILED("INCORRECT RESULT FROM INTEGER-ARRAY-INTEGER");
- END IF;
-
- RESULT;
-END CDA201A;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201b.ada b/gcc/testsuite/ada/acats/tests/cd/cda201b.ada
deleted file mode 100644
index 742cd92..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cda201b.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CDA201B.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR
--- CONVERSION BETWEEN FLOAT AND BOOLEAN ARRAY TYPES.
-
--- HISTORY:
--- JET 09/12/88 CREATED ORIGINAL TEST.
--- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
--- GJD 11/15/95 REMOVED USE OF OBSOLETE ADA 83 ATTRIBUTE (LARGE).
-
-WITH REPORT; USE REPORT;
-WITH UNCHECKED_CONVERSION;
-PROCEDURE CDA201B IS
-
- TYPE BOOL_ARR IS ARRAY (1..FLOAT'SIZE) OF BOOLEAN;
- PRAGMA PACK (BOOL_ARR);
-
- B : BOOL_ARR;
-
- FUNCTION FLT_TO_BOOL IS NEW UNCHECKED_CONVERSION(FLOAT, BOOL_ARR);
-
- FUNCTION BOOL_TO_FLT IS NEW UNCHECKED_CONVERSION(BOOL_ARR, FLOAT);
-
-BEGIN
- TEST ("CDA201B", "CHECK THAT UNCHECKED_CONVERSION CAN BE " &
- "INSTANTIATED FOR CONVERSION BETWEEN " &
- "FLOAT AND BOOLEAN ARRAY TYPES");
-
- B := FLT_TO_BOOL(FLOAT'LAST + FLOAT(IDENT_INT(0)));
-
- FOR J IN B'RANGE LOOP
- B(J) := B(J+IDENT_INT(0));
- END LOOP;
-
- IF BOOL_TO_FLT(B) /= FLOAT'LAST THEN
- FAILED("INCORRECT RESULT FROM FLOAT-ARRAY-FLOAT");
- END IF;
-
- RESULT;
-END CDA201B;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201c.ada b/gcc/testsuite/ada/acats/tests/cd/cda201c.ada
deleted file mode 100644
index db742ac..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cda201c.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CDA201C.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR
--- CONVERSION BETWEEN CONSTRAINED ARRAY AND RECORD TYPES.
-
--- HISTORY:
--- JET 09/12/88 CREATED ORIGINAL TEST.
--- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
-
-WITH REPORT; USE REPORT;
-WITH UNCHECKED_CONVERSION;
-PROCEDURE CDA201C IS
-
- TYPE INT IS NEW INTEGER;
-
- TYPE ARR IS ARRAY (1..2) OF INTEGER;
- TYPE ARR2 IS ARRAY (ARR'RANGE) OF INT;
-
- TYPE REC IS RECORD
- D : INTEGER;
- I : INTEGER;
- END RECORD;
-
- TYPE REC2 IS RECORD
- D : INT;
- I : INT;
- END RECORD;
-
- A : ARR2;
- R : REC2;
-
- FUNCTION ARR_CONV IS NEW UNCHECKED_CONVERSION(ARR, ARR2);
- FUNCTION REC_CONV IS NEW UNCHECKED_CONVERSION(REC, REC2);
-
-BEGIN
- TEST ("CDA201C", "CHECK THAT UNCHECKED_CONVERSION CAN BE " &
- "INSTANTIATED FOR CONVERSION BETWEEN " &
- "CONSTRAINED ARRAY AND RECORD TYPES");
-
- A := ARR_CONV(ARR'(ARR'RANGE => IDENT_INT(-1)));
-
- IF A /= ARR2'(ARR'RANGE => -1) THEN
- FAILED("INCORRECT RESULT FROM ARRAY CONVERSION");
- END IF;
-
- R := REC_CONV(REC'(D | I => IDENT_INT(1)));
-
- IF R /= REC2'(D => 1, I => 1) THEN
- FAILED("INCORRECT RESULT FROM RECORD CONVERSION");
- END IF;
-
- RESULT;
-END CDA201C;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201e.ada b/gcc/testsuite/ada/acats/tests/cd/cda201e.ada
deleted file mode 100644
index c82e48c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cda201e.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- CDA201E.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR THE
--- CONVERSION OF AN ENUMERATION TYPE WITH A REPRESENTATION CLAUSE TO
--- INTEGER.
-
--- HISTORY:
--- JET 09/23/88 CREATED ORIGINAL TEST.
--- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
--- RJW 02/28/90 ADDED SIZE CLAUSE FOR TYPE STOOGE.
--- LDC 09/20/90 ADDED CHECK FOR CONVERSION FROM INT TO STOOGE,
--- ADDED COMMENT WHEN SIZES AREN'T EQUAL.
-
-WITH REPORT; USE REPORT;
-WITH UNCHECKED_CONVERSION;
-PROCEDURE CDA201E IS
-
- TYPE STOOGE IS (CURLY, MOE, LARRY);
- FOR STOOGE USE (CURLY => -5, MOE => 13, LARRY => 127);
- FOR STOOGE'SIZE USE 8;
-
- TYPE INT IS RANGE -128 .. 127;
- FOR INT'SIZE USE 8;
-
- I : INT := 0;
- NAME : STOOGE := CURLY;
-
- FUNCTION E_TO_I IS NEW UNCHECKED_CONVERSION(STOOGE, INT);
- FUNCTION I_TO_E IS NEW UNCHECKED_CONVERSION(INT, STOOGE);
-
- FUNCTION ID(E : STOOGE) RETURN STOOGE IS
- BEGIN
- RETURN STOOGE'VAL(STOOGE'POS(E) + IDENT_INT(0));
- END ID;
-
- FUNCTION ID_INT (X : INT) RETURN INT IS
- A : INTEGER := IDENT_INT(3);
- BEGIN
- IF EQUAL (A, IDENT_INT(3)) THEN -- ALWAYS EQUAL.
- RETURN X; -- ALWAYS EXECUTED.
- END IF;
- RETURN 0; -- NEVER EXECUTED.
- END ID_INT;
-
-BEGIN
- TEST ("CDA201E", "CHECK THAT UNCHECKED_CONVERSION CAN BE " &
- "INSTANTIATED FOR THE CONVERSION OF AN " &
- "ENUMERATION TYPE WITH A REPRESENTATION " &
- "CLAUSE TO INTEGER");
-
- IF I'SIZE /= NAME'SIZE THEN
- COMMENT( "UNCHECKED_CONVERSION MIGHT BE INSTANTIATED WITH " &
- "DIFFERNT SIZES");
- END IF;
-
- BEGIN
- I := E_TO_I(ID(CURLY));
- IF I /= -5 THEN
- FAILED ("INCORRECT VALUE OF CURLY: " & INT'IMAGE(I));
- END IF;
-
- I := E_TO_I(ID(MOE));
- IF I /= 13 THEN
- FAILED ("INCORRECT VALUE OF MOE: " & INT'IMAGE(I));
- END IF;
-
- I := E_TO_I(ID(LARRY));
- IF I /= 127 THEN
- FAILED ("INCORRECT VALUE OF LARRY: " & INT'IMAGE(I));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION");
- END;
-
- BEGIN -- 2
- NAME := I_TO_E(ID_INT(-5));
- IF NAME /= CURLY THEN
- FAILED ("INCORRECT VALUE OF -5 : " & STOOGE'IMAGE(NAME));
- END IF;
-
- NAME := I_TO_E(ID_INT(13));
- IF NAME /= MOE THEN
- FAILED ("INCORRECT VALUE OF 13: " & STOOGE'IMAGE(NAME));
- END IF;
-
- NAME := I_TO_E(ID_INT(127));
- IF NAME /= LARRY THEN
- FAILED ("INCORRECT VALUE OF 127: " & STOOGE'IMAGE(NAME));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION - 2");
- END;
-
- RESULT;
-END CDA201E;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
deleted file mode 100644
index 566fad1..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CDB0A01.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 storage pool may be user_determined, and that storage
--- is allocated by calling Allocate.
---
--- Check that a storage.pool may be specified using 'Storage_Pool
--- and that S'Storage_Pool denotes the storage pool of the type S.
---
--- TEST DESCRIPTION:
--- The package System.Storage_Pools is exercised by two very similar
--- packages which define a tree type and exercise it in a simple manner.
--- One package uses a user defined pool. The other package uses a
--- storage pool assigned by the implementation; Storage_Size is
--- specified for this pool.
--- The dispatching procedures Allocate and Deallocate are tested as an
--- intentional side effect of the tree packages.
---
--- For completeness, the actions of the tree packages are checked for
--- correct operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FDB0A00.A (foundation code)
--- CDB0A01.A
---
---
--- CHANGE HISTORY:
--- 02 JUN 95 SAIC Initial version
--- 07 MAY 96 SAIC Removed ambiguity with CDB0A02
--- 13 FEB 97 PWB.CTA Corrected lexically ordered string literal
---!
-
----------------------------------------------------------------- CDB0A01_1
-
----------------------------------------------------------- FDB0A00.Pool1
-
-package FDB0A00.Pool1 is
- User_Pool : Stack_Heap( 5_000 );
-end FDB0A00.Pool1;
-
----------------------------------------------------------- FDB0A00.Comparator
-
-with System.Storage_Pools;
-package FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean;
-
-end FDB0A00.Comparator;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean is
- use type System.Address;
- begin
- return A'Address = B'Address;
- end "=";
-
-end FDB0A00.Comparator;
-
----------------------------------------------------------------- CDB0A01_2
-
-with FDB0A00.Pool1;
-package CDB0A01_2 is
-
- type Cell;
- type User_Pool_Tree is access Cell;
-
- for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool;
-
- type Cell is record
- Data : Character;
- Left,Right : User_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree );
-
- procedure Traverse( The_Tree : User_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out User_Pool_Tree );
-
-end CDB0A01_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_2 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : User_Pool_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out User_Pool_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A01_2;
-
----------------------------------------------------------------- CDB0A01_3
-
-with FDB0A00.Pool1;
-package CDB0A01_3 is
-
- type Cell;
- type System_Pool_Tree is access Cell;
-
- for System_Pool_Tree'Storage_Size use 2000;
-
- -- assumptions: Cell is <= 20 storage_units
- -- Tree building exercise requires O(15) cells
- -- 2000 > 20 * 15 by a generous margin
-
- type Cell is record
- Data: Character;
- Left,Right : System_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree );
-
- procedure Traverse( The_Tree : System_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out System_Pool_Tree );
-
-end CDB0A01_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_3 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : System_Pool_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out System_Pool_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A01_3;
-
------------------------------------------------------------------- CDB0A01
-
-with Report;
-with TCTouch;
-with FDB0A00.Comparator;
-with FDB0A00.Pool1;
-with CDB0A01_2;
-with CDB0A01_3;
-
-procedure CDB0A01 is
-
- Banyan : CDB0A01_2.User_Pool_Tree;
- Torrey : CDB0A01_3.System_Pool_Tree;
-
- use type CDB0A01_2.User_Pool_Tree;
- use type CDB0A01_3.System_Pool_Tree;
-
- Countess : constant String := "Ada Augusta Lovelace";
- Cenosstu : constant String := " AALaaacdeeglostuuv";
- Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA";
- Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
-
-begin -- Main test procedure.
-
- Report.Test ("CDB0A01", "Check that a storage pool may be " &
- "user_determined, and that storage is " &
- "allocated by calling Allocate. Check that " &
- "a storage.pool may be specified using " &
- "'Storage_Pool and that S'Storage_Pool denotes " &
- "the storage pool of the type S" );
-
--- Check that S'Storage_Pool denotes the storage pool for the type S.
-
- TCTouch.Assert(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_2.User_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree");
-
- TCTouch.Assert_Not(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_3.System_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree");
-
--- Check that storage is allocated by calling Allocate.
-
- for Count in Countess'Range loop
- CDB0A01_2.Insert( Countess(Count), Banyan );
- end loop;
- TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" );
-
- for Count in Countess'Range loop
- CDB0A01_3.Insert( Countess(Count), Torrey );
- end loop;
- TCTouch.Validate("", "Allocate calls via CDB0A01_3" );
-
- CDB0A01_2.Traverse(Banyan);
- TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
-
- CDB0A01_3.Traverse(Torrey);
- TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
-
- CDB0A01_2.Defoliate(Banyan);
- TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
- TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
-
- CDB0A01_3.Defoliate(Torrey);
- TCTouch.Validate("", "Deforestation of Torrey" );
- TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
-
- Report.Result;
-
-end CDB0A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a
deleted file mode 100644
index 6a7fca5..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- CDB0A02.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 several access types can share the same pool.
---
--- Check that any exception propagated by Allocate is
--- propagated by the allocator.
---
--- Check that for an access type S, S'Max_Size_In_Storage_Elements
--- denotes the maximum values for Size_In_Storage_Elements that will
--- be requested via Allocate.
---
--- TEST DESCRIPTION:
--- After checking correct operation of the tree packages, the limits of
--- the storage pools (first the shared user defined storage pool, then
--- the system storage pool) are intentionally exceeded. The test checks
--- that the correct exception is raised.
---
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FDB0A00.A (foundation code)
--- CDB0A02.A
---
---
--- CHANGE HISTORY:
--- 10 AUG 95 SAIC Initial version
--- 07 MAY 96 SAIC Disambiguated for 2.1
--- 13 FEB 97 PWB.CTA Reduced minimum allowable
--- Max_Size_In_Storage_Units, for implementations
--- with larger storage units
--- 25 JAN 01 RLB Removed dubious checks on Max_Size_In_Storage_Units;
--- tightened important one.
-
---!
-
----------------------------------------------------------- FDB0A00.Pool2
-
-package FDB0A00.Pool2 is
- Pond : Stack_Heap( 5_000 );
-end FDB0A00.Pool2;
-
----------------------------------------------------------------- CDB0A02_2
-
-with FDB0A00.Pool2;
-package CDB0A02_2 is
-
- type Small_Cell;
- type Small_Tree is access Small_Cell;
-
- for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- first usage
-
- type Small_Cell is record
- Data: Character;
- Left,Right : Small_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out Small_Tree );
-
- procedure Traverse( The_Tree : Small_Tree );
-
- procedure Defoliate( The_Tree : in out Small_Tree );
-
- procedure TC_Exceed_Pool;
-
- Pool_Max_Elements : constant := 6000;
- -- to guarantee overflow in TC_Exceed_Pool
-
-end CDB0A02_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Report;
-with Unchecked_Deallocation;
-package body CDB0A02_2 is
- procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Small_Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : Small_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out Small_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
- procedure TC_Exceed_Pool is
- Wild_Branch : Small_Tree;
- begin
- for Ever in 1..Pool_Max_Elements loop
- Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch);
- TCTouch.Validate("A","Allocating element for overflow");
- end loop;
- Report.Failed(" Pool_Overflow not raised on exceeding user pool size");
- exception
- when FDB0A00.Pool_Overflow => null; -- anticipated case
- when others =>
- Report.Failed("wrong exception raised in user Exceed_Pool");
- end TC_Exceed_Pool;
-
-end CDB0A02_2;
-
----------------------------------------------------------------- CDB0A02_3
-
--- This package is essentially identical to CDB0A02_2, except that the size
--- of a cell is significantly larger. This is used to check that different
--- access types may share a single pool
-
-with FDB0A00.Pool2;
-package CDB0A02_3 is
-
- type Large_Cell;
- type Large_Tree is access Large_Cell;
-
- for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- second usage
-
- type Large_Cell is record
- Data: Character;
- Extra_Data : String(1..2);
- Left,Right : Large_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out Large_Tree );
-
- procedure Traverse( The_Tree : Large_Tree );
-
- procedure Defoliate( The_Tree : in out Large_Tree );
-
-end CDB0A02_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A02_3 is
- procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Large_Cell'(Item,(Item,Item),null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : Large_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out Large_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A02_3;
-
------------------------------------------------------------------- CDB0A02
-
-with Report;
-with TCTouch;
-with System.Storage_Elements;
-with CDB0A02_2;
-with CDB0A02_3;
-with FDB0A00;
-
-procedure CDB0A02 is
-
- Banyan : CDB0A02_2.Small_Tree;
- Torrey : CDB0A02_3.Large_Tree;
-
- use type CDB0A02_2.Small_Tree;
- use type CDB0A02_3.Large_Tree;
-
- Countess1 : constant String := "Ada ";
- Countess2 : constant String := "Augusta ";
- Countess3 : constant String := "Lovelace";
- Cenosstu : constant String := " AALaaacdeeglostuuv";
- Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA"
- & "AAAAAAAAAAAAAAAAAAAA";
- Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
-
-begin -- Main test procedure.
-
- Report.Test ("CDB0A02", "Check that several access types can share " &
- "the same pool. Check that any exception " &
- "propagated by Allocate is propagated by the " &
- "allocator. Check that for an access type S, " &
- "S'Max_Size_In_Storage_Elements denotes the " &
- "maximum values for Size_In_Storage_Elements " &
- "that will be requested via Allocate" );
-
- -- Check that access types can share the same pool.
-
- for Count in Countess1'Range loop
- CDB0A02_2.Insert( Countess1(Count), Banyan );
- end loop;
-
- for Count in Countess1'Range loop
- CDB0A02_3.Insert( Countess1(Count), Torrey );
- end loop;
-
- for Count in Countess2'Range loop
- CDB0A02_2.Insert( Countess2(Count), Banyan );
- end loop;
-
- for Count in Countess2'Range loop
- CDB0A02_3.Insert( Countess2(Count), Torrey );
- end loop;
-
- for Count in Countess3'Range loop
- CDB0A02_2.Insert( Countess3(Count), Banyan );
- end loop;
-
- for Count in Countess3'Range loop
- CDB0A02_3.Insert( Countess3(Count), Torrey );
- end loop;
-
- TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" );
-
-
- CDB0A02_2.Traverse(Banyan);
- TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
-
- CDB0A02_3.Traverse(Torrey);
- TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
-
- CDB0A02_2.Defoliate(Banyan);
- TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
- TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
-
- CDB0A02_3.Defoliate(Torrey);
- TCTouch.Validate(Deallocation, "Deforestation of Torrey" );
- TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
-
- -- Check that for an access type S, S'Max_Size_In_Storage_Elements
- -- denotes the maximum values for Size_In_Storage_Elements that will
- -- be requested via Allocate. (Of course, all we can do is check that
- -- whatever was requested of Allocate did not exceed the values of the
- -- attributes.)
-
- TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 ..
- System.Storage_Elements.Storage_Count'Max (
- CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements,
- CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements),
- "An object of excessive size was allocated. Size: "
- & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request));
-
- -- Check that an exception raised in Allocate is propagated by the allocator.
-
- CDB0A02_2.TC_Exceed_Pool;
-
- Report.Result;
-
-end CDB0A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd1001.a b/gcc/testsuite/ada/acats/tests/cd/cdd1001.a
deleted file mode 100644
index 0641798..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd1001.a
+++ /dev/null
@@ -1,94 +0,0 @@
--- CDD1001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 components of Stream_Element_Array are aliased. (Defect
--- Report 8652/0044).
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations for which Stream_Element'Size is a multiple of
--- System.Storage_Unit, this test must execute.
---
--- For other implementations, if this test compiles without error messages
--- at compilation, it must bind and execute.
---
--- PASS/FAIL CRITERIA:
--- For implementations for which Stream_Element'Size is a multiple of
--- System.Storage_Unit, this test must execute, report PASSED, and
--- complete normally, otherwise the test FAILS.
---
--- For other implementations:
--- PASSING behavior is:
--- this test executes, reports PASSED, and completes normally
--- or
--- this test produces at least one error message at compilation, and
--- the error message is associated with one of the items marked:
--- -- N/A => ERROR.
---
--- All other behaviors are FAILING.
---
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release.
-
---!
-with Ada.Streams;
-use Ada.Streams;
-with Report;
-use Report;
-procedure CDD1001 is
-
- type Acc is access all Stream_Element;
-
- A : Stream_Element_Array
- (Stream_Element_Offset (Ident_Int (1)) ..
- Stream_Element_Offset (Ident_Int (10)));
- B : array (A'Range) of Acc;
-begin
- Test ("CDD1001",
- "Check that components of Stream_Element_Array are aliased");
-
- for I in A'Range loop
- A (I) := Stream_Element (Ident_Int (Integer (I)) * Ident_Int (3));
- end loop;
-
- for I in B'Range loop
- B (I) := A (I)'Access; -- N/A => ERROR.
- end loop;
-
- for I in B'Range loop
- if B (I).all /= Stream_Element
- (Ident_Int (Integer (I)) * Ident_Int (3)) then
- Failed ("Unable to build access values designating elements " &
- "of a Stream_Element_Array");
- end if;
- end loop;
-
- Result;
-end CDD1001;
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2001.a b/gcc/testsuite/ada/acats/tests/cd/cdd2001.a
deleted file mode 100644
index 3184dde..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2001.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CDD2001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 default implementation of Read and Input raise End_Error
--- if the end of stream is reached before the reading of a value is
--- completed. (Defect Report 8652/0045,
--- Technical Corrigendum 13.13.2(35.1/1)).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-
-with Ada.Streams;
-use Ada.Streams;
-package CDD2001_0 is
-
- type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
- record
- First : Stream_Element_Offset := 1;
- Last : Stream_Element_Offset := 0;
- Contents : Stream_Element_Array (1 .. Size);
- end record;
-
- procedure Clear (Stream : in out My_Stream);
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
-
- procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
-
-end CDD2001_0;
-
-package body CDD2001_0 is
-
- procedure Clear (Stream : in out My_Stream) is
- begin
- Stream.First := 1;
- Stream.Last := 0;
- end Clear;
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- if Item'Length >= Stream.Last - Stream.First + 1 then
- Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
- Stream.Contents (Stream.First .. Stream.Last);
- Last := Item'First + Stream.Last - Stream.First;
- Stream.First := Stream.Last + 1;
- else
- Item := Stream.Contents (Stream.First ..
- Stream.First + Item'Length - 1);
- Last := Item'Last;
- Stream.First := Stream.First + Item'Length;
- end if;
- end Read;
-
- procedure Write (Stream : in out My_Stream;
- Item : in Stream_Element_Array) is
- begin
- Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
- Stream.Last := Stream.Last + Item'Length;
- end Write;
-
-end CDD2001_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with CDD2001_0;
-use CDD2001_0;
-with Io_Exceptions;
-use Io_Exceptions;
-with Report;
-use Report;
-procedure CDD2001 is
-
- subtype Int is Integer range -20 .. 20;
-
- type R (D : Int) is
- record
- C1 : Character := Ident_Char ('a');
- case D is
- when 0 .. 20 =>
- C2 : String (1 .. D) := (others => Ident_Char ('b'));
- when others =>
- C3, C4 : Float := Float (-D);
- end case;
- end record;
-
- S : aliased My_Stream (200);
-
-begin
- Test
- ("CDD2001",
- "Check that the default implementation of Read and Input " &
- "raise End_Error if the end of stream is reached before the " &
- "reading of a value is completed");
-
- Read:
- declare
- X : R (Ident_Int (13));
- begin
- Clear (S);
-
- -- A complete object.
- R'Write (S'Access, X);
- X.C1 := Ident_Char ('A');
- X.C2 := (others => Ident_Char ('B'));
- R'Read (S'Access, X);
- if X.C1 /= Ident_Char ('a') or X.C2 /=
- (1 .. 13 => Ident_Char ('b')) then
- Failed ("Read did not produce the expected result");
- end if;
-
- Clear (S);
-
- -- Not enough data.
- Character'Write (S'Access, 'a');
- String'Write (S'Access, "bbb");
-
- begin
- R'Read (S'Access, X);
- Failed
- ("No exception raised when the end of stream is reached " &
- "before the reading of a value is completed - 1");
- exception
- when End_Error =>
- null;
- when E: others =>
- Failed ("Wrong Exception " & Exception_Name (E) &
- " - " & Exception_Information (E) &
- " - " & Exception_Message (E) & " - 1");
- end;
-
- end Read;
-
- Input:
- declare
- X : R (Ident_Int (-11));
- begin
- Clear (S);
-
- -- A complete object.
- R'Output (S'Access, X);
- X.C1 := Ident_Char ('A');
- X.C3 := 4.0;
- X.C4 := 5.0;
- X := R'Input (S'Access);
- if X.C1 /= Ident_Char ('a') or X.C3 /= 11.0 or X.C4 /= 11.0 then
- Failed ("Input did not produce the expected result");
- end if;
-
- Clear (S);
-
- -- Not enough data.
- Integer'Output (S'Access, Ident_Int (-11)); -- The discriminant
- Character'Output (S'Access, 'a');
- Float'Output (S'Access, 11.0);
-
- begin
- X := R'Input (S'Access);
- Failed
- ("No exception raised when the end of stream is reached " &
- "before the reading of a value is completed - 2");
- exception
- when End_Error =>
- null;
- when E: others =>
- Failed ("Wrong exception " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 2");
- end;
-
- end Input;
-
- Result;
-end CDD2001;
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a
deleted file mode 100644
index 7c8000c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- CDD2A01.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Read and Write attributes for a type extension are created
--- from the parent type's attribute (which may be user-defined) and those
--- for the extension components. Also check that the default Input and
--- Output attributes are used for a type extension, even if the parent
--- type's attribute is user-defined. (Defect Report 8652/0040,
--- as reflected in Technical Corrigendum 1, penultimate sentence of
--- 13.13.2(9/1) and 13.13.2(25/1)).
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A01 is
-
- Input_Output_Error : exception;
-
- type Int is range 1 .. 1000;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is tagged
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- X : Parent (1, 1, True);
- begin
- raise Input_Output_Error;
- return X;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- raise Input_Output_Error;
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
- type Derived1 is new Parent with
- record
- C3 : Int;
- end record;
-
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False) with
- record
- C3 : Int;
- end record;
-
-begin
- Test ("CDD2A01",
- "Check that the Read and Write attributes for a type " &
- "extension are created from the parent type's " &
- "attribute (which may be user-defined) and those for the " &
- "extension components; also check that the default input " &
- "and output attributes are used for a type extension, even " &
- "if the parent type's attribute is user-defined");
-
- Test1:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- Y1 : Derived1 := (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (100),
- C3 => Int (Ident_Int (88)));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
- X1.C3 := Int (Ident_Int (99));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call parent type's Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
-
- if X2 /= (D1 => 2,
- D2 => 5,
- B => True,
- S => Str (Ident_Str ("bcde")),
- C2 => Float (Ident_Int (4)),
- C3 => Int (Ident_Int (99))) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 1");
- end if;
-
- begin
- Derived1'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 4, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 2");
- end if;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Output - 2");
- end;
-
- begin
- declare
- Y2 : Derived1 := Derived1'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 2");
- end if;
- if Y2 /= (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (88))) then
- Failed
- ("Input and Output are not inverses of each other - 2");
- end if;
- end;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Input - 2");
- end;
-
- end Test1;
-
- Test2:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- Y1 : Derived2 := (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (200),
- C3 => Int (Ident_Int (77)));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
- X1.C3 := Int (Ident_Int (666));
-
- Derived2'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 5, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 3, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 3");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 5, Write => 5, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 3, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 3");
- end if;
-
- if X2 /= (D => 7,
- S => Str (Ident_Str ("g")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (666))) then
- Failed ("Read and Write are not inverses of each other - 3");
- end if;
-
- begin
- Derived2'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 5, Write => 7, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 4, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 4");
- end if;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Output - 4");
- end;
-
- begin
- declare
- Y2 : Derived2 := Derived2'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 7, Write => 7, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 4");
- end if;
- if Y2 /= (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (77))) then
- Failed
- ("Input and Output are not inverses of each other - 4");
- end if;
- end;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Input - 4");
- end;
-
- end Test2;
-
- Result;
-end CDD2A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a
deleted file mode 100644
index 854431c..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a
+++ /dev/null
@@ -1,345 +0,0 @@
--- CDD2A02.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Read, Write, Input, and Output attributes are inherited
--- for untagged derived types. (Defect Report 8652/0040,
--- as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
--- 13.13.2(25/1)).
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A02 is
-
- type Int is range 1 .. 10;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- D1, D2 : Int;
- B : Boolean;
- begin
- Int'Read (Stream, D2);
- Boolean'Read (Stream, B);
- Int'Read (Stream, D1);
-
- declare
- Item : Parent (D1 => D1, D2 => D2, B => B);
- begin
- Parent'Read (Stream, Item);
- return Item;
- end;
-
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- Int'Write (Stream, Item.D2);
- Boolean'Write (Stream, Item.B);
- Int'Write (Stream, Item.D1);
- Parent'Write (Stream, Item);
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
-begin
- Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
- "attributes are inherited for untagged derived types");
-
- Test1:
- declare
- type Derived1 is new Parent;
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
- Y1 : Derived1 := (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (100));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 0, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 0, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
-
- if X2 /= (D1 => 2,
- D2 => 5,
- B => True,
- S => Str (Ident_Str ("bcde")),
- C2 => Float (Ident_Int (4))) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 1");
- end if;
-
- Derived1'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 2, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 1) then
- Failed ("Didn't call inherited Output - 2");
- end if;
-
- declare
- Y2 : Derived1 := Derived1'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Input - 2");
- end if;
-
- if Y2 /= (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Input and Output are not inverses of each other - 2");
- end if;
- end;
- end Test1;
-
- Test2:
- declare
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False);
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- Y1 : Derived2 := (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (200));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
-
- Derived2'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 3, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Write - 3");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 3, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Read - 3");
- end if;
-
- if X2 /= (D => 7,
- S => Str (Ident_Str ("g")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 3");
- end if;
-
- Derived2'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 4, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 4, Input => 1, Output => 2) then
- Failed ("Didn't call inherited Output - 4");
- end if;
-
- declare
- Y2 : Derived2 := Derived2'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 2, Output => 2) then
- Failed ("Didn't call inherited Input - 4");
- end if;
-
- if Y2 /= (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Input and Output are not inverses of each other - 4");
- end if;
- end;
- end Test2;
-
- Result;
-end CDD2A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a
deleted file mode 100644
index b4c2917..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a
+++ /dev/null
@@ -1,325 +0,0 @@
--- CDD2A03.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 default Read and Write attributes for a limited type
--- extension are created from the parent type's attribute (which may be
--- user-defined) and those for the extension components, if the extension
--- components are non-limited or have user-defined attributes. Check that
--- such limited type extension attributes are callable (Defect Report
--- 8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence
--- of 13.13.2(9/1) and 13.13.2(36/1)).
---
--- CHANGE HISTORY:
--- 1 AUG 2001 PHL Initial version.
--- 3 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A03 is
-
- Input_Output_Error : exception;
-
- type Int is range 1 .. 1000;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Lim is limited
- record
- C : Int;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim);
- function Input (Stream : access Root_Stream_Type'Class) return Lim;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim);
-
- for Lim'Read use Read;
- for Lim'Write use Write;
- for Lim'Input use Input;
- for Lim'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is tagged limited
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Lim) is
- begin
- Integer'Read (Stream, Integer (Item.C));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Lim) is
- begin
- Integer'Write (Stream, Integer (Item.C));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is
- Result : Lim;
- begin
- Result.C := Int (Integer'Input (Stream));
- return Result;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Lim) is
- begin
- Integer'Output (Stream, Integer (Item.C));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- X : Parent (1, 1, True);
- begin
- raise Input_Output_Error;
- return X;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- raise Input_Output_Error;
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Lim_Ops is new Counting_Stream_Ops (T => Lim,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim)
- renames Lim_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim)
- renames Lim_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Lim
- renames Lim_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim)
- renames Lim_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
- type Derived1 is new Parent with
- record
- C3 : Int;
- end record;
-
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False) with
- record
- C3 : Lim;
- end record;
-
-begin
- Test ("CDD2A03",
- "Check that the default Read and Write attributes for a limited " &
- "type extension are created from the parent type's " &
- "attribute (which may be user-defined) and those for the " &
- "extension components, if the extension components are " &
- "non-limited or have user-defined attributes; check that such " &
- "limited type extension attributes are callable");
-
- Test1:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
- X1.C3 := Int (Ident_Int (99));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call parent type's Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
- end Test1;
-
- Test2:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
- X1.C3.C := Int (Ident_Int (666));
-
- Derived2'Write (S'Access, X1);
- if Lim_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 2");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Lim_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 2");
- end if;
- end Test2;
-
- Result;
-end CDD2A03;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cde0001.a b/gcc/testsuite/ada/acats/tests/cd/cde0001.a
deleted file mode 100644
index 59db225..0000000
--- a/gcc/testsuite/ada/acats/tests/cd/cde0001.a
+++ /dev/null
@@ -1,324 +0,0 @@
--- CDE0001.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 following names can be used in the declaration of a
--- generic formal parameter (object, array type, or access type) without
--- causing freezing of the named type:
--- (1) The name of a private type,
--- (2) A name that denotes a subtype of a private type, and
--- (3) A name that denotes a composite type with a subcomponent of a
--- private type (or subtype).
--- Check for untagged and tagged types.
---
--- TEST DESCRIPTION:
--- This transition test defines private and limited private types,
--- subtypes of these private types, records and arrays of both types and
--- subtypes, a tagged type and a private extension.
--- This test creates examples where the above types are used in the
--- definition of several generic formal type parameters (object, array
--- type, or access type) in both visible and private parts. These
--- visible and private generic packages are instantiated in the body of
--- the public child and the private child, respectively.
--- The main program utilizes the functions declared in the public child
--- to verify results of the instantiations.
---
--- Inspired by B74103F.ADA.
---
---
--- CHANGE HISTORY:
--- 12 Mar 96 SAIC Initial version for ACVC 2.1.
--- 05 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate for CDE0001.
--- 21 Nov 98 RLB Added pragma Elaborate for CDE0001 to CDE0001_3.
---!
-
-package CDE0001_0 is
-
- subtype Small_Int is Integer range 1 .. 2;
-
- type Private_Type is private;
- type Limited_Private is limited private;
-
- subtype Private_Subtype is Private_Type;
- subtype Limited_Private_Subtype is Limited_Private;
-
- type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype;
-
- type Rec_Of_Limited_Private is
- record
- C1 : Limited_Private;
- end record;
-
- type Rec_Of_Private_SubType is
- record
- C1 : Private_SubType;
- end record;
-
- type Tag_Type is tagged
- record
- C1 : Small_Int;
- end record;
-
- type New_TagType is new Tag_Type with private;
-
- generic
-
- Formal_Obj01 : in out Private_Type; -- Formal objects defined
- Formal_Obj02 : in out Limited_Private; -- by names of private
- Formal_Obj03 : in out Private_Subtype; -- types, names that
- Formal_Obj04 : in out Limited_Private_Subtype; -- denotes subtypes of
- Formal_Obj05 : in out New_TagType; -- the private types.
-
- package CDE0001_1 is
- procedure Assign_Objects;
-
- end CDE0001_1;
-
-private
-
- generic
- -- Formal array types of a private type, a composite type with a
- -- subcomponent of a private type.
-
- type Formal_Arr01 is array (Small_Int) of Private_Type;
- type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
-
- -- Formal access types of composite types with a subcomponent of
- -- a private subtype.
-
- type Formal_Acc01 is access Rec_Of_Private_Subtype;
- type Formal_Acc02 is access Array_Of_LP_Subtype;
-
- package CDE0001_2 is
-
- procedure Assign_Arrays (P1 : out Formal_Arr01;
- P2 : out Formal_Arr02);
-
- procedure Assign_Access (P1 : out Formal_Acc01;
- P2 : out Formal_Acc02);
-
- end CDE0001_2;
-
- ----------------------------------------------------------
- type Private_Type is range 1 .. 10;
- type Limited_Private is (Eh, Bee, Sea, Dee);
- type New_TagType is new Tag_Type with
- record
- C2 : Private_Type;
- end record;
-
-end CDE0001_0;
-
- --==================================================================--
-
-package body CDE0001_0 is
-
- package body CDE0001_1 is
-
- procedure Assign_Objects is
- begin
- Formal_Obj01 := Private_Type'First;
- Formal_Obj02 := Limited_Private'Last;
- Formal_Obj03 := Private_Subtype'Last;
- Formal_Obj04 := Limited_Private_Subtype'First;
- Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last);
-
- end Assign_Objects;
-
- end CDE0001_1;
-
- --===========================================================--
-
- package body CDE0001_2 is
-
- procedure Assign_Arrays (P1 : out Formal_Arr01;
- P2 : out Formal_Arr02) is
- begin
- P1(1) := Private_Type'Pred(Private_Type'Last);
- P1(2) := Private_Type'Succ(Private_Type'First);
- P2(1).C1 := Limited_Private'Succ(Limited_Private'First);
- P2(2).C1 := Limited_Private'Pred(Limited_Private'Last);
-
- end Assign_Arrays;
-
- -----------------------------------------------------------------
- procedure Assign_Access (P1 : out Formal_Acc01;
- P2 : out Formal_Acc02) is
- begin
- P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last);
- P2 := new Array_Of_LP_Subtype'(Eh, Dee);
-
- end Assign_Access;
-
- end CDE0001_2;
-
-end CDE0001_0;
-
- --==================================================================--
-
--- The following private child package instantiates its parent private generic
--- package.
-
-with CDE0001_0;
-pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated.
-private
-package CDE0001_0.CDE0001_3 is
-
- type Arr01 is array (Small_Int) of Private_Type;
- type Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
- type Acc01 is access Rec_Of_Private_Subtype;
- type Acc02 is access Array_Of_LP_Subtype;
-
- package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02);
-
- Arr01_Obj : Arr01;
- Arr02_Obj : Arr02;
- Acc01_Obj : Acc01;
- Acc02_Obj : Acc02;
-
-end CDE0001_0.CDE0001_3;
-
- --==================================================================--
-
-package CDE0001_0.CDE0001_4 is
-
- -- The following functions check the private types defined in the parent
- -- and the private child package from within the client program.
-
- function Verify_Objects return Boolean;
-
- function Verify_Arrays return Boolean;
-
- function Verify_Access return Boolean;
-
-end CDE0001_0.CDE0001_4;
-
- --==================================================================--
-
-with CDE0001_0.CDE0001_3; -- private sibling.
-
-pragma Elaborate (CDE0001_0.CDE0001_3);
-
-package body CDE0001_0.CDE0001_4 is
-
- Obj1 : Private_Type := 2;
- Obj2 : Limited_Private := Bee;
- Obj3 : Private_Subtype := 3;
- Obj4 : Limited_Private_Subtype := Sea;
- Obj5 : New_TagType := (1, 5);
-
- -- Instantiate the generic package declared in the visible part of
- -- the parent.
-
- package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5);
-
- ---------------------------------------------------
- function Verify_Objects return Boolean is
- Result : Boolean := False;
- begin
- if Obj1 = 1 and
- Obj2 = Dee and
- Obj3 = 10 and
- Obj4 = Eh and
- Obj5.C1 = 2 and
- Obj5.C2 = 10 then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Objects;
-
- ---------------------------------------------------
- function Verify_Arrays return Boolean is
- Result : Boolean := False;
- begin
- if CDE0001_0.CDE0001_3.Arr01_Obj(1) = 9 and
- CDE0001_0.CDE0001_3.Arr01_Obj(2) = 2 and
- CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee and
- CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Arrays;
-
- ---------------------------------------------------
- function Verify_Access return Boolean is
- Result : Boolean := False;
- begin
- if CDE0001_0.CDE0001_3.Acc01_Obj.C1 = 10 and
- CDE0001_0.CDE0001_3.Acc02_Obj(1) = Eh and
- CDE0001_0.CDE0001_3.Acc02_Obj(2) = Dee then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Access;
-
-begin
-
- Formal_Obj_Pck.Assign_Objects;
-
- CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays
- (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj);
- CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access
- (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj);
-
-end CDE0001_0.CDE0001_4;
-
- --==================================================================--
-
-with Report;
-with CDE0001_0.CDE0001_4;
-
-procedure CDE0001 is
-
-begin
-
- Report.Test ("CDE0001", "Check that the name of the private type, a " &
- "name that denotes a subtype of the private type, or a " &
- "name that denotes a composite type with a subcomponent " &
- "of a private type can be used in the declaration of a " &
- "generic formal type parameter without causing freezing " &
- "of the named type");
-
- if not CDE0001_0.CDE0001_4.Verify_Objects then
- Report.Failed ("Wrong values for formal objects");
- end if;
-
- if not CDE0001_0.CDE0001_4.Verify_Arrays then
- Report.Failed ("Wrong values for formal array types");
- end if;
-
- if not CDE0001_0.CDE0001_4.Verify_Access then
- Report.Failed ("Wrong values for formal access types");
- end if;
-
- Report.Result;
-
-end CDE0001;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada
deleted file mode 100644
index b784b87..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- CE2102A.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 TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL
--- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE SEQUENTIAL_IO.
-
--- A) OPENED FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- DLD 08/10/82
--- JBG 02/22/84
--- SPW 07/29/87 SPLIT CASE FOR UNOPENED FILES INTO CE2102L.ADA.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102A IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER);
- USE SEQ_IO;
- TEST_FILE_ONE : SEQ_IO.FILE_TYPE;
-
-BEGIN
-
- TEST ("CE2102A", "CHECK THAT STATUS_ERROR IS RAISED WHEN " &
- "PERFORMING ILLEGAL OPERATIONS ON OPENED FILES " &
- "OF TYPE SEQUENTIAL_IO");
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
-
--- CHECK THAT OPEN STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY OPEN
-
- BEGIN
- OPEN (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " &
- "ALREADY OPEN - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 1");
- END;
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " &
- "ALREADY OPEN - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 2");
- END;
-
--- CHECK THAT CREATE STATEMENT RAISES EXCEPTION WHEN FILE
--- IS ALREADY OPEN
-
- BEGIN
- CREATE (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " &
- "FILE IS USED IN A CREATE - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 1");
- END;
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " &
- "FILE IS USED IN A CREATE - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2");
- END;
-
---DELETE TEST FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF EXTERNAL FILE APPEARS NOT " &
- "TO BE SUPPORTED");
-
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "FOR DELETE");
- END;
-
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED FOR CREATE " &
- "WITH OUT_FILE MODE");
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED FOR CREATE " &
- "WITH OUT_FILE MODE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CREATE");
- END;
-
- RESULT;
-END CE2102A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada
deleted file mode 100644
index 98494c6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada
+++ /dev/null
@@ -1,155 +0,0 @@
--- CE2102B.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 TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL
--- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE DIRECT_IO.
-
--- A) OPENED FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO THOSE IMPLEMENTATIONS WHICH
--- SUPPORT CREATE WITH OUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- DLD 08/10/82
--- SPS 11/03/82
--- JBG 02/22/84
--- SPW 08/13/87 SPLIT CASE FOR UNOPENED FILES INTO CE2102M.ADA.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102B IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER);
- USE DIR_IO;
- TEST_FILE_ONE : DIR_IO.FILE_TYPE;
-
-BEGIN
-
- TEST ("CE2102B", "CHECK THAT STATUS_ERROR IS RAISED WHEN " &
- "PERFORMING ILLEGAL OPERATIONS ON FILES " &
- "OF TYPE DIRECT_IO");
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
-
--- CHECK THAT OPEN STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY OPEN
-
- BEGIN
- OPEN (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " &
- "ALREADY OPEN - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 1");
- END;
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " &
- "ALREADY OPEN - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 2");
- END;
-
- BEGIN
- OPEN (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " &
- "ALREADY OPEN - 3");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 3");
- END;
-
--- CHECK THAT CREATE STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY
--- OPEN
-
- BEGIN
- CREATE (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " &
- "FILE IS USED IN A CREATE - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 1");
- END;
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " &
- "FILE IS USED IN A CREATE - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2");
- END;
-
- BEGIN
- CREATE (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " &
- "FILE IS USED IN A CREATE - 3");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 3");
- END;
-
---DELETE TEST FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF EXTERNAL FILE APPEARS NOT " &
- "TO BE SUPPORTED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR DELETE");
- END;
-
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED FOR CREATE " &
- "WITH OUT_FILE MODE");
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED FOR CREATE " &
- "WITH OUT_FILE MODE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CREATE");
- END;
-
- RESULT;
-
-END CE2102B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst b/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst
deleted file mode 100644
index 11868bc..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst
+++ /dev/null
@@ -1,140 +0,0 @@
--- CE2102C.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.
---*
--- OBJECTIVE:
--- CHECK THAT NAME_ERROR IS RAISED WHEN THE NAME STRING DOES NOT
--- IDENTIFY AN EXTERNAL FILE FOR AN OPEN OR CREATE OPERATION FOR
--- SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL TEMPORARY FILES.
-
--- HISTORY:
--- SPS 08/26/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- JRK 11/30/84 CHANGED TO .TST TEST.
--- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2102H-B.TST.
--- SPW 08/25/87 CORRECTED EXCEPTION HANDLING.
--- BCB 09/28/88 ADDED EXCEPTION HANDLERS FOR DELETE STATEMENTS.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102C IS
-
- NAME1 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME1";
- -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY)
- -- CONTAINS INVALID CHARACTERS OR IS TOO LONG.
-
- NAME2 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME2";
- -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY)
- -- CONTAINS A WILD CARD CHARACTER OR IS TOO LONG.
-
-BEGIN
-
- TEST ("CE2102C", "CHECK THAT NAME_ERROR IS RAISED BY OPEN AND " &
- "CREATE WHEN NAME DOES NOT IDENTIFY AN " &
- "EXTERNAL FILE FOR SEQUENTIAL_IO");
-
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- BEGIN
-
--- CHECK WHETHER CREATE RAISES USE_ERROR
-
- BEGIN
- CREATE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("TEMPORARY SEQUENTIAL FILES WITH " &
- "OUT_FILE MODE NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE");
- RAISE INCOMPLETE;
- END;
- CLOSE (FILE1);
-
- BEGIN
- CREATE(FILE1, OUT_FILE, NAME1);
- FAILED ("NAME_ERROR NOT RAISED - CREATE SEQ 1");
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - CREATE SEQ 1");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CREATE SEQ 1");
- END;
-
- BEGIN
- CREATE (FILE1, OUT_FILE, NAME2);
- FAILED("NAME_ERROR NOT RAISED - CREATE SEQ 2");
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - CREATE SEQ 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CREATE SEQ 2");
- END;
-
--- CHECK WHETHER OPEN RAISES NAME_ERROR IN THE CASE OF A LEGAL FILE
--- NAME BUT A NON-EXISTENT FILE.
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- FAILED("NAME_ERROR NOT RAISED - OPEN SEQ");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - OPEN SEQ");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - OPEN SEQ");
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada
deleted file mode 100644
index 728eed1..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CE2102D.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE
--- IMPLEMENTATION FOR SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT IN_FILE FOR CREATE FOR SEQUENTIAL_IO.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102D IS
-BEGIN
-
- TEST ("CE2102D", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR SEQUENTIAL_IO");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- BEGIN
- CREATE (FILE1, IN_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE2102D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada
deleted file mode 100644
index caaf3fd..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CE2102E.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE
--- IMPLEMENTATION FOR SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OUT_FILE FOR CREATE FOR SEQUENTIAL_IO.
-
--- HISTORY:
--- SPS 08/26/82
--- JBG 06/04/84
--- EG 05/08/85
--- TBN 07/23/87 COMPLETELY REVISED TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102E IS
-BEGIN
-
- TEST ("CE2102E", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR SEQUENTIAL_IO");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- BEGIN
- CREATE (FILE1, OUT_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE2102E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada
deleted file mode 100644
index 8d8328d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada
+++ /dev/null
@@ -1,65 +0,0 @@
--- CE2102F.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY
--- THE IMPLEMENTATION FOR DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT INOUT_FILE FOR CREATE FOR DIRECT FILES.
-
--- HISTORY:
--- SPS 08/26/82
--- JBG 06/04/84
--- TBN 07/23/87 COMPLETELY REVISED TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102F IS
-BEGIN
-
- TEST ("CE2102F", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "INOUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR DIRECT_IO");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- BEGIN
- CREATE (FILE1, INOUT_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE INOUT_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE2102F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada
deleted file mode 100644
index b5de4e6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- CE2102G.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 USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT
--- SUPPORT RESET FOR SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- SPS 08/27/82
--- JBG 06/04/84
--- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2102K.ADA.
--- TBN 09/15/87 COMPLETELY REVISED TEST.
-
-WITH SEQUENTIAL_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2102G IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2102G", "CHECK THAT USE_ERROR IS RAISED IF AN " &
- "IMPLEMENTATION DOES NOT SUPPORT RESET FOR " &
- "SEQUENTIAL_IO");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INT1 : INTEGER := IDENT_INT(1);
- INT2 : INTEGER := 2;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " &
- "SEQUENTIAL FILE WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " &
- "SEQUENTIAL FILE WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, INT2);
- BEGIN
- RESET (FILE1, IN_FILE);
- COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS ALLOWED");
- BEGIN
- READ (FILE1, INT1);
- IF INT1 /= IDENT_INT(2) THEN
- FAILED ("RESETTING FROM OUT_FILE TO IN_FILE " &
- "AFFECTED DATA");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "READING FROM FILE");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS NOT " &
- "ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM OUT_FILE TO IN_FILE");
- END;
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " &
- "SEQUENTIAL FILE WITH IN_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE1, OUT_FILE);
- COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS NOT " &
- "ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM IN_FILE TO OUT_FILE");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst b/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst
deleted file mode 100644
index ea265c0..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst
+++ /dev/null
@@ -1,136 +0,0 @@
--- CE2102H.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.
---*
--- OBJECTIVE:
--- CHECK THAT NAME_ERROR IS RAISED WHEN THE NAME STRING DOES NOT
--- IDENTIFY AN EXTERNAL FILE FOR AN OPEN OR CREATE OPERATION FOR
--- DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH INOUT_FILE MODE FOR TEMPORARY DIRECT FILES.
-
--- HISTORY:
--- TBN 02/12/86
--- SPW 08/26/87 CORRECTED EXCEPTION HANDLING.
--- BCB 09/28/88 ADDED EXCEPTION HANDLERS FOR DELETE STATEMENTS.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102H IS
-
- NAME1 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME1";
- -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY)
- -- CONTAINS INVALID CHARACTERS OR IS TOO LONG.
-
- NAME2 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME2";
- -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY)
- -- CONTAINS A WILD CARD CHARACTER OR IS TOO LONG.
-
-BEGIN
-
- TEST ("CE2102H", "CHECK THAT NAME_ERROR IS RAISED BY OPEN AND " &
- "CREATE WHEN NAME DOES NOT IDENTIFY AN " &
- "EXTERNAL FILE FOR DIRECT_IO");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- BEGIN
-
--- CHECK WHETHER CREATE RAISES USE_ERROR
-
- BEGIN
- CREATE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("TEMPORARY DIRECT FILES WITH " &
- "INOUT_FILE MODE NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE");
- RAISE INCOMPLETE;
- END;
- CLOSE (FILE1);
-
- BEGIN
- CREATE(FILE1, OUT_FILE, NAME1);
- FAILED ("NAME_ERROR NOT RAISED - CREATE DIR 1");
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - CREATE DIR 1");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CREATE DIR 1");
- END;
-
- BEGIN
- CREATE (FILE1, OUT_FILE, NAME2);
- FAILED("NAME_ERROR NOT RAISED - CREATE DIR 2");
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - CREATE DIR 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CREATE DIR 2");
- END;
-
--- CHECK WHETHER OPEN RAISES NAME_ERROR IN THE CASE OF A LEGAL FILE NAME
--- BUT A NON-EXISTENT FILE.
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- FAILED("NAME_ERROR NOT RAISED - OPEN DIR");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED - OPEN DIR");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - OPEN DIR");
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada
deleted file mode 100644
index 43616c2..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CE2102I.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY
--- THE IMPLEMENTATION FOR DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT IN_FILE FOR CREATE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102I IS
-BEGIN
-
- TEST ("CE2102I", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR DIRECT_IO");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- BEGIN
- CREATE (FILE1, IN_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE2102I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada
deleted file mode 100644
index efe08a6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada
+++ /dev/null
@@ -1,66 +0,0 @@
--- CE2102J.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY
--- THE IMPLEMENTATION FOR DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OUT_FILE FOR CREATE FOR DIRECT FILES.
-
--- HISTORY:
--- SPS 08/26/82
--- JBG 06/04/84
--- EG 05/08/85
--- TBN 07/23/87 COMPLETELY REVISED TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102J IS
-BEGIN
-
- TEST ("CE2102J", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR DIRECT_IO");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- BEGIN
- CREATE (FILE1, OUT_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE2102J;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada
deleted file mode 100644
index fed673f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada
+++ /dev/null
@@ -1,248 +0,0 @@
--- CE2102K.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 USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT
--- SUPPORT RESET FOR DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- TBN 02/12/86 CREATED ORIGINAL TEST.
--- TBN 09/15/87 COMPLETELY REVISED TEST.
-
-WITH DIRECT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2102K IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2102K", "CHECK THAT USE_ERROR IS RAISED IF AN " &
- "IMPLEMENTATION DOES NOT SUPPORT RESET FOR " &
- "DIRECT_IO");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INT1 : INTEGER := IDENT_INT(1);
- INT2 : INTEGER := 2;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " &
- "DIRECT FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " &
- "DIRECT FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, INT2);
-
- -- RESETTING FROM OUT_FILE TO IN_FILE.
-
- BEGIN
- RESET (FILE1, IN_FILE);
- COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS ALLOWED");
- BEGIN
- READ (FILE1, INT1);
- IF INT1 /= IDENT_INT(2) THEN
- FAILED ("RESETTING FROM OUT_FILE TO IN_FILE " &
- "AFFECTED DATA");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "READING FROM FILE - 1");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS NOT " &
- "ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM OUT_FILE TO IN_FILE");
- END;
-
- CLOSE (FILE1);
-
- -- RESETTING FROM OUT_FILE TO INOUT_FILE.
-
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME(2));
-
- WRITE (FILE1, INT2);
- BEGIN
- RESET (FILE1, INOUT_FILE);
- COMMENT ("RESET FROM OUT_FILE TO INOUT_FILE IS ALLOWED");
- BEGIN
- READ (FILE1, INT1);
- IF INT1 /= IDENT_INT(2) THEN
- FAILED ("RESETTING FROM OUT_FILE TO " &
- "INOUT_FILE AFFECTED DATA");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "READING FROM FILE - 2");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM OUT_FILE TO INOUT_FILE IS " &
- "NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM OUT_FILE TO INOUT_FILE");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- -- RESETTING FROM IN_FILE TO OUT_FILE.
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " &
- "DIRECT FILE WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE1, OUT_FILE);
- COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS NOT " &
- "ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM IN_FILE TO OUT_FILE");
- END;
-
- CLOSE (FILE1);
-
- -- RESETTING FROM IN_FILE TO INOUT_FILE.
-
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
-
- BEGIN
- RESET (FILE1, INOUT_FILE);
- COMMENT ("RESET FROM IN_FILE TO INOUT_FILE IS ALLOWED");
- BEGIN
- READ (FILE1, INT1);
- IF INT1 /= IDENT_INT(2) THEN
- FAILED ("RESETTING FROM IN_FILE TO " &
- "INOUT_FILE AFFECTED DATA");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "READING FROM FILE - 3");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM IN_FILE TO INOUT_FILE IS " &
- "NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM IN_FILE TO INOUT_FILE");
- END;
-
- CLOSE (FILE1);
-
- -- RESETTING FROM INOUT_FILE TO IN_FILE.
-
- BEGIN
- OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " &
- "DIRECT FILE WITH INOUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE1, IN_FILE);
- COMMENT ("RESET FROM INOUT_FILE TO IN_FILE IS ALLOWED");
- BEGIN
- READ (FILE1, INT1);
- IF INT1 /= IDENT_INT(2) THEN
- FAILED ("RESETTING FROM INOUT_FILE TO " &
- "IN_FILE AFFECTED DATA");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "READING FROM FILE - 2");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM INOUT_FILE TO IN_FILE IS " &
- "NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM INOUT_FILE TO IN_FILE");
- END;
-
- CLOSE (FILE1);
-
- -- RESETTING FROM INOUT_FILE TO OUT_FILE.
-
- OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
-
- BEGIN
- RESET (FILE1, OUT_FILE);
- COMMENT ("RESET FROM INOUT_FILE TO OUT_FILE IS ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("RESET FROM INOUT_FILE TO OUT_FILE IS " &
- "NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " &
- "RESETTING FROM INOUT_FILE TO OUT_FILE");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102K;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada
deleted file mode 100644
index 81d8663..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CE2102L.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 TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL
--- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE SEQUENTIAL_IO.
-
--- B) UNOPENED FILES
-
--- HISTORY:
--- SPW 07/29/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102L IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER);
- USE SEQ_IO;
-
- TEST_FILE_ONE : SEQ_IO.FILE_TYPE;
- STR : STRING (1 .. 10);
- FL_MODE : SEQ_IO.FILE_MODE ;
-
-BEGIN
-
- TEST ("CE2102L", "CHECK THAT STATUS_ERROR IS RAISED WHEN " &
- "PERFORMING ILLEGAL OPERATIONS ON UNOPENED " &
- "FILES OF TYPE SEQUENTIAL_IO");
-
--- CHECK TO SEE THAT PROPER EXCEPTIONS ARE RAISED WHEN
--- PERFORMING OPERATIONS ON AN UNOPENED FILE
-
--- CLOSE AN UNOPENED FILE
-
- BEGIN
- CLOSE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " &
- "FILE IS USED IN A CLOSE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CLOSE");
- END;
-
--- DELETE AN UNOPENED FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " &
- "FILE IS USED IN A DELETE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON DELETE");
- END;
-
--- RESET UNOPENED FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " &
- "FILE IS USED IN A RESET");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON RESET");
- END;
-
- BEGIN
- RESET (TEST_FILE_ONE, IN_FILE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED FILE " &
- "IS USED IN A RESET WITH MODE PARAMETER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON RESET " &
- "WITH MODE");
- END;
-
--- ATTEMPT TO DETERMINE MODE OF UNOPENED FILE
-
- BEGIN
- FL_MODE := MODE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED " &
- "FILE IS USED IN A MODE OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON MODE");
- END;
-
--- ATTEMPT TO DETERMINE NAME OF UNOPENED FILE
-
- BEGIN
- STR := NAME (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED " &
- "FILE IS USED IN A NAME OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON NAME");
- END;
-
---ATTEMPT TO DETERMINE FORM OF UNOPENED FILE
-
- BEGIN
- STR := FORM (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " &
- "FILE IS USED IN A FORM OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON FORM");
- END;
-
- RESULT;
-
-END CE2102L;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada
deleted file mode 100644
index 8ea79cf..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- CE2102M.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 TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL
--- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE DIRECT_IO.
-
--- B) UNOPENED FILES
-
--- HISTORY:
--- SPW 02/24/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102M IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER);
- USE DIR_IO;
-
- TEST_FILE_ONE : DIR_IO.FILE_TYPE;
- STR : STRING (1 .. 10);
- FL_MODE : DIR_IO.FILE_MODE ;
-
-BEGIN
-
- TEST ("CE2102M", "CHECK THAT STATUS_ERROR IS RAISED WHEN " &
- "PERFORMING ILLEGAL OPERATIONS ON UNOPENED " &
- "FILES OF TYPE DIRECT_IO");
-
--- CHECK TO SEE THAT PROPER EXCEPTIONS ARE RAISED WHEN
--- PERFORMING OPERATIONS ON AN UNOPENED FILE
-
--- CLOSE AN UNOPENED FILE
-
- BEGIN
- CLOSE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A CLOSE OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CLOSE");
- END;
-
--- DELETE AN UNOPENED FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A DELETE OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON DELETE");
- END;
-
--- RESET UNOPENED FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A RESET");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON RESET");
- END;
-
- BEGIN
- RESET (TEST_FILE_ONE, IN_FILE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A RESET WITH MODE PARAMETER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON RESET WITH " &
- "MODE PARAMETER");
- END;
-
--- ATTEMPT TO DETERMINE MODE OF UNOPENED FILE
-
- BEGIN
- FL_MODE := MODE (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A MODE OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON MODE");
- END;
-
--- ATTEMPT TO DETERMINE NAME OF UNOPENED FILE
-
- BEGIN
- STR := NAME (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A NAME OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON NAME");
- END;
-
---ATTEMPT TO DETERMINE FORM OF UNOPENED FILE
-
- BEGIN
- STR := FORM (TEST_FILE_ONE);
- FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " &
- "IS USED IN A FORM OPERATION");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON FORM");
- END;
-
- RESULT;
-END CE2102M;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada
deleted file mode 100644
index c7b6414..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102N.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OPEN WITH IN_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102N IS
-BEGIN
-
- TEST ("CE2102N", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR SEQUENTIAL FILES");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102N;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada
deleted file mode 100644
index 699ffa7..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE2102O.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 USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR RESET BY THE
--- IMPLEMENTATION FOR SEQUENTIAL FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT RESET WITH IN_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102O IS
-BEGIN
-
- TEST ("CE2102O", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " &
- "A FILE OF MODE IN_FILE, WHEN IN_FILE MODE IS " &
- "NOT SUPPORTED FOR RESET BY THE IMPLEMENTATION " &
- "FOR SEQUENTIAL FILES");
-
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE1);
- NOT_APPLICABLE ("RESET FOR IN_FILE MODE IS " &
- "SUPPORTED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "RESET");
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102O;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada
deleted file mode 100644
index f5db1c9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102P.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OPEN WITH OUT_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102P IS
-BEGIN
-
- TEST ("CE2102P", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR SEQUENTIAL FILES");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102P;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada
deleted file mode 100644
index af7fbe5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- CE2102Q.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 USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR RESET BY THE
--- IMPLEMENTATION FOR SEQUENTIAL FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT RESET WITH OUT_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2102Q IS
-BEGIN
-
- TEST ("CE2102Q", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " &
- "A FILE OF MODE OUT_FILE, WHEN OUT_FILE MODE " &
- "IS NOT SUPPORTED FOR RESET BY THE " &
- "IMPLEMENTATION FOR SEQUENTIAL FILES");
-
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
-
- BEGIN
- RESET (FILE1);
- NOT_APPLICABLE ("RESET FOR OUT_FILE MODE IS SUPPORTED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102Q;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada
deleted file mode 100644
index 8ec6c9e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102R.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OPEN WITH INOUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102R IS
-BEGIN
-
- TEST ("CE2102R", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "INOUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR DIRECT FILES");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR INOUT_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102R;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada
deleted file mode 100644
index 030ce49..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102S.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 USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE
--- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR RESET BY
--- THE IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT RESET WITH INOUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102S IS
-BEGIN
-
- TEST ("CE2102S", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " &
- "A FILE OF MODE INOUT_FILE, WHEN INOUT_FILE " &
- "MODE IS NOT SUPPORTED FOR RESET BY THE " &
- "IMPLEMENTATION FOR DIRECT FILES");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
-
- BEGIN
- RESET (FILE1);
- NOT_APPLICABLE ("RESET FOR INOUT_FILE MODE IS " &
- "SUPPORTED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102S;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada
deleted file mode 100644
index b97ad62..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102T.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OPEN WITH IN_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102T IS
-BEGIN
-
- TEST ("CE2102T", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR DIRECT FILES");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102T;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada
deleted file mode 100644
index 0a9d946..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE2102U.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 USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR RESET BY
--- THE IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT RESET WITH IN_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102U IS
-BEGIN
-
- TEST ("CE2102U", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " &
- "A FILE OF MODE IN_FILE, WHEN IN_FILE " &
- "MODE IS NOT SUPPORTED FOR RESET BY THE " &
- "IMPLEMENTATION FOR DIRECT FILES");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE " &
- "NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE1);
- NOT_APPLICABLE ("RESET FOR IN_FILE MODE IS " &
- "SUPPORTED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "RESET");
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102U;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada
deleted file mode 100644
index 4232002..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102V.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OPEN WITH OUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102V IS
-BEGIN
-
- TEST ("CE2102V", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR DIRECT FILES");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "INOUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102V;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada
deleted file mode 100644
index 5239f0b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2102W.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 USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR RESET BY
--- THE IMPLEMENTATION FOR DIRECT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT RESET WITH OUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2102W IS
-BEGIN
-
- TEST ("CE2102W", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " &
- "A FILE OF MODE OUT_FILE, WHEN OUT_FILE " &
- "MODE IS NOT SUPPORTED FOR RESET BY THE " &
- "IMPLEMENTATION FOR DIRECT FILES");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- VAR1 : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, VAR1);
-
- BEGIN
- RESET (FILE1);
- NOT_APPLICABLE ("RESET FOR OUT_FILE MODE IS " &
- "SUPPORTED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2102W;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada
deleted file mode 100644
index 8f56ac5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada
+++ /dev/null
@@ -1,85 +0,0 @@
--- CE2102X.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 USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT
--- SUPPORT DELETION OF AN EXTERNAL SEQUENTIAL FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF A SEQUENTIAL FILE WITH OUT_FILE MODE.
-
--- HISTORY:
--- TBN 09/15/87 CREATED ORIGINAL TEST.
-
-WITH SEQUENTIAL_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2102X IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2102X", "CHECK THAT USE_ERROR IS RAISED IF AN " &
- "IMPLEMENTATION DOES NOT SUPPORT DELETION " &
- "OF AN EXTERNAL SEQUENTIAL FILE");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FILE1 : FILE_TYPE;
- INT1 : INTEGER := IDENT_INT(1);
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " &
- "SEQUENTIAL FILE WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " &
- "SEQUENTIAL FILE WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, INT1);
- BEGIN
- DELETE (FILE1);
- COMMENT ("DELETION OF AN EXTERNAL SEQUENTIAL FILE IS " &
- "ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF AN EXTERNAL SEQUENTIAL " &
- "FILE IS NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "DELETING AN EXTERNAL FILE");
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102X;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada b/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada
deleted file mode 100644
index e6ae6d3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CE2102Y.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 USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT
--- SUPPORT DELETION OF AN EXTERNAL DIRECT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF A DIRECT FILE WITH OUT_FILE MODE.
-
--- HISTORY:
--- TBN 09/15/87 CREATED ORIGINAL TEST.
-
-WITH DIRECT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2102Y IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2102Y", "CHECK THAT USE_ERROR IS RAISED IF AN " &
- "IMPLEMENTATION DOES NOT SUPPORT DELETION " &
- "OF AN EXTERNAL DIRECT FILE");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INT1 : INTEGER := IDENT_INT(1);
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " &
- "DIRECT FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " &
- "DIRECT FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, INT1);
- BEGIN
- DELETE (FILE1);
- COMMENT ("DELETION OF AN EXTERNAL DIRECT FILE IS " &
- "ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF AN EXTERNAL DIRECT " &
- "FILE IS NOT ALLOWED");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " &
- "DELETING AN EXTERNAL FILE");
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE2102Y;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst b/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst
deleted file mode 100644
index 6a6d21a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst
+++ /dev/null
@@ -1,142 +0,0 @@
--- CE2103A.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.
---*
--- OBJECTIVE:
--- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE SEQUENTIAL_IO.
-
--- A) UNOPENED FILES
-
--- HISTORY:
--- DLD 08/10/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 06/03/85
--- SPW 08/10/87 SPLIT CASE FOR OPENED FILES INTO CE2103C.ADA.
--- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2103A IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(CHARACTER);
- USE SEQ_IO;
-
- TEST_FILE_ZERO : SEQ_IO.FILE_TYPE;
- TEST_FILE_ONE : SEQ_IO.FILE_TYPE;
- TEST_FILE_TWO : SEQ_IO.FILE_TYPE;
- TEST_FILE_THREE : SEQ_IO.FILE_TYPE;
- TEST_FILE_FOUR : SEQ_IO.FILE_TYPE;
- VAL : BOOLEAN;
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2103A", "CHECK THAT IS_OPEN RETURNS THE PROPER " &
- "VALUES FOR UNOPENED FILES OF TYPE " &
- "SEQUENTIAL_IO");
-
--- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS SEQUENTIAL FILES AT ALL
-
- BEGIN
- SEQ_IO.CREATE ( TEST_FILE_ZERO,
- SEQ_IO.OUT_FILE,
- REPORT.LEGAL_FILE_NAME );
- EXCEPTION
- WHEN SEQ_IO.USE_ERROR | SEQ_IO.NAME_ERROR =>
- REPORT.NOT_APPLICABLE
- ( "SEQUENTIAL FILES NOT SUPPORTED -- CREATE OUT-FILE" );
- RAISE INCOMPLETE;
- END;
- SEQ_IO.DELETE ( TEST_FILE_ZERO );
-
--- WHEN FILE IS DECLARED BUT NOT OPEN
-
- BEGIN
- VAL := TRUE;
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE");
- END IF;
- END;
-
--- FOLLOWING UNSUCCESSFUL CREATE
-
- BEGIN
- VAL := TRUE;
- CREATE (TEST_FILE_TWO, OUT_FILE,
- "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN (TEST_FILE_TWO);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE AFTER AN " &
- "UNSUCCESSFUL CREATE");
- END IF;
- END;
-
--- FOLLOWING UNSUCCESSFUL OPEN
-
- BEGIN
- VAL := TRUE;
- OPEN (TEST_FILE_THREE, IN_FILE,
- "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL OPEN");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN (TEST_FILE_THREE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE - UNSUCCESSFUL OPEN");
- END IF;
- END;
-
--- FOLLOWING CLOSING FILE THAT IS NOT OPEN
-
- BEGIN
- VAL := TRUE;
- CLOSE (TEST_FILE_FOUR);
- FAILED ("STATUS ERROR NOT RAISED WHEN " &
- "ATTEMPTING TO CLOSE AN UNOPENED FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- VAL := IS_OPEN (TEST_FILE_FOUR);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE AFTER ATTEMPTING " &
- "TO CLOSE AN UNOPENED FILE");
- END IF;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- REPORT.RESULT;
- WHEN OTHERS =>
- REPORT.FAILED ( "UNEXPECTED EXCEPTION" );
- REPORT.RESULT;
-END CE2103A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst b/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst
deleted file mode 100644
index 2bcd7ad..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst
+++ /dev/null
@@ -1,141 +0,0 @@
--- CE2103B.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.
---*
--- OBJECTIVE:
--- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE DIRECT_IO.
-
--- A) UNOPENED FILES
-
--- HISTORY:
--- DLD 08/10/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 06/03/85
--- SPW 08/13/87 SPLIT CASE FOR OPEN FILES INTO CE2103D.ADA.
--- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2103B IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(CHARACTER);
- USE DIR_IO;
-
- TEST_FILE_ZERO : DIR_IO.FILE_TYPE;
- TEST_FILE_ONE : DIR_IO.FILE_TYPE;
- TEST_FILE_TWO : DIR_IO.FILE_TYPE;
- TEST_FILE_THREE : DIR_IO.FILE_TYPE;
- TEST_FILE_FOUR : DIR_IO.FILE_TYPE;
- VAL : BOOLEAN;
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2103B", "CHECK THAT IS_OPEN RETURNS THE PROPER " &
- "VALUES FOR UNOPENED FILES OF TYPE DIRECT_IO");
-
--- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS DIRECT FILES AT ALL
-
- BEGIN
- DIR_IO.CREATE ( TEST_FILE_ZERO,
- DIR_IO.OUT_FILE,
- REPORT.LEGAL_FILE_NAME );
- EXCEPTION
- WHEN DIR_IO.USE_ERROR | DIR_IO.NAME_ERROR =>
- REPORT.NOT_APPLICABLE
- ( "DIRECT FILES NOT SUPPORTED -- CREATE OUT-FILE" );
- RAISE INCOMPLETE;
- END;
- DIR_IO.DELETE ( TEST_FILE_ZERO );
-
--- WHEN FILE IS DECLARED BUT NOT OPEN
-
- BEGIN
- VAL := TRUE;
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE");
- END IF;
- END;
-
--- FOLLOWING UNSUCCESSFUL CREATE
-
- BEGIN
- VAL := TRUE;
- CREATE (TEST_FILE_TWO, OUT_FILE,
- "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN (TEST_FILE_TWO);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE AFTER AN " &
- "UNSUCCESSFUL CREATE");
- END IF;
- END;
-
--- FOLLOWING UNSUCCESSFUL OPEN
-
- BEGIN
- VAL := TRUE;
- OPEN (TEST_FILE_THREE, IN_FILE,
- "$ILLEGAL_EXTERNAL_FILE_NAME2");
- FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL OPEN");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN (TEST_FILE_THREE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE - UNSUCCESSFUL OPEN");
- END IF;
- END;
-
--- FOLLOWING CLOSING FILE THAT IS NOT OPEN
-
- BEGIN
- VAL := TRUE;
- CLOSE (TEST_FILE_FOUR);
- FAILED ("STATUS ERROR NOT RAISED WHEN ATTEMPTING " &
- "CLOSE AN UNOPENED FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- VAL := IS_OPEN (TEST_FILE_FOUR);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN GIVES TRUE AFTER ATTEMPTING " &
- "TO CLOSE AN UNOPENED FILE");
- END IF;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- REPORT.RESULT;
- WHEN OTHERS =>
- REPORT.FAILED ( "UNEXPECTED EXCEPTION" );
- REPORT.RESULT;
-END CE2103B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada
deleted file mode 100644
index 2f70f3c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- CE2103C.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 IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE SEQUENTIAL_IO.
-
--- B) OPENED FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- SPW 08/10/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2103C IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(CHARACTER);
- USE SEQ_IO;
- INCOMPLETE : EXCEPTION;
- TEST_FILE_ONE : SEQ_IO.FILE_TYPE;
- VAL : BOOLEAN;
-
-BEGIN
-
- TEST ("CE2103C", "CHECK THAT IS_OPEN RETURNS THE PROPER " &
- "VALUES FOR FILES OF TYPE SEQUENTIAL_IO");
-
--- FOLLOWING A CREATE
-
- VAL := FALSE;
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
-
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER CREATE");
- END IF;
-
--- FOLLOWING CLOSE
-
- VAL := TRUE;
- CLOSE (TEST_FILE_ONE);
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN RETURNS TRUE AFTER CLOSE");
- END IF;
-
--- FOLLOWING OPEN
-
- VAL := FALSE;
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN
- FAILED ("IS_OPEN GIVES TRUE ON " &
- "UNSUCESSFUL OPEN");
- END IF;
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER OPEN");
- END IF;
-
--- AFTER RESET
-
- VAL := FALSE;
-
- BEGIN
- RESET (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER RESET");
- END IF;
-
--- AFTER DELETE
-
- VAL := TRUE;
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN
- FAILED ("IS_OPEN GIVES TRUE ON UNSUCCESSFUL " &
- "DELETE");
- END IF;
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN RETURNS TRUE AFTER DELETE");
- END IF;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2103C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada b/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada
deleted file mode 100644
index 691650b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- CE2103D.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 IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE DIRECT_IO.
-
--- B) OPENED FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTAIONS WHICH SUPPORT
--- CREATION OF EXTERNAL FILES FOR DIRECT FILES.
-
--- HISTORY:
--- SPW 08/13/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2103D IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(CHARACTER);
- USE DIR_IO;
- INCOMPLETE : EXCEPTION;
- TEST_FILE_ONE : DIR_IO.FILE_TYPE;
- VAL : BOOLEAN;
-
-BEGIN
-
- TEST ("CE2103D", "CHECK THAT IS_OPEN RETURNS THE PROPER " &
- "VALUES FOR FILES OF TYPE DIRECT_IO");
-
--- FOLLOWING A CREATE
-
- VAL := FALSE;
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER CREATE");
- END IF;
-
--- FOLLOWING CLOSE
-
- VAL := TRUE;
- CLOSE (TEST_FILE_ONE);
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN RETURNS TRUE AFTER CLOSE");
- END IF;
-
--- FOLLOWING OPEN
-
- VAL := FALSE;
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN
- FAILED ("IS_OPEN GIVES TRUE ON " &
- "UNSUCCESSFUL OPEN");
- END IF;
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER OPEN");
- END IF;
-
--- AFTER RESET
-
- VAL := FALSE;
-
- BEGIN
- RESET (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED ("IS_OPEN RETURNS FALSE AFTER RESET");
- END IF;
-
--- AFTER DELETE
-
- VAL := TRUE;
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN
- FAILED ("IS_OPEN GIVES TRUE ON UNSUCCESSFUL " &
- "DELETE");
- END IF;
- RAISE INCOMPLETE;
- END;
-
- VAL := IS_OPEN (TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED ("IS_OPEN RETURNS TRUE AFTER DELETE");
- END IF;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2103D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada
deleted file mode 100644
index 55e3fc3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CE2104A.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 FILE CAN BE CLOSED AND THEN RE-OPENED.
-
--- A) SEQUENTIAL FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE
--- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 06/03/85
--- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2104A IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER);
- USE SEQ_IO;
-
- SEQ_FILE : SEQ_IO.FILE_TYPE;
- VAR : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2104A", "CHECK THAT A FILE CAN BE CLOSED " &
- "AND THEN RE-OPENED");
-
--- INITIALIZE TEST FILE
-
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
-
- END;
-
- WRITE (SEQ_FILE, 17);
- CLOSE (SEQ_FILE);
-
--- RE-OPEN SEQUENTIAL TEST FILE
-
- BEGIN
- OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- READ (SEQ_FILE, VAR);
- IF VAR /= 17 THEN
- FAILED ("WRONG DATA RETURNED FROM READ - " &
- "SEQUENTIAL");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
-
- DELETE (SEQ_FILE);
-
- EXCEPTION
-
- WHEN USE_ERROR =>
- NULL;
-
- END;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2104A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada
deleted file mode 100644
index 000d00b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- CE2104B.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 NAME RETURNED BY NAME CAN BE USED IN A
--- SUBSEQUENT OPEN.
-
--- A) SEQUENTIAL FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE
--- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/31/85
--- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED IS
--- CALLED FOR OPEN OR CREATE.
--- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH SEQUENTIAL_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE2104B IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER);
- USE SEQ_IO;
- TYPE ACC_STR IS ACCESS STRING;
-
- SEQ_FILE_ONE : SEQ_IO.FILE_TYPE;
- SEQ_FILE_TWO : SEQ_IO.FILE_TYPE;
- SEQ_FILE_NAME : ACC_STR;
- VAR : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2104B", "CHECK THAT THE NAME RETURNED BY NAME " &
- "CAN BE USED IN A SUBSEQUENT OPEN");
-
--- CREATE TEST FILE
-
- BEGIN
- CREATE(SEQ_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (SEQ_FILE_ONE, 14);
- SEQ_FILE_NAME := NEW STRING'(NAME(SEQ_FILE_ONE));
- CLOSE (SEQ_FILE_ONE);
-
--- ATTEMPT TO RE-OPEN SEQUENTIAL TEST FILE USING RETURNED NAME VALUE
-
- BEGIN
- OPEN (SEQ_FILE_TWO, IN_FILE, SEQ_FILE_NAME.ALL);
- EXCEPTION
- WHEN SEQ_IO.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- WHEN SEQ_IO.NAME_ERROR =>
- FAILED ("STRING NOT ACCEPTED AS NAME FOR FILE - SEQ");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("FILE NOT RE-OPENED - SEQ");
- RAISE INCOMPLETE;
- END;
-
- READ (SEQ_FILE_TWO, VAR);
- IF VAR /= 14 THEN
- FAILED ("WRONG DATA RETURNED FROM READ -SEQ");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
- DELETE (SEQ_FILE_TWO);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF EXTERNAL FILE IS NOT SUPPORTED");
- END;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2104B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada
deleted file mode 100644
index 840eb57..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CE2104C.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 FILE CAN BE CLOSED AND THEN RE-OPENED.
-
--- B) DIRECT FILES
-
--- APPLICABLILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE
--- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 06/03/85
--- PWB 02/10/86 CORRECTED REPORTED TEST NAME; CHANGED DATA FILE
--- NAME TO "Y2104C" TO MATCH TEST NAME.
--- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2104C IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER);
- USE DIR_IO;
-
- DIR_FILE : DIR_IO.FILE_TYPE;
- VAR : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2104C", "CHECK THAT A FILE CAN BE CLOSED " &
- "AND THEN RE-OPENED");
-
--- INITIALIZE TEST FILE
-
- BEGIN
- CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
-
- END;
-
- WRITE (DIR_FILE, 28);
- CLOSE (DIR_FILE);
-
--- RE-OPEN DIRECT TEST FILE
-
- BEGIN
- OPEN (DIR_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- READ (DIR_FILE, VAR);
- IF VAR /= 28 THEN
- FAILED ("WRONG DATA RETURNED FROM READ - DIRECT");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
- DELETE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2104C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada b/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada
deleted file mode 100644
index 068826d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- CE2104D.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 NAME RETURNED BY NAME CAN BE USED IN A
--- SUBSEQUENT OPEN.
-
--- B) DIRECT FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE
--- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/31/85
--- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED IS
--- CALLED FOR OPEN OR CREATE.
--- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH DIRECT_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE2104D IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER);
- USE DIR_IO;
- TYPE ACC_STR IS ACCESS STRING;
-
- DIR_FILE_ONE : DIR_IO.FILE_TYPE;
- DIR_FILE_TWO : DIR_IO.FILE_TYPE;
- DIR_FILE_NAME : ACC_STR;
- VAR : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2104D", "CHECK THAT THE NAME RETURNED BY NAME " &
- "CAN BE USED IN A SUBSEQUENT OPEN");
-
--- CREATE TEST FILE
-
- BEGIN
- CREATE (DIR_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (DIR_FILE_ONE, 3);
- DIR_FILE_NAME := NEW STRING'(NAME(DIR_FILE_ONE));
- CLOSE (DIR_FILE_ONE);
-
--- ATTEMPT TO RE-OPEN DIRECT TEST FILE USING RETURNED NAME VALUE
-
- BEGIN
- OPEN (DIR_FILE_TWO, IN_FILE, DIR_FILE_NAME.ALL);
- EXCEPTION
- WHEN DIR_IO.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- WHEN DIR_IO.NAME_ERROR =>
- FAILED ("STRING NOT ACCEPTED AS NAME FOR FILE - DIR");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("FILE NOT RE-OPENED - DIR");
- RAISE INCOMPLETE;
-
- END;
-
- READ (DIR_FILE_TWO, VAR);
- IF VAR /= 3 THEN
- FAILED ("WRONG DATA RETURNED FROM READ - DIR");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
- DELETE (DIR_FILE_TWO);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("DELETION OF EXTERNAL FILE IS NOT SUPPORTED");
- END;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2104D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada
deleted file mode 100644
index 0facea5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CE2106A.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 AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE
--- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION.
-
--- A) SEQUENTIAL FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH OUT_FILE MODE FOR SEQUENTIAL FILES AND
--- DELETION OF EXTERNAL FILES.
-
--- HISTORY:
--- SPS 08/25/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2106B.ADA.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- SPW 08/07/87 INSERTED ALLOWABLE EXCEPTION USE_ERROR ON
--- DELETE.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2106A IS
-
-BEGIN
-
- TEST ("CE2106A", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " &
- "AFTER AN EXTERNAL FILE WITH SAME NAME HAS " &
- "BEEN DELETED FOR SEQUENTIAL_IO");
-
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FL1 : FILE_TYPE;
- FL2 : FILE_TYPE;
- T_FAILED : BOOLEAN := FALSE;
- D_FILE : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " &
- "CREATE");
- T_FAILED := TRUE;
- END;
-
- IF NOT T_FAILED THEN
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL FILE " &
- "IS NOT SUPPORTED");
- T_FAILED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "DELETE");
- T_FAILED := TRUE;
- END;
- END IF;
-
- IF NOT T_FAILED THEN
- BEGIN
- CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME);
- D_FILE := TRUE;
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR FOR RECREATE - SEQ");
- WHEN OTHERS =>
- FAILED ("UNABLE TO RECREATE FILE AFTER " &
- "DELETION - SEQ");
- END;
-
- IF D_FILE THEN
- BEGIN
- DELETE (FL2);
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR FOR DELETE - SEQ");
- END;
- END IF;
- END IF;
- END;
-
- RESULT;
-
-END CE2106A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada
deleted file mode 100644
index da6bc8c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- CE2106B.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 AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE
--- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION.
-
--- B) DIRECT FILES
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH OUT_FILE MODE FOR DIRECT FILES AND
--- DELETION OF EXTERNAL FILES.
-
--- HISTORY:
--- TBN 02/12/86
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- SPW 08/07/87 INSERTED ALLOWABLE EXCEPTION USE_ERROR ON
--- DELETE.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2106B IS
-BEGIN
-
- TEST ("CE2106B", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " &
- "AFTER AN EXTERNAL FILE WITH SAME NAME HAS " &
- "BEEN DELETED FOR DIRECT_IO");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FL1 : FILE_TYPE;
- FL2 : FILE_TYPE;
- T_FAILED : BOOLEAN := FALSE;
- D_FILE : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; DIRECT CREATE " &
- "WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; DIRECT " &
- "CREATE WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; DIRECT " &
- "CREATE");
- T_FAILED := TRUE;
- END;
-
- IF NOT T_FAILED THEN
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL FILE " &
- "IS NOT SUPPORTED");
- T_FAILED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "DELETE");
- T_FAILED := TRUE;
- END;
- END IF;
-
- IF NOT T_FAILED THEN
- BEGIN
- CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME);
- D_FILE := TRUE;
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR FOR RECREATE - DIR");
- WHEN OTHERS =>
- FAILED ("UNABLE TO RECREATE FILE AFTER " &
- "DELETION - DIR");
- END;
-
- IF D_FILE THEN
- BEGIN
- DELETE (FL2);
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR WHILE DELETING DIR " &
- "FILE");
- END;
- END IF;
- END IF;
- END;
-
- RESULT;
-
-END CE2106B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada b/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada
deleted file mode 100644
index d03dd2d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CE2108E.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 EXTERNAL SEQUENTIAL FILE SPECIFIED BY A NON-NULL
--- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN
--- PROGRAM.
-
--- THIS TEST CREATES A SEQUENTIAL FILE; CE2108F.ADA READS IT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF AN EXTERNAL SEQUENTIAL FILE WITH OUT_FILE MODE.
-
--- HISTORY:
--- TBN 07/16/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2108E IS
-
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- INCOMPLETE : EXCEPTION;
- FILE_NAME : SEQ.FILE_TYPE;
- PREVENT_EMPTY_FILE : NATURAL := 5;
-
-BEGIN
-
- TEST ("CE2108E" , "CHECK THAT AN EXTERNAL SEQUENTIAL FILE " &
- "SPECIFIED BY A NON-NULL STRING NAME IS " &
- "ACCESSIBLE AFTER THE COMPLETION OF THE MAIN " &
- "PROGRAM");
- BEGIN
- BEGIN
- SEQ.CREATE (FILE_NAME, SEQ.OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN SEQ.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN SEQ.NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "SEQUENTIAL CREATE");
- RAISE INCOMPLETE;
- END;
-
- SEQ.WRITE (FILE_NAME, PREVENT_EMPTY_FILE);
- SEQ.CLOSE (FILE_NAME);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2108E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada b/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada
deleted file mode 100644
index 7f88abd..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE2108F.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 EXTERNAL SEQUENTIAL FILE SPECIFIED BY A NON-NULL
--- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN
--- PROGRAM.
-
--- THIS TEST CHECKS THE CREATION OF A SEQUENTIAL FILE WHICH WAS
--- CREATED BY CE2108E.ADA.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 07/16/87 CREATED ORIGINAL TESTED.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2108F IS
-
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- INCOMPLETE : EXCEPTION;
- CHECK_SUPPORT, FILE_NAME : FILE_TYPE;
- PREVENT_EMPTY_FILE : NATURAL := 0;
-
-BEGIN
- TEST ("CE2108F", "CHECK THAT AN EXTERNAL SEQUENTIAL FILE " &
- "SPECIFIED BY A NON-NULL STRING NAME IS " &
- "ACCESSIBLE AFTER THE COMPLETION OF THE MAIN " &
- "PROGRAM");
-
- -- TEST FOR SEQUENTIAL FILE SUPPORT.
-
- BEGIN
- CREATE (CHECK_SUPPORT, OUT_FILE, LEGAL_FILE_NAME);
- BEGIN
- DELETE (CHECK_SUPPORT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON DELETE");
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "SEQUENTIAL CREATE");
- RAISE INCOMPLETE;
- END;
-
- -- BEGIN TEST OBJECTIVE.
-
- BEGIN
- OPEN (FILE_NAME, IN_FILE, LEGAL_FILE_NAME(1, "CE2108E"));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN FOR " &
- "SEQUENTIAL FILE WITH IN_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
- READ (FILE_NAME, PREVENT_EMPTY_FILE);
- IF PREVENT_EMPTY_FILE /= 5 THEN
- FAILED ("OPENED WRONG FILE OR DATA ERROR");
- END IF;
- BEGIN
- DELETE (FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " &
- "EXTERNAL FILE");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE2108F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada b/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada
deleted file mode 100644
index 8116656..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- CE2108G.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 EXTERNAL DIRECT FILE SPECIFIED BY A NON-NULL
--- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN
--- PROGRAM.
-
--- THIS TEST CREATES A DIRECT FILE; CE2108H.ADA READS IT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF AN EXTERNAL DIRECT FILE.
-
--- HISTORY:
--- TBN 07/16/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2108G IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- INCOMPLETE : EXCEPTION;
- FILE_NAME : DIR.FILE_TYPE;
- PREVENT_EMPTY_FILE : NATURAL := 5;
-
-BEGIN
-
- TEST ("CE2108G", "CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED " &
- "BY A NON-NULL STRING NAME IS ACCESSIBLE AFTER " &
- "THE COMPLETION OF THE MAIN PROGRAM");
- BEGIN
- BEGIN
- DIR.CREATE (FILE_NAME, DIR.OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN DIR.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON DIRECT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN DIR.NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON DIRECT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "DIRECT CREATE");
- RAISE INCOMPLETE;
- END;
-
- DIR.WRITE (FILE_NAME, PREVENT_EMPTY_FILE);
- DIR.CLOSE (FILE_NAME);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2108G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada b/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada
deleted file mode 100644
index 483f23e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- CE2108H.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 EXTERNAL DIRECT FILE SPECIFIED BY A NON-NULL
--- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN
--- PROGRAM.
-
--- THIS TEST CHECKS THE CREATION OF A DIRECT FILE WHICH WAS
--- CREATED BY CE2108G.ADA.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- TBN 07/16/87 CREATED ORIGINAL TESTED.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2108H IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- INCOMPLETE : EXCEPTION;
- CHECK_SUPPORT, FILE_NAME : FILE_TYPE;
- PREVENT_EMPTY_FILE : NATURAL := 0;
-
-BEGIN
- TEST ("CE2108H", "CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED " &
- "BY A NON-NULL STRING NAME IS ACCESSIBLE AFTER " &
- "THE COMPLETION OF THE MAIN PROGRAM");
-
- -- TEST FOR DIRECT FILE SUPPORT.
-
- BEGIN
- CREATE (CHECK_SUPPORT, OUT_FILE, LEGAL_FILE_NAME);
- BEGIN
- DELETE (CHECK_SUPPORT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON DIRECT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON DIRECT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON DIRECT CREATE");
- RAISE INCOMPLETE;
- END;
-
- -- BEGIN TEST OBJECTIVE.
-
- BEGIN
- OPEN (FILE_NAME, IN_FILE, LEGAL_FILE_NAME(1, "CE2108G"));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- READ (FILE_NAME, PREVENT_EMPTY_FILE);
- IF PREVENT_EMPTY_FILE /= 5 THEN
- FAILED ("OPENED WRONG FILE OR DATA ERROR");
- END IF;
- BEGIN
- DELETE (FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " &
- "EXTERNAL FILE");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE2108H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada
deleted file mode 100644
index 5d25a59..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada
+++ /dev/null
@@ -1,83 +0,0 @@
--- CE2109A.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 DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR
--- SEQUENTIAL_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- ABW 08/13/82
--- SPS 11/09/82
--- JBG 11/11/83
--- TBN 02/13/86 SPLIT TEST. PUT DIRECT_IO INTO CE2109B.ADA AND
--- TEXT_IO INTO CE2109C.ADA.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED
--- NAME_ERROR, AND CLOSED THE FILE.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2109A IS
-
- INCOMPLETE : EXCEPTION;
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FILE2 : SEQ.FILE_TYPE;
-
-BEGIN
-
- TEST( "CE2109A", "CHECK DEFAULT MODE IN CREATE FOR SEQ_IO");
-
- BEGIN
- CREATE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "OUT_FILE MODE NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF MODE (FILE2) /= OUT_FILE THEN
- FAILED( "MODE INCORRECTLY SET FOR SEQUENTIAL_IO" );
- END IF;
-
- CLOSE (FILE2);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2109A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada
deleted file mode 100644
index 5d17489..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada
+++ /dev/null
@@ -1,80 +0,0 @@
--- CE2109B.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 DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR
--- DIRECT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- TBN 02/13/86
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED
--- NAME_ERROR, AND CLOSED THE FILE.
--- LDC 05/26/88 CHANGED APPLICABILITY COMMENT FROM OUT_FILE TO
--- INOUT_FILE.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2109B IS
-
- INCOMPLETE : EXCEPTION;
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE3 : DIR.FILE_TYPE;
-
-BEGIN
-
- TEST( "CE2109B", "CHECK DEFAULT MODE IN CREATE FOR DIRECT_IO");
-
- BEGIN
- CREATE (FILE3);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("CREATE OF DIRECT FILE WITH " &
- "INOUT_FILE MODE NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; DIRECT CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF MODE (FILE3) /= INOUT_FILE THEN
- FAILED( "MODE INCORRECTLY SET FOR DIRECT_IO" );
- END IF;
-
- CLOSE (FILE3);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2109B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada
deleted file mode 100644
index 9d4f3bb..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CE2109C.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 DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR
--- TEXT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR TEXT FILES.
-
--- HISTORY:
--- TBN 02/13/86
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED
--- NAME_ERROR, AND CLOSED THE FILE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE2109C IS
-
- INCOMPLETE : EXCEPTION;
- FILE1 : TEXT_IO.FILE_TYPE;
-
-BEGIN
-
- TEST( "CE2109C", "CHECK DEFAULT MODE IN CREATE FOR TEXT_IO");
-
- BEGIN
- CREATE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("CREATE OF TEXT FILE WITH OUT_FILE" &
- "MODE NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF MODE (FILE1) /= OUT_FILE THEN
- FAILED( "MODE INCORRECTLY SET FOR TEXT_IO" );
- END IF;
-
- CLOSE (FILE1);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2109C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada
deleted file mode 100644
index f71bbfe..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CE2110A.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 EXTERNAL FILE CEASES TO EXIST AFTER A SUCCESSFUL
--- DELETE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION AND DELETION OF SEQUENTIAL FILES.
-
--- HISTORY:
--- SPS 08/25/82
--- SPS 11/09/82
--- JBG 04/01/83
--- EG 05/31/85
--- JLH 07/21/87 ADDED A CALL TO NOT_APPLICABLE, IF EXCEPTION
--- USE_ERROR IS RAISED BY DELETE.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2110A IS
-BEGIN
-
- TEST ("CE2110A", "CHECK THAT THE EXTERNAL FILE CEASES TO EXIST " &
- "AFTER A SUCCESSFUL DELETE");
-
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FL1, FL2 : FILE_TYPE;
- VAR1 : INTEGER := 5;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FL1, VAR1); -- THIS WRITES TO THE FILE IF IT
- EXCEPTION -- CAN, NOT NECESSARY FOR THE
- WHEN OTHERS => -- OBJECTIVE.
- NULL;
- END;
-
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL FILES NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FL2, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("EXTERNAL FILE STILL EXISTS AFTER " &
- "A SUCCESSFUL DELETION - SEQ");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2110A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada
deleted file mode 100644
index 983657a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CE2110C.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 EXTERNAL FILE CEASES TO EXIST AFTER A SUCCESSFUL
--- DELETE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION AND DELETION OF DIRECT FILES.
-
--- HISTORY:
--- SPS 08/25/82
--- SPS 11/09/82
--- JBG 04/01/83
--- EG 05/31/85
--- JLH 07/21/87 ADDED A CALL TO NOT_APPLICABLE IF EXCEPTION
--- USE_ERROR IS RAISED ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2110C IS
-BEGIN
-
- TEST ("CE2110C", "CHECK THAT THE EXTERNAL FILE CEASES TO EXIST " &
- "AFTER A SUCCESSFUL DELETE");
-
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FL1, FL2 : FILE_TYPE;
- VAR1 : INTEGER := 5;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXCEPTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FL1, VAR1); -- THIS WRITES TO THE FILE IF IT
- EXCEPTION -- CAN, NOT NECESSARY FOR THE
- WHEN OTHERS => -- OBJECTIVE.
- NULL;
- END;
-
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL FILE NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FL2, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("EXTERNAL FILE STILL EXISTS AFTER " &
- "A SUCCESSFUL DELETION - DIR");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2110C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada
deleted file mode 100644
index c71591a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada
+++ /dev/null
@@ -1,131 +0,0 @@
--- CE2111A.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 FILE REMAINS OPEN AFTER A RESET.
-
--- THIS OBJECTIVE IS BEING INTERPRETED AS : CHECK THAT A FILE
--- REMAINS OPEN AFTER AN ATTEMPT TO RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- DLD 08/13/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/28/85
--- JLH 07/22/87 REWROTE TEST ALGORITHM.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2111A IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER);
- USE SEQ_IO;
-
- SEQ_FILE : SEQ_IO.FILE_TYPE;
- VAR1 : INTEGER := 5;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2111A", "CHECK THAT THE FILE REMAINS OPEN AFTER A RESET");
-
--- CREATE SEQUENTIAL TEST FILE
-
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- WRITE (SEQ_FILE, VAR1);
- CLOSE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("SEQUENTIAL FILES NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
--- OPEN FILE
-
- BEGIN
- OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT SUPPORTED " &
- "FOR SEQ_IO");
- RAISE INCOMPLETE;
- END;
-
--- RESET FILE
-
- BEGIN
- RESET(SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (SEQ_FILE) THEN
- CLOSE (SEQ_FILE);
- ELSE
- FAILED ("RESET FOR IN_FILE, CLOSED FILE");
- END IF;
-
--- RE-OPEN AS OUT_FILE AND REPEAT TEST
-
- BEGIN
- OPEN (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " &
- "SUPPORTED FOR SEQ_IO");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (SEQ_FILE) THEN
- BEGIN
- DELETE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- ELSE
- FAILED ("RESET FOR OUT_FILE, CLOSED FILE");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada
deleted file mode 100644
index 58ceb83..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada
+++ /dev/null
@@ -1,183 +0,0 @@
--- CE2111B.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 SUCCESSFUL RESET POSITIONS THE INDEX CORRECTLY
--- TO THE START OF THE FILE FOR DIRECT IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR DIRECT FILES.
-
--- HISTORY:
--- DLD 08/13/82
--- JBG 03/24/83
--- EG 05/29/85
--- JLH 07/23/87 ADDED CHECKS FOR USE_ERROR WHEN FILE IS RESET.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2111B IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- TEST_FILE_ONE : DIR_IO.FILE_TYPE;
- DATUM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2111B", "CHECK THAT SUCCESSFUL RESETS POSITION THE " &
- "INDEX CORRECTLY");
-
--- CREATE AND INITIALIZE TEST FILE
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (TEST_FILE_ONE, 5);
- WRITE (TEST_FILE_ONE, 6);
- WRITE (TEST_FILE_ONE, 7);
- WRITE (TEST_FILE_ONE, 8);
-
--- CHECK THAT RESET POSITIONS INDEX CORRECTLY FOR OUT_FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- IF INDEX (TEST_FILE_ONE) /= 1 THEN
- FAILED ("RESET INCORRECTLY POSITIONED FILE FOR " &
- "OUT_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR OUT_FILE");
- RAISE INCOMPLETE;
- END;
-
--- WRITE MORE DATA
-
- WRITE (TEST_FILE_ONE, 2);
- CLOSE (TEST_FILE_ONE);
-
--- NOW CHECK TO SEE THAT RESET WORKED FOR OUT_FILE
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DIR_IO NOT SUPPORTED FOR IN_FILE OPEN");
- RAISE INCOMPLETE;
- END;
- READ (TEST_FILE_ONE, DATUM);
- IF DATUM /= 2 THEN
- FAILED ("RESET FAILED FOR OUT_FILE");
- END IF;
-
--- POSITION POINTER APPROPRIATELY FOR IN_FILE RESET
-
- READ (TEST_FILE_ONE, DATUM);
-
--- RESET IN_FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- IF INDEX (TEST_FILE_ONE) /= 1 THEN
- FAILED ("RESET INCORRECTLY POSITIONED FILE " &
- "FOR IN_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR IN_FILE");
- RAISE INCOMPLETE;
- END;
-
--- VALIDATE IN_FILE RESET
-
- READ (TEST_FILE_ONE, DATUM);
- IF DATUM /= 2 THEN
- FAILED ("RESET FAILED FOR IN_FILE");
- END IF;
-
--- VALIDATE RESET FOR IN_OUT FILE
-
- CLOSE (TEST_FILE_ONE);
- BEGIN
- OPEN (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DIR_IO NOT SUPPORTED FOR INOUT_FILE " &
- "OPEN");
- RAISE INCOMPLETE;
- END;
-
--- WRITE NEW DATA
-
- WRITE (TEST_FILE_ONE, 3);
-
--- RESET INOUT_FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- IF INDEX (TEST_FILE_ONE) /= 1 THEN
- FAILED ("RESET INCORRECTLY POSITIONED FILE " &
- "FOR INOUT_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR INOUT_FILE");
- RAISE INCOMPLETE;
- END;
-
--- VALIDATE RESET
-
- READ (TEST_FILE_ONE, DATUM);
- IF DATUM /= 3 THEN
- FAILED ("RESET FAILED FOR INOUT_FILE");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada
deleted file mode 100644
index 09aff66..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- CE2111C.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 SUPPLIED MODE PARAMETER IN A RESET CHANGES
--- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED
--- THE MODE REMAINS THE SAME.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- DLD 08/16/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/29/85
--- JLH 07/23/87 ADDED CHECKS FOR USE_ERROR WHEN FILE IS RESET.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2111C IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- SEQ_FILE : SEQ_IO.FILE_TYPE;
- SEQ_MODE : SEQ_IO.FILE_MODE;
- INCOMPLETE : EXCEPTION;
- VAR1 : INTEGER := 5;
-
-BEGIN
-
- TEST ("CE2111C", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " &
- "THE MODE OF THE GIVEN FILE APPROPRIATELY");
-
--- CREATE SEQUENTIAL TEST FILE
-
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- WRITE (SEQ_FILE, VAR1);
- CLOSE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("SEQUENTIAL FILES WITH IN_FILE MODE " &
- "NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
--- RESET TO DEFAULT
-
- BEGIN
- SEQ_MODE := OUT_FILE;
- RESET (SEQ_FILE);
- SEQ_MODE := MODE (SEQ_FILE);
- IF SEQ_MODE /= IN_FILE THEN
- FAILED ("DEFAULT RESET CHANGED MODE - SEQ");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR SEQ IN_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
--- RESET TO OUT_FILE
-
- BEGIN
- SEQ_MODE := IN_FILE;
- RESET (SEQ_FILE, OUT_FILE);
- SEQ_MODE := MODE (SEQ_FILE);
- IF SEQ_MODE /= OUT_FILE THEN
- FAILED ("RESET TO OUT_FILE FAILED - SEQ");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM IN_FILE TO OUT_FILE MODE " &
- "NOT SUPPORTED FOR SEQ FILES");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- DELETE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada
deleted file mode 100644
index 57e4cb8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- CE2111E.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 FILE REMAINS OPEN AFTER A RESET.
-
--- THIS OBJECTIVE IS BEING INTERPRETED AS : CHECK THAT A FILE
--- REMAINS OPEN AFTER AN ATTEMPT TO RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- DLD 08/13/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/28/85
--- JLH 07/23/87 REWROTE TEST ALGORITHM.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2111E IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
-
- DIR_FILE : DIR_IO.FILE_TYPE;
- VAR1 : INTEGER := 5;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2111E", "CHECK THAT THE FILE REMAINS OPEN AFTER A RESET");
-
--- CREATE DIRECT TEST FILE
-
- BEGIN
- CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME);
- WRITE (DIR_FILE, VAR1);
- CLOSE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("DIRECT FILES NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
--- OPEN FILE
-
- BEGIN
- OPEN (DIR_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT SUPPORTED " &
- "FOR DIR_IO");
- RAISE INCOMPLETE;
- END;
-
--- RESET FILE
-
- BEGIN
- RESET (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (DIR_FILE) THEN
- CLOSE (DIR_FILE);
- ELSE
- FAILED ("RESET FOR IN_FILE, CLOSED FILE");
- END IF;
-
-
--- RE-OPEN AS OUT_FILE AND REPEAT TEST
-
- BEGIN
- OPEN (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " &
- "SUPPORTED FOR DIR_IO");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (DIR_FILE) THEN
- CLOSE (DIR_FILE);
- ELSE
- FAILED ("RESET FOR OUT_FILE, CLOSED FILE");
- END IF;
-
--- RE-OPEN AS IN_OUT FILE AND REPEAT TEST
-
- BEGIN
- OPEN (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_OUT FILE MODE NOT " &
- "SUPPORTED FOR DIR_IO");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (DIR_FILE) THEN
- BEGIN
- DELETE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- ELSE
- FAILED ("RESET FOR INOUT_FILE, CLOSED FILE");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada
deleted file mode 100644
index 1259cb8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- CE2111F.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 SUCCESSFUL RESET POSITIONS THE FILE CORRECTLY
--- TO THE START OF THE FILE FOR SEQUENTIAL IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 08/03/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2111F IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- TEST_FILE_ONE : SEQ_IO.FILE_TYPE;
- DATUM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2111F", "CHECK THAT SUCCESSFUL RESET POSITIONS THE " &
- "FILE CORRECTLY");
-
--- CREATE AND INITIALIZE TEST FILE
-
- BEGIN
- CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (TEST_FILE_ONE, 5);
- WRITE (TEST_FILE_ONE, 6);
-
--- CHECK THAT RESET POSITIONS INDEX CORRECTLY FOR OUT_FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR OUT_FILE");
- RAISE INCOMPLETE;
- END;
-
--- WRITE MORE DATA
-
- WRITE (TEST_FILE_ONE, 2);
- CLOSE (TEST_FILE_ONE);
-
--- NOW CHECK TO SEE THAT RESET WORKED FOR OUT_FILE
-
- BEGIN
- OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("SEQ_IO NOT SUPPORTED FOR IN_FILE OPEN");
- RAISE INCOMPLETE;
- END;
-
- READ (TEST_FILE_ONE, DATUM);
-
- IF DATUM /= 2 THEN
- FAILED ("RESET INCORRECTLY POSITIONED FILE FOR OUT_FILE");
- END IF;
-
-
--- RESET IN_FILE
-
- BEGIN
- RESET (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR IN_FILE");
- RAISE INCOMPLETE;
- END;
-
--- VALIDATE IN_FILE RESET
-
- READ (TEST_FILE_ONE, DATUM);
-
- IF DATUM /= 2 THEN
- FAILED ("RESET INCORRECTLY POSITIONED FILE FOR IN_FILE");
- END IF;
-
--- DELETE TEST FILE
-
- BEGIN
- DELETE (TEST_FILE_ONE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada
deleted file mode 100644
index c337548..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CE2111G.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 SUPPLIED MODE PARAMETER IN A RESET CHANGES
--- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED
--- THE MODE REMAINS THE SAME.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR DIRECT FILES.
-
--- HISTORY:
--- DLD 08/16/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/29/85
--- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED
--- IS CALLED FOR OPEN OR CREATE.
--- JLH 07/24/87 ADDED CHECKS FOR USE_ERR0R WHEN FILE IS RESET.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2111G IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- DIR_FILE : DIR_IO.FILE_TYPE;
- DIR_MODE : DIR_IO.FILE_MODE;
- INCOMPLETE : EXCEPTION;
- VAR1 : INTEGER := 5;
-
-BEGIN
-
- TEST ("CE2111G", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " &
- "THE MODE OF THE GIVEN FILE APPROPRIATELY");
-
--- CREATE DIRECT TEST FILE
-
- BEGIN
- CREATE (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME);
- WRITE (DIR_FILE, VAR1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
--- RESET TO DEFAULT
-
- BEGIN
- DIR_MODE := OUT_FILE;
- RESET (DIR_FILE);
- DIR_MODE := MODE (DIR_FILE);
- IF DIR_MODE /= INOUT_FILE THEN
- FAILED ("DEFAULT RESET CHANGED MODE - DIR");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR DIR " &
- "INOUT_FILES");
- END;
-
--- RESET TO OUT_FILE
-
- BEGIN
- DIR_MODE := IN_FILE;
- RESET (DIR_FILE, OUT_FILE);
- DIR_MODE := MODE (DIR_FILE);
- IF DIR_MODE /= OUT_FILE THEN
- FAILED ("RESET TO OUT_FILE FAILED - DIR");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM INOUT_FILE TO OUT_FILE " &
- "NOT SUPPORTED FOR DIR FILES");
- END;
-
--- RESET TO IN_FILE
-
- BEGIN
- DIR_MODE := OUT_FILE;
- RESET (DIR_FILE, IN_FILE);
- DIR_MODE := MODE (DIR_FILE);
- IF DIR_MODE /= IN_FILE THEN
- FAILED ("RESET TO IN_FILE FAILED - DIR");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE NOT " &
- "SUPPORTED FOR DIR IN_FILE");
- END;
-
--- RESET TO INOUT_FILE
-
- BEGIN
- DIR_MODE := OUT_FILE;
- RESET (DIR_FILE, INOUT_FILE);
- DIR_MODE := MODE (DIR_FILE);
- IF DIR_MODE /= INOUT_FILE THEN
- FAILED ("RESET TO INOUT_FILE FAILED - DIR");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM IN_FILE TO INOUT_FILE NOT " &
- "SUPPORTED FOR DIR INOUT_FILES");
- END;
-
- BEGIN
- DELETE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada b/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada
deleted file mode 100644
index d9367f5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- CE2111I.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 SUPPLIED MODE PARAMETER IN A RESET CHANGES
--- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED
--- THE MODE REMAINS THE SAME.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 07/23/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2111I IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- SEQ_FILE : SEQ_IO.FILE_TYPE;
- SEQ_MODE : SEQ_IO.FILE_MODE;
- INCOMPLETE : EXCEPTION;
- VAR1 : INTEGER := 5;
-
-BEGIN
-
- TEST("CE2111I", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " &
- "THE MODE OF THE GIVEN FILE APPROPRIATELY");
-
--- CREATE SEQUENTIAL TEST FILE
-
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- WRITE (SEQ_FILE, VAR1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
--- RESET TO DEFAULT
-
- BEGIN
- SEQ_MODE := IN_FILE;
- RESET (SEQ_FILE);
- SEQ_MODE := MODE (SEQ_FILE);
- IF SEQ_MODE /= OUT_FILE THEN
- FAILED ("DEFAULT RESET CHANGED MODE - SEQ");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET NOT SUPPORTED FOR SEQ OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
--- RESET TO IN_FILE
-
- BEGIN
- SEQ_MODE := OUT_FILE;
- RESET (SEQ_FILE, IN_FILE);
- SEQ_MODE := MODE (SEQ_FILE);
- IF SEQ_MODE /= IN_FILE THEN
- FAILED ("RESET TO IN_FILE FAILED - SEQ");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE MODE " &
- "NOT SUPPORTED FOR SEQ FILES");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- DELETE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2111I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada
deleted file mode 100644
index 85c188f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE2201A.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT_TYPE STRING.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- ABW 08/16/82
--- SPS 11/09/82
--- JBG 01/05/83
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 07/28/87 REMOVED DEPENDENCE ON SUPPORT OF RESET.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201A IS
-
-BEGIN
-
- TEST ("CE2201A", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - STRING TYPE");
-
- DECLARE
- SUBTYPE STRNG IS STRING (1..12);
- PACKAGE SEQ_STR IS NEW SEQUENTIAL_IO (STRNG);
- USE SEQ_STR;
- FILE_STR : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- STR : STRNG := "TEXT OF FILE";
- ITEM_STR : STRNG;
- BEGIN
- BEGIN
- CREATE (FILE_STR, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_STR, STR);
- CLOSE (FILE_STR);
-
- BEGIN
- OPEN (FILE_STR, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_STR) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE STRING");
- END IF;
-
- READ (FILE => FILE_STR, ITEM => ITEM_STR);
-
- IF ITEM_STR /= STRNG (IDENT_STR("TEXT OF FILE")) THEN
- FAILED ("READ WRONG VALUE - STRING");
- END IF;
-
- IF NOT END_OF_FILE (FILE_STR) THEN
- FAILED ("END OF FILE NOT TRUE - STRING");
- END IF;
-
- BEGIN
- DELETE (FILE_STR);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada
deleted file mode 100644
index 151f886..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- CE2201B.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED ARRAY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED ARRAY.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 05/02/83
--- EG 05/08/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED
--- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY
--- FILES.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201B IS
-
-BEGIN
-
- TEST ("CE2201B", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - CONSTRAINED ARRAY");
-
- DECLARE
- TYPE ARR_CN IS ARRAY (1..5) OF BOOLEAN;
- PACKAGE SEQ_ARR_CN IS NEW SEQUENTIAL_IO (ARR_CN);
- USE SEQ_ARR_CN;
- FILE_ARR_CN : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- ARR1 : ARR_CN := (TRUE,TRUE,FALSE,TRUE,TRUE);
- ITEM_ARR1 : ARR_CN;
- BEGIN
- BEGIN
- CREATE (FILE_ARR_CN, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_ARR_CN, ARR1);
- CLOSE (FILE_ARR_CN);
-
- BEGIN
- OPEN (FILE_ARR_CN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_ARR_CN) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "CONSTRAINED ARRAY");
- END IF;
-
- READ (FILE_ARR_CN, ITEM_ARR1);
-
- IF ITEM_ARR1 /= ARR1 THEN
- FAILED ("READ WRONG VALUE - CONSTRAINED ARRAY");
- END IF;
-
- IF NOT END_OF_FILE (FILE_ARR_CN) THEN
- FAILED ("END OF FILE NOT TRUE - CONSTRAINED ARRAY");
- END IF;
-
- BEGIN
- DELETE (FILE_ARR_CN);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada
deleted file mode 100644
index 44516b1..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CE2201C.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT_TYPE FLOAT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 11/10/82
--- JBG 20/22/84 CHANGED TO .ADA TEST.
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED AN EXTERNAL
--- FILE RATHER THAN A TEMPORARY FILE.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201C IS
-BEGIN
-
- TEST ("CE2201C", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - FLOAT");
-
- DECLARE
- PACKAGE SEQ_FLT IS NEW SEQUENTIAL_IO (FLOAT);
- USE SEQ_FLT;
- FILE_FLT : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- FLT : FLOAT := 65.0;
- ITEM_FLT : FLOAT;
- BEGIN
- BEGIN
- CREATE (FILE_FLT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_FLT, FLT);
- CLOSE (FILE_FLT);
-
- BEGIN
- OPEN (FILE_FLT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_FLT) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR FLOATING POINT");
- END IF;
-
- READ (FILE_FLT, ITEM_FLT);
-
- IF ITEM_FLT /= 65.0 THEN
- FAILED ("READ WRONG VALUE - FLOAT");
- END IF;
-
- IF NOT END_OF_FILE (FILE_FLT) THEN
- FAILED ("END OF FILE NOT TRUE - FLOAT");
- END IF;
-
- BEGIN
- DELETE (FILE_FLT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2201C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep b/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep
deleted file mode 100644
index fdbe40e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep
+++ /dev/null
@@ -1,145 +0,0 @@
--- CE2201D.DEP
-
--- 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 WHETHER READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT_TYPE UNCONSTRAINED ARRAY.
-
--- IF I/O IS NOT SUPPORTED, THEN CREATE AND OPEN CAN RAISE USE_ERROR
--- OR NAME_ERROR. SEE (AI-00332).
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS NON-APPLICABLE IF THE INSTANTIATION OF SEQUENTIAL_IO
--- WITH UNCONSTRAINED ARRAY TYPE, ARR_UNCN, IS NOT SUPPORTED.
-
--- IF THE INSTANTIATION OF SEQUENTIAL_IO IS NOT SUPPORTED THEN
--- THE INSTANTIATION MUST BE REJECTED.
-
--- HISTORY:
--- ABW 8/17/82
--- SPS 9/15/82
--- SPS 11/9/82
--- JBG 1/6/83
--- JBG 6/4/84
--- TBN 11/01/85 RENAMED FROM CE2201D.DEP AND MODIFIED COMMENTS.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- THS 03/30/90 RENAMED FROM EE2201D.ADA.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201D IS
- INCOMPLETE : EXCEPTION;
-BEGIN
-
- TEST ("CE2201D" , "CHECK WHETHER READ, WRITE, AND END_OF_FILE " &
- "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " &
- "UNCONSTRAINED ARRAY TYPES");
-
- DECLARE
- SUBTYPE ONE_TEN IS INTEGER RANGE 1..10;
- TYPE ARR_UNCN IS ARRAY (ONE_TEN RANGE <>) OF INTEGER;
- PACKAGE SEQ_ARR_UNCN
- IS NEW SEQUENTIAL_IO (ARR_UNCN); -- N/A => ERROR.
- USE SEQ_ARR_UNCN;
- FILE_ARR_UNCN : FILE_TYPE;
- ARR2 : ARR_UNCN (1..6) := (1,3,5,7,9,0);
- ITEM_ARR2 : ARR_UNCN (1..6);
- BEGIN
- BEGIN
- CREATE (FILE_ARR_UNCN);
-
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FILE_ARR_UNCN,ARR2);
- WRITE (FILE_ARR_UNCN, (0, -2));
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRITE FOR UNCONSTRAINED ARRAY");
- END;
-
- RESET (FILE_ARR_UNCN,IN_FILE);
-
- IF END_OF_FILE (FILE_ARR_UNCN) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "UNCONSTRAINED ARRAY");
- END IF;
-
- BEGIN
- READ (FILE_ARR_UNCN,ITEM_ARR2);
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ FOR UNCONSTRAINED ARRAY");
- END;
-
- IF ITEM_ARR2 /= (1,3,5,7,9,0) THEN
- FAILED ("READ WRONG VALUE - 1");
- END IF;
-
- BEGIN
- READ (FILE_ARR_UNCN, ITEM_ARR2(3..4));
-
- IF ITEM_ARR2 /= (1,3,0,-2,9,0) THEN
- FAILED ("READ WRONG VALUE - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR SECOND ARRAY READ");
- END;
-
- IF NOT END_OF_FILE(FILE_ARR_UNCN) THEN
- FAILED ("NOT AT END OF FILE");
- END IF;
-
- CLOSE (FILE_ARR_UNCN);
-
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED BY RESET");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2201D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep b/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep
deleted file mode 100644
index 2ee9578..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep
+++ /dev/null
@@ -1,155 +0,0 @@
--- CE2201E.DEP
-
--- 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 WHETHER READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH VARIANT RECORDS WITH NON-DEFAULT
--- DISCRIMINANTS.
-
--- IF I/O IS NOT SUPPORTED, THEN CREATE AND OPEN CAN RAISE USE_ERROR
--- OR NAME_ERROR. SEE (AI-00332).
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS NON-APPLICABLE IF THE INSTANTIATION OF
--- SEQUENTIAL_IO WITH VARIANT RECORDS HAVING NO DEFAULT
--- DISCRIMINANT VALUES IS REJECTED.
-
--- HISTORY:
--- JBG 1/6/83
--- JBG 5/2/83
--- TBN 11/18/85 RENAMED FROM CE2201E.DEP AND MODIFIED COMMENTS.
--- SPLIT DEFAULT DISCRIMINANT CASE INTO
--- CE2201G.ADA.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- THS 03/30/90 RENAMED FROM EE2201E.ADA.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201E IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2201E", "CHECK WHETHER READ, WRITE, AND END_OF_FILE " &
- "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " &
- "UNCONSTRAINED VARIANT RECORD TYPES WITH " &
- "NON-DEFAULT DISCRIMINANTS.");
-
- DECLARE
- TYPE VAR_REC (DISCR : BOOLEAN) IS
- RECORD
- CASE DISCR IS
- WHEN TRUE =>
- A : INTEGER;
- WHEN FALSE =>
- B : STRING (1..20);
- END CASE;
- END RECORD;
-
- PACKAGE SEQ_VAR_REC
- IS NEW SEQUENTIAL_IO (VAR_REC); -- N/A => ERROR.
- USE SEQ_VAR_REC;
-
- FILE_VAR_REC : FILE_TYPE;
- ITEM_TRUE : VAR_REC(TRUE);
- ITEM_FALSE : VAR_REC(FALSE);
-
- BEGIN
-
- BEGIN
- CREATE (FILE_VAR_REC);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FILE_VAR_REC, (TRUE, -6));
- WRITE (FILE_VAR_REC, (FALSE, (1..20 => 'C')));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRITE FOR RECORD WITH DISCRIMINANT");
- END;
-
- BEGIN
- RESET (FILE_VAR_REC,IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR FOR RESET");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_VAR_REC) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" &
- "WITH DISCRIMINANT");
- END IF;
-
- BEGIN
- READ (FILE_VAR_REC,ITEM_TRUE);
-
- IF ITEM_TRUE /= (TRUE, IDENT_INT(-6)) THEN
- FAILED ("READ WRONG VALUE - 1");
- END IF;
-
- IF END_OF_FILE (FILE_VAR_REC) THEN
- FAILED ("PREMATURE END OF FILE");
- END IF;
-
- READ (FILE_VAR_REC, ITEM_FALSE);
-
- IF ITEM_FALSE /= (FALSE, (1..IDENT_INT(20) => 'C')) THEN
- FAILED ("READ WRONG VALUE - 2");
- END IF;
-
- IF NOT END_OF_FILE(FILE_VAR_REC) THEN
- FAILED ("NOT AT END OF FILE");
- END IF;
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ FOR VARIANT RECORD");
- END;
-
- CLOSE (FILE_VAR_REC);
-
- END;
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2201E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada
deleted file mode 100644
index 7baa401e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- CE2201F.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH PRIVATE ELEMENT_TYPES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES WITH PRIVATE ELEMENT_TYPES.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 01/06/83
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED EXTERNAL
--- FILES RATHER THAN TEMPORARY FILES.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201F IS
-
- PACKAGE PKG IS
- TYPE PRIV IS PRIVATE;
- FUNCTION MAKE_PRIV (X : INTEGER) RETURN PRIV;
- PRIVATE
- TYPE PRIV IS NEW INTEGER;
- END PKG;
- USE PKG;
-
- PACKAGE BODY PKG IS
- FUNCTION MAKE_PRIV (X : INTEGER) RETURN PRIV IS
- BEGIN
- RETURN PRIV(X);
- END;
- END PKG;
-
-BEGIN
-
- TEST ("CE2201F", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES FOR PRIVATE TYPES");
-
- DECLARE
- PACKAGE SEQ_PRV IS NEW SEQUENTIAL_IO (PRIV);
- USE SEQ_PRV;
- PRV, ITEM_PRV : PRIV;
- FILE_PRV : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FILE_PRV, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- PRV := MAKE_PRIV(IDENT_INT(26));
-
- WRITE (FILE_PRV, PRV);
- CLOSE (FILE_PRV);
-
- BEGIN
- OPEN (FILE_PRV, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_PRV) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR PRIVATE TYPE");
- END IF;
-
- READ (FILE_PRV, ITEM_PRV);
-
- IF ITEM_PRV /= MAKE_PRIV (26) THEN
- FAILED ("READ WRONG VALUE");
- END IF;
-
- IF NOT END_OF_FILE (FILE_PRV) THEN
- FAILED ("NOT AT END OF FILE");
- END IF;
-
- BEGIN
- DELETE (FILE_PRV);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada
deleted file mode 100644
index cb8a528..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- CE2201G.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED
--- FOR SEQUENTIAL FILES WITH VARIANT RECORDS WITH DEFAULT
--- DISCRIMINANTS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 05/15/86
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED EXTERNAL
--- FILES RATHER THAN TEMPORARY FILES.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201G IS
-
-BEGIN
-
- TEST ("CE2201G", "CHECK THAT READ, WRITE, AND END_OF_FILE " &
- "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " &
- "UNCONSTRAINED VARIANT RECORD TYPES WITH " &
- "DEFAULT DISCRIMINANTS.");
-
- DECLARE
- TYPE VAR_REC (DISCR : BOOLEAN := TRUE) IS
- RECORD
- CASE DISCR IS
- WHEN TRUE =>
- A : INTEGER;
- WHEN FALSE =>
- B : STRING (1..20);
- END CASE;
- END RECORD;
-
- PACKAGE SEQ_VAR_REC IS NEW SEQUENTIAL_IO (VAR_REC);
- USE SEQ_VAR_REC;
-
- FILE_VAR_REC : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- ITEM_TRUE : VAR_REC(TRUE); -- CONSTRAINED
- ITEM : VAR_REC; -- UNCONSTRAINED
-
- BEGIN
- BEGIN
- CREATE (FILE_VAR_REC, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_VAR_REC, (TRUE, -5));
- WRITE (FILE_VAR_REC, (FALSE, (1..20 => 'B')));
- CLOSE (FILE_VAR_REC);
-
- BEGIN
- OPEN (FILE_VAR_REC, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_VAR_REC) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" &
- "WITH DISCRIMINANT");
- END IF;
-
- BEGIN
- READ (FILE_VAR_REC, ITEM_TRUE);
-
- IF ITEM_TRUE /= (TRUE, IDENT_INT(-5)) THEN
- FAILED ("READ WRONG VALUE - 1");
- END IF;
-
- IF END_OF_FILE (FILE_VAR_REC) THEN
- FAILED ("PREMATURE END OF FILE");
- END IF;
-
- READ (FILE_VAR_REC, ITEM);
-
- IF ITEM /= (FALSE, (1..IDENT_INT(20) => 'B')) THEN
- FAILED ("READ WRONG VALUE - 2");
- END IF;
-
- IF NOT END_OF_FILE(FILE_VAR_REC) THEN
- FAILED ("NOT AT END OF FILE");
- END IF;
-
- END;
-
- BEGIN
- DELETE (FILE_VAR_REC);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2201G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada
deleted file mode 100644
index 03705c8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- CE2201H.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT TYPE INTEGER.
-
--- APPLICABILITY:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES WITH ELEMENT TYPE INTEGER.
-
--- HISTORY:
--- JLH 07/28/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201H IS
-
-BEGIN
-
- TEST ("CE2201H" , "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - INTEGER TYPE");
-
- DECLARE
- PACKAGE SEQ_INT IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_INT;
- FILE_INT : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- INT : INTEGER := IDENT_INT (33);
- ITEM_INT : INTEGER;
- BEGIN
- BEGIN
- CREATE (FILE_INT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_INT, INT);
- CLOSE (FILE_INT);
-
- BEGIN
- OPEN (FILE_INT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_INT) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE INTEGER");
- END IF;
-
- READ (FILE_INT, ITEM_INT);
-
- IF ITEM_INT /= IDENT_INT(33) THEN
- FAILED ("READ WRONG VALUE - INTEGER");
- END IF;
-
- IF NOT END_OF_FILE (FILE_INT) THEN
- FAILED ("END OF FILE NOT TRUE - INTEGER");
- END IF;
-
- BEGIN
- DELETE (FILE_INT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada
deleted file mode 100644
index e3e6e60..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- CE2201I.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT TYPE BOOLEAN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 07/28/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201I IS
-
-BEGIN
-
- TEST ("CE2201I", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - BOOLEAN TYPE");
-
- DECLARE
- PACKAGE SEQ_BOOL IS NEW SEQUENTIAL_IO (BOOLEAN);
- USE SEQ_BOOL;
- FILE_BOOL : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- BOOL : BOOLEAN := IDENT_BOOL (TRUE);
- ITEM_BOOL : BOOLEAN;
- BEGIN
- BEGIN
- CREATE (FILE_BOOL, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_BOOL, BOOL);
- CLOSE (FILE_BOOL);
-
- BEGIN
- OPEN (FILE_BOOL, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_BOOL) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE BOOLEAN");
- END IF;
-
- READ (FILE_BOOL, BOOL);
-
- IF BOOL /= IDENT_BOOL (TRUE) THEN
- FAILED ("READ WRONG VALUE - BOOLEAN");
- END IF;
-
- IF NOT END_OF_FILE (FILE_BOOL) THEN
- FAILED ("END OF FILE NOT TRUE - BOOLEAN");
- END IF;
-
- BEGIN
- DELETE (FILE_BOOL);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada
deleted file mode 100644
index 060909c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CE2201J.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT TYPE ENUMERATION.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 07/28/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201J IS
-
-BEGIN
-
- TEST ("CE2201J", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - ENUMERATION TYPE");
-
- DECLARE
- TYPE ENUMERATION IS (ONE, TWO, '4');
- PACKAGE SEQ_ENUM IS NEW SEQUENTIAL_IO (ENUMERATION);
- USE SEQ_ENUM;
- FILE_ENUM : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- ENUM : ENUMERATION := ('4');
- ITEM_ENUM : ENUMERATION;
- BEGIN
- BEGIN
- CREATE (FILE_ENUM, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_ENUM, ENUM);
- CLOSE (FILE_ENUM);
-
- BEGIN
- OPEN (FILE_ENUM, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_ENUM) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE ENUMERATION");
- END IF;
-
- READ (FILE_ENUM, ITEM_ENUM);
-
- IF ITEM_ENUM /= '4' THEN
- FAILED ("READ WRONG VALUE - ENUMERATION");
- END IF;
-
- IF NOT END_OF_FILE (FILE_ENUM) THEN
- FAILED ("END OF FILE NOT TRUE - ENUMERATION");
- END IF;
-
- BEGIN
- DELETE (FILE_ENUM);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201J;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada
deleted file mode 100644
index a372ad6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- CE2201K.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT TYPE ACCESS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 07/28/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201K IS
-
-BEGIN
-
- TEST ("CE2201K", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - ACCESS TYPE");
-
- DECLARE
- TYPE ACC_INT IS ACCESS INTEGER;
- PACKAGE SEQ_ACC IS NEW SEQUENTIAL_IO (ACC_INT);
- USE SEQ_ACC;
- FILE_ACC : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- ACC : ACC_INT := NEW INTEGER'(33);
- ITEM_ACC : ACC_INT;
- BEGIN
- BEGIN
- CREATE (FILE_ACC, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_ACC, ACC);
- CLOSE (FILE_ACC);
-
- BEGIN
- OPEN (FILE_ACC, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_ACC) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE ACCESS");
- END IF;
-
- READ (FILE_ACC, ITEM_ACC);
-
- IF NOT END_OF_FILE (FILE_ACC) THEN
- FAILED ("END OF FILE NOT TRUE - ACCESS");
- END IF;
-
- BEGIN
- DELETE (FILE_ACC);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201K;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada
deleted file mode 100644
index 15af840..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CE2201L.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT TYPE FIXED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 08/03/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201L IS
-BEGIN
-
- TEST ("CE2201L", "CHECK THAT READ, WRITE, AND END_OF_FILE " &
- "ARE SUPPORTED FOR SEQUENTIAL FILES - FIXED");
-
- DECLARE
- TYPE FIX IS DELTA 0.5 RANGE -10.0 .. 255.0;
- PACKAGE SEQ_FIX IS NEW SEQUENTIAL_IO (FIX);
- USE SEQ_FIX;
- FILE_FIX : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- FX : FIX := -8.5;
- ITEM_FIX : FIX;
- BEGIN
- BEGIN
- CREATE (FILE_FIX, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_FIX, FX);
- CLOSE (FILE_FIX);
-
- BEGIN
- OPEN (FILE_FIX, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_FIX) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR FIXED POINT");
- END IF;
-
- READ (FILE_FIX, ITEM_FIX);
-
- IF NOT END_OF_FILE (FILE_FIX) THEN
- FAILED ("END OF FILE NOT TRUE - FIXED");
- END IF;
-
- IF ITEM_FIX /= -8.5 THEN
- FAILED ("READ WRONG VALUE - STRING");
- END IF;
-
- BEGIN
- DELETE (FILE_FIX);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201L;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada
deleted file mode 100644
index cf32381..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- CE2201M.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED
--- FOR SEQUENTIAL FILES WITH ELEMENT_TYPE RECORD WITHOUT
--- DISCRIMINANTS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT SEQUENTIAL FILES WITH ELEMENT_TYPE RECORD WITHOUT
--- DISCRIMINANTS.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 05/02/83
--- EG 05/08/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED
--- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY
--- FILES.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201M IS
-
-BEGIN
-
- TEST ("CE2201M", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - RECORD WITHOUT " &
- "DISCRIMINANTS");
-
- DECLARE
- TYPE REC IS
- RECORD
- ONE : INTEGER;
- TWO : INTEGER;
- END RECORD;
- PACKAGE SEQ_REC IS NEW SEQUENTIAL_IO (REC);
- USE SEQ_REC;
- FILE_REC : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- REC1 : REC := (ONE=>18, TWO=>36);
- ITEM_REC1 : REC;
- BEGIN
-
- BEGIN
- CREATE (FILE_REC, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_REC, REC1);
- CLOSE (FILE_REC);
-
- BEGIN
- OPEN (FILE_REC, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_REC) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE RECORD");
- END IF;
-
- READ (FILE_REC, ITEM_REC1);
-
- IF ITEM_REC1 /= (18, IDENT_INT(36)) THEN
- FAILED ("READ WRONG VALUE - RECORD");
- END IF;
-
- IF NOT END_OF_FILE (FILE_REC) THEN
- FAILED ("END OF FILE NOT TRUE - RECORD");
- END IF;
-
- BEGIN
- DELETE (FILE_REC);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201M;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada b/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada
deleted file mode 100644
index 2eaa296..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada
+++ /dev/null
@@ -1,123 +0,0 @@
--- CE2201N.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 READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR
--- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED RECORD TYPES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED RECORD TYPES.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 05/02/83
--- EG 05/08/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED
--- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY
--- FILES.
-
-WITH REPORT;
-USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2201N IS
-
-BEGIN
-
- TEST ("CE2201N", "CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE ARE SUPPORTED FOR " &
- "SEQUENTIAL FILES - CONSTRAINED RECORDS");
-
- DECLARE
- TYPE REC_DEF (DISCR : INTEGER := 18) IS
- RECORD
- ONE : INTEGER := 1;
- TWO : INTEGER := 2;
- THREE : INTEGER := 17;
- FOUR : INTEGER := 2;
- END RECORD;
- SUBTYPE REC_DEF_2 IS REC_DEF(2);
- PACKAGE SEQ_REC_DEF IS NEW SEQUENTIAL_IO (REC_DEF_2);
- USE SEQ_REC_DEF;
- FILE_REC_DEF : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- REC3 : REC_DEF(2);
- ITEM_REC3 : REC_DEF(2);
- BEGIN
- BEGIN
- CREATE (FILE_REC_DEF, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " &
- "MODE OUT_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE_REC_DEF, REC3);
- CLOSE (FILE_REC_DEF);
-
- BEGIN
- OPEN (FILE_REC_DEF, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " &
- "MODE IN_FILE NOT SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_FILE (FILE_REC_DEF) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" &
- "WITH DEFAULT");
- END IF;
-
- READ (FILE_REC_DEF, ITEM_REC3);
-
- IF ITEM_REC3 /= (2, IDENT_INT(1),2,17,2) THEN
- FAILED ("READ WRONG VALUE - RECORD WITH DEFAULT");
- END IF;
-
- IF NOT END_OF_FILE (FILE_REC_DEF) THEN
- FAILED ("END OF FILE NOT TRUE - RECORD WITH DEFAULT");
- END IF;
-
- BEGIN
- DELETE (FILE_REC_DEF);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2201N;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada
deleted file mode 100644
index a407357..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada
+++ /dev/null
@@ -1,143 +0,0 @@
--- CE2202A.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 READ, WRITE, AND END_OF_FILE RAISE STATUS_ERROR
--- WHEN APPLIED TO A NON-OPEN SEQUENTIAL FILE. USE_ERROR IS
--- NOT PERMITTED.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/13/82
--- SPS 11/09/82
--- EG 11/26/84
--- EG 05/16/85
--- GMT 07/24/87 REPLACED CALL TO REPORT.COMMENT WITH "NULL;".
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2202A IS
-
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ;
- FILE1, FILE2 : FILE_TYPE;
- CNST : CONSTANT INTEGER := 101;
- IVAL : INTEGER;
- BOOL : BOOLEAN;
-
-BEGIN
- TEST ("CE2202A","CHECK THAT READ, WRITE, AND " &
- "END_OF_FILE RAISE STATUS_ERROR " &
- "WHEN APPLIED TO A NON-OPEN " &
- "SEQUENTIAL FILE");
- BEGIN
- BEGIN
- WRITE (FILE1,CNST);
- FAILED ("STATUS_ERROR NOT RAISED WHEN WRITE APPLIED " &
- "TO NON-EXISTENT FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN WRITE " &
- "APPLIED TO NON-EXISTENT FILE");
- END;
-
- BEGIN
- READ (FILE1,IVAL);
- FAILED ("STATUS_ERROR NOT RAISED WHEN READ APPLIED " &
- "TO NON-EXISTENT FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN READ " &
- "APPLIED TO NON-EXISTENT FILE");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE1);
- FAILED ("STATUS_ERROR NOT RAISED WHEN END_OF_FILE " &
- "APPLIED TO NON-EXISTENT FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN END_OF_FILE " &
- "APPLIED TO NON-EXISTENT FILE");
- END;
- END;
-
- BEGIN
- BEGIN
- CREATE (FILE2);
- CLOSE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL; -- IF FILE2 CANNOT BE CREATED THEN WE WILL
- -- BE REPEATING EARLIER TESTS, BUT THAT'S OK.
- END;
-
- BEGIN
- WRITE (FILE2,CNST);
- FAILED ("STATUS_ERROR NOT RAISED WHEN WRITE APPLIED " &
- "TO FILE2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN WRITE " &
- "APPLIED TO FILE2");
- END;
-
- BEGIN
- READ (FILE2,IVAL);
- FAILED ("STATUS_ERROR NOT RAISED WHEN READ APPLIED " &
- "TO FILE2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN READ " &
- "APPLIED TO FILE2");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE2);
- FAILED ("STATUS_ERROR NOT RAISED WHEN END_OF_FILE " &
- "APPLIED TO FILE2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED WHEN END_OF_FILE " &
- "APPLIED TO FILE2");
- END;
-
- END;
-
- RESULT;
-
-END CE2202A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst b/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst
deleted file mode 100644
index f9a3f65..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst
+++ /dev/null
@@ -1,121 +0,0 @@
--- CE2203A.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.
---*
--- OBJECTIVE:
--- CHECK THAT, FOR SEQUENTIAL_IO, WRITE RAISES THE EXCEPTION
--- USE_ERROR IF THE CAPACITY OF THE EXTERNAL FILE IS EXCEEDED.
--- THIS TEST ONLY CHECKS THAT THE IMPLEMENTATION SUPPORTS AN
--- EXTERNAL FILE CAPACITY OF 4096 CHARACTERS OR LESS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES. ALSO, THE IMPLEMENTATION MUST BE ABLE TO
--- RESTRICT THE CAPACITY OF AN EXTERNAL FILE.
-
--- $FORM_STRING2 IS DEFINED SUCH THAT THE CAPACITY OF THE FILE IS
--- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION
--- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL
--- "CANNOT_RESTRICT_FILE_CAPACITY".
-
--- HISTORY:
--- JLH 07/12/88 CREATED ORIGINAL TEST.
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2203A IS
-
- SUBTYPE STR512 IS STRING (1 .. 512);
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (STR512);
- USE SEQ_IO;
-
- FILE : FILE_TYPE;
- ITEM : STR512 := (1 .. 512 => 'A');
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2203A", "CHECK FOR SEQUENTIAL_IO THAT WRITE RAISES " &
- "USE_ERROR IF THE CAPACITY OF THE EXTERNAL " &
- "FILE IS EXCEEDED");
-
- BEGIN
-
- IF
-$FORM_STRING2
- = STRING'("CANNOT_RESTRICT_FILE_CAPACITY") THEN
- NOT_APPLICABLE ("IMPLEMENTATION CANNOT RESTRICT FILE " &
- "CAPACITY");
- RAISE INCOMPLETE;
- ELSE
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME,
-
-$FORM_STRING2
-);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON " &
- "CREATE WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
- END IF;
-
- BEGIN
- FOR I IN 1 .. 9 LOOP
- WRITE (FILE, ITEM);
- END LOOP;
- FAILED ("USE_ERROR NOT RAISED WHEN THE CAPACITY " &
- "OF THE EXTERNAL FILE IS EXCEEDED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2203A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada
deleted file mode 100644
index ee60898..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE2204A.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 WRITE IS FORBIDDEN FOR SEQUENTIAL FILES OF
--- MODE IN_FILE.
-
--- A) CHECK NON-TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- DLD 08/17/82
--- SPS 08/24/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- JBG 03/30/84
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 07/27/87 SPLIT THIS TEST BY MOVING THE CODE FOR CHECKING
--- TEMPORARY FILES INTO CE2204C.ADA.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2204A IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2204A", "CHECK THAT MODE_ERROR IS RAISED BY WRITE " &
- "WHEN THE MODE IS IN_FILE AND THE FILE " &
- "IS A NON-TEMPORARY FILE");
- DECLARE
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- SEQ_FILE : FILE_TYPE;
- VAR1 : INTEGER := 5;
- BEGIN
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE,
- LEGAL_FILE_NAME (1, "CE2204A"));
- WRITE (SEQ_FILE, VAR1);
- CLOSE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; " &
- "SEQUENTIAL CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; " &
- "SEQUENTIAL CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; " &
- "SEQUENTIAL CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (SEQ_FILE, IN_FILE,
- LEGAL_FILE_NAME (1, "CE2204A"));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON THE " &
- "OPENING OF A SEQUENTIAL " &
- "NON-TEMPORARY FILE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (SEQ_FILE, 3);
- FAILED ("MODE_ERROR NOT RAISED - NAMED FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NAMED FILE");
- END;
-
- BEGIN
- DELETE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2204A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada
deleted file mode 100644
index 61ef0ab..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CE2204B.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 READ AND END_OF_FILE ARE FORBIDDEN FOR SEQUENTIAL
--- FILES OF MODE OUT_FILE.
-
--- A) CHECK NON-TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- THE CREATION OF SEQUENTIAL FILES.
-
--- HISTORY:
--- DLD 08/17/82
--- SPS 08/24/82
--- SPS 110/9/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 07/24/87 SPLIT THIS TEST BY MOVING THE CODE FOR CHECKING
--- TEMPORARY FILES INTO CE2204D.ADA.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2204B IS
-BEGIN
- TEST ("CE2204B", "FOR A NON-TEMPORARY SEQUENTIAL FILE, CHECK " &
- "THAT MODE_ERROR IS RAISED BY READ AND " &
- "END_OF_FILE WHEN THE MODE IS OUT_FILE");
- DECLARE
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- SEQ_FILE : FILE_TYPE;
- X : INTEGER;
- B : BOOLEAN;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- WRITE (SEQ_FILE, 5);
-
- BEGIN -- THIS IS ONLY
- RESET (SEQ_FILE); -- AN ATTEMPT
- EXCEPTION -- TO RESET,
- WHEN USE_ERROR => -- IF RESET
- NULL; -- N/A THEN
- END; -- TEST IS
- -- NOT AFFECTED.
- BEGIN
- READ (SEQ_FILE, X);
- FAILED ("MODE_ERROR NOT RAISED ON READ - 4");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 5");
- END;
-
- BEGIN
- B := END_OF_FILE (SEQ_FILE);
- FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 6");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - END_OF_FILE - 7");
- END;
-
- BEGIN
- DELETE (SEQ_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2204B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada
deleted file mode 100644
index 5981d38..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- CE2204C.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 WRITE IS FORBIDDEN FOR SEQUENTIAL FILES OF
--- MODE IN_FILE.
-
--- B) CHECK TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEMPORARY SEQUENTIAL FILES AND THE RESETTING FROM OUT_FILE
--- TO IN_FILE.
-
--- HISTORY:
--- GMT 07/27/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2204C IS
- INCOMPLETE : EXCEPTION;
-BEGIN
- TEST ("CE2204C", "CHECK THAT MODE_ERROR IS RAISED BY WRITE " &
- "WHEN THE MODE IS INFILE AND THE FILE IS " &
- "A TEMPORARY FILE");
- DECLARE
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- FT : FILE_TYPE;
- VAR1 : INTEGER := 5;
- BEGIN
- BEGIN
- CREATE (FT, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FT, VAR1);
-
- BEGIN
- RESET (FT, IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON RESET - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE(FT, 3);
- FAILED ("MODE_ERROR NOT RAISED ON WRITE - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON WRITE - 4");
- END;
-
- CLOSE (FT);
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2204C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada b/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada
deleted file mode 100644
index 38427f5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CE2204D.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 READ AND END_OF_FILE ARE FORBIDDEN FOR SEQUENTIAL
--- FILES OF MODE OUT_FILE.
-
--- B) CHECK TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- THE CREATION OF TEMPORARY SEQUENTIAL FILES.
-
--- HISTORY:
--- GMT 07/24/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2204D IS
-BEGIN
- TEST ("CE2204D", "FOR A TEMPORARY SEQUENTIAL FILE, CHECK THAT " &
- "MODE_ERROR IS RAISED BY READ AND END_OF_FILE " &
- "WHEN THE MODE IS OUT_FILE");
- DECLARE
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
- FT : FILE_TYPE;
- X : INTEGER;
- B : BOOLEAN;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FT, 5);
-
- BEGIN -- THIS IS ONLY
- RESET (FT); -- AN ATTEMPT
- EXCEPTION -- TO RESET,
- WHEN USE_ERROR => -- IF RESET
- NULL; -- N/A THEN
- END; -- TEST IS
- -- NOT AFFECTED.
-
- BEGIN
- READ (FT, X);
- FAILED ("MODE_ERROR NOT RAISED ON READ - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 4");
- END;
-
- BEGIN
- B := END_OF_FILE (FT);
- FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 5");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - END_OF_FILE - 6");
- END;
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2204D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada
deleted file mode 100644
index 33edc2d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- CE2205A.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 WHETHER READ FOR A SEQUENTIAL FILE RAISES DATA_ERROR OR
--- CONSTRAINT_ERROR WHEN AN ELEMENT IS READ THAT IS OUTSIDE THE
--- RANGE OF THE ITEM TYPE BUT WITHIN THE RANGE OF THE INSTANTIATED
--- TYPE, AND CHECK THAT READING CAN CONTINUE AFTER THE EXCEPTION
--- HAS BEEN HANDLED.
-
--- A) CHECK ENUMERATION TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT SEQUENTIAL FILES.
-
--- HISTORY:
--- SPS 09/28/82
--- JBG 06/04/84
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 07/24/87 RENAMED FROM CE2210A.ADA AND REMOVED THE USE OF
--- RESET.
--- PWB 05/18/89 DELETED CALL TO FAILED WHEN NO EXCEPTION RAISED.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2205A IS
-BEGIN
-
- TEST ("CE2205A", "CHECK WHETHER READ FOR A SEQUENTIAL FILE " &
- "RAISES DATA_ERROR OR CONSTRAINT_ERROR WHEN " &
- "AN ELEMENT IS READ THAT IS OUTSIDE THE RANGE " &
- "OF THE ITEM TYPE BUT WITHIN THE RANGE OF THE " &
- "INSTANTIATED TYPE, AND CHECK THAT READING CAN " &
- "CONTINUE AFTER THE EXCEPTION HAS BEEN HANDLED");
- DECLARE
- PACKAGE SEQ IS NEW SEQUENTIAL_IO (CHARACTER);
- USE SEQ;
- FT : FILE_TYPE;
- SUBTYPE CH IS CHARACTER RANGE 'A' .. 'D';
- X : CH;
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " &
- "CREATE WITH OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "SEQUENTIAL CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FT, 'A');
- WRITE (FT, 'M');
- WRITE (FT, 'B');
- WRITE (FT, 'C');
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE IS NOT " &
- "SUPPORTED - 4");
- RAISE INCOMPLETE;
- END;
-
- -- BEGIN TEST
-
- READ (FT, X);
- IF X /= 'A' THEN
- FAILED ("INCORRECT VALUE FOR READ - 5");
- END IF;
-
- BEGIN
- READ (FT, X);
- COMMENT ("NO EXCEPTION RAISED FOR READ WITH ELEMENT " &
- "OUT OF RANGE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED FOR SCALAR " &
- "TYPES - 7");
- WHEN DATA_ERROR =>
- COMMENT ("DATA_ERROR RAISED FOR SCALAR TYPES - 8");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 9");
- END;
-
- BEGIN
- READ (FT, X);
- IF X /= 'B' THEN
- FAILED ("INCORRECT VALUE FOR READ - 10");
- END IF;
-
- READ (FT, X);
- IF X /= 'C' THEN
- FAILED ("INCORRECT VALUE FOR READ - 11");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNABLE TO CONTINUE READING - 12");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2205A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada
deleted file mode 100644
index 841b680..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- CE2206A.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 READ FOR A SEQUENTIAL FILE RAISES END_ERROR WHEN
--- THERE ARE NO MORE ELEMENTS THAT CAN BE READ FROM THE GIVEN
--- FILE. ALSO CHECK THAT END_OF_FILE CORRECTLY DETECTS THE END
--- OF A SEQUENTIAL FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- SEQUENTIAL FILES.
-
--- HISTORY:
--- JLH 08/22/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH SEQUENTIAL_IO;
-
-PROCEDURE CE2206A IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (CHARACTER);
- USE SEQ_IO;
-
- FILE : FILE_TYPE;
- ITEM : CHARACTER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2206A", "CHECK THAT READ FOR A SEQUENTIAL FILE RAISES " &
- "END_ERROR WHEN THERE ARE NO MORE ELEMENTS " &
- "THAT CAN BE READ FROM THE GIVEN FILE. ALSO " &
- "CHECK THAT END_OF_FILE CORRECTLY DETECTS THE " &
- "END OF A SEQUENTIAL FILE");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE, 'A');
- WRITE (FILE, 'B');
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- READ (FILE, ITEM);
- IF ITEM /= 'A' THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- IF END_OF_FILE (FILE) THEN
- FAILED ("END_OF_FILE NOT DETECTED CORRECTLY - 1");
- END IF;
-
- READ (FILE, ITEM);
-
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("END_OF_FILE NOT DETECTED CORRECTLY - 2");
- END IF;
-
- BEGIN
- READ (FILE, ITEM);
- FAILED ("END_ERROR NOT RAISED FOR READ");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON READ");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2206A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada
deleted file mode 100644
index 418199a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada
+++ /dev/null
@@ -1,185 +0,0 @@
--- CE2208B.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 DATA CAN BE OVERWRITTEN IN THE SEQUENTIAL FILE AND THE
--- CORRECT VALUES CAN LATER BE READ. ALSO CHECK THAT OVERWRITING
--- TRUNCATES THE FILE TO THE LAST ELEMENT WRITTEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- THE CREATING AND OPENING OF SEQUENTIAL FILES.
-
--- HISTORY:
--- TBN 09/30/86 CREATED ORIGINAL TEST.
--- GMT 07/24/87 ADDED CHECKS FOR USE_ERROR AND REMOVED SOME CODE.
--- BCB 10/03/90 CHANGED CODE TO CHECK THAT OVERWRITING TRUNCATES
--- INSTEAD OF WHETHER IT TRUNCATES.
-
-WITH SEQUENTIAL_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2208B IS
-
- PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER);
- USE SEQ_IO;
-
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2208B",
- "CHECK THAT DATA CAN BE OVERWRITTEN IN THE SEQUENTIAL " &
- "FILE AND THE CORRECT VALUES CAN LATER BE READ. ALSO " &
- "CHECK THAT OVERWRITING TRUNCATES THE FILE." );
-
- -- INITIALIZE TEST FILE
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED DURING CREATE");
- RAISE INCOMPLETE;
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED DURING CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED DURING CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- FOR I IN 1 .. 25 LOOP
- WRITE (FILE1, I);
- END LOOP;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING WRITE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CLOSE (FILE1);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING CLOSE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ( "OPEN WITH OUT_FILE MODE NOT " &
- "SUPPORTED FOR SEQUENTIAL FILES" );
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING OPEN");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- FOR I IN 26 .. 36 LOOP
- WRITE (FILE1, I);
- END LOOP;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING OVERWRITE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CLOSE (FILE1);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING 2ND CLOSE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ( "OPEN WITH IN_FILE MODE NOT " &
- "SUPPORTED FOR SEQUENTIAL FILES" );
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED DURING SECOND OPEN");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- END_REACHED : BOOLEAN := FALSE;
- COUNT : INTEGER := 26;
- NUM : INTEGER;
- BEGIN
- WHILE COUNT <= 36 AND NOT END_REACHED LOOP
- BEGIN
- READ (FILE1, NUM);
- IF NUM /= COUNT THEN
- FAILED ("INCORRECT RESULTS READ FROM FILE " &
- INTEGER'IMAGE (NUM));
- END IF;
- COUNT := COUNT + 1;
- EXCEPTION
- WHEN END_ERROR =>
- END_REACHED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
- "READING - 1");
- RAISE INCOMPLETE;
- END;
- END LOOP;
- IF COUNT <= 36 THEN
- FAILED ("FILE WAS INCOMPLETE");
- RAISE INCOMPLETE;
- ELSE
- BEGIN
- READ (FILE1, NUM);
- FAILED ("END_ERROR NOT RAISED BY ATTEMPT TO READ");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "DURING READING - 2");
- RAISE INCOMPLETE;
- END;
- END IF;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2208B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada
deleted file mode 100644
index 4ec4227..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada
+++ /dev/null
@@ -1,357 +0,0 @@
--- CE2401A.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE AND
--- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPES
--- STRING, CHARACTER, AND INTEGER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT DIRECT FILES.
-
--- HISTORY:
--- ABW 08/16/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 07/31/87 ISOLATED EXCEPTIONS.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401A IS
- END_SUBTEST : EXCEPTION;
-BEGIN
-
- TEST ("CE2401A" , "CHECK THAT READ, WRITE, SET_INDEX " &
- "INDEX, SIZE AND END_OF_FILE ARE " &
- "SUPPORTED FOR DIRECT FILES");
-
- DECLARE
- SUBTYPE STR_TYPE IS STRING (1..12);
- PACKAGE DIR_STR IS NEW DIRECT_IO (STR_TYPE);
- USE DIR_STR;
- FILE_STR : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_STR, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - STRING");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - STRING");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- STR : STR_TYPE := "TEXT OF FILE";
- ITEM_STR : STR_TYPE;
- ONE_STR : POSITIVE_COUNT := 1;
- TWO_STR : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_STR,STR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "STRING - 1");
- END;
-
- BEGIN
- WRITE (FILE_STR,STR,TWO_STR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "STRING - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_STR) /= TWO_STR THEN
- FAILED ("SIZE FOR TYPE STRING");
- END IF;
- IF NOT END_OF_FILE (FILE_STR) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR STRING");
- END IF;
- SET_INDEX (FILE_STR,ONE_STR);
- IF INDEX (FILE_STR) /= ONE_STR THEN
- FAILED ("WRONG INDEX VALUE FOR STRING");
- END IF;
- END;
-
- CLOSE (FILE_STR);
-
- BEGIN
- OPEN (FILE_STR, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 1");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_STR,ITEM_STR);
- IF ITEM_STR /= STR THEN
- FAILED ("INCORRECT STRING VALUE READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR STRING");
- END;
-
- BEGIN
- READ (FILE_STR,ITEM_STR,ONE_STR);
- IF ITEM_STR /= STR THEN
- FAILED ("INCORRECT STRING VALUE READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR STRING");
- END;
- END;
-
- BEGIN
- DELETE (FILE_STR);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- DECLARE
- PACKAGE DIR_CHR IS NEW DIRECT_IO (CHARACTER);
- USE DIR_CHR;
- FILE_CHR : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_CHR, INOUT_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - CHARACTER");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - CHARACTER");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- CHR : CHARACTER := 'C';
- ITEM_CHR : CHARACTER;
- ONE_CHR : POSITIVE_COUNT := 1;
- TWO_CHR : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_CHR,CHR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "CHARACTER - 1");
- END;
-
- BEGIN
- WRITE (FILE_CHR,CHR,TWO_CHR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "CHARACTER - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_CHR) /= TWO_CHR THEN
- FAILED ("SIZE FOR TYPE CHARACTER");
- END IF;
- IF NOT END_OF_FILE (FILE_CHR) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
- "CHARACTER");
- END IF;
- SET_INDEX (FILE_CHR,ONE_CHR);
- IF INDEX (FILE_CHR) /= ONE_CHR THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE " &
- "CHARACTER");
- END IF;
- END;
-
- CLOSE (FILE_CHR);
-
- BEGIN
- OPEN (FILE_CHR, IN_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 2");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_CHR,ITEM_CHR);
- IF ITEM_CHR /= CHR THEN
- FAILED ("INCORRECT CHR VALUE READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE CHARACTER");
- END;
-
- BEGIN
- READ (FILE_CHR,ITEM_CHR,ONE_CHR);
- IF ITEM_CHR /= CHR THEN
- FAILED ("INCORRECT CHR VALUE READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE CHARACTER");
- END;
- END;
-
- BEGIN
- DELETE (FILE_CHR);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- DECLARE
- PACKAGE DIR_INT IS NEW DIRECT_IO (INTEGER);
- USE DIR_INT;
- FILE_INT : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_INT, INOUT_FILE, LEGAL_FILE_NAME(3));
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - INTEGER");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - INTEGER");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- INT : INTEGER := IDENT_INT (33);
- ITEM_INT : INTEGER;
- ONE_INT : POSITIVE_COUNT := 1;
- TWO_INT : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_INT,INT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "INTEGER - 1");
- END;
-
- BEGIN
- WRITE (FILE_INT,INT,TWO_INT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "INTEGER - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_INT) /= TWO_INT THEN
- FAILED ("SIZE FOR TYPE INTEGER");
- END IF;
- IF NOT END_OF_FILE (FILE_INT) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
- "INTEGER");
- END IF;
- SET_INDEX (FILE_INT, ONE_INT);
- IF INDEX (FILE_INT) /= ONE_INT THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE INTEGER");
- END IF;
- END;
-
- CLOSE (FILE_INT);
-
- BEGIN
- OPEN (FILE_INT, IN_FILE, LEGAL_FILE_NAME(3));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 3");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_INT,ITEM_INT);
- IF ITEM_INT /= INT THEN
- FAILED ("INCORRECT INT VALUE READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE INTEGER");
- END;
-
- BEGIN
- READ (FILE_INT,ITEM_INT,ONE_INT);
- IF ITEM_INT /= INT THEN
- FAILED ("INCORRECT INT VALUE READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE INTEGER");
- END;
- END;
-
- BEGIN
- DELETE (FILE_INT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada
deleted file mode 100644
index e527fbb..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada
+++ /dev/null
@@ -1,347 +0,0 @@
--- CE2401B.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE FOR DIRECT FILES WITH ELEMENT_TYPES BOOLEAN,
--- ACCESS, AND ENUMERATED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- ABW 08/18/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/07/87 ISOLATED EXCEPTIONS.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401B IS
- END_SUBTEST : EXCEPTION;
-BEGIN
-
- TEST ("CE2401B", "CHECK READ, WRITE, SET_INDEX " &
- "INDEX, SIZE, AND END_OF_FILE FOR " &
- "DIRECT FILES FOR BOOLEAN, ACCESS " &
- "AND ENUMERATION TYPES");
- DECLARE
- PACKAGE DIR_BOOL IS NEW DIRECT_IO (BOOLEAN);
- USE DIR_BOOL;
- FILE_BOOL : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_BOOL, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - BOOLEAN");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - BOOLEAN");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- BOOL : BOOLEAN := IDENT_BOOL (TRUE);
- ITEM_BOOL : BOOLEAN;
- ONE_BOOL : POSITIVE_COUNT := 1;
- TWO_BOOL : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_BOOL,BOOL);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "BOOLEAN - 1");
- END;
-
- BEGIN
- WRITE (FILE_BOOL,BOOL,TWO_BOOL);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "BOOLEAN - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_BOOL) /= TWO_BOOL THEN
- FAILED ("SIZE FOR TYPE BOOLEAN");
- END IF;
- IF NOT END_OF_FILE (FILE_BOOL) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "BOOLEAN");
- END IF;
- SET_INDEX (FILE_BOOL,ONE_BOOL);
- IF INDEX (FILE_BOOL) /= ONE_BOOL THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE BOOLEAN");
- END IF;
- END;
-
- CLOSE (FILE_BOOL);
-
- BEGIN
- OPEN (FILE_BOOL, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 1");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_BOOL,ITEM_BOOL);
- IF ITEM_BOOL /= BOOL THEN
- FAILED ("INCORRECT BOOLEAN VALUE READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE BOOLEAN");
- END;
-
- BEGIN
- READ (FILE_BOOL,ITEM_BOOL,ONE_BOOL);
- IF ITEM_BOOL /= BOOL THEN
- FAILED ("INCORRECT BOOLEAN VALUE READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR BOOLEAN");
- END;
- END;
-
- BEGIN
- DELETE (FILE_BOOL);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- DECLARE
- TYPE ENUMERATED IS (ONE,TWO,THREE);
- PACKAGE DIR_ENUM IS NEW DIRECT_IO (ENUMERATED);
- USE DIR_ENUM;
- FILE_ENUM : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_ENUM, INOUT_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - ENUMERATED");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - ENUMERATED");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- ENUM : ENUMERATED := (THREE);
- ITEM_ENUM : ENUMERATED;
- ONE_ENUM : POSITIVE_COUNT := 1;
- TWO_ENUM : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_ENUM,ENUM);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "ENUMERATED - 1");
- END;
-
- BEGIN
- WRITE (FILE_ENUM,ENUM,TWO_ENUM);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "ENUMERATED - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_ENUM) /= TWO_ENUM THEN
- FAILED ("SIZE FOR TYPE ENUMERATED");
- END IF;
- IF NOT END_OF_FILE (FILE_ENUM) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
- "ENUMERATED");
- END IF;
- SET_INDEX (FILE_ENUM,ONE_ENUM);
- IF INDEX (FILE_ENUM) /= ONE_ENUM THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE " &
- "ENUMERATED");
- END IF;
- END;
-
- CLOSE (FILE_ENUM);
-
- BEGIN
- OPEN (FILE_ENUM, IN_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 2");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_ENUM,ITEM_ENUM);
- IF ITEM_ENUM /= ENUM THEN
- FAILED ("INCORRECT ENUM VALUE READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR ENUMERATED");
- END;
-
- BEGIN
- READ (FILE_ENUM,ITEM_ENUM,ONE_ENUM);
- IF ITEM_ENUM /= ENUM THEN
- FAILED ("INCORRECT ENUM VALUE READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE ENUMERATED");
- END;
- END;
-
- BEGIN
- DELETE (FILE_ENUM);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- DECLARE
- TYPE ACC_INT IS ACCESS INTEGER;
- PACKAGE DIR_ACC IS NEW DIRECT_IO (ACC_INT);
- USE DIR_ACC;
- FILE_ACC : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE_ACC, INOUT_FILE, LEGAL_FILE_NAME(3));
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - ACCESS");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- ACC : ACC_INT := NEW INTEGER'(33);
- ITEM_ACC : ACC_INT;
- ONE_ACC : POSITIVE_COUNT := 1;
- TWO_ACC : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_ACC,ACC);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "ACCESS - 1");
- END;
-
- BEGIN
- WRITE (FILE_ACC,ACC,TWO_ACC);
-
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "ACCESS - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_ACC) /= TWO_ACC THEN
- FAILED ("SIZE FOR TYPE ACCESS");
- END IF;
- IF NOT END_OF_FILE (FILE_ACC) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR ACCESS");
- END IF;
- SET_INDEX (FILE_ACC,ONE_ACC);
- IF INDEX (FILE_ACC) /= ONE_ACC THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE ACCESS");
- END IF;
- END;
-
- CLOSE (FILE_ACC);
-
- BEGIN
- OPEN (FILE_ACC, IN_FILE, LEGAL_FILE_NAME(3));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE NOT " &
- "SUPPORTED - 3");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_ACC,ITEM_ACC);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR ACCESS");
- END;
-
- BEGIN
- READ (FILE_ACC,ITEM_ACC,ONE_ACC);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR ACCESS");
- END;
- END;
-
- BEGIN
- DELETE (FILE_ACC);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada
deleted file mode 100644
index d793104..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada
+++ /dev/null
@@ -1,268 +0,0 @@
--- CE2401C.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE ARE IMPLEMENTED FOR DIRECT FILES WITH
--- ELEMENT_TYPE CONSTRAINED ARRAY, AND RECORD WITHOUT DISCRIMINANTS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- ABW 08/18/82
--- SPS 09/20/82
--- SPS 11/09/82
--- JBG 05/02/83
--- JRK 03/26/84
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/10/87 ISOLATED EXCEPTIONS.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401C IS
- END_SUBTEST: EXCEPTION;
-BEGIN
-
- TEST ("CE2401C" , "CHECK READ, WRITE, SET_INDEX " &
- "INDEX, SIZE, AND END_OF_FILE FOR " &
- "DIRECT FILES FOR CONSTRAINED ARRAY TYPES, " &
- "AND RECORD TYPES WITHOUT DISCRIMINANTS");
-
- DECLARE
- TYPE ARR_CN IS ARRAY (1..5) OF BOOLEAN;
- PACKAGE DIR_ARR_CN IS NEW DIRECT_IO (ARR_CN);
- USE DIR_ARR_CN;
- FILE : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - CONSTRAINED ARRAY");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - CONSTRAINED ARRAY");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- ARR : ARR_CN := (TRUE,TRUE,FALSE,TRUE,TRUE);
- ITEM : ARR_CN;
- ONE : POSITIVE_COUNT := 1;
- TWO : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE,ARR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "CONTRAINED ARRAY - 1");
- END;
-
- BEGIN
- WRITE (FILE,ARR,TWO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "CONSTRAINED ARRAY - 2");
- END;
-
- BEGIN
- IF SIZE (FILE) /= TWO THEN
- FAILED ("SIZE FOR TYPE CONSTRAINED ARRAY");
- END IF;
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
- "CONSTRAINED ARRAY");
- END IF;
- SET_INDEX (FILE,ONE);
- IF INDEX (FILE) /= ONE THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE " &
- "CONSTRAINED ARRAY");
- END IF;
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 1");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE,ITEM);
- IF ITEM /= ARR THEN
- FAILED ("INCORRECT ARRAY VALUES READ " &
- "- 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE CONSTRAINED ARRAY");
- END;
-
- BEGIN
- READ (FILE,ITEM,ONE);
- IF ITEM /= ARR THEN
- FAILED ("INCORRECT ARRAY VALUES READ " &
- "- 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE CONSTRAINED ARRAY");
- END;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- DECLARE
- TYPE REC IS
- RECORD
- ONE : INTEGER;
- TWO : INTEGER;
- END RECORD;
- PACKAGE DIR_REC IS NEW DIRECT_IO (REC);
- USE DIR_REC;
- FILE : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - RECORD");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON CREATE - " &
- "RECORD");
- END;
-
- DECLARE
- REC1 : REC := REC'(ONE=>18,TWO=>36);
- ITEM : REC;
- ONE : POSITIVE_COUNT := 1;
- TWO : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE,REC1);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR - " &
- "RECORD - 1");
- END;
-
- BEGIN
- WRITE (FILE,REC1,TWO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR - " &
- "RECORD - 2");
- END;
-
- BEGIN
- IF SIZE (FILE) /= TWO THEN
- FAILED ("SIZE FOR TYPE RECORD");
- END IF;
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR RECORD");
- END IF;
- SET_INDEX (FILE,ONE);
- IF INDEX (FILE) /= ONE THEN
- FAILED ("WRONG INDEX VALUE FOR TYPE RECORD");
- END IF;
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED - 2");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE,ITEM);
- IF ITEM /= REC1 THEN
- FAILED ("INCORRECT RECORD VALUES READ " &
- "- 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR RECORD");
- END;
-
- BEGIN
- READ (FILE,ITEM,ONE);
- IF ITEM /= REC1 THEN
- FAILED ("INCORRECT RECORD VALUES READ " &
- "- 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE RECORD");
- END;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada
deleted file mode 100644
index a9b050d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada
+++ /dev/null
@@ -1,172 +0,0 @@
--- CE2401E.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE
--- FLOATING POINT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY FOR IMPLEMENTATIONS WHICH SUPPORT CREATION OF
--- DIRECT FILES WITH INOUT_FILE MODE AND OPENING OF DIRECT FILES
--- WITH IN_FILE MODE.
-
--- HISTORY:
--- ABW 08/18/82
--- SPS 09/15/82
--- SPS 11/11/82
--- JBG 05/02/83
--- EG 11/19/85 HANDLE IMPLEMENTATIONS WITH
--- POSITIVE_COUNT'LAST=1.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/10/87 ISOLATED EXCEPTIONS. SPLIT FIXED POINT TESTS
--- INTO CE2401I.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401E IS
-
- END_SUBTEST : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2401E", "CHECK THAT READ, WRITE, SET_INDEX, " &
- "INDEX, SIZE, AND END_OF_FILE ARE " &
- "SUPPORTED FOR DIRECT FILES WITH " &
- "ELEMENT_TYPE FLOAT");
-
- DECLARE
-
- PACKAGE DIR_FLT IS NEW DIRECT_IO (FLOAT);
- USE DIR_FLT;
- FILE_FLT : FILE_TYPE;
-
- BEGIN
- BEGIN
- CREATE (FILE_FLT, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - FLOAT");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - FLOAT");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- FLT : FLOAT := 65.0;
- ITEM_FLT : FLOAT;
- ONE_FLT : POSITIVE_COUNT := 1;
- TWO_FLT : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE_FLT, FLT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "FLOATING POINT - 1");
- END;
-
- BEGIN
- WRITE (FILE_FLT, FLT, TWO_FLT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "FLOATING POINT - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_FLT) /= TWO_FLT THEN
- FAILED ("SIZE FOR FLOATING POINT");
- END IF;
-
- IF NOT END_OF_FILE (FILE_FLT) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "FLOATING POINT");
- END IF;
-
- SET_INDEX (FILE_FLT, ONE_FLT);
- IF INDEX (FILE_FLT) /= ONE_FLT THEN
- FAILED ("WRONG INDEX VALUE FOR " &
- "FLOATING POINT");
- END IF;
- END;
-
- CLOSE (FILE_FLT);
-
- BEGIN
- OPEN (FILE_FLT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE " &
- "MODE NOT SUPPORTED");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_FLT, ITEM_FLT);
- IF ITEM_FLT /= FLT THEN
- FAILED ("WRONG VALUE READ FOR " &
- "FLOATING POINT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE FLOATING POINT");
- END;
-
- BEGIN
- READ (FILE_FLT, ITEM_FLT, ONE_FLT);
- IF ITEM_FLT /= FLT THEN
- FAILED ("WRONG VALUE READ WITH INDEX FOR " &
- "FLOATING POINT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE FLOATING POINT");
- END;
-
- BEGIN
- DELETE (FILE_FLT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
-
- RESULT;
-
-END CE2401E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada
deleted file mode 100644
index 30b69c99..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada
+++ /dev/null
@@ -1,200 +0,0 @@
--- CE2401F.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE
--- PRIVATE.
-
--- APPLICABILITY CRITERIA:
---
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR
--- DIRECT FILES.
-
--- HISTORY:
--- ABW 08/18/82
--- SPS 09/15/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGE TO .ADA TEST
--- EG 11/19/85 CORRECT SO TEST CAN HANDLE IMPLEMENTATION WITH
--- POSITIVE_COUNT'LAST=1; COVER POSSIBILITY OF CREATE
--- RAISING USE_ERROR; ENSURE RESET DOESN'T RAISE
--- EXCEPTION IF CREATE FAILS; CHECK THAT WE CAN READ
--- DATA THAT HAS BEEN WRITTEN.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/11/87 ISOLATED EXCEPTIONS.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401F IS
-
- END_SUBTEST : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2401F", "CHECK THAT READ, WRITE, SET_INDEX, " &
- "INDEX, SIZE, AND END_OF_FILE ARE " &
- "SUPPORTED FOR DIRECT FILES WITH " &
- "ELEMENT_TYPE PRIVATE");
-
- DECLARE
-
- PACKAGE PKG IS
- TYPE PRIV IS PRIVATE;
- FUNCTION ASSIGN RETURN PRIV;
- PRIVATE
- TYPE PRIV IS NEW INTEGER;
- END PKG;
-
- USE PKG;
-
- PACKAGE DIR_PRV IS NEW DIRECT_IO (PRIV);
- USE DIR_PRV;
- FILE_PRV : FILE_TYPE;
-
- PACKAGE BODY PKG IS
- FUNCTION ASSIGN RETURN PRIV IS
- BEGIN
- RETURN (16);
- END;
- BEGIN
- NULL;
- END PKG;
-
- BEGIN
- BEGIN
- CREATE (FILE_PRV, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - PRIVATE");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - PRIVATE");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
-
- DECLARE
-
- PRV, ITEM_PRV : PRIV;
- ONE_PRV : POSITIVE_COUNT := 1;
- TWO_PRV : POSITIVE_COUNT := 2;
-
- BEGIN
-
- PRV := ASSIGN;
-
- BEGIN
- WRITE (FILE_PRV, PRV);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "PRIVATE - 1");
- END;
-
- BEGIN
- WRITE (FILE_PRV, PRV, TWO_PRV);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "PRIVATE - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_PRV) /= TWO_PRV THEN
- FAILED ("SIZE FOR TYPE PRIVATE");
- END IF;
- IF NOT END_OF_FILE (FILE_PRV) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "PRIVATE TYPE");
- END IF;
-
- SET_INDEX (FILE_PRV, ONE_PRV);
-
- IF INDEX (FILE_PRV) /= ONE_PRV THEN
- FAILED ("WRONG INDEX VALUE FOR PRIVATE " &
- "TYPE");
- END IF;
- END;
-
- CLOSE (FILE_PRV);
-
- BEGIN
- OPEN (FILE_PRV, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE NOT " &
- "SUPPORTED");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_PRV, ITEM_PRV);
- IF ITEM_PRV /= PRV THEN
- FAILED ("INCORRECT PRIVATE TYPE VALUE " &
- "READ - 1");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "PRIVATE TYPE");
- END;
-
- BEGIN
- READ (FILE_PRV, ITEM_PRV, ONE_PRV);
- IF ITEM_PRV /= PRV THEN
- FAILED ("INCORRECT PRIVATE TYPE VALUE " &
- "READ - 2");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "PRIVATE TYPE");
- END;
- END;
-
- BEGIN
- DELETE (FILE_PRV);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada
deleted file mode 100644
index 70ce088..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- CE2401H.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 READ, WRITE, SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH
--- ELEMENT_TYPE UNCONSTRAINED RECORDS WITH DEFAULT DISCRIMINANTS.
-
--- THIS INSTANTIATION IS ALWAYS LEGAL BY AI-00037.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR
--- DIRECT FILES.
-
--- HISTORY:
--- TBN 05/15/86
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/10/87 ISOLATED EXCEPTIONS.
-
-WITH REPORT;
-USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401H IS
-
- END_SUBTEST : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2401H", "CHECK THAT READ, WRITE, SET_INDEX, INDEX, " &
- "SIZE, AND END_OF_FILE ARE SUPPORTED FOR " &
- "DIRECT FILES WITH ELEMENT_TYPE UNCONSTRAINED " &
- "RECORDS WITH DEFAULT DISCRIMINANTS");
-
- DECLARE
- TYPE REC_DEF (DISCR : INTEGER := 1) IS
- RECORD
- ONE : INTEGER := DISCR;
- TWO : INTEGER := 3;
- THREE : INTEGER := 5;
- FOUR : INTEGER := 7;
- END RECORD;
- PACKAGE DIR_REC_DEF IS NEW DIRECT_IO (REC_DEF);
- USE DIR_REC_DEF;
- FILE1 : FILE_TYPE;
- REC : REC_DEF;
- ITEM : REC_DEF;
- ONE : POSITIVE_COUNT := 1;
- TWO : POSITIVE_COUNT := 2;
-
- BEGIN
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " &
- "NOT SUPPORTED FOR " &
- "UNCONSTRAINED RECORDS WITH " &
- "DEFAULT DISCRIMINATES");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON DIRECT " &
- "CREATE");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- WRITE (FILE1, REC);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "RECORD WITH DEFAULT - 1");
- END;
-
- BEGIN
- WRITE (FILE1, REC, TWO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "RECORD WITH DEFAULT - 2");
- END;
-
- BEGIN
- IF SIZE (FILE1) /= TWO THEN
- FAILED ("SIZE FOR RECORD WITH DEFAULT");
- END IF;
- IF NOT END_OF_FILE (FILE1) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " &
- "RECORD WITH DEFAULT");
- END IF;
- SET_INDEX (FILE1, ONE);
- IF INDEX (FILE1) /= ONE THEN
- FAILED ("WRONG INDEX VALUE FOR RECORD" &
- "WITH DEFAULT");
- END IF;
- END;
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE NOT SUPPORTED");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE1, ITEM);
- IF ITEM /= (1,1,3,5,7) THEN
- FAILED ("WRONG VALUE READ");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR " &
- "TYPE RECORD WITH DEFAULT");
- END;
-
- BEGIN
- ITEM := (OTHERS => 0);
- READ (FILE1, ITEM, ONE);
- IF ITEM /= (1,1,3,5,7) THEN
- FAILED ("WRONG VALUE READ");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR " &
- "TYPE RECORD WITH DEFAULT");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada
deleted file mode 100644
index 68f2ba4..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- CE2401I.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 READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH
--- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND
--- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE
--- FIXED POINT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY FOR IMPLEMENTATIONS WHICH SUPPORT CREATION OF
--- DIRECT FILES WITH INOUT_FILE MODE AND OPENING OF DIRECT FILES
--- WITH IN_FILE MODE.
-
--- HISTORY:
--- DWC 08/10/87 CREATED ORIGINAL VERSION.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401I IS
-
- END_SUBTEST : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2401I", "CHECK THAT READ, WRITE, SET_INDEX, " &
- "INDEX, SIZE, AND END_OF_FILE ARE " &
- "SUPPORTED FOR DIRECT FILES WITH " &
- "ELEMENT_TYPE FIXED");
-
- DECLARE
-
- TYPE FIX_TYPE IS DELTA 0.5 RANGE 0.0 .. 255.0;
- PACKAGE DIR_FIX IS NEW DIRECT_IO (FIX_TYPE);
- USE DIR_FIX;
- FILE_FIX : FILE_TYPE;
-
- BEGIN
- BEGIN
- CREATE (FILE_FIX, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " &
- "ON CREATE - FIXED POINT");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE - FIXED POINT");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- FIX : FIX_TYPE := 16.0;
- ITEM_FIX : FIX_TYPE;
- ONE_FIX : POSITIVE_COUNT := 1;
- TWO_FIX : POSITIVE_COUNT := 2;
-
- BEGIN
- BEGIN
- WRITE (FILE_FIX, FIX);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "FIXED POINT - 1");
- END;
-
- BEGIN
- WRITE (FILE_FIX, FIX, TWO_FIX);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE FOR " &
- "FIXED POINT - 2");
- END;
-
- BEGIN
- IF SIZE (FILE_FIX) /= TWO_FIX THEN
- FAILED ("SIZE FOR TYPE FIXED POINT");
- END IF;
-
- IF NOT END_OF_FILE (FILE_FIX) THEN
- FAILED ("WRONG END_OF_FILE VALUE FOR " &
- "FIXED POINT");
- END IF;
-
- SET_INDEX (FILE_FIX, ONE_FIX);
-
- IF INDEX (FILE_FIX) /= ONE_FIX THEN
- FAILED ("WRONG INDEX VALUE FOR FIXED " &
- "POINT");
- END IF;
- END;
-
- CLOSE (FILE_FIX);
-
- BEGIN
- OPEN (FILE_FIX, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " &
- "NOT SUPPORTED");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE_FIX, ITEM_FIX);
- IF ITEM_FIX /= FIX THEN
- FAILED ("WRONG VALUE READ FOR FIXED POINT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITHOUT FROM FOR FIXED " &
- "POINT");
- END;
-
- BEGIN
- READ (FILE_FIX, ITEM_FIX, ONE_FIX);
- IF ITEM_FIX /= FIX THEN
- FAILED ("WRONG VALUE READ WITH INDEX " &
- "FOR FIXED POINT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ WITH FROM FOR FIXED POINT");
- END;
-
- BEGIN
- DELETE (FILE_FIX);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada
deleted file mode 100644
index 85e43cc..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada
+++ /dev/null
@@ -1,176 +0,0 @@
--- CE2401J.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 DATA WRITTEN INTO A DIRECT FILE CAN BE READ
--- CORRECTLY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR
--- DIRECT FILES.
-
--- HISTORY:
--- DWC 08/12/87 CREATE ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401J IS
- END_SUBTEST: EXCEPTION;
-BEGIN
-
- TEST ("CE2401J" , "CHECK THAT DATA WRITTEN INTO A DIRECT FILE " &
- "CAN BE READ CORRECTLY");
-
- DECLARE
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- FILE : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH INOUT FILE NOT " &
- "SUPPORTED");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- OUT_ITEM1 : INTEGER := 10;
- OUT_ITEM2 : INTEGER := 21;
- OUT_ITEM3 : INTEGER := 32;
- IN_ITEM : INTEGER;
- ONE : POSITIVE_COUNT := 1;
- THREE : POSITIVE_COUNT := 3;
- FIVE : POSITIVE_COUNT := 5;
- BEGIN
- BEGIN
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM2, THREE);
- BEGIN
- READ (FILE, IN_ITEM, ONE);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE " &
- "READ - 1");
- END IF;
- END;
- WRITE (FILE, OUT_ITEM3, FIVE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, THREE);
- IF OUT_ITEM2 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 2");
- END IF;
- END;
-
- BEGIN
- RESET (FILE);
- READ (FILE, IN_ITEM);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 3");
- END IF;
- EXCEPTION
- WHEN USE_ERROR => NULL;
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE, IN_ITEM);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 4");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ IN IN_FILE MODE - 1");
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, ONE);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 5");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ IN IN_FILE MODE - 2");
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, FIVE);
- IF OUT_ITEM3 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 6");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ IN IN_FILE MODE - 3");
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, THREE);
- IF OUT_ITEM2 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 7");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("READ IN IN_FILE MODE - 4");
- END;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401J;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada
deleted file mode 100644
index 2e00f66..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CE2401K.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 DATA CAN BE OVERWRITTEN IN THE DIRECT FILE AND
--- THE CORRECT VALUES CAN LATER BE READ.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF INOUT_FILE MODE AND OPENING OF OUT_FILE MODE FOR
--- DIRECT FILES.
-
--- HISTORY:
--- DWC 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401K IS
- END_SUBTEST: EXCEPTION;
-BEGIN
-
- TEST ("CE2401K" , "CHECK THAT DATA CAN BE OVERWRITTEN IN " &
- "THE DIRECT FILE AND THE CORRECT VALUES " &
- "CAN LATER BE READ.");
-
- DECLARE
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- FILE : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " &
- "NOT SUPPORTED");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- OUT_ITEM1 : INTEGER := 10;
- OUT_ITEM2 : INTEGER := 21;
- IN_ITEM : INTEGER;
- ONE : POSITIVE_COUNT := 1;
- TWO : POSITIVE_COUNT := 2;
- BEGIN
- BEGIN
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM2, TWO);
- WRITE (FILE, OUT_ITEM2, ONE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE " &
- "IN INOUT_FILE MODE");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, ONE);
- IF OUT_ITEM2 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 1");
- RAISE END_SUBTEST;
- END IF;
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, TWO);
- IF OUT_ITEM2 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 2");
- RAISE END_SUBTEST;
- END IF;
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM2, TWO);
- WRITE (FILE, OUT_ITEM1, TWO);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE " &
- "IN OUT_FILE MODE");
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- RESET (FILE, IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE END_SUBTEST;
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, ONE);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 3");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("READ IN IN_FILE MODE - 1");
- END;
-
- BEGIN
- READ (FILE, IN_ITEM, TWO);
- IF OUT_ITEM1 /= IN_ITEM THEN
- FAILED ("INCORRECT INTEGER VALUE READ - 4");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("READ IN IN_FILE MODE - 2");
- END;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401K;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada b/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada
deleted file mode 100644
index 3ecba26..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- CE2401L.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 REWRITING AN ELEMENT DOES NOT CHANGE THE SIZE OF
--- THE FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- DWC 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2401L IS
- END_SUBTEST: EXCEPTION;
-BEGIN
-
- TEST ("CE2401L" , "CHECK THAT REWRITING AN ELEMENT DOES NOT " &
- "CHANGE THE SIZE OF THE FILE");
-
- DECLARE
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- FILE : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " &
- "NOT SUPPORTED");
- RAISE END_SUBTEST;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED ON " &
- "CREATE");
- RAISE END_SUBTEST;
- END;
-
- DECLARE
- OUT_ITEM1 : INTEGER := 10;
- OUT_ITEM2 : INTEGER := 21;
- OUT_ITEM4 : INTEGER := 43;
- IN_ITEM : INTEGER;
- ONE : POSITIVE_COUNT := 1;
- TWO : POSITIVE_COUNT := 2;
- FOUR : POSITIVE_COUNT := 4;
- OLD_FILE_SIZE : POSITIVE_COUNT;
- BEGIN
- BEGIN
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM4, FOUR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED ON WRITE " &
- "IN INOUT_FILE MODE");
- RAISE END_SUBTEST;
- END;
-
- OLD_FILE_SIZE := SIZE (FILE);
-
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM4, FOUR);
-
- IF OLD_FILE_SIZE /= SIZE (FILE) THEN
- FAILED ("FILE SIZE CHANGED DURING REWRITE - 1");
- RAISE END_SUBTEST;
- END IF;
-
- WRITE (FILE, OUT_ITEM1, ONE);
- WRITE (FILE, OUT_ITEM2, TWO);
- WRITE (FILE, OUT_ITEM4, FOUR);
-
- OLD_FILE_SIZE := SIZE (FILE);
-
- WRITE (FILE, OUT_ITEM1, FOUR);
-
- IF OLD_FILE_SIZE /= SIZE (FILE) THEN
- FAILED ("FILE SIZE CHANGED DURING REWRITE - 2");
- RAISE END_SUBTEST;
- END IF;
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN END_SUBTEST =>
- NULL;
- END;
-
- RESULT;
-
-END CE2401L;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada
deleted file mode 100644
index f05330a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada
+++ /dev/null
@@ -1,161 +0,0 @@
--- CE2402A.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 READ, WRITE, INDEX, SET_INDEX, SIZE, AND
--- END_OF_FILE RAISE STATUS_ERROR WHEN APPLIED TO A NON-OPEN
--- DIRECT FILE. USE_ERROR IS NOT PERMITTED.
-
--- HISTORY:
--- ABW 08/17/82
--- SPS 09/16/82
--- SPS 11/09/82
--- JBG 08/30/83
--- EG 11/26/84
--- EG 06/04/85
--- GMT 08/03/87 CLARIFIED SOME OF THE FAILED MESSAGES, AND
--- REMOVED THE EXCEPTION FOR CONSTRAINT_ERROR.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2402A IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- CNST : CONSTANT INTEGER := 101;
- IVAL : INTEGER;
- BOOL : BOOLEAN;
- X_COUNT : COUNT;
- P_COUNT : POSITIVE_COUNT;
-
-BEGIN
- TEST ("CE2402A","CHECK THAT READ, WRITE, INDEX, " &
- "SET_INDEX, SIZE, AND END_OF_FILE " &
- "RAISE STATUS_ERROR WHEN APPLIED " &
- "A NON-OPEN DIRECT FILE");
- BEGIN
- WRITE (FILE1, CNST);
- FAILED ("STATUS_ERROR WAS NOT RAISED ON WRITE - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON WRITE - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON WRITE - 3");
- END;
-
- BEGIN
- X_COUNT := SIZE (FILE1);
- FAILED ("STATUS_ERROR NOT RAISED ON SIZE - 4");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON SIZE - 5");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON SIZE - 6");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE1);
- FAILED ("STATUS_ERROR WAS NOT RAISED ON END_OF_FILE - 7");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON END_OF_FILE - 8");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON END_OF_FILE - 9");
- END;
-
- BEGIN
- P_COUNT := INDEX (FILE1);
- FAILED ("STATUS_ERROR WAS NOT RAISED ON INDEX - 10");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON INDEX - 11");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON INDEX - 12");
- END;
-
- BEGIN
- READ (FILE1, IVAL);
- FAILED ("STATUS_ERROR WAS NOT RAISED ON READ - 13");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON READ - 14");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 15");
- END;
-
- DECLARE
- ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1));
- BEGIN
- BEGIN
- WRITE (FILE1, CNST, ONE);
- FAILED ("STATUS_ERROR NOT RAISED ON WRITE - 16");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON WRITE - 17");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON WRITE - 18");
- END;
-
- BEGIN
- SET_INDEX (FILE1,ONE);
- FAILED ("STATUS_ERROR NOT RAISED ON SET_INDEX - 19");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON SET_INDEX - 20");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON SET_INDEX - 21");
- END;
-
- BEGIN
- READ (FILE1, IVAL, ONE);
- FAILED ("STATUS_ERROR WAS NOT RAISED ON READ - 22");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON READ - 23");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 24");
- END;
- END;
-
- RESULT;
-
-END CE2402A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst b/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst
deleted file mode 100644
index 0988eb2..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst
+++ /dev/null
@@ -1,121 +0,0 @@
--- CE2403A.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.
---*
--- OBJECTIVE:
--- CHECK THAT, FOR DIRECT_IO, WRITE RAISES THE EXCEPTION
--- USE_ERROR IF THE CAPACITY OF THE EXTERNAL FILE IS EXCEEDED.
--- THIS TEST ONLY CHECKS THAT THE IMPLEMENTATION SUPPORTS AN
--- EXTERNAL FILE CAPACITY OF 4096 CHARACTERS OR LESS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES. ALSO, THE IMPLEMENTATION MUST BE ABLE TO
--- RESTRICT THE CAPACITY OF AN EXTERNAL FILE.
-
--- $FORM_STRING2 IS DEFINED SUCH THAT THE CAPACITY OF THE FILE IS
--- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION
--- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL
--- "CANNOT_RESTRICT_FILE_CAPACITY".
-
--- HISTORY:
--- JLH 07/12/88 CREATED ORIGINAL TEST.
--- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2403A IS
-
- SUBTYPE STR512 IS STRING (1 .. 512);
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (STR512);
- USE DIR_IO;
-
- FILE : FILE_TYPE;
- ITEM : STR512 := (1 .. 512 => 'A');
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2403A", "CHECK FOR DIRECT_IO THAT WRITE RAISES " &
- "USE_ERROR IF THE CAPACITY OF THE EXTERNAL " &
- "FILE IS EXCEEDED");
-
- BEGIN
-
- IF
-$FORM_STRING2
- = STRING'("CANNOT_RESTRICT_FILE_CAPACITY") THEN
- NOT_APPLICABLE ("IMPLEMENTATION CANNOT RESTRICT FILE " &
- "CAPACITY");
- RAISE INCOMPLETE;
- ELSE
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME,
-
-$FORM_STRING2
-);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON " &
- "CREATE WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
- END IF;
-
- BEGIN
- FOR I IN 1 .. 9 LOOP
- WRITE (FILE, ITEM);
- END LOOP;
- FAILED ("USE_ERROR NOT RAISED WHEN THE CAPACITY " &
- "OF THE EXTERNAL FILE IS EXCEEDED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2403A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada
deleted file mode 100644
index 11bec0f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- CE2404A.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 READ RAISES MODE_ERROR WHEN THE CURRENT MODE IS
--- OUT_FILE.
-
--- A) CHECK NON-TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF DIRECT FILES WITH MODE OUT_FILE.
-
--- HISTORY:
--- DLD 08/17/82
--- SPS 11/09/82
--- SPS 11/22/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 08/03/87 MOVED THE TEMP-FILE CASE TO CE2404B.ADA.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2404A IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
- DIR_FILE_1 : FILE_TYPE;
- I : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2404A", "CHECK THAT READ RAISES MODE_ERROR WHEN THE " &
- "CURRENT MODE IS OUT_FILE AND THE FILE IS " &
- "A NON-TEMPORARY FILE");
- BEGIN
-
- CREATE (DIR_FILE_1, OUT_FILE, LEGAL_FILE_NAME);
-
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- READ (DIR_FILE_1, I);
- FAILED ("MODE_ERROR NOT RAISED ON READ - 4");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 5");
- END;
-
- BEGIN
- DELETE (DIR_FILE_1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2404A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada
deleted file mode 100644
index 8e3d560..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- CE2404B.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 READ RAISES MODE_ERROR WHEN THE CURRENT MODE IS
--- OUT_FILE.
-
--- B) CHECK TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF DIRECT FILES WITH MODE OUT_FILE.
-
--- HISTORY:
--- GMT 08/03/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2404B IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER);
- USE DIR_IO;
- DIR_FILE_2 : FILE_TYPE;
- I : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2404B", "CHECK THAT READ RAISES MODE_ERROR WHEN THE " &
- "CURRENT MODE IS OUT_FILE AND THE FILE IS " &
- "A TEMPORARY FILE");
- BEGIN
- CREATE (DIR_FILE_2, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- READ(DIR_FILE_2, I);
- FAILED("MODE_ERROR NOT RAISED ON READ - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("WRONG EXCEPTION RAISED ON READ - 4");
- END;
-
- CLOSE (DIR_FILE_2);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2404B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada
deleted file mode 100644
index fb82242..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada
+++ /dev/null
@@ -1,157 +0,0 @@
--- CE2405B.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 READ RAISES END_ERROR WHEN THE CURRENT READ POSITION
--- IS GREATER THAN THE END POSITION. ALSO CHECK THAT END_OF_FILE
--- CORRECTLY DETECTS THE END OF A DIRECT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH INOUT_FILE MODE AND OPENING OF IN_FILE MODE.
-
--- HISTORY:
--- SPS 09/28/82
--- JBG 02/22/84 CHANGE TO .ADA TEST
--- EG 05/16/85
--- GMT 08/03/87 ADDED CODE TO CHECK THAT END_OF_FILE WORKS, AND
--- ADDED CODE TO PREVENT SOME EXCEPTION PROPAGATION.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2405B IS
-BEGIN
- TEST ("CE2405B", "CHECK THAT END_ERROR IS RAISED BY READ AT THE " &
- "END OF A FILE AND THAT END_OF_FILE CORRECTLY " &
- "DETECTS THE END OF A DIRECT_IO FILE");
- DECLARE
- PACKAGE DIR IS NEW DIRECT_IO (CHARACTER);
- USE DIR;
- FT : FILE_TYPE;
- CH : CHARACTER;
- INCOMPLETE : EXCEPTION;
- BEGIN
-
- -- CREATE AND INITIALIZE FILE
-
- BEGIN
- CREATE (FT, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("USE_ERROR | NAME_ERROR WAS " &
- "RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
-
- WRITE (FT, 'C');
- WRITE (FT, 'X');
-
- -- BEGIN TEST
-
- IF NOT END_OF_FILE (FT) THEN
- FAILED ("END_OF_FILE RETURNED INCORRECT " &
- "BOOLEAN VALUE - 3");
- END IF;
-
- BEGIN
- READ (FT, CH);
- FAILED ("END_ERROR NOT RAISED ON READ - 4");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 5");
- END;
-
- WRITE (FT,'E');
-
- BEGIN
- READ (FT, CH);
- FAILED ("END_ERROR NOT RAISED ON READ - 6");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON READ - 7");
- END;
-
- END;
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN - 8");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON OPEN - 9");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- COUNT_NBR_OF_READS : NATURAL := 0;
- EXPECTED_COUNT : CONSTANT := 3;
- BEGIN
- LOOP
- IF END_OF_FILE (FT) THEN
- EXIT;
- ELSE
- READ (FT, CH);
- COUNT_NBR_OF_READS := COUNT_NBR_OF_READS + 1;
- END IF;
- END LOOP;
-
- IF COUNT_NBR_OF_READS /= EXPECTED_COUNT THEN
- FAILED ("THE BAD VALUE FOR COUNT_NBR_OF_READS " &
- "IS " &
- NATURAL'IMAGE (COUNT_NBR_OF_READS) );
- END IF;
-
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
-
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE2405B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada
deleted file mode 100644
index 3fbf037..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada
+++ /dev/null
@@ -1,199 +0,0 @@
--- CE2406A.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:
--- FOR A DIRECT ACCESS FILE, CHECK THAT AFTER A READ, THE CURRENT
--- READ POSITION IS INCREMENTED BY ONE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT_IO FILES.
-
--- HISTORY:
--- ABW 08/20/82
--- SPS 09/16/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGE TO .ADA TEST.
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 08/05/87 REMOVED DEPENDENCE ON RESET AND ADDED CHECK FOR
--- USE_ERROR ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2406A IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INT : INTEGER := IDENT_INT (18);
- BOOL : BOOLEAN := IDENT_BOOL (TRUE);
- INT_ITEM1, INT_ITEM2 : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2406A", "CHECK THAT READ POSITION IS INCREMENTED " &
- "BY ONE AFTER A READ");
-
- -- CREATE AND INITIALIZE FILE1
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN NAME_ERROR | USE_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR | USE_ERROR RAISED " &
- "ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FILE1, INT);
- WRITE (FILE1, 26);
- WRITE (FILE1, 12);
- WRITE (FILE1, 19);
- WRITE (FILE1, INT);
- WRITE (FILE1, 3);
-
- -- BEGIN TEST
-
- CLOSE (FILE1);
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON" &
- "OPEN - 3");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON " &
- "OPEN - 4");
- RAISE INCOMPLETE;
- END;
-
-
- IF INDEX(FILE1) /= POSITIVE_COUNT (IDENT_INT(1)) THEN
- FAILED ("INITIAL INDEX VALUE INCORRECT - 5");
- ELSE
- READ (FILE1, INT_ITEM1);
- IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN
- FAILED ("INDEX VALUE NOT INCREMENTED - 6");
- ELSE
- IF INT_ITEM1 /= IDENT_INT(18) THEN
- FAILED ("READ INCORRECT VALUE - 7");
- END IF;
- READ (FILE1, INT_ITEM1, 4);
- IF INDEX(FILE1) /=
- POSITIVE_COUNT (IDENT_INT(5)) THEN
- FAILED ("INDEX VALUE NOT INCREMENTED " &
- "WHEN TO IS SPECIFIED - 8");
- ELSE
- IF INT_ITEM1 /= IDENT_INT(19) THEN
- FAILED ("READ INCORRECT VALUE - 9");
- END IF;
- READ (FILE1, INT_ITEM1);
- IF INDEX(FILE1) /=
- POSITIVE_COUNT(IDENT_INT(6)) THEN
- FAILED ("INDEX VALUE NOT " &
- "INCREMENTED WHEN " &
- "LAST - 10");
- ELSIF INT_ITEM1 /= IDENT_INT(18) THEN
- FAILED ("READ INCORRECT " &
- "IN_FILE VALUE - 11");
- END IF;
- END IF;
- END IF;
- END IF;
-
- CLOSE (FILE1);
- BEGIN
- OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON " &
- "OPEN - 12");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON " &
- "OPEN - 13");
- RAISE INCOMPLETE;
- END;
-
- IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(1)) THEN
- FAILED ("INITIAL INDEX VALUE INCORRECT - 14");
- ELSE
- READ (FILE1, INT_ITEM2);
- IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN
- FAILED ("INDEX VALUE NOT INCREMENTED - 15");
- ELSE
- IF INT_ITEM2 /= IDENT_INT(18) THEN
- FAILED ("READ INCORRECT VALUE - 16");
- END IF;
- READ (FILE1, INT_ITEM2, 4);
- IF INDEX (FILE1) /=
- POSITIVE_COUNT(IDENT_INT(5)) THEN
- FAILED ("INDEX VALUE NOT INCREMENTED " &
- "WHEN TO IS SPECIFIED - 17");
- ELSE
- IF INT_ITEM2 /= IDENT_INT(19) THEN
- FAILED ("INCORRECT VALUE - 18");
- END IF;
- READ (FILE1, INT_ITEM2);
- IF INDEX(FILE1) /=
- POSITIVE_COUNT(IDENT_INT(6)) THEN
- FAILED ("INDEX VALUE NOT " &
- "INCREMENTED WHEN " &
- "LAST - INOUT_FILE - 19");
- ELSIF INT_ITEM2 /= IDENT_INT(18) THEN
- FAILED ("READ INCORRECT " &
- "INOUT_FILE VALUE - 20");
- END IF;
- END IF;
- END IF;
- END IF;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE2406A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada
deleted file mode 100644
index ce55310..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- CE2407A.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 WRITE RAISES MODE_ERROR WHEN THE CURRENT MODE
--- IS IN_FILE.
-
--- 1) CHECK NON-TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE AND OPEN WITH IN_FILE MODE FOR DIRECT
--- FILES.
-
--- HISTORY:
--- ABW 08/20/82
--- SPS 09/16/82
--- SPS 11/09/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 08/06/86 REMOVED THE DEPENDENCE ON RESET AND MOVED THE CHECK
--- FOR TEMPORARY FILES INTO CE2407B.ADA.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2407A IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- INCOMPLETE : EXCEPTION;
- FILE1 : FILE_TYPE;
- INT : INTEGER := IDENT_INT (18);
-
-BEGIN
- TEST ("CE2407A", "CHECK THAT WRITE RAISES MODE_ERROR WHEN THE " &
- "CURRENT MODE IS IN_FILE AND THE FILE IS " &
- "A NON-TEMPORARY FILE");
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE1, INT);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE("USE_ERROR RAISED ON OPEN - 4");
- RAISE INCOMPLETE;
- END;
-
-
-
- BEGIN
- WRITE (FILE1,INT);
- FAILED ("MODE_ERROR NOT RAISED ON WRITE - 5");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED ON WRITE - 6");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2407A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada
deleted file mode 100644
index b97b761..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada
+++ /dev/null
@@ -1,93 +0,0 @@
--- CE2407B.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 WRITE RAISES MODE_ERROR WHEN THE CURRENT MODE
--- IS IN_FILE.
-
--- 2) CHECK TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE AND RESET FROM OUT_FILE MODE TO
--- IN_FILE MODE.
-
--- HISTORY:
--- GMT 08/06/86 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2407B IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- INCOMPLETE : EXCEPTION;
- FILE2 : FILE_TYPE;
- INT : INTEGER := IDENT_INT (18);
-
-BEGIN
- TEST ("CE2407B", "CHECK THAT WRITE RAISES MODE_ERROR WHEN THE " &
- "CURRENT MODE IS IN_FILE AND THE FILE IS " &
- "A TEMPORARY FILE");
- BEGIN
- CREATE (FILE2, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- WRITE (FILE2, INT);
-
- BEGIN
- RESET (FILE2, IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE("USE_ERROR RAISED ON RESET - 3");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- WRITE (FILE2, INT);
- FAILED ("MODE_ERROR NOT RAISED ON WRITE - 4");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED ON WRITE - 5");
- END;
-
- CLOSE (FILE2);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2407B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada
deleted file mode 100644
index a6cf7d3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- CE2408A.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 WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE TO
--- PARAMETER IS GREATER THAN THE END POSITION.
-
--- 1) FILE MODE IS OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF DIRECT FILES WITH MODE OUT_FILE.
-
--- HISTORY:
--- DLD 08/19/82
--- SPS 11/09/82
--- EG 05/16/85
--- GMT 08/05/87 ADDED A CHECK FOR USE_ERROR ON DELETE AND REMOVED
--- THE OTHERS EXCEPTION AT THE BOTTOM OF THE FILE.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2408A IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
-
- DIR_FILE : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2408A", "FOR FILES OF MODE OUT_FILE, CHECK THAT " &
- "WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE " &
- """TO"" PARAMETER IS GREATER THAN THE END " &
- "POSITION");
-
- -- CREATE TEST FILE
-
- BEGIN
- CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH MODE " &
- "OUT_FILE FOR DIR_IO - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "MODE OUT_FILE FOR DIR_IO - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE WITH " &
- "MODE OUT_FILE FOR DIR_IO - 3");
- RAISE INCOMPLETE;
- END;
-
- -- FILL UP FILE
-
- WRITE (DIR_FILE, 3);
- WRITE (DIR_FILE, 4);
- WRITE (DIR_FILE, 5);
- WRITE (DIR_FILE, 6);
-
- -- WRITE WHERE TO IS LARGER THAN END OF FILE
-
- BEGIN
- WRITE (DIR_FILE, 9, 7);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRITE RAISED EXCEPTION WHEN TO " &
- "PARAMETER WAS BEYOND END - 4");
- END;
-
- BEGIN
- SET_INDEX (DIR_FILE, 11);
- WRITE (DIR_FILE, 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("SET_INDEX/WRITE RAISED EXCEPTION WHEN TO " &
- "PARAMETER EXCEEDS THE END POSITION - 5");
- END;
-
- -- DELETE TEST FILE
-
- BEGIN
- DELETE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2408A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada
deleted file mode 100644
index 7c2da6b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE2408B.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 WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE TO
--- PARAMETER IS GREATER THAN THE END POSITION.
-
--- 2) FILE MODE IS INOUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF DIRECT FILES WITH MODE INOUT_FILE.
-
--- HISTORY:
--- GMT 08/05/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2408B IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
-
- DIR_FILE : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2408B", "FOR FILES OF MODE INOUT_FILE, CHECK THAT " &
- "WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE " &
- """TO"" PARAMETER IS GREATER THAN THE END " &
- "POSITION");
- BEGIN
- CREATE (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "MODE INOUT_FILE FOR DIR_IO - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "MODE INOUT_FILE FOR DIR_IO - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE WITH " &
- "MODE INOUT_FILE FOR DIR_IO - 3");
- RAISE INCOMPLETE;
- END;
-
- -- FILL UP FILE
-
- WRITE (DIR_FILE, 3);
- WRITE (DIR_FILE, 4);
- WRITE (DIR_FILE, 5);
- WRITE (DIR_FILE, 6);
-
- -- WRITE WHERE TO IS LARGER THAN END OF FILE
-
- BEGIN
- WRITE (DIR_FILE, 9, 7);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("WRITE RAISED EXCEPTION WHEN TO " &
- "PARAMETER WAS BEYOND END - 4");
- END;
-
- BEGIN
- SET_INDEX (DIR_FILE, 11);
- WRITE (DIR_FILE, 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("SET_INDEX/WRITE RAISED EXCEPTION WHEN TO " &
- "PARAMETER EXCEEDS THE END POSITION - 5");
- END;
-
- -- DELETE TEST FILE
-
- BEGIN
- DELETE (DIR_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2408B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada
deleted file mode 100644
index e6e591f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada
+++ /dev/null
@@ -1,113 +0,0 @@
--- CE2409A.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:
--- FOR DIRECT ACCESS FILES, CHECK THAT A WRITE TO A POSITION
--- GREATER THAN THE CURRENT END POSITION CAUSES THE WRITE
--- POSITION AND THE FILE SIZE TO BE INCREMENTED.
-
--- 1) CHECK FILES OF MODE INOUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- ABW 08/27/82
--- SPS 11/09/82
--- SPS 03/18/83
--- EG 05/16/85
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 08/05/87 REVISED EXCEPTION HANDLING, ADDED CHECK FOR WRITE
--- USING TO, AND MOVED OUT_FILE CASE TO CE2409B.ADA.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2409A IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2409A", "CHECK THAT WRITE POSITION AND " &
- "SIZE ARE INCREMENTED CORRECTLY FOR " &
- "DIR FILES OF MODE INOUT_FILE");
-
- BEGIN
- CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE NOT " &
- "SUPPORTED FOR DIR FILES - 1");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- INT : INTEGER := IDENT_INT (18);
- TWO_C : COUNT := COUNT (IDENT_INT(2));
- THREE_PC : POSITIVE_COUNT
- := POSITIVE_COUNT (IDENT_INT(3));
- FIVE_C : COUNT := COUNT (IDENT_INT(5));
- FIVE_PC : POSITIVE_COUNT
- := POSITIVE_COUNT (IDENT_INT(5));
- SIX_PC : POSITIVE_COUNT
- := POSITIVE_COUNT (IDENT_INT(6));
- BEGIN
- WRITE (FILE1, INT);
- WRITE (FILE1, INT);
- IF INDEX (FILE1) /= THREE_PC THEN
- FAILED ("INCORRECT INDEX VALUE - 1");
- END IF;
- IF SIZE (FILE1) /= TWO_C THEN
- FAILED ("INCORRECT SIZE VALUE - 2");
- END IF;
-
- WRITE (FILE1, INT, FIVE_PC);
- IF INDEX (FILE1) /= SIX_PC THEN
- FAILED ("INCORRECT INDEX VALUE - 3");
- END IF;
- IF SIZE (FILE1) /= FIVE_C THEN
- FAILED ("INCORRECT SIZE VALUE - 4");
- END IF;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT ;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2409A ;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada
deleted file mode 100644
index 5448198..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE2409B.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:
--- FOR DIRECT ACCESS FILES, CHECK THAT A WRITE TO A POSITION
--- GREATER THAN THE CURRENT END POSITION CAUSES THE WRITE
--- POSITION AND THE FILE SIZE TO BE INCREMENTED.
-
--- 2) CHECK FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH MODE OUT_FILE FOR DIRECT FILES.
-
--- HISTORY:
--- GMT 08/05/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2409B IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2409B", "CHECK THAT WRITE POSITION AND " &
- "SIZE ARE INCREMENTED APPROPRIATELY");
- BEGIN
- CREATE (FILE1, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE NOT " &
- "SUPPORTED FOR DIR FILES - 1");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- INT : INTEGER := IDENT_INT (18);
- TWO_C : COUNT := COUNT (IDENT_INT(2));
- THREE_C : COUNT := COUNT (IDENT_INT(3));
- THREE_PC : POSITIVE_COUNT
- := POSITIVE_COUNT (IDENT_INT(3));
- FOUR_PC : POSITIVE_COUNT
- := POSITIVE_COUNT (IDENT_INT(4));
- BEGIN
- WRITE (FILE1, INT);
- WRITE (FILE1, INT);
- IF INDEX (FILE1) /= THREE_PC THEN
- FAILED ("INCORRECT VALUE FOR INDEX - 2");
- END IF;
- IF SIZE (FILE1) /= TWO_C THEN
- FAILED ("INCORRECT VALUE FOR SIZE - 3");
- END IF;
-
- WRITE (FILE1, INT);
- IF INDEX (FILE1) /= FOUR_PC THEN
- FAILED ("INCORRECT VALUE FOR INDEX - 4");
- END IF;
- IF SIZE (FILE1) /= THREE_C THEN
- FAILED ("INCORRECT VALUE FOR SIZE - 5");
- END IF;
-
- END;
-
- CLOSE (FILE1);
-
- RESULT ;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2409B ;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada
deleted file mode 100644
index 5029d1e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada
+++ /dev/null
@@ -1,96 +0,0 @@
--- CE2410A.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 END_OF_FILE RAISES MODE_ERROR WHEN THE CURRENT
--- MODE IS OUT_FILE.
-
--- 1) CHECK NON-TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- ABW 08/20/82
--- SPS 09/16/82
--- SPS 11/09/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- EG 11/02/84
--- EG 05/16/85
--- GMT 08/05/87 REVISED EXCEPTION HANDLING AND MOVED THE CASE FOR
--- TEMPORARY FILES INTO CE2410B.ADA.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2410A IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INT : INTEGER := IDENT_INT (18);
- BOOL : BOOLEAN;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2410A", "CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN " &
- "THE CURRENT MODE IS OUT_FILE AND THE FILE IS " &
- "A NON-TEMPORARY FILE.");
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE NOT " &
- "SUPPORTED FOR DIRECT FILES - 1");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE1);
- FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 2");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON " &
- "END_OF_FILE - 3");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT ;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2410A ;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada b/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada
deleted file mode 100644
index 665bc8e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CE2410B.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 END_OF_FILE RAISES MODE_ERROR WHEN THE CURRENT
--- MODE IS OUT_FILE.
-
--- 2) CHECK TEMPORARY FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR DIRECT FILES.
-
--- HISTORY:
--- GMT 08/05/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH DIRECT_IO;
-
-PROCEDURE CE2410B IS
-
- PACKAGE DIR IS NEW DIRECT_IO (INTEGER);
- USE DIR;
- FILE1 : FILE_TYPE;
- INT : INTEGER := IDENT_INT (18);
- BOOL : BOOLEAN;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE2410B", "CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN " &
- "THE CURRENT MODE IS OUT_FILE AND THE FILE IS " &
- "A TEMPORARY FILE.");
-
- BEGIN
- CREATE (FILE1, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE NOT " &
- "SUPPORTED FOR DIRECT FILES - 1");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE1);
- FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 2");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED ON " &
- "END_OF_FILE - 3");
- END;
-
- CLOSE (FILE1);
-
- RESULT ;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE2410B ;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada b/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada
deleted file mode 100644
index 9f735df..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada
+++ /dev/null
@@ -1,207 +0,0 @@
--- CE2411A.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 INDEX RETURNS THE CORRECT INDEX POSITION AND THAT
--- SET_INDEX CORRECTLY SETS THE INDEX POSITION IN A DIRECT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- DIRECT FILES.
-
--- HISTORY:
--- TBN 10/01/86
--- JLH 08/07/87 REVISED EXTERNAL FILE NAME, REMOVED CHECK FOR
--- NAME_ERROR ON OPEN CALLS, AND REMOVED
--- UNNECESSARY CODE.
-
-WITH DIRECT_IO;
-WITH REPORT; USE REPORT;
-PROCEDURE CE2411A IS
-
- PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER);
- USE DIR_IO;
-
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE2411A", "CHECK THAT INDEX RETURNS THE CORRECT INDEX " &
- "POSITION AND THAT SET_INDEX CORRECTLY SETS " &
- "THE INDEX POSITION IN A DIRECT FILE");
-
-
- -- INITIALIZE TEST FILE
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED DURING CREATE " &
- "WITH OUT_FILE MODE FOR DIR_IO");
- RAISE INCOMPLETE;
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED DURING CREATE " &
- "WITH OUT_FILE MODE FOR DIR_IO");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED DURING CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- IF INDEX (FILE1) /= 1 THEN
- FAILED ("STARTING INDEX POSITION IS INCORRECT - 1");
- RAISE INCOMPLETE;
- END IF;
- FOR I IN 1 .. 10 LOOP
- WRITE (FILE1, I);
- END LOOP;
- IF INDEX (FILE1) /= 11 THEN
- FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 2");
- END IF;
- WRITE (FILE1, 20, 20);
- IF INDEX (FILE1) /= 21 THEN
- FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 3");
- END IF;
- SET_INDEX (FILE1, 11);
- IF INDEX (FILE1) /= 11 THEN
- FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - 4");
- END IF;
- WRITE (FILE1, 11);
- IF INDEX (FILE1) /= 12 THEN
- FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 5");
- END IF;
- END;
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED DURING OPEN INFILE " &
- "FOR DIR_IO");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED DURING OPEN INFILE");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- NUM : INTEGER;
- BEGIN
- IF INDEX (FILE1) /= 1 THEN
- FAILED ("STARTING INDEX POSITION IS INCORRECT - 7");
- RAISE INCOMPLETE;
- END IF;
- FOR I IN 1 .. 10 LOOP
- READ (FILE1, NUM);
- IF NUM /= I THEN
- FAILED ("FILE CONTAINS INCORRECT DATA - 8");
- END IF;
- IF INDEX (FILE1) /= POSITIVE_COUNT(I + 1) THEN
- FAILED ("INDEX DOES NOT RETURN THE CORRECT " &
- "POSITION - 9");
- END IF;
- END LOOP;
- SET_INDEX (FILE1, 20);
- IF INDEX (FILE1) /= 20 THEN
- FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " &
- "10");
- END IF;
- READ (FILE1, NUM, 20);
- IF NUM /= 20 THEN
- FAILED ("FILE CONTAINS INCORRECT DATA - 11");
- END IF;
- IF INDEX (FILE1) /= 21 THEN
- FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 12");
- END IF;
- SET_INDEX (FILE1, 1);
- IF INDEX (FILE1) /= 1 THEN
- FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " &
- "13");
- END IF;
- END;
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED DURING OPEN " &
- "INOUT_FILE FOR DIR_IO");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNKNOWN EXCEPTION RAISED DURING OPEN INOUT");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- NUM : INTEGER;
- BEGIN
- IF INDEX (FILE1) /= 1 THEN
- FAILED ("STARTING INDEX POSITION IS INCORRECT - 15");
- RAISE INCOMPLETE;
- END IF;
- FOR I IN 1 .. 10 LOOP
- READ (FILE1, NUM);
- IF NUM /= I THEN
- FAILED ("FILE CONTAINS INCORRECT DATA - 16");
- END IF;
- IF INDEX (FILE1) /= POSITIVE_COUNT(I + 1) THEN
- FAILED ("INDEX DOES NOT RETURN THE CORRECT " &
- "POSITION - 17");
- END IF;
- END LOOP;
- SET_INDEX (FILE1, 20);
- IF INDEX (FILE1) /= 20 THEN
- FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " &
- "18");
- END IF;
- WRITE (FILE1, 12, 12);
- IF INDEX (FILE1) /= 13 THEN
- FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 19");
- END IF;
- SET_INDEX (FILE1, 1);
- IF INDEX (FILE1) /= 1 THEN
- FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " &
- "20");
- END IF;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE2411A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst b/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst
deleted file mode 100644
index 7dcc28f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst
+++ /dev/null
@@ -1,84 +0,0 @@
--- CE3002B.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.
---*
--- OBJECTIVE:
--- CHECK THAT COUNT IS A VISIBLE TYPE, THAT COUNT'FIRST IS 0,
--- THAT POSITIVE_COUNT IS A SUBTYPE OF COUNT, THAT
--- POSITIVE_COUNT'FIRST IS 1, THAT POSITIVE_COUNT'LAST
--- EQUALS COUNT'LAST, AND COUNT'LAST HAS A SPECIFIED
--- IMPLEMENTATION-DEPENDENT VALUE.
-
--- HISTORY:
--- SPS 09/30/82
--- SPS 11/09/82
--- JBG 03/16/83
--- JLH 08/07/87 REVISED VALUES USED IN COUNT AND POSITIVE_COUNT
--- TO THE INTEGER VALUE 1.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3002B IS
-BEGIN
-
- TEST ("CE3002B", "CHECK THAT COUNT IS VISIBLE, COUNT'FIRST IS " &
- "0, POSITIVE_COUNT IS A SUBTYPE OF COUNT, " &
- "POSITIVE_COUNT'FIRST IS 1, POSITIVE_COUNT'" &
- "LAST EQUALS COUNT'LAST, AND COUNT'LAST " &
- "HAS A SPECIFIED VALUE");
-
- DECLARE
- X : COUNT;
- A : POSITIVE_COUNT;
- BEGIN
- IF COUNT'FIRST /= COUNT(IDENT_INT (0)) THEN
- FAILED ("COUNT'FIRST NOT 0; IS" &
- COUNT'IMAGE(COUNT'FIRST));
- END IF;
-
- IF POSITIVE_COUNT'FIRST /= POSITIVE_COUNT (IDENT_INT (1)) THEN
- FAILED ("POSITIVE_COUNT'FIRST NOT 1; IS" &
- COUNT'IMAGE(POSITIVE_COUNT'FIRST));
- END IF;
-
- IF POSITIVE_COUNT'LAST /= COUNT'LAST THEN
- FAILED ("POSITIVE_COUNT'LAST NOT EQUAL COUNT'LAST");
- END IF;
-
- IF COUNT'LAST /= $COUNT_LAST THEN
- FAILED ("COUNT'LAST NOT $COUNT_LAST; IS" &
- COUNT'IMAGE(COUNT'LAST));
- END IF;
-
- X := POSITIVE_COUNT (IDENT_INT (1));
- A := X;
- A := COUNT (IDENT_INT (1));
- X := A;
- END;
-
- RESULT;
-
-END CE3002B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst b/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst
deleted file mode 100644
index c240907..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst
+++ /dev/null
@@ -1,69 +0,0 @@
--- CE3002C.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.
---*
--- OBJECTIVE:
--- CHECK THAT FIELD IS A SUBTYPE OF INTEGER, FIELD'FIRST = 0, AND
--- FIELD'LAST HAS A SPECIFIED IMPLEMENTATION-DEPENDENT VALUE.
-
--- HISTORY:
--- SPS 09/30/82
--- SPS 11/09/82
--- JBG 03/16/83
--- JLH 08/07/87 REVISED VALUES USED IN INTEGER AND FIELD TO THE
--- INTEGER VALUE 1.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3002C IS
-BEGIN
-
- TEST ("CE3002C", "CHECK THAT FIELD IS A SUBTYPE OF INTEGER AND " &
- "FIELD'FIRST = 0");
-
- DECLARE
- A : INTEGER;
- B : FIELD;
- BEGIN
- IF FIELD'FIRST /= IDENT_INT (0) THEN
- FAILED ("FIELD'FIRST NOT 0; IS" &
- FIELD'IMAGE(FIELD'FIRST));
- END IF;
-
- IF FIELD'LAST /= $FIELD_LAST THEN
- FAILED ("FIELD'LAST NOT $FIELD_LAST; IS" &
- FIELD'IMAGE(FIELD'LAST));
- END IF;
-
- A := IDENT_INT (1);
- B := A;
- B := IDENT_INT (1);
- A := B;
- END;
-
- RESULT;
-
-END CE3002C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada
deleted file mode 100644
index 3d19760..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada
+++ /dev/null
@@ -1,61 +0,0 @@
--- CE3002D.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 NUMBER_BASE IS A SUBTYPE OF INTEGER, WITH
--- NUMBER_BASE'FIRST EQUAL 2 AND NUMBER_BASE'LAST EQUAL 16.
-
--- SPS 10/1/82
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3002D IS
-BEGIN
-
- TEST ("CE3002D", "CHECK THAT NUMBER_BASE IS A SUBTYPE " &
- "OF INTEGER WITH NUMBER_BASE'FIRST = 2 " &
- "AND NUMBER_BASE'LAST = 16");
-
- DECLARE
- X : INTEGER;
- Y : NUMBER_BASE;
- BEGIN
- IF NUMBER_BASE'FIRST /= IDENT_INT (2) THEN
- FAILED ("NUMBER_BASE'FIRST NOT 2");
- END IF;
-
- IF NUMBER_BASE'LAST /= IDENT_INT (16) THEN
- FAILED ("NUMBER_BASE'LAST NOT 16");
- END IF;
-
- X := IDENT_INT (3);
- Y := X;
- Y := IDENT_INT (8);
- X := Y;
- END;
-
-RESULT;
-END CE3002D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada
deleted file mode 100644
index ad15ecd..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada
+++ /dev/null
@@ -1,55 +0,0 @@
--- CE3002F.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 UNBOUNDED HAS TYPE COUNT AND VALUE ZERO.
-
--- SPS 10/1/82
--- SPS 11/9/82
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3002F IS
-BEGIN
-
- TEST ("CE3002F", "CHECK THAT UNBOUNDED HAS TYPE COUNT AND " &
- "VALUE ZERO");
-
- DECLARE
- Z : COUNT := 0;
- BEGIN
- IF UNBOUNDED /= COUNT(IDENT_INT(0)) THEN
- FAILED ("UNBOUNDED NOT 0");
- END IF;
-
- IF UNBOUNDED /= Z THEN
- FAILED ("UNBOUNDED NOT COUNT");
- END IF;
- END;
-
- RESULT;
-
-END CE3002F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada
deleted file mode 100644
index ec5c500..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada
+++ /dev/null
@@ -1,151 +0,0 @@
--- CE3102A.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 STATUS_ERROR IS RAISED BY CREATE AND OPEN
--- IF THE GIVEN TEXT FILES ARE ALREADY OPEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH MODE OUT_FILE FOR TEXT FILES.
-
--- HISTORY:
--- ABW 08/24/82
--- SPS 09/16/82
--- SPS 11/09/82
--- JBG 07/25/83
--- JLH 08/07/87 COMPLETE REVISION OF TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3102A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3102A" , "CHECK THAT STATUS_ERROR IS RAISED " &
- "APPROPRIATELY FOR TEXT FILES");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CREATE (FILE, OUT_FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 1");
- END;
-
- BEGIN
- CREATE (FILE, IN_FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 2");
- END;
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 3");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 3");
- END;
-
- BEGIN
- OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 1");
- END;
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 2");
- END;
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME (2, "CE3102A"));
- FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 3");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 3");
- END;
-
- BEGIN
- CREATE (FILE, IN_FILE, LEGAL_FILE_NAME (2, "CE3102A"));
- FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 4");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 4");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst b/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst
deleted file mode 100644
index 2383d45..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst
+++ /dev/null
@@ -1,184 +0,0 @@
--- CE3102B.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.
---*
--- OBJECTIVE:
--- CHECK THAT FOR TEXT FILES NAME_ERROR IS RAISED BY CREATE AND
--- OPEN IF THE GIVEN NAME STRING DOES NOT ALLOW THE IDENTIFICATION
--- OF AN EXTERNAL FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE FOR TEXT_IO.
-
--- HISTORY:
--- ABW 08/24/82
--- JBG 03/16/83
--- EG 05/30/85
--- JLH 08/12/87 REMOVED UNNECESSARY CODE, ADDED NEW CASES FOR OPEN,
--- AND REMOVED DEPENDENCE ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102B IS
-
- FILE1, FILE2 : FILE_TYPE;
- FILE_NAME_OK : BOOLEAN := FALSE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3102B", "CHECK THAT NAME_ERROR IS RAISED " &
- "APPROPRIATELY");
-
- -- CHECK THAT A LEGAL FILE NAME IS OK SO TEST IS VALID
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "OF ASSUMED VALID FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "OF ASSUMED VALID FILE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- DELETE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("FILE STILL EXISTS AFTER DELETE");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT OPEN");
- END;
-
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- -- PERFORM VARIOUS CHECKS
-
- BEGIN
- OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2));
- FAILED ("NO EXCEPTION FOR NON-EXISTENT FILE - IN_FILE");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR OPEN OF " &
- "NON-EXISTENT FILE - IN_FILE");
- END;
-
- BEGIN
- OPEN (FILE2, OUT_FILE, LEGAL_FILE_NAME(3));
- FAILED ("NO EXCEPTION FOR NON-EXISTENT FILE - OUT_FILE");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR OPEN FOR " &
- "NON-EXISTENT FILE - OUT_FILE");
- END;
-
- BEGIN
- CREATE (FILE1, NAME => "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED ("NO EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE");
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE");
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE");
- END;
-
- BEGIN
- CREATE (FILE2, NAME => "$ILLEGAL_EXTERNAL_FILE_NAME2");
- FAILED ("NO EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE");
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE");
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE");
- END;
-
- BEGIN
- OPEN (FILE2, IN_FILE,
- NAME => "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED ("NO EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN");
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE ERROR RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN");
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN");
- END;
-
- BEGIN
- OPEN (FILE1, IN_FILE,
- NAME => "$ILLEGAL_EXTERNAL_FILE_NAME2");
- FAILED ("NO EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN");
- EXCEPTION
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN");
- WHEN NAME_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR " &
- "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN");
- END;
-
- RESULT;
-
-EXCEPTION
-
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada
deleted file mode 100644
index 0f58c19..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- CE3102D.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 STATUS_ERROR IS RAISED BY CLOSE, DELETE, RESET, MODE,
--- NAME, AND FORM IF THE GIVEN TEXT FILES ARE NOT OPEN.
-
--- HISTORY:
--- JLH 08/10/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3102D IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- FT : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3102D" , "CHECK THAT STATUS_ERROR IS RAISED " &
- "APPROPRIATELY FOR TEXT FILES");
-
- BEGIN
- CREATE (FT);
- CLOSE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CREATE");
- END;
-
- BEGIN
- RESET (FT);
- FAILED ("STATUS_ERROR NOT RAISED FOR RESET");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR RESET OF CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR RESET");
- END;
-
- BEGIN
- DECLARE
- MD : FILE_MODE := MODE (FT);
- BEGIN
- FAILED ("STATUS_ERROR NOT RAISED FOR MODE");
- END;
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR MODE OF CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR MODE");
- END;
-
- BEGIN
- DECLARE
- NM : CONSTANT STRING := NAME (FT);
- BEGIN
- FAILED ("STATUS_ERROR NOT RAISED FOR NAME");
- END;
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR NAME OF CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR NAME");
- END;
-
- BEGIN
- DECLARE
- FM : CONSTANT STRING := FORM (FT);
- BEGIN
- FAILED ("STATUS_ERROR NOT RAISED FOR FORM");
- END;
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR FORM OF CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR FORM");
- END;
-
- BEGIN
- CLOSE (FT);
- FAILED ("STATUS_ERROR NOT RAISED FOR CLOSE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED WHEN CLOSING CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CLOSE");
- END;
-
- BEGIN
- DELETE (FT);
- FAILED ("STATUS_ERROR NOT RAISED FOR DELETE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED FOR DELETE OF CLOSED FILE");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR DELETE");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada
deleted file mode 100644
index c971abd..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CE3102E.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE
--- IMPLEMENTATION FOR TEXT FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT IN_FILE MODE WITH CREATE FOR TEXT FILES.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102E IS
-
- FILE1 : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3102E", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR TEXT FILES");
-
- BEGIN
- CREATE (FILE1, IN_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE3102E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada
deleted file mode 100644
index d87b80a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- CE3102F.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 USE_ERROR IS RAISED WHEN AN EXTERNAL FILE
--- CANNOT BE RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES, BUT DO NOT SUPPORT RESET OF EXTERNAL FILES.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3102F IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3102F", "CHECK THAT USE_ERROR IS RAISED WHEN AN " &
- "EXTERNAL FILE CANNOT BE RESET");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- NOT_APPLICABLE ("RESET FOR OUT_FILE MODE ALLOWED - 1");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 1");
- END;
-
- PUT (FILE, "HELLO");
-
- BEGIN
- RESET (FILE, IN_FILE);
- NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE MODE " &
- "ALLOWED - 1");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RASIED FOR RESET - 2");
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("TEXT_IO NOT SUPPORTED FOR IN_FILE " &
- "OPEN");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- NOT_APPLICABLE ("RESET FOR IN_FILE MODE ALLOWED - 2");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 3");
- END;
-
- BEGIN
- RESET (FILE, OUT_FILE);
- NOT_APPLICABLE ("RESET FROM IN_FILE TO OUT_FILE MODE " &
- "ALLOWED - 2");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 4");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada
deleted file mode 100644
index a60f50f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada
+++ /dev/null
@@ -1,84 +0,0 @@
--- CE3102G.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 USE_ERROR IS RAISED WHEN AN EXTERNAL FILE
--- CANNOT BE DELETED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES, BUT DO NOT SUPPORT DELETION OF EXTERNAL FILES.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3102G IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- VAR1 : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3102G" , "CHECK THAT USE_ERROR IS RAISED WHEN AN " &
- "EXTERNAL FILE CANNOT BE DELETED");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- NOT_APPLICABLE ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, VAR1);
-
- BEGIN
- DELETE (FILE);
- NOT_APPLICABLE ("DELETION OF EXTERNAL FILES ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR DELETE");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada
deleted file mode 100644
index 152b6ea..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada
+++ /dev/null
@@ -1,116 +0,0 @@
--- CE3102H.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 MODE_ERROR IS RAISED WHEN ATTEMPTING TO CHANGE
--- THE MODE OF A FILE SERVING AS THE CURRENT DEFAULT INPUT
--- OR DEFAULT OUTPUT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102H IS
-
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- ITEM : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3102H", "CHECK THAT MODE_ERROR IS RAISED WHEN " &
- "ATTEMPTING TO CHANGE THE MODE OF A FILE " &
- "SERVING AS THE CURRENT DEFAULT INPUT OR " &
- "DEFAULT OUTPUT FILE");
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_OUTPUT (FILE1);
-
- BEGIN
- RESET (FILE1, IN_FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR RESET");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET");
- END;
-
- SET_OUTPUT (STANDARD_OUTPUT);
-
- PUT (FILE1, ITEM);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE1);
-
- BEGIN
- RESET (FILE1, OUT_FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR RESET");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET");
- END;
-
- SET_INPUT (STANDARD_INPUT);
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3102H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada
deleted file mode 100644
index cc126bc..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada
+++ /dev/null
@@ -1,63 +0,0 @@
--- CE3102I.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 USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE
--- IMPLEMENTATION FOR TEXT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OUT_FILE FOR CREATE FOR TEXT_IO.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102I IS
-
- FILE1 : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3102I", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF CREATE FOR TEXT_IO");
-
- BEGIN
- CREATE (FILE1, OUT_FILE);
- CLOSE (FILE1);
- NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- END;
-
- RESULT;
-
-END CE3102I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada
deleted file mode 100644
index ce1b5f6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE3102J.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR TEXT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT IN_FILE MODE FOR OPEN FOR TEXT_IO.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102J IS
-
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- RAISED_USE_ERROR : BOOLEAN := FALSE;
- VAR1 : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3102J", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR TEXT_IO");
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3102J;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada b/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada
deleted file mode 100644
index 151a4d6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada
+++ /dev/null
@@ -1,98 +0,0 @@
--- CE3102K.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 USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE
--- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE
--- IMPLEMENTATION FOR TEXT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT
--- SUPPORT OUT_FILE MODE FOR OPEN FOR TEXT_IO.
-
--- HISTORY:
--- JLH 08/12/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3102K IS
-
- FILE1 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
- RAISED_USE_ERROR : BOOLEAN := FALSE;
- VAR1 : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3102K", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " &
- "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " &
- "OF OPEN FOR TEXT_IO");
- BEGIN
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, VAR1);
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED");
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- END;
-
- IF IS_OPEN (FILE1) THEN
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3102K;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada
deleted file mode 100644
index 7b09a77..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada
+++ /dev/null
@@ -1,216 +0,0 @@
--- CE3103A.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 PAGE AND LINE LENGTH OF TEXT FILES ARE ZERO
--- AFTER A CREATE, OPEN, OR RESET TO OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILE.
-
--- HISTORY:
--- ABW 08/24/82
--- SPS 09/16/82
--- SPS 11/09/82
--- SPS 01/18/83
--- EG 11/02/84
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/13/87 REVISED TEST TO INCLUDE CASES TO RESET THE FILE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3103A IS
-
- SUBTEST : EXCEPTION;
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ZERO : CONSTANT COUNT := COUNT(IDENT_INT(0));
- TWO : CONSTANT COUNT := COUNT (IDENT_INT(2));
- FIVE : CONSTANT COUNT := COUNT (IDENT_INT(5));
-
-BEGIN
-
- TEST ("CE3103A" , "CHECK THAT PAGE AND LINE LENGTH " &
- "ARE SET TO ZERO AFTER CREATE, " &
- "OPEN, OR RESET");
-
-BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF LINE_LENGTH (FILE) /= ZERO THEN
- FAILED ("LINE_LENGTH FOR CREATE IS NOT ZERO");
- END IF;
- IF PAGE_LENGTH (FILE) /= ZERO THEN
- FAILED ("PAGE_LENGTH FOR CREATE IS NOT ZERO");
- END IF;
-
- SET_LINE_LENGTH (FILE, TWO);
- SET_PAGE_LENGTH (FILE, FIVE);
-
- PUT_LINE (FILE, "HI");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN");
- RAISE INCOMPLETE;
- END;
-
- IF LINE_LENGTH (FILE) /= ZERO THEN
- FAILED ("LINE_LENGTH FOR OPEN IS NOT ZERO");
- END IF;
- IF PAGE_LENGTH (FILE) /= ZERO THEN
- FAILED ("PAGE_LENGTH FOR OPEN IS NOT ZERO");
- END IF;
-
- SET_LINE_LENGTH (FILE, TWO);
- SET_PAGE_LENGTH (FILE, TWO);
-
- PUT_LINE (FILE, "HI");
-
- BEGIN
- BEGIN
- RESET (FILE, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE SUBTEST;
- END;
-
- IF LINE_LENGTH (FILE) /= ZERO THEN
- FAILED ("LINE_LENGTH FOR RESET TO OUT_FILE IS NOT " &
- "ZERO - 1");
- END IF;
- IF PAGE_LENGTH (FILE) /= ZERO THEN
- FAILED ("PAGE_LENGTH FOR RESET TO OUT_FILE IS NOT " &
- "ZERO - 1");
- END IF;
- EXCEPTION
- WHEN SUBTEST =>
- NULL;
- END;
-
- SET_LINE_LENGTH (FILE, FIVE);
- SET_PAGE_LENGTH (FILE, FIVE);
-
- PUT_LINE (FILE, "HELLO");
-
- IF LINE_LENGTH (FILE) /= 5 THEN
- FAILED ("LINE_LENGTH FOR RESET IN OUT_FILE, PLUS HELLO " &
- "IS NOT FIVE");
- END IF;
- IF PAGE_LENGTH (FILE) /= 5 THEN
- FAILED ("PAGE_LENGTH FOR RESET IN OUT_FILE, PLUS HELLO " &
- "IS NOT FIVE");
- END IF;
-
- BEGIN
- BEGIN
- RESET (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE SUBTEST;
- END;
-
- IF LINE_LENGTH (FILE) /= ZERO THEN
- FAILED ("LINE_LENGTH FOR RESET IS NOT ZERO");
- END IF;
- IF PAGE_LENGTH (FILE) /= ZERO THEN
- FAILED ("PAGE_LENGTH FOR RESET IS NOT ZERO");
- END IF;
- EXCEPTION
- WHEN SUBTEST =>
- NULL;
- END;
-
- SET_LINE_LENGTH (FILE, FIVE);
- SET_PAGE_LENGTH (FILE, FIVE);
-
- PUT_LINE (FILE, "HELLO");
-
- IF LINE_LENGTH (FILE) /= 5 THEN
- FAILED ("LINE_LENGTH FOR RESET PLUS HELLO");
- END IF;
- IF PAGE_LENGTH (FILE) /= 5 THEN
- FAILED ("PAGE_LENGTH FOR RESET PLUS HELLO");
- END IF;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE INCOMPLETE;
- END;
-
- IF LINE_LENGTH (FILE) /= ZERO THEN
- FAILED ("LINE_LENGTH FOR RESET TO OUT_FILE IS NOT ZERO - 2");
- END IF;
- IF PAGE_LENGTH (FILE) /= ZERO THEN
- FAILED ("PAGE_LENGTH FOR RESET TO OUT_FILE IS NOT ZERO - 2");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-END;
-
-RESULT;
-
-END CE3103A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada
deleted file mode 100644
index 4725f24..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada
+++ /dev/null
@@ -1,231 +0,0 @@
--- CE3104A.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 CURRENT COLUMN, LINE, AND PAGE NUMBERS OF
--- TEXT FILES ARE SET TO ONE AFTER A CREATE, OPEN, OR RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/24/82
--- SPS 09/16/82
--- SPS 11/09/82
--- JBG 03/16/83
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/13/87 CHANGED FAILED MESSAGES AND ADDED SUBTEST
--- EXCEPTION.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3104A IS
-
- INCOMPLETE, SUBTEST : EXCEPTION;
- FILE, FT : FILE_TYPE;
- ONE : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3104A" , "CHECK THAT COLUMN, LINE, AND " &
- "PAGE NUMBERS ARE ONE AFTER A " &
- "CREATE, OPEN, OR RESET");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER CREATE");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER CREATE");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER CREATE");
- END IF;
-
- NEW_PAGE (FILE);
- NEW_LINE (FILE);
- PUT (FILE, "STRING");
-
- CLOSE (FILE);
-
- BEGIN
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE SUBTEST;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER " &
- "OPEN - IN_FILE");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER " &
- "OPEN - IN_FILE");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER " &
- "OPEN - IN_FILE");
- END IF;
-
- GET (FILE, CHAR); -- SETS PAGE, LINE, AND COL /= 1
-
- BEGIN
- RESET (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- CLOSE (FILE);
- RAISE SUBTEST;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER RESET");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER RESET");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER RESET");
- END IF;
-
- GET (FILE, CHAR); -- CHANGES LINE, PAGE, COL; STILL IN_FILE
-
- BEGIN
- RESET (FILE,OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- CLOSE (FILE);
- RAISE SUBTEST;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER RESET " &
- "TO OUT_FILE");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER RESET " &
- "TO OUT_FILE");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER RESET " &
- "TO OUT_FILE");
- END IF;
-
- CLOSE (FILE);
-
- EXCEPTION
- WHEN SUBTEST =>
- NULL;
- END;
-
- BEGIN
- BEGIN
- OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE SUBTEST;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER OPEN " &
- "TO OUT_FILE");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER OPEN " &
- "TO OUT_FILE");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER OPEN " &
- "TO OUT_FILE");
- END IF;
-
- EXCEPTION
- WHEN SUBTEST =>
- NULL;
- END;
-
- BEGIN
- BEGIN
- CREATE (FT, IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- RAISE SUBTEST;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM COLUMN AFTER CREATE " &
- "IN IN_FILE");
- END IF;
- IF LINE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM LINE AFTER CREATE " &
- "IN IN_FILE");
- END IF;
- IF PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT RESULTS FROM PAGE AFTER CREATE " &
- "IN IN_FILE");
- END IF;
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN SUBTEST =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3104A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada
deleted file mode 100644
index 34af989..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada
+++ /dev/null
@@ -1,120 +0,0 @@
--- CE3104B.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 FILE REMAINS OPEN AFTER A RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- DWC 08/13/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3104B IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ITEM1 : STRING (1..5) := "STUFF";
-
-BEGIN
-
- TEST ("CE3104B", "CHECK THAT THE FILE REMAINS OPEN AFTER " &
- "A RESET");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- PUT_LINE (FILE, ITEM1);
- CLOSE (FILE);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE " &
- "NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
- "FILE I/O");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (FILE) THEN
- CLOSE (FILE);
- ELSE
- FAILED ("RESET FOR IN_FILE, CLOSED FILE");
- END IF;
-
- BEGIN
- OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- IF IS_OPEN (FILE) THEN
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- ELSE
- FAILED ("RESET FOR OUT_FILE CLOSED FILE");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3104B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada
deleted file mode 100644
index a9379ef..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE3104C.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 MODE PARAMETER IN RESET CHANGES THE MODE OF A
--- GIVEN FILE, AND IF NO MODE IS SUPPLIED, THE MODE IS LEFT AS IT
--- WAS BEFORE THE RESET.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- RESET FOR TEXT FILES.
-
--- HISTORY:
--- DWC 08/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3104C IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ITEM1 : STRING (1..5) := "STUFF";
- ITEM2 : STRING (1..5);
- LENGTH : NATURAL;
-
-BEGIN
-
- TEST ("CE3104C", "CHECK THAT THE FILE REMAINS OPEN AFTER " &
- "A RESET");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- PUT_LINE (FILE, ITEM1);
- EXCEPTION
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE NOT " &
- "SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
- "FILE I/O");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- IF MODE (FILE) /= OUT_FILE THEN
- FAILED ("RESET CHANGED MODE OF OUT_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FOR OUT_FILE MODE NOT " &
- "SUPPORTED FOR TEXT FILES");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE, IN_FILE);
- IF MODE (FILE) /= IN_FILE THEN
- FAILED ("RESET MODE TO IN_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE " &
- "NOT SUPPORTED FOR TEXT FILES");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- RESET (FILE);
- IF MODE (FILE) /= IN_FILE THEN
- FAILED ("RESET CHANGED MODE OF IN_FILE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("RESET OF IN_FILE MODE NOT SUPPORTED " &
- "FOR TEXT FILES");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3104C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada
deleted file mode 100644
index 474a66a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada
+++ /dev/null
@@ -1,226 +0,0 @@
--- CE3106A.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 CLOSING A FILE HAS THE FOLLOWING EFFECT:
--- 1) IF THERE IS NO LINE TERMINATOR, A LINE TERMINATOR, PAGE
--- TERMINATOR, AND FILE TERMINATOR ARE WRITTEN AT THE END
--- OF THE FILE.
--- 2) IF THERE IS A LINE TERMINATOR BUT NO PAGE TERMINATOR, A
--- PAGE TERMINATOR AND A FILE TERMINATOR ARE WRITTEN.
--- 3) IF THERE IS A PAGE TERMINATOR, A FILE TERMINATOR IS
--- WRITTEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3106A IS
-
- INCOMPLETE : EXCEPTION;
- FILE1, FILE2, FILE3 : FILE_TYPE;
- ITEM : CHARACTER;
-
-BEGIN
-
- TEST ("CE3106A", "CHECK THAT CLOSING A FILE HAS THE CORRECT " &
- "EFFECT ON THE FILE CONCERNING LINE, PAGE, " &
- "AND FILE TERMINATORS");
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE" &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, 'A');
- NEW_LINE (FILE1);
- PUT (FILE1, 'B');
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE1, ITEM);
-
- IF LINE (FILE1) /= 1 THEN
- FAILED ("INCORRECT LINE NUMBER - 1");
- END IF;
-
- GET (FILE1, ITEM);
- IF ITEM /= 'B' THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- IF LINE (FILE1) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 2");
- END IF;
-
- IF NOT END_OF_LINE (FILE1) THEN
- FAILED ("LINE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED");
- END IF;
-
- IF NOT END_OF_PAGE (FILE1) THEN
- FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED");
- END IF;
-
- IF NOT END_OF_FILE (FILE1) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED");
- END IF;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2));
- PUT (FILE2, 'A');
- NEW_LINE (FILE2);
- PUT (FILE2, 'B');
- NEW_PAGE (FILE2);
- PUT (FILE2, 'C');
- NEW_LINE (FILE2);
-
- CLOSE (FILE2);
-
- OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2));
-
- GET (FILE2, ITEM);
-
- GET (FILE2, ITEM);
- IF ITEM /= 'B' THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- IF LINE (FILE2) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 3");
- END IF;
-
- GET (FILE2, ITEM);
-
- IF LINE (FILE2) /= 1 THEN
- FAILED ("INCORRECT LINE NUMBER - 4");
- END IF;
-
- IF PAGE (FILE2) /= 2 THEN
- FAILED ("INCORRECT PAGE NUMBER - 1");
- END IF;
-
- IF NOT END_OF_PAGE (FILE2) THEN
- FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED - 2");
- END IF;
-
- IF NOT END_OF_FILE (FILE2) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED - 2");
- END IF;
-
- BEGIN
- DELETE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CREATE (FILE3, OUT_FILE, LEGAL_FILE_NAME(3));
- PUT (FILE3, 'A');
- NEW_PAGE (FILE3);
- PUT (FILE3, 'B');
- NEW_PAGE (FILE3);
- NEW_LINE (FILE3);
- PUT (FILE3, 'C');
- NEW_PAGE (FILE3);
-
- CLOSE (FILE3);
-
- OPEN (FILE3, IN_FILE, LEGAL_FILE_NAME(3));
-
- GET (FILE3, ITEM);
-
- GET (FILE3, ITEM);
- IF ITEM /= 'B' THEN
- FAILED ("INCORRECT VALUE READ - 3");
- END IF;
-
- GET (FILE3, ITEM);
-
- IF LINE (FILE3) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 5");
- END IF;
-
- IF PAGE (FILE3) /= 3 THEN
- FAILED ("INCORRECT PAGE NUMBER - 2");
- END IF;
-
- IF NOT END_OF_FILE (FILE3) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS CLOSED - 3");
- END IF;
-
- BEGIN
- DELETE (FILE3);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3106A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada
deleted file mode 100644
index 9d507a9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada
+++ /dev/null
@@ -1,220 +0,0 @@
--- CE3106B.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 RESETTING AN OUT_FILE TO AN IN_FILE HAS THE FOLLOWING
--- EFFECT:
--- 1) IF THERE IS NO LINE TERMINATOR, A LINE TERMINATOR, PAGE
--- TERMINATOR, AND FILE TERMINATOR ARE WRITTEN AT THE END
--- OF THE FILE.
--- 2) IF THERE IS A LINE TERMINATOR BUT NO PAGE TERMINATOR, A
--- PAGE TERMINATOR AND A FILE TERMINATOR ARE WRITTEN.
--- 3) IF THERE IS A PAGE TERMINATOR, A FILE TERMINATOR IS
--- WRITTEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3106B IS
-
- INCOMPLETE : EXCEPTION;
- FILE1, FILE2, FILE3 : FILE_TYPE;
- ITEM : CHARACTER;
-
-BEGIN
-
- TEST ("CE3106B", "CHECK THAT RESETTING AN OUT_FILE TO AN " &
- "IN_FILE HAS THE CORRECT EFFECT ON THE " &
- "FILE CONCERNING LINE, PAGE, AND FILE " &
- "TERMINATORS");
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE" &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, 'A');
- NEW_LINE (FILE1);
- PUT (FILE1, 'B');
-
- BEGIN
- RESET (FILE1, IN_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON FILE RESET " &
- "FROM OUT_FILE TO IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE1, ITEM);
-
- IF LINE (FILE1) /= 1 THEN
- FAILED ("INCORRECT LINE NUMBER - 1");
- END IF;
-
- GET (FILE1, ITEM);
- IF ITEM /= 'B' THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- IF LINE (FILE1) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 2");
- END IF;
-
- IF NOT END_OF_LINE (FILE1) THEN
- FAILED ("LINE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET");
- END IF;
-
- IF NOT END_OF_PAGE (FILE1) THEN
- FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET");
- END IF;
-
- IF NOT END_OF_FILE (FILE1) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET");
- END IF;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2));
- PUT (FILE2, 'A');
- NEW_LINE (FILE2);
- PUT (FILE2, 'B');
- NEW_PAGE (FILE2);
- PUT (FILE2, 'C');
- NEW_LINE (FILE2);
-
- RESET (FILE2, IN_FILE);
-
- GET (FILE2, ITEM);
- GET (FILE2, ITEM);
-
- IF LINE (FILE2) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 3");
- END IF;
-
- GET (FILE2, ITEM);
- IF ITEM /= 'C' THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- IF LINE(FILE2) /= 1 THEN
- FAILED ("INCORRECT LINE NUMBER - 4");
- END IF;
-
- IF PAGE(FILE2) /= 2 THEN
- FAILED ("INCORRECT PAGE NUMBER - 1");
- END IF;
-
- IF NOT END_OF_PAGE (FILE2) THEN
- FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET - 2");
- END IF;
-
- IF NOT END_OF_FILE (FILE2) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET - 2");
- END IF;
-
- BEGIN
- DELETE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CREATE (FILE3, OUT_FILE, LEGAL_FILE_NAME(3));
- PUT (FILE3, 'A');
- NEW_PAGE (FILE3);
- PUT (FILE3, 'B');
- NEW_PAGE (FILE3);
- NEW_LINE (FILE3);
- PUT (FILE3, 'C');
- NEW_PAGE (FILE3);
-
- RESET (FILE3, IN_FILE);
-
- GET (FILE3, ITEM);
- IF ITEM /= 'A' THEN
- FAILED ("INCORRECT VALUE READ - 3");
- END IF;
-
- GET (FILE3, ITEM);
- GET (FILE3, ITEM);
-
- IF LINE(FILE3) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER - 5");
- END IF;
-
- IF PAGE(FILE3) /= 3 THEN
- FAILED ("INCORRECT PAGE NUMBER - 2");
- END IF;
-
- IF NOT END_OF_FILE (FILE3) THEN
- FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " &
- "IS RESET - 3");
- END IF;
-
- BEGIN
- DELETE (FILE3);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3106B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst b/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst
deleted file mode 100644
index 96646fb..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst
+++ /dev/null
@@ -1,135 +0,0 @@
--- CE3107A.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.
---*
--- OBJECTIVE:
--- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE TEXT_IO.
-
--- HISTORY:
--- DLD 08/10/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/29/85
--- DWC 08/17/87 SPLIT OUT CASES WHICH DEPEND ON A TEXT FILE
--- BEING CREATED OR SUCCESSFULLY OPENED. PLACED
--- CASES INTO CE3107B.ADA.
--- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3107A IS
-
- TEST_FILE_ZERO : FILE_TYPE;
- TEST_FILE_ONE : FILE_TYPE;
- TEST_FILE_TWO : FILE_TYPE;
- TEST_FILE_THREE : FILE_TYPE;
- VAL : BOOLEAN;
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST("CE3107A", "CHECK THAT IS_OPEN RETURNS THE PROPER " &
- "VALUES FOR UNOPENED FILES OF TYPE TEXT_IO");
-
--- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS TEXT FILES AT ALL
-
- BEGIN
- TEXT_IO.CREATE ( TEST_FILE_ZERO,
- TEXT_IO.OUT_FILE,
- REPORT.LEGAL_FILE_NAME );
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR | TEXT_IO.NAME_ERROR =>
- REPORT.NOT_APPLICABLE
- ( "TEXT FILES NOT SUPPORTED -- CREATE OUT-FILE" );
- RAISE INCOMPLETE;
- END;
- TEXT_IO.DELETE ( TEST_FILE_ZERO );
-
--- WHEN FILE IS DECLARED BUT NOT OPEN
-
- VAL := TRUE;
- VAL := IS_OPEN(TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE");
- END IF;
-
--- FOLLOWING UNSUCCESSFUL CREATE
-
- BEGIN
- VAL := TRUE;
- CREATE(TEST_FILE_TWO, OUT_FILE,
- "$ILLEGAL_EXTERNAL_FILE_NAME1");
- FAILED("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN(TEST_FILE_TWO);
- IF VAL = TRUE THEN
- FAILED("IS_OPEN GIVES TRUE AFTER AN " &
- "UNSUCCESSFUL CREATE");
- END IF;
- END;
-
--- FOLLOWING UNSUCCESSFUL OPEN
-
- BEGIN
- VAL := FALSE;
- OPEN(TEST_FILE_TWO, IN_FILE, LEGAL_FILE_NAME);
- FAILED("NAME_ERROR NOT RAISED - " &
- "UNSUCCESSFUL OPEN");
- EXCEPTION
- WHEN NAME_ERROR =>
- VAL := IS_OPEN(TEST_FILE_TWO);
- IF VAL = TRUE THEN
- FAILED("IS_OPEN GIVES TRUE - " &
- "UNSUCCESSFUL OPEN");
- END IF;
- END;
-
--- CLOSE FILE WHILE NOT OPEN
-
- BEGIN
- VAL := TRUE;
- CLOSE(TEST_FILE_THREE); -- STATUS ERROR
- FAILED("STATUS_ERROR NOT RAISED - UNSUCCESSFUL CLOSE");
- EXCEPTION
- WHEN OTHERS =>
- VAL := IS_OPEN(TEST_FILE_THREE);
- IF VAL = TRUE THEN
- FAILED("IS_OPEN GIVES TRUE - UNSUCCESSFUL " &
- "CLOSE");
- END IF;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- REPORT.RESULT;
- WHEN OTHERS =>
- REPORT.FAILED ( "UNEXPECTED EXCEPTION" );
- REPORT.RESULT;
-END CE3107A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada
deleted file mode 100644
index 6c40c5d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- CE3107B.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 IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF
--- TYPE TEXT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION WITH OUT_FILE MODE FOR TEXT FILES.
-
--- HISTORY:
--- DWC 08/17/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3107B IS
-
- TEST_FILE_ONE : FILE_TYPE;
- TEST_FILE_TWO : FILE_TYPE;
- VAL : BOOLEAN;
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST("CE3107B", "CHECK THAT IS_OPEN RETURNS THE " &
- "PROPER VALUES FOR FILES OF TYPE TEXT_IO");
-
--- FOLLOWING A CREATE
-
- BEGIN
- VAL := FALSE;
- CREATE(TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- VAL := IS_OPEN(TEST_FILE_ONE);
- IF VAL = FALSE THEN
- FAILED("IS_OPEN RETURNS FALSE AFTER CREATE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
--- FOLLOWING CLOSE
-
- VAL := TRUE;
- IF IS_OPEN(TEST_FILE_ONE) = TRUE THEN
- CLOSE(TEST_FILE_ONE);
- END IF;
- VAL := IS_OPEN(TEST_FILE_ONE);
- IF VAL = TRUE THEN
- FAILED("IS_OPEN RETURNS TRUE AFTER CLOSE");
- END IF;
-
--- FOLLOWING OPEN
-
- BEGIN
- VAL := FALSE;
- BEGIN
- OPEN (TEST_FILE_TWO, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_TWO) /= FALSE THEN
- FAILED ("FILE OPEN AFTER USE_ERROR " &
- "DURING OPEN");
- END IF;
- RAISE INCOMPLETE;
- END;
- VAL := IS_OPEN(TEST_FILE_TWO);
- IF VAL = FALSE THEN
- FAILED("IS_OPEN RETURNS FALSE AFTER OPEN");
- END IF;
-
--- AFTER RESET
-
- BEGIN
- VAL := FALSE;
- RESET(TEST_FILE_TWO);
- VAL := IS_OPEN(TEST_FILE_TWO);
- IF VAL = FALSE THEN
- FAILED("IS_OPEN RETURNS FALSE AFTER RESET");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT("IMPLEMENTATION DOES NOT SUPPORT RESET");
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
--- AFTER DELETE
-
- BEGIN
- VAL := TRUE;
- DELETE(TEST_FILE_TWO);
- VAL := IS_OPEN(TEST_FILE_TWO);
- IF VAL = TRUE THEN
- FAILED("IS_OPEN RETURNS TRUE AFTER DELETE");
- END IF;
- EXCEPTION
- WHEN USE_ERROR =>
- IF IS_OPEN (TEST_FILE_TWO) /= FALSE THEN
- FAILED ("FILE OPEN AFTER USE_ERROR " &
- "DURING DELETE");
- END IF;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3107B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada
deleted file mode 100644
index f5297a6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CE3108A.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 FILE CAN BE CLOSED AND THEN RE-OPENED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/16/85
--- GMT 08/17/87 REMOVED UNNECESSARY CODE AND ADDED A CHECK FOR
--- USE_ERROR ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3108A IS
-
- TXT_FILE : FILE_TYPE;
- VAR : STRING (1..2);
- LAST : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3108A", "CHECK THAT A FILE CAN BE CLOSED " &
- "AND THEN RE-OPENED");
-
- -- INITIALIZE TEST FILES
-
- BEGIN
-
- BEGIN
- CREATE (TXT_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (TXT_FILE, "17");
- CLOSE (TXT_FILE);
-
- -- RE-OPEN TEXT TEST FILE
-
- BEGIN
- OPEN (TXT_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (TXT_FILE, VAR);
- IF VAR /= "17" THEN
- FAILED ("WRONG DATA RETURNED FROM READ -TEXT");
- END IF;
-
- -- DELETE TEST FILES
-
- BEGIN
- DELETE (TXT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3108A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada
deleted file mode 100644
index 0c366f6..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CE3108B.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 NAME RETURNED BY THE NAME FUNCTION CAN BE USED
--- IN A SUBSEQUENT OPEN.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- DLD 08/11/82
--- SPS 11/09/82
--- JBG 03/24/83
--- EG 05/16/85
--- GMT 08/17/87 REMOVED UNNECESSARY CODE AND ADDED A CHECK FOR
--- USE_ERROR ON DELETE.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE3108B IS
-
- TYPE ACC_STR IS ACCESS STRING;
-
- TXT_FILE : FILE_TYPE;
- TXT_FILE_NAME : ACC_STR;
- DIR_FILE_NAME : ACC_STR;
- VAR : STRING(1..2);
- LAST : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3108B", "CHECK THAT THE NAME RETURNED BY THE NAME-" &
- "FUNCTION CAN BE USED IN A SUBSEQUENT OPEN");
-
- -- CREATE TEST FILES
-
- BEGIN
- BEGIN
- CREATE (TXT_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 1");
- RAISE INCOMPLETE;
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (TXT_FILE, "14");
- TXT_FILE_NAME := NEW STRING'(NAME (TXT_FILE));
- CLOSE (TXT_FILE);
-
- -- ATTEMPT TO RE-OPEN TEXT TEST FILE USING RETURNED NAME
- -- VALUE
-
- BEGIN
- OPEN (TXT_FILE, IN_FILE, TXT_FILE_NAME.ALL);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR ON RE-OPEN - 3");
- RAISE INCOMPLETE;
- END;
-
- GET (TXT_FILE, VAR);
- IF VAR /= "14" THEN
- FAILED ("WRONG DATA RETURNED FROM READ - 4");
- END IF;
-
- -- CLOSE AND DELETE TEST FILES
-
- BEGIN
- DELETE (TXT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3108B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada
deleted file mode 100644
index f6d756a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- CE3110A.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 AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE
--- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION AND DELETION OF TEXT FILES.
-
--- HISTORY:
--- SPS 08/25/82
--- SPS 11/09/82
--- JBG 06/04/84
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/18/87 CORRECTED EXCEPTION FORMAT.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3110A IS
-BEGIN
-
- TEST ("CE3110A", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " &
- "AFTER AN EXTERNAL FILE WITH SAME NAME HAS BEEN" &
- " DELETED");
- DECLARE
- FL1 : FILE_TYPE;
- FL2 : FILE_TYPE;
- T_FAILED : BOOLEAN := FALSE;
- D_FILE : BOOLEAN := FALSE;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE");
- T_FAILED := TRUE;
- END;
-
- IF NOT T_FAILED THEN
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL " &
- "FILES NOT SUPPORTED");
- T_FAILED := TRUE;
- END;
- END IF;
-
- IF NOT T_FAILED THEN
- BEGIN
- CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME);
- D_FILE := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNABLE TO RECREATE FILE AFTER " &
- "DELETION - TEXT");
- END;
- IF D_FILE THEN
- BEGIN
- DELETE (FL2);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DELETE SHOULD STILL BE " &
- "SUPPORTED");
- END;
- END IF;
- END IF;
- END;
-
- RESULT;
-
-END CE3110A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada
deleted file mode 100644
index 3ee20cf..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada
+++ /dev/null
@@ -1,81 +0,0 @@
--- CE3112C.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 EXTERNAL TEXT FILE SPECIFIED BY A NON-NULL
--- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN
--- PROGRAM.
-
--- THIS TEST CREATES A TEXT FILE WHICH CE3112D.ADA WILL READ.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF AN EXTERNAL TEXT FILE WITH OUT_FILE MODE.
-
--- HISTORY:
--- GMT 08/13/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO;
-
-PROCEDURE CE3112C IS
-
- INCOMPLETE : EXCEPTION;
- FILE_NAME : TEXT_IO.FILE_TYPE;
- PREVENT_EMPTY_FILE : STRING (1..5) := "HELLO";
-
-BEGIN
- TEST ("CE3112C" , "CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED " &
- "BY A NON-NULL STRING NAME IS ACCESSIBLE " &
- "AFTER THE COMPLETION OF THE MAIN PROGRAM");
- BEGIN
- BEGIN
- TEXT_IO.CREATE (FILE_NAME, TEXT_IO.OUT_FILE,
- LEGAL_FILE_NAME);
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN TEXT_IO.NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- TEXT_IO.PUT (FILE_NAME, PREVENT_EMPTY_FILE);
- TEXT_IO.CLOSE (FILE_NAME);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3112C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada
deleted file mode 100644
index 3328c81..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE3112D.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 EXTERNAL TEXT FILE SPECIFIED BY A NON-NULL STRING
--- NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN PROGRAM.
-
--- THIS TEST CHECKS THE CREATION OF A TEXT FILE X3112C, WHICH WAS
--- CREATED BY CE3112C.ADA.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- GMT 08/13/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO;
-
-PROCEDURE CE3112D IS
-
- INCOMPLETE : EXCEPTION;
- CHECK_SUPPORT, FILE_NAME : TEXT_IO.FILE_TYPE;
- PREVENT_EMPTY_FILE : STRING (1..5);
-
-BEGIN
- TEST ("CE3112D", "CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED BY " &
- "A NON-NULL STRING NAME IS ACCESSIBLE AFTER " &
- "THE COMPLETION OF THE MAIN PROGRAM");
-
- -- TEST FOR TEXT FILE SUPPORT.
-
- BEGIN
- TEXT_IO.CREATE (CHECK_SUPPORT, TEXT_IO.OUT_FILE,
- LEGAL_FILE_NAME);
- BEGIN
- TEXT_IO.DELETE (CHECK_SUPPORT);
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "DELETE - 1");
- END;
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN TEXT_IO.NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE - 3");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE - 4");
- RAISE INCOMPLETE;
- END;
-
- -- BEGIN TEST OBJECTIVE.
-
- BEGIN
- TEXT_IO.OPEN (FILE_NAME, TEXT_IO.IN_FILE,
- LEGAL_FILE_NAME (1, "CE3112C"));
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE("USE_ERROR RAISED ON OPEN FOR TEXT " &
- "FILE WITH IN_FILE MODE - 5");
- RAISE INCOMPLETE;
- END;
-
- TEXT_IO.GET (FILE_NAME, PREVENT_EMPTY_FILE);
-
- IF PREVENT_EMPTY_FILE /= "HELLO" THEN
- FAILED ("OPENED WRONG FILE OR DATA ERROR - 6");
- END IF;
- BEGIN
- TEXT_IO.DELETE (FILE_NAME);
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " &
- "EXTERNAL FILE - 7");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3112D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada
deleted file mode 100644
index f217cde..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- CE3114A.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 EXTERNAL TEXT FILE CEASES TO EXIST AFTER
--- A SUCCESSFUL DELETE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION AND DELETION OF TEXT FILES.
-
--- HISTORY:
--- SPS 08/25/82
--- SPS 11/09/82
--- JBG 04/01/83
--- EG 05/16/85
--- GMT 08/25/87 COMPLETELY REVISED.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3114A IS
-BEGIN
-
- TEST ("CE3114A", "CHECK THAT AN EXTERNAL TEXT FILE CEASES TO " &
- "EXIST AFTER A SUCCESSFUL DELETE");
-
- DECLARE
- FL1, FL2 : FILE_TYPE;
- VAR1 : CHARACTER := 'A';
- INCOMPLETE : EXCEPTION;
- BEGIN
- BEGIN
- CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FL1, VAR1); -- THIS PUTS TO THE FILE IF
- EXCEPTION -- IT CAN, NOT NECESSARY FOR
- WHEN OTHERS => -- THE OBJECTIVE.
- NULL;
- END;
-
- BEGIN
- DELETE (FL1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("DELETION OF EXTERNAL TEXT FILES " &
- "IS NOT SUPPORTED - 4");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- OPEN (FL2, IN_FILE, LEGAL_FILE_NAME);
- FAILED ("EXTERNAL TEXT FILE STILL EXISTS AFTER " &
- "A SUCCESSFUL DELETION - 5");
- EXCEPTION
- WHEN NAME_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3114A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada
deleted file mode 100644
index 66d951e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada
+++ /dev/null
@@ -1,232 +0,0 @@
--- CE3115A.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 RESETTING ONE OF A MULTIPLE OF INTERNAL FILES
--- ASSOCIATED WITH THE SAME EXTERNAL FILE HAS NO EFFECT ON ANY
--- OF THE OTHER INTERNAL FILES.
-
-
--- APPLICABILITY CRITERIA:
--- THIS TEST APPLIES ONLY TO IMPLEMENTATIONS WHICH SUPPORT MULTIPLE
--- INTERNAL FILES ASSOCIATED WITH THE SAME EXTERNAL FILE AND
--- RESETTING OF THESE MULTIPLE INTERNAL FILES FOR TEXT FILES.
-
--- HISTORY:
--- DLD 08/16/82
--- SPS 11/09/82
--- JBG 06/04/84
--- EG 11/19/85 MADE TEST INAPPLICABLE IF CREATE USE_ERROR.
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE RESULT WHEN
--- FILES NOT SUPPORTED.
--- GMT 08/25/87 COMPLETELY REVISED.
--- EDS 12/01/97 ADD NAME_ERROR HANDLER TO OUTPUT NOT_APPLICABLE RESULT.
--- RLB 09/29/98 MADE MODIFICATION TO AVOID BUFFERING PROBLEMS.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3115A IS
-
-BEGIN
-
- TEST ("CE3115A", "CHECK THAT RESETTING ONE OF A MULTIPLE OF " &
- "INTERNAL FILES ASSOCIATED WITH THE SAME " &
- "EXTERNAL FILE HAS NO EFFECT ON ANY OF THE " &
- "OTHER INTERNAL FILES");
-
- DECLARE
- TXT_FILE_ONE : TEXT_IO.FILE_TYPE;
- TXT_FILE_TWO : TEXT_IO.FILE_TYPE;
-
- CH : CHARACTER := 'A';
-
- INCOMPLETE : EXCEPTION;
-
- PROCEDURE TXT_CLEANUP IS
- FILE1_OPEN : BOOLEAN := IS_OPEN (TXT_FILE_ONE);
- FILE2_OPEN : BOOLEAN := IS_OPEN (TXT_FILE_TWO);
- BEGIN
- IF FILE1_OPEN AND FILE2_OPEN THEN
- CLOSE (TXT_FILE_TWO);
- DELETE (TXT_FILE_ONE);
- ELSIF FILE1_OPEN THEN
- DELETE (TXT_FILE_ONE);
- ELSIF FILE2_OPEN THEN
- DELETE (TXT_FILE_TWO);
- END IF;
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED " &
- "IN CLEANUP - 1");
- END TXT_CLEANUP;
-
- BEGIN
-
- BEGIN -- CREATE FIRST FILE
-
- CREATE (TXT_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME);
- PUT (TXT_FILE_ONE, CH);
-
- EXCEPTION
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; CREATE OF " &
- "EXTERNAL FILENAME IS NOT " &
- "SUPPORTED - 2");
- RAISE INCOMPLETE;
- WHEN TEXT_IO.NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; CREATE OF " &
- "EXTERNAL FILENAME IS NOT " &
- "SUPPORTED - 3");
- RAISE INCOMPLETE;
-
- END; -- CREATE FIRST FILE
-
- BEGIN -- OPEN SECOND FILE
-
- OPEN (TXT_FILE_TWO, IN_FILE, LEGAL_FILE_NAME);
-
- EXCEPTION
-
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE ("MULTIPLE INTERNAL FILES ARE NOT " &
- "SUPPORTED WHEN ONE IS MODE " &
- "OUT_FILE AND THE OTHER IS MODE " &
- "IN_FILE - 4" &
- " - USE_ERROR RAISED ");
- TXT_CLEANUP;
- RAISE INCOMPLETE;
-
- WHEN TEXT_IO.NAME_ERROR =>
- NOT_APPLICABLE ("MULTIPLE INTERNAL FILES ARE NOT " &
- "SUPPORTED WHEN ONE IS MODE " &
- "OUT_FILE AND THE OTHER IS MODE " &
- "IN_FILE - 4" &
- " - NAME_ERROR RAISED ");
- TXT_CLEANUP;
- RAISE INCOMPLETE;
-
- END; -- OPEN SECOND FILE
- FLUSH (TXT_FILE_ONE); -- AVOID BUFFERING PROBLEMS.
-
- CH := 'B';
- GET (TXT_FILE_TWO, CH);
- IF CH /= 'A' THEN
- FAILED ("INCORRECT VALUE FOR GET - 5");
- END IF;
-
- BEGIN -- INITIALIZE FIRST FILE TO CHECK POINTER RESETTING
-
- RESET (TXT_FILE_ONE);
- IF MODE (TXT_FILE_ONE) /= OUT_FILE THEN
- FAILED ("FILE WAS NOT RESET - 6");
- END IF;
- IF MODE (TXT_FILE_TWO) /= IN_FILE THEN
- FAILED ("RESETTING OF ONE INTERNAL FILE " &
- "AFFECTED THE OTHER INTERNAL FILE - 7");
- END IF;
-
- EXCEPTION
-
- WHEN TEXT_IO.USE_ERROR =>
- NOT_APPLICABLE ("RESETTING OF EXTERNAL FILE FOR " &
- "OUT_FILE MODE IS " &
- " NOT SUPPORTED - 8");
- TXT_CLEANUP;
- RAISE INCOMPLETE;
-
- END; -- INITIALIZE FIRST FILE TO CHECK POINTER RESETTING
-
- -- PERFORM SOME I/O ON THE FIRST FILE
-
- PUT (TXT_FILE_ONE, 'C');
- PUT (TXT_FILE_ONE, 'D');
- PUT (TXT_FILE_ONE, 'E');
- CLOSE (TXT_FILE_ONE);
-
- BEGIN
- OPEN (TXT_FILE_ONE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("MULTIPLE INTERNAL FILES NOT " &
- "SUPPORTED WHEN BOTH FILES HAVE " &
- "IN_FILE MODE - 9");
- RAISE INCOMPLETE;
- END;
-
- GET (TXT_FILE_ONE, CH);
- GET (TXT_FILE_ONE, CH);
-
- BEGIN -- INITIALIZE SECOND FILE AND PERFORM SOME I/O
-
- CLOSE (TXT_FILE_TWO);
- OPEN (TXT_FILE_TWO, IN_FILE, LEGAL_FILE_NAME);
-
- EXCEPTION
-
- WHEN TEXT_IO.USE_ERROR =>
- FAILED ("MULTIPLE INTERNAL FILES SHOULD STILL " &
- "BE ALLOWED - 10");
- TXT_CLEANUP;
- RAISE INCOMPLETE;
-
- END; -- INITIALIZE SECOND FILE AND PERFORM SOME I/O
-
- BEGIN -- RESET FIRST FILE AND CHECK EFFECTS ON SECOND FILE
-
- GET (TXT_FILE_TWO, CH);
- IF CH /= 'C' THEN
- FAILED ("INCORRECT VALUE FOR GET OPERATION - 11");
- END IF;
-
- RESET (TXT_FILE_ONE);
- GET (TXT_FILE_TWO, CH);
- IF CH /= 'D' THEN
- FAILED ("RESETTING INDEX OF ONE TEXT FILE " &
- "RESETS THE OTHER ASSOCIATED FILE - 12");
- END IF;
-
- EXCEPTION
-
- WHEN TEXT_IO.USE_ERROR =>
- FAILED ("RESETTING SHOULD STILL BE SUPPORTED - 13");
- TXT_CLEANUP;
- RAISE INCOMPLETE;
-
- END; -- RESET FIRST FILE AND CHECK EFFECTS ON SECOND FILE
-
- TXT_CLEANUP;
-
- EXCEPTION
-
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3115A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada
deleted file mode 100644
index eb7b6ea..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada
+++ /dev/null
@@ -1,71 +0,0 @@
--- CE3201A.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 STANDARD INPUT AND OUTPUT FILES EXIST
--- AND ARE OPEN.
-
--- ABW 8/25/82
--- SPS 9/16/82
--- SPS 12/14/82
--- JBG 3/17/83
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3201A IS
- CH : CHARACTER;
-BEGIN
-
- TEST ("CE3201A", "CHECK THAT STANDARD INPUT AND " &
- "OUTPUT EXIST AND ARE OPEN");
-
- IF NOT IS_OPEN (STANDARD_INPUT) THEN
- FAILED ("STANDARD_INPUT NOT OPEN - IS_OPEN");
- END IF;
-
- IF NOT IS_OPEN (STANDARD_OUTPUT) THEN
- FAILED ("STANDARD_OUTPUT NOT OPEN - IS_OPEN");
- END IF;
-
- BEGIN
- PUT ('X');
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("STANDARD_OUTPUT NOT AVAILABLE - " &
- "PUT DEFAULT");
- END;
-
- BEGIN
- PUT (STANDARD_OUTPUT, 'D');
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("STANDARD_OUTPUT NOT AVAILABLE - " &
- "PUT");
- END;
-
- RESULT;
-
-END CE3201A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada
deleted file mode 100644
index 755d488..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada
+++ /dev/null
@@ -1,57 +0,0 @@
--- CE3202A.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 CURRENT_INPUT AND CURRENT_OUTPUT INITIALLY
--- CORRESPOND TO STANDARD FILES.
-
--- ABW 8/25/82
--- SPS 11/9/82
--- JBG 3/17/83
--- JBG 5/8/84
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3202A IS
-
-
-BEGIN
-
- TEST ("CE3202A", "CHECK THAT CURRENT_INPUT AND " &
- "CURRENT_OUTPUT INITIALLY " &
- "CORRESPOND TO STANDARD FILES");
-
- IF NAME (CURRENT_INPUT) /= NAME (STANDARD_INPUT) THEN
- FAILED ("CURRENT_INPUT INCORRECT - NAME");
- END IF;
-
- IF NAME (CURRENT_OUTPUT) /= NAME (STANDARD_OUTPUT) THEN
- FAILED ("CURRENT_OUTPUT INCORRECT - NAME");
- END IF;
-
- RESULT;
-
-END CE3202A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada
deleted file mode 100644
index a865b60..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CE3206A.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 SET_INPUT AND SET_OUTPUT RAISE STATUS_ERROR WHEN
--- CALLED WITH A FILE PARAMETER DENOTING A CLOSED FILE.
-
--- HISTORY:
--- ABW 08/31/82
--- SPS 10/01/82
--- SPS 11/09/82
--- JLH 08/18/87 ADDED NEW CASES FOR SET_INPUT AND SET_OUTPUT.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3206A IS
-
- FILE_IN, FILE1 : FILE_TYPE;
- ITEM : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3206A", "CHECK THAT SET_INPUT AND SET_OUTPUT " &
- "RAISE STATUS_ERROR WHEN CALLED WITH A " &
- "FILE PARAMETER DENOTING A CLOSED FILE");
-
- BEGIN
- SET_INPUT (FILE_IN);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_INPUT - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT - 1");
- END;
-
- BEGIN
- SET_OUTPUT (FILE_IN);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_OUTPUT - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT - 1");
- END;
-
- BEGIN
- CREATE (FILE1, OUT_FILE);
- PUT (FILE1, ITEM);
- CLOSE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- SET_INPUT (FILE1);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_INPUT - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT - 2");
- END;
-
- BEGIN
- SET_OUTPUT (FILE1);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_OUTPUT - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT - 2");
- END;
-
-
- RESULT;
-
-END CE3206A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada
deleted file mode 100644
index 6b234ce..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- CE3207A.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 MODE_ERROR IS RAISED IF THE PARAMETER TO SET_INPUT HAS
--- MODE OUT_FILE OR THE PARAMETER TO SET_OUTPUT HAS MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3207A IS
-
- FILE1, FILE2 : FILE_TYPE;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3207A", "CHECK THAT MODE_ERROR IS RAISED IF THE " &
- "PARAMETER TO SET_INPUT HAS MODE OUT_FILE " &
- "OR THE PARAMETER TO SET_OUTPUT HAS MODE " &
- "IN_FILE");
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SET_INPUT (FILE1);
- FAILED ("MODE_ERROR NOT RAISED FOR SET_INPUT WITH " &
- "MODE OUT_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT");
- END;
-
- CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME);
-
- PUT (FILE2, "OUTPUT STRING");
- CLOSE (FILE2);
- OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME);
-
- BEGIN
- SET_OUTPUT (FILE2);
- FAILED ("MODE_ERROR NOT RAISED FOR SET_OUTPUT WITH " &
- "MODE IN_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT");
- END;
-
- BEGIN
- DELETE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3207A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada
deleted file mode 100644
index 4766cb9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada
+++ /dev/null
@@ -1,176 +0,0 @@
--- CE3301A.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 WHEN THE LINE AND PAGE LENGTH ARE NONZERO, LINE AND
--- PAGE TERMINATORS ARE OUTPUT AT THE APPROPRIATE POINTS.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/22/82
--- SPS 11/15/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/27/87 COMPLETELY REVISED TEST.
--- LDC 05/26/88 ADDED "FILE" PARAMETERS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3301A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- TWO : CONSTANT COUNT := COUNT(IDENT_INT(2));
- TEN : CONSTANT COUNT := COUNT(IDENT_INT(10));
- THREE : CONSTANT COUNT := COUNT(IDENT_INT(3));
- ITEM1 : STRING (1..10);
- ITEM2 : STRING (1..2);
-
-BEGIN
-
- TEST ("CE3301A", "CHECK THAT WHEN THE LINE AND PAGE LENGTH ARE " &
- "NONZERO, LINE AND PAGE TERMINATORS ARE " &
- "OUTPUT AT THE APPROPRIATE POINTS");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF LINE_LENGTH (FILE) /= UNBOUNDED THEN
- FAILED ("LINE LENGTH NOT INITIALLY UNBOUNDED");
- END IF;
-
- IF PAGE_LENGTH (FILE) /= UNBOUNDED THEN
- FAILED ("PAGE LENGTH NOT INITIALLY UNBOUNDED");
- END IF;
-
- SET_LINE_LENGTH (FILE,TEN);
- SET_PAGE_LENGTH (FILE,TWO);
-
- FOR I IN 1 .. 30 LOOP
- PUT (FILE,'C');
- END LOOP;
-
- IF PAGE (FILE) /= 2 AND LINE (FILE) /= 1 THEN
- FAILED ("LINE AND PAGE LENGTHS WERE NOT BOUND " &
- "CORRECTLY");
- END IF;
-
- SET_LINE_LENGTH (FILE, TWO);
- SET_PAGE_LENGTH (FILE, THREE);
- PUT (FILE, "DDDDDDD");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM1);
-
- IF NOT (END_OF_LINE (FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR");
- END IF;
-
- IF END_OF_PAGE (FILE) THEN
- FAILED ("PAGE TERMINATOR OUTPUT AT INAPPROPRIATE POINT");
- END IF;
-
- GET (FILE, ITEM1);
-
- IF ITEM1 /= "CCCCCCCCCC" THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- IF NOT (END_OF_LINE(FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR");
- END IF;
-
- IF NOT (END_OF_PAGE(FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR");
- END IF;
-
- GET (FILE, ITEM1);
- GET (FILE, ITEM2);
-
- IF ITEM2 /= "DD" THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- IF NOT (END_OF_LINE(FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR");
- END IF;
-
- IF END_OF_PAGE (FILE) THEN
- FAILED ("PAGE TERMINATOR OUTPUT AT INAPPROPRIATE POINT");
- END IF;
-
- GET (FILE, ITEM2);
-
- IF ITEM2 /= "DD" THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- IF NOT (END_OF_LINE(FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR");
- END IF;
-
- IF NOT (END_OF_PAGE(FILE)) THEN
- FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3301A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada
deleted file mode 100644
index 905da7a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- CE3302A.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 SET_LINE_LENGTH, SET_PAGE_LENGTH, LINE_LENGTH, AND
--- PAGE_LENGTH RAISE MODE_ERROR WHEN APPLIED TO A FILE OF MODE
--- IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/19/87 CREATED AN EXTERNAL FILE WITH A NAME, REMOVED
--- DEPENDENCE ON RESET, AND ADDED CODE TO DELETE
--- EXTERNAL FILE.
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3302A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- FIVE : COUNT := COUNT(IDENT_INT(5));
- VAR1 : COUNT;
- ITEM : CHARACTER := 'A';
-
-BEGIN
- TEST ("CE3302A", "CHECK THAT SET_LINE_LENGTH, SET_PAGE_LENGTH, " &
- "LINE_LENGTH, AND PAGE_LENGTH RAISE MODE_ERROR " &
- "WHEN APPLIED TO A FILE OF MODE IN_FILE");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT FILE CREATE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT FILE CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, ITEM);
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT FILE OPEN");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SET_LINE_LENGTH (FILE, FIVE);
- FAILED ("MODE_ERROR NOT RAISED - SET_LINE_LENGTH");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - SET_LINE_LENGTH");
- END;
-
- BEGIN
- SET_PAGE_LENGTH (FILE, FIVE);
- FAILED ("MODE_ERROR NOT RAISED - SET_PAGE_LENGTH");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - SET_PAGE_LENGTH");
- END;
-
- BEGIN
- VAR1 := LINE_LENGTH (FILE);
- FAILED ("MODE_ERROR NOT RAISED - LINE_LENGTH");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - LINE_LENGTH");
- END;
-
- BEGIN
- VAR1 := PAGE_LENGTH (FILE);
- FAILED ("MODE_ERROR NOT RAISED - PAGE_LENGTH");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PAGE_LENGTH");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3302A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada
deleted file mode 100644
index 50facad..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- CE3303A.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 SET_LINE_LENGTH, SET_PAGE_LENGTH, LINE_LENGTH, AND
--- PAGE_LENGTH RAISE STATUS_ERROR WHEN APPLIED TO A CLOSED FILE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- JLH 08/19/87 ADDED AN ATTEMPT TO CREATE AN EXTERNAL FILE;
--- ADDED CHECKS TO THE SAME FOUR CASES WHICH EXIST
--- IN TEST AGAINST ATTEMPTED CREATE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3303A IS
-
- FILE : FILE_TYPE;
- FIVE : COUNT := COUNT(IDENT_INT(5));
- C : COUNT;
- ITEM : CHARACTER := 'A';
-
-BEGIN
-
- TEST ("CE3303A" , "CHECK THAT SET_LINE_LENGTH, " &
- "SET_PAGE_LENGTH, LINE_LENGTH, AND " &
- "PAGE_LENGTH RAISE STATUS_ERROR " &
- "WHEN APPLIED TO A CLOSED FILE");
-
--- FILE NONEXISTANT
-
- BEGIN
- SET_LINE_LENGTH (FILE, FIVE);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_LINE_LENGTH - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR SET_LINE_LENGTH " &
- "- 1");
- END;
-
- BEGIN
- SET_PAGE_LENGTH (FILE, FIVE);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_PAGE_LENGTH - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR SET_PAGE_LENGTH " &
- "- 1");
- END;
-
- BEGIN
- C := LINE_LENGTH (FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR LINE_LENGTH - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR LINE_LENGTH - 1");
- END;
-
- BEGIN
- C := PAGE_LENGTH (FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR PAGE_LENGTH - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR PAGE_LENGTH - 1");
- END;
-
- BEGIN
- CREATE (FILE, OUT_FILE);
- PUT (FILE, ITEM);
- CLOSE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- SET_LINE_LENGTH (FILE, FIVE);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_LINE_LENGTH - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR SET_LINE_LENGTH " &
- "- 2");
- END;
-
- BEGIN
- SET_PAGE_LENGTH (FILE, FIVE);
- FAILED ("STATUS_ERROR NOT RAISED FOR SET_PAGE_LENGTH - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR SET_PAGE_LENGTH " &
- "- 2");
- END;
-
- BEGIN
- C := LINE_LENGTH (FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR LINE_LENGTH - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR LINE_LENGTH - 2");
- END;
-
- BEGIN
- C := PAGE_LENGTH (FILE);
- FAILED ("STATUS_ERROR NOT RAISED FOR PAGE_LENGTH - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR PAGE_LENGTH - 2");
- END;
-
- RESULT;
-
-END CE3303A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst b/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst
deleted file mode 100644
index e1ee3f8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst
+++ /dev/null
@@ -1,204 +0,0 @@
--- CE3304A.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.
---*
--- OBJECTIVE:
--- CHECK THAT USE_ERROR IS RAISED BY A CALL TO SET_LINE_LENGTH
--- OR TO SET_PAGE_LENGTH WHEN THE SPECIFIED VALUE IS INAPPROPRIATE
--- FOR THE EXTERNAL FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS THAT SATISFY THE
--- FOLLOWING CONDITIONS:
--- 1) TEXT FILES ARE SUPPORTED
--- 2) EITHER BY DEFAULT OR BY USE OF THE "FORM" PARAMETER TO
--- THE CREATE PROCEDURE, A TEXT FILE CAN BE CREATED FOR
--- WHICH AT LEAST ONE OF THE FOLLOWING CONDITIONS HOLDS:
--- A) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT
--- AN APPROPRIATE LINE-LENGTH FOR THE FILE,
--- OR
--- B) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT
--- AN APPROPRIATE PAGE-LENGTH FOR THE FILE.
-
--- MACRO SUBSTITUTIONS:
--- FOR THE MACRO SYMBOL "$FORM_STRING," SUBSTITUTE A STRING LITERAL
--- SPECIFIYING THAT THE EXTERNAL FILE MEETS BOTH OF THE CONDITIONS
--- (A) AND (B) ABOVE. IF IT IS NOT POSSIBLE TO SATISFY BOTH
--- CONDITIONS, THEN SUBSTITUTE A STRING LITERAL SPECIFYING THAT THE
--- EXTERNAL FILE SATISFIES ONE OF THE CONDITIONS. IF IT IS NOT
--- POSSIBLE TO SATISFY EITHER CONDITION, THEN SUBSTITUE THE NULL
--- STRING ("").
--- FOR THE MACRO SYMBOL "$INAPPROPRIATE_LINE_LENGTH," SUBSTITUTE
--- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE LINE-LENGTH
--- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1.
--- FOR THE MACRO SYMBOL "$INAPPROPRIATE_PAGE_LENGTH," SUBSTITUTE
--- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE PAGE-LENGTH
--- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1.
-
--- HISTORY:
--- PWB 07/07/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3304A IS
-
- FILE1,
- FILE2,
- FILE3 : FILE_TYPE;
-
- LINE_LENGTH_SHOULD_WORK,
- PAGE_LENGTH_SHOULD_WORK : BOOLEAN;
-
- INCOMPLETE : EXCEPTION;
-
- TEST_VALUE : COUNT;
-
-BEGIN
-
- TEST ("CE3304A", "CHECK THAT USE_ERROR IS RAISED IF A CALL TO " &
- "SET_LINE_LENGTH OR SET_PAGE_LENGTH SPECIFIES " &
- "A VALUE THAT IS INAPPROPRIATE FOR THE " &
- "EXTERNAL FILE");
-
- BEGIN -- CHECK WHETHER TEXT FILES ARE SUPPORTED.
-
- CREATE(FILE1, OUT_FILE, LEGAL_FILE_NAME(1),
- FORM => $FORM_STRING);
- PUT_LINE(FILE1, "AAA");
- CLOSE(FILE1);
-
- EXCEPTION
-
- WHEN USE_ERROR | NAME_ERROR =>
- NOT_APPLICABLE ("CREATION OF TEXT FILES NOT SUPPORTED");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED AT INITIAL CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN -- CHECK INAPPROPRIATE LINE LENGTH.
-
- BEGIN -- IS THERE AN INAPPROPRIATE VALUE?
- TEST_VALUE :=
- COUNT(IDENT_INT($INAPPROPRIATE_LINE_LENGTH));
- IF NOT EQUAL (INTEGER(TEST_VALUE),
- INTEGER(TEST_VALUE)) THEN
- COMMENT ("OPTIMIZATION DEFEATED" &
- COUNT'IMAGE(TEST_VALUE));
- END IF;
- LINE_LENGTH_SHOULD_WORK := TRUE;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- LINE_LENGTH_SHOULD_WORK := FALSE;
- COMMENT("THERE IS NO INAPPROPRIATE LINE LENGTH");
- END;
-
- IF LINE_LENGTH_SHOULD_WORK THEN
- BEGIN
- CREATE(FILE2, OUT_FILE, LEGAL_FILE_NAME(2),
- FORM => $FORM_STRING);
- SET_LINE_LENGTH(FILE2, $INAPPROPRIATE_LINE_LENGTH);
- FAILED("NO EXCEPTION FOR INAPPROPRIATE LINE " &
- "LENGTH");
- EXCEPTION
- WHEN USE_ERROR =>
- IF NOT IS_OPEN(FILE2) THEN
- FAILED ("FILE NOT OPENED -- LINE LENGTH");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "INAPPROPRIATE LINE LENGTH");
- END;
- END IF;
- END;
-
------------------------------------------------------------------------
-
- BEGIN -- CHECK INAPPROPRIATE PAGE LENGTH.
-
- BEGIN -- IS THERE AN INAPPROPRIATE VALUE?
- TEST_VALUE :=
- COUNT(IDENT_INT($INAPPROPRIATE_PAGE_LENGTH));
- IF NOT EQUAL (INTEGER(TEST_VALUE),
- INTEGER(TEST_VALUE)) THEN
- COMMENT ("OPTIMIZATION DEFEATED" &
- COUNT'IMAGE(TEST_VALUE));
- END IF;
- PAGE_LENGTH_SHOULD_WORK := TRUE;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- PAGE_LENGTH_SHOULD_WORK := FALSE;
- COMMENT("THERE IS NO INAPPROPRIATE PAGE LENGTH");
- END;
-
- IF PAGE_LENGTH_SHOULD_WORK THEN
- BEGIN
- CREATE(FILE3, OUT_FILE, LEGAL_FILE_NAME(3),
- FORM => $FORM_STRING);
- SET_PAGE_LENGTH(FILE3, $INAPPROPRIATE_PAGE_LENGTH);
- FAILED("NO EXCEPTION FOR INAPPROPRIATE PAGE " &
- "LENGTH");
- EXCEPTION
- WHEN USE_ERROR =>
- IF NOT IS_OPEN(FILE3) THEN
- FAILED ("FILE NOT OPENED -- PAGE LENGTH");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "INAPPROPRIATE PAGE LENGTH");
- END;
- END IF;
- END;
-
- IF NOT (PAGE_LENGTH_SHOULD_WORK OR LINE_LENGTH_SHOULD_WORK) THEN
- NOT_APPLICABLE("NO INAPPROPRIATE VALUES FOR EITHER LINE " &
- "LENGTH OR PAGE LENGTH");
- END IF;
-
- BEGIN -- CLEAN UP FILES.
-
- IF IS_OPEN(FILE1) THEN
- CLOSE(FILE1);
- END IF;
-
- IF IS_OPEN(FILE2) THEN
- CLOSE(FILE2);
- END IF;
-
- IF IS_OPEN(FILE3) THEN
- CLOSE(FILE3);
- END IF;
-
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT("FILES NOT DELETED");
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3304A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada
deleted file mode 100644
index 1807d91..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada
+++ /dev/null
@@ -1,182 +0,0 @@
--- CE3305A.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 LINE AND PAGE LENGTHS MAY BE ALTERED DYNAMICALLY
--- SEVERAL TIMES. CHECK THAT WHEN RESET TO ZERO, THE LENGTHS ARE
--- UNBOUNDED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES WITH UNBOUNDED LINE LENGTH.
-
--- HISTORY:
--- SPS 09/28/82
--- EG 05/22/85
--- DWC 08/18/87 ADDED CHECK_FILE WITHOUT A'S.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3305A IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3305A", "CHECK THAT LINE AND PAGE LENGTHS MAY BE " &
- "ALTERED DYNAMICALLY");
-
- DECLARE
- FT : FILE_TYPE;
-
- PROCEDURE PUT_CHARS (CNT: INTEGER; CH: CHARACTER) IS
- BEGIN
- FOR I IN 1 .. CNT LOOP
- PUT (FT, CH);
- END LOOP;
- END PUT_CHARS;
-
- BEGIN
-
- BEGIN
- CREATE(FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 10);
- SET_PAGE_LENGTH (FT, 5);
-
- PUT_CHARS (150, 'X'); -- 15 LINES
-
- BEGIN
- SET_LINE_LENGTH (FT, 5);
- SET_PAGE_LENGTH (FT, 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNABLE TO CHANGE LINE OR PAGE LENGTH");
- END;
-
- PUT_CHARS (50, 'B'); -- 10 LINES
-
- BEGIN
- SET_LINE_LENGTH (FT, 25);
- SET_PAGE_LENGTH (FT,4);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("UNABLE TO CHANGE LINE OR PAGE LENGTH - 2");
- END;
-
- PUT_CHARS (310, 'K'); -- 12 LINES, 10 CHARACTERS
-
--- THIS CAN RAISE USE_ERROR IF AN IMPLEMENTATION REQUIRES A BOUNDED
--- LINE LENGTH FOR AN EXTERNAL FILE.
-
- BEGIN
- BEGIN
- SET_LINE_LENGTH (FT, UNBOUNDED);
- SET_PAGE_LENGTH (FT, UNBOUNDED);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("BOUNDED LINE LENGTH " &
- "REQUIRED");
- RAISE INCOMPLETE;
- END;
-
- PUT_CHARS (100, 'A'); -- ONE LINE
-
- CHECK_FILE (FT,"XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#@" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#@" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "XXXXXXXXXX#" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBB#@" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBB#" &
- "BBBBBKKKKKKKKKKKKKKKKKKKK#@" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#@" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#@" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#" &
- "KKKKKKKKKKKKKKKKKKKKKKKKK#"&
- "KKKKKKKKKKKKKKKKKKKKKKKKK#"&
- "KKKKKKKKKKKKKKKAAAAAAAAAAA" &
- "AAAAAAAAAAAAAAAAAAAAAAAAAA" &
- "AAAAAAAAAAAAAAAAAAAAAAAAAA" &
- "AAAAAAAAAAAAAAAAAAAAAAAAAA" &
- "AAAAAAAAAAA#@%");
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3305A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada
deleted file mode 100644
index c021f31..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada
+++ /dev/null
@@ -1,82 +0,0 @@
--- CE3306A.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 CONSTRAINT_ERROR IS RAISED IF THE VALUE OF 'TO' IS
--- NEGATIVE OR GREATER THAN COUNT'LAST WHEN COUNT'LAST IS LESS THAN
--- COUNT'BASE'LAST.
-
--- HISTORY:
--- JET 08/17/88 CREATED ORIGINAL TEST.
--- PWN 10/27/95 REMOVED CONSTRAINT CHECK THAT NOW HAPPENS AT
--- COMPILE TIME.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-PROCEDURE CE3306A IS
-
-BEGIN
- TEST ("CE3306A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " &
- "VALUE OF 'TO' IS NEGATIVE OR GREATER THAN " &
- "COUNT'LAST WHEN COUNT'LAST IS LESS THAN " &
- "COUNT'BASE'LAST");
-
- BEGIN
- SET_LINE_LENGTH(-1);
- FAILED("NO EXCEPTION FOR SET_LINE_LENGTH(-1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION FOR SET_LINE_LENGTH(-1)");
- END;
-
- BEGIN
- SET_PAGE_LENGTH(COUNT(IDENT_INT(-1)));
- FAILED("NO EXCEPTION FOR SET_PAGE_LENGTH(-1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION FOR SET_PAGE_LENGTH(-1)");
- END;
-
- IF COUNT'LAST < COUNT'BASE'LAST THEN
- BEGIN
- SET_LINE_LENGTH(COUNT'LAST + COUNT(IDENT_INT(1)));
- FAILED("NO EXCEPTION FOR SET_LINE_LENGTH(COUNT'LAST+1)");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION FOR SET_LINE_LENGTH" &
- "(COUNT'LAST+1)");
- END;
-
- ELSE
- COMMENT("COUNT'LAST IS EQUAL TO COUNT'BASE'LAST");
- END IF;
-
- RESULT;
-END CE3306A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada
deleted file mode 100644
index 714e16c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada
+++ /dev/null
@@ -1,105 +0,0 @@
--- CE3401A.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 FORMAL PARAMETERS OF EACH COLUMN, LINE, AND
--- PAGE OPERATION ARE NAMED CORRECTLY.
-
--- HISTORY:
--- JET 08/17/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-PROCEDURE CE3401A IS
-
- FIN, FOUT : FILE_TYPE;
- B : BOOLEAN;
- C : COUNT;
- FILE_OK : BOOLEAN := FALSE;
-
-BEGIN
- TEST ("CE3401A", "CHECK THAT THE FORMAL PARAMETERS OF EACH " &
- "COLUMN, LINE, AND PAGE OPERATION ARE NAMED " &
- "CORRECTLY");
-
- BEGIN
- CREATE(FOUT, OUT_FILE, LEGAL_FILE_NAME);
- FILE_OK := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- NOT_APPLICABLE("OUTPUT FILE COULD NOT BE CREATED");
- END;
-
- IF FILE_OK THEN
- NEW_LINE(FILE => FOUT, SPACING => 1);
- NEW_PAGE(FILE => FOUT);
- SET_COL(FILE => FOUT, TO => 1);
- SET_LINE(FILE => FOUT, TO => 1);
- C := COL(FILE => FOUT);
- C := LINE(FILE => FOUT);
- C := PAGE(FILE => FOUT);
-
- NEW_PAGE(FOUT);
-
- BEGIN
- CLOSE(FOUT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED("OUTPUT FILE COULD NOT BE CLOSED");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- BEGIN
- OPEN(FIN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN OTHERS =>
- FAILED("INPUT FILE COULD NOT BE OPENED");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- SKIP_LINE(FILE => FIN, SPACING => 1);
- SKIP_PAGE(FILE => FIN);
- B := END_OF_LINE(FILE => FIN);
- B := END_OF_PAGE(FILE => FIN);
- B := END_OF_FILE(FILE => FIN);
-
- BEGIN
- DELETE(FIN);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT("FILE COULD NOT BE DELETED");
- WHEN OTHERS =>
- FAILED("UNEXPECTED ERROR AT DELETION");
- END;
- END IF;
-
- RESULT;
-EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED");
-END CE3401A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada
deleted file mode 100644
index 18773f8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE3402A.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 NEW_LINE RAISES MODE_ERROR WHEN THE FILE MODE
--- IS IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/19/87 ADDED ATTEMPT TO DELETE THE FILE AND REPLACED
--- RESET WITH CLOSE AND OPEN.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3402A IS
-
- INCOMPLETE : EXCEPTION;
- FILE1 : FILE_TYPE;
- SPAC : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1));
-
-BEGIN
-
- TEST ("CE3402A" , "CHECK THAT NEW_LINE RAISES MODE_ERROR " &
- "WHEN THE FILE MODE IS IN_FILE");
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT_LINE (FILE1, "STUFF");
- CLOSE (FILE1);
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED FOR OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- NEW_LINE (FILE1,SPAC);
- FAILED ("MODE_ERROR NOT RAISED FOR IN_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR IN_FILE");
- END;
-
- BEGIN
- NEW_LINE (STANDARD_INPUT,SPAC);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR STANDARD_INPUT");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3402A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada
deleted file mode 100644
index ed5d27b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE3402C.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 NEW_LINE INCREMENTS THE CURRENT PAGE BY ONE AND
--- SETS THE CURRENT LINE NUMBER TO ONE WHEN THE PAGE LENGTH IS
--- BOUNDED AND THE LINE NUMBER WOULD HAVE EXCEEDED THE
--- MAXIMUM PAGE LENGTH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 09/01/82
--- SPS 11/30/82
--- SPS 01/24/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/19/87 ADDED ORIGINAL_LINE_LENGTH AND
--- ORIGINAL_PAGE_LENGTH VARIABLES AND CLOSED FILE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3402C IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
- ORIGINAL_LINE_LENGTH : COUNT := LINE_LENGTH;
- ORIGINAL_PAGE_LENGTH : COUNT := PAGE_LENGTH;
-
-BEGIN
-
- TEST ("CE3402C" , "CHECK END_OF_PAGE BEHAVIOR OF NEW_LINE");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FILE,THREE);
- SET_PAGE_LENGTH (FILE,TWO);
-
- FOR I IN 1..6
- LOOP
- PUT (FILE,CHAR);
- END LOOP;
-
- NEW_LINE (FILE);
-
- IF PAGE (FILE) /= TWO THEN
- FAILED ("PAGE NOT INCREMENTED BY ONE");
- END IF;
-
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE NOT SET TO ONE");
- END IF;
-
- NEW_LINE (FILE, 7);
- IF PAGE (FILE) /= POSITIVE_COUNT(IDENT_INT (5)) THEN
- FAILED ("MULTIPLE PAGES NOT CREATED BY NEW_LINE");
- END IF;
-
- SET_LINE_LENGTH (FILE, ORIGINAL_LINE_LENGTH);
- SET_PAGE_LENGTH (FILE, ORIGINAL_PAGE_LENGTH);
- CHECK_FILE (FILE, "CCC#CCC#@##@##@##@#@%");
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3402C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada
deleted file mode 100644
index a52c7de..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada
+++ /dev/null
@@ -1,92 +0,0 @@
--- CE3402D.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 NEW_LINE SETS THE CURRENT COLUMN NUMBER TO ONE,
--- AND NEW_LINE OUTPUTS LINE TERMINATORS WHEN THE SPACING IS
--- GREATER THAN ONE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATE WITH OUT_FILE MODE FOR TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/19/87 CHANGED FAILED MESSAGE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3402D IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- SPAC3 : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4));
-
-BEGIN
-
- TEST ("CE3402D", "CHECK THAT NEW_LINE SETS THE CURRENT " &
- "COLUMN NUMBER TO ONE, AND NEW_LINE OUTPUTS " &
- "TERMINATORS WHEN THE SPACING IS " &
- "GREATER THAN ONE");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..5 LOOP
- PUT (FILE, 'X');
- END LOOP;
-
- NEW_LINE (FILE, SPAC3);
- IF LINE (FILE) /= FOUR THEN
- FAILED ("NEW_LINE DID NOT OUTPUT LINE TERMINATORS");
- END IF;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("COLUMN NOT SET TO ONE");
- END IF;
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3402D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada
deleted file mode 100644
index 7b49879..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CE3402E.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 NEW_LINE RAISES CONSTRAINT_ERROR IF SPACING IS
--- ZERO, OR NEGATIVE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- JBG 08/30/83
--- DWC 08/19/87 ADDED COUNT'LAST CASE.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3402E IS
-
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3402E" , "CHECK THAT NEW_LINE RAISES CONSTRAINT_ERROR " &
- "IF SPACING IS ZERO, OR NEGATIVE");
-
- BEGIN
- NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR ZERO");
- END;
-
- BEGIN
- NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(-2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR NEGATIVE NUMBER");
- END;
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR ZERO");
- END;
-
- BEGIN
- NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(-2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR NEGATIVE NUMBER");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-
-END CE3402E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada
deleted file mode 100644
index 67ed44c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- CE3403A.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 SKIP_LINE CAN ONLY BE APPLIED TO FILES OF MODE
--- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT CREATION OF TEMPORARY FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/04/87 REVISED EXCEPTION HANDLERS AND ADDED A CASE
--- FOR STANDARD_OUTPUT.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- SPAC : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1));
-
-BEGIN
-
- TEST ("CE3403A" , "CHECK THAT SKIP_LINE CAN ONLY BE " &
- "APPLIED TO FILES OF MODE IN_FILE");
-
- BEGIN
- CREATE (FILE, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE OF " &
- "TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SKIP_LINE (FILE,SPAC);
- FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OUT_FILE");
- END;
-
- BEGIN
- SKIP_LINE (CURRENT_OUTPUT,SPAC);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "CURRENT_OUTPUT");
- END;
-
- BEGIN
- SKIP_LINE (STANDARD_OUTPUT,SPAC);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "STANDARD_OUTPUT");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3403A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada
deleted file mode 100644
index 5cae13d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- CE3403B.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 SPACING PARAMETER OF SKIP_LINE IS OPTIONAL,
--- AND THAT THE DEFAULT VALUE IS ONE.
--- CHECK THAT THE FILE PARAMETER IS ALSO OPTIONAL, AND THAT THE
--- FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 12/14/82
--- JBG 1/17/83
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/04/87 REVISED EXCEPTION HANDLERS, REMOVED
--- DEPENDENCIES ON RESET, AND ADDED AN ATTEMPT
--- TO DELETE FILE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403B IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- SPAC, TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2));
- A : INTEGER := CHARACTER'POS('A');
- CH : CHARACTER;
-
-BEGIN
-
- TEST ("CE3403B" , "CHECK DEFAULT SPACING AND FILE " &
- "OF SKIP_LINE");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1 .. 3 LOOP -- CREATES "BBB#CC#D##F#@%"
- FOR J IN 1 .. 4-I LOOP
- PUT (FILE, CHARACTER'VAL(A + I));
- END LOOP;
- NEW_LINE (FILE);
- END LOOP;
- NEW_LINE (FILE);
- PUT (FILE, 'F');
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, CH);
- IF CH /= CHARACTER'VAL (A + 1) THEN
- FAILED ("LINE CONTENT WRONG - 1");
- END IF;
-
- SKIP_LINE (FILE);
-
- IF LINE (FILE) /= TWO THEN
- FAILED ("SPACING DEFAULT NOT ONE");
- END IF;
-
- GET (FILE, CH);
- IF CH /= CHARACTER'VAL (A + 2) THEN
- FAILED ("LINE CONTENT WRONG - 2");
- END IF;
-
- SET_INPUT (FILE);
- SKIP_LINE (FILE);
-
- IF LINE (FILE) /= 3 THEN
- FAILED ("SKIP_LINE DOES NOT OPERATE CORRECTLY ON " &
- "DEFAULT FILE");
- END IF;
-
- GET (FILE, CH);
- IF CH /= CHARACTER'VAL (A + 3) THEN
- FAILED ("LINE CONTENT WRONG - 3");
- END IF;
-
- SKIP_LINE;
-
- IF LINE (FILE) /= 4 THEN
- FAILED ("LINE COUNT NOT 4; WAS " & COUNT'IMAGE(LINE(FILE)));
- END IF;
-
- GET (FILE, CH);
- IF CH /= 'F' THEN
- FAILED ("NOT RIGHT LINE");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3403B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada
deleted file mode 100644
index d6dd658..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CE3403C.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 SKIP_LINE SETS THE CURRENT COLUMN NUMBER TO ONE,
--- AND THAT IT IS PERFORMED SPACING TIMES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/08/87 REVISED EXCEPTION HANDLING, REMOVED
--- DEPENDENCE ON RESET, AND ADDED NEW CASES.
--- GJD 11/15/95 FIXED ADA 95 INCOMPATIBLE USE OF CHARACTER LITERALS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403C IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- SPAC3 : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4));
- CH: CHARACTER;
-
-BEGIN
-
- TEST ("CE3403C" , "CHECK THAT SKIP_LINE SETS THE CURRENT " &
- "COLUMN NUMBER TO ONE, AND THAT IT IS " &
- "PERFORMED SPACING TIMES");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN CHARACTER RANGE 'A' .. 'E' LOOP
- FOR J IN 1 .. 3 LOOP
- PUT (FILE, I);
- END LOOP;
- NEW_LINE (FILE);
- END LOOP;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF COL (FILE) /= ONE THEN
- FAILED ("COLUMN NOT SET TO ONE");
- END IF;
-
- GET (FILE, CH);
-
- IF CH /= 'A' THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- SKIP_LINE (FILE,SPAC3);
- GET (FILE, CH);
-
- IF CH /= 'D' THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- IF LINE (FILE) /= FOUR THEN
- FAILED ("NOT PERFORMED SPACING TIMES");
- END IF;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3403C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada
deleted file mode 100644
index 6fc1a25..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada
+++ /dev/null
@@ -1,99 +0,0 @@
--- CE3403D.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 SKIP_LINE RAISES CONSTRAINT_ERROR IF SPACING IS
--- ZERO OR NEGATIVE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- SPS 11/11/82
--- DWC 09/09/87 ADDED CASE FOR COUNT'LAST.
--- KAS 11/27/95 REMOVED CASES FOR COUNT'LAST
--- TMB 11/19/96 FIXED OBJECTIVE
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403D IS
-
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3403D" , "CHECK THAT SKIP_LINE RAISES " &
- "CONSTRAINT_ERROR IF SPACING IS ZERO, " &
- "OR NEGATIVE" );
- BEGIN
- SKIP_LINE (FILE, POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO");
- END;
-
- BEGIN
- SKIP_LINE (FILE, POSITIVE_COUNT(IDENT_INT(-2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "NEGATIVE NUMBER");
- END;
-
-
- BEGIN
- SKIP_LINE (POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO " &
- "- DEFAULT");
- END;
-
- BEGIN
- SKIP_LINE (POSITIVE_COUNT(IDENT_INT(-6)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUM " &
- "- DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED NEGATIVE NUM " &
- "- DEFAULT");
- END;
-
-
- RESULT;
-
-END CE3403D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada
deleted file mode 100644
index 3d324a7..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- CE3403E.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 SKIP_LINE INCREMENTS THE CURRENT LINE NUMBER BY ONE
--- AND SETS THE CURRENT COLUMN NUMBER TO ONE IF THE LINE TERMINATOR
--- IS NOT FOLLOWED BY A PAGE TERMINATOR, AND THAT IT SETS BOTH THE
--- LINE AND COLUMN NUMBERS TO ONE AND INCREMENTS THE CURRENT PAGE
--- NUMBER BY ONE IF THE LINE TERMINATOR IS FOLLOWED BY A PAGE
--- TERMINATOR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 REVISED TEST TO USE A FILE NAME, REMOVED
--- DEPENDENCE ON RESET, AND ATTEMPTED TO
--- DELETE THE FILE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403E IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
- CHAR : CHARACTER := ('C');
-
-BEGIN
-
- TEST ("CE3403E" , "CHECK THAT SKIP_LINE SETS COLUMN, " &
- "LINE, AND PAGE NUMBERS CORRECTLY");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, CHAR);
- NEW_LINE (FILE);
- PUT (FILE, CHAR);
- NEW_PAGE (FILE);
- PUT (FILE, CHAR);
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF (LINE (FILE) /= ONE) OR (PAGE (FILE) /= ONE) THEN
- FAILED ("INCORRECT LINE AND PAGE NUMBERS");
- ELSE
-
--- LINE TERMINATOR NOT FOLLOWED BY PAGE TERMINATOR
-
- GET (FILE, CHAR);
-
- IF CHAR /= 'C' THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- SKIP_LINE (FILE);
- IF LINE (FILE) /= TWO THEN
- FAILED ("FIRST SUBTEST - LINE NOT INCREMENTED");
- END IF;
- IF COL (FILE) /= ONE THEN
- FAILED ("FIRST SUBTEST - COLUMN NOT SET TO ONE");
- END IF;
-
--- LINE TERMINATOR FOLLOWED BY PAGE TERMINATOR
-
- GET (FILE, CHAR);
-
- IF CHAR /= 'C' THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- SKIP_LINE (FILE);
- IF LINE (FILE) /= ONE THEN
- FAILED ("SECOND SUBTEST - LINE NOT SET TO ONE");
- END IF;
- IF COL (FILE) /= ONE THEN
- FAILED ("SECOND SUBTEST - COLUMN NOT SET TO ONE");
- END IF;
- IF PAGE (FILE) /= TWO THEN
- FAILED ("SECOND SUBTEST - PAGE NOT INCREMENTED");
- END IF;
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3403E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada
deleted file mode 100644
index ebd6420..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada
+++ /dev/null
@@ -1,156 +0,0 @@
--- CE3403F.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 SKIP_LINE RAISES END_ERROR IF AN ATTEMPT IS
--- MADE TO SKIP A FILE TERMINATOR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 11/11/82
--- SPS 12/14/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 REVISED TEST TO USE A FILE NAME, REMOVED
--- DEPENDENCE ON RESET, AND ADDED ATTEMPT TO
--- DELETE THE FILE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3403F IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT (1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT (2));
-
-BEGIN
- TEST ("CE3403F" , "CHECK THAT SKIP_LINE RAISES END_ERROR " &
- "IF AN ATTEMPT IS MADE TO SKIP A FILE " &
- "TERMINATOR");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..3
- LOOP
- PUT (FILE,CHAR);
- END LOOP;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FILE, CHAR);
- IF CHAR /= 'C' THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- SKIP_LINE (FILE);
- SKIP_LINE (FILE);
- FAILED ("END_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN END_ERROR =>
-
- IF COL (FILE) /= ONE THEN
- FAILED ("COL NOT RESET CORRECTLY");
- END IF;
-
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("NOT POSITIONED AT END OF FILE");
- END IF;
-
- IF PAGE (FILE) /= TWO THEN
- FAILED ("PAGE NOT INCREMENTED");
- END IF;
-
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE NOT RESET CORRECTLY");
- END IF;
-
- IF NOT END_OF_LINE (FILE) THEN
- FAILED ("EOL FALSE AT FILE TERMINATOR");
- END IF;
-
- IF NOT END_OF_PAGE (FILE) THEN
- FAILED ("EOP FALSE AT FILE TERMINATOR");
- END IF;
-
- BEGIN
- SKIP_LINE (FILE);
- FAILED ("END_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
- END;
-
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3403F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada
deleted file mode 100644
index a944138..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada
+++ /dev/null
@@ -1,94 +0,0 @@
--- CE3404A.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 END_OF_LINE RAISES MODE_ERROR WHEN APPLIED TO
--- AN OUT_FILE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/17/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 29/28/87 COMPLETELY REVISED.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3404A IS
-
- MY_FILE : FILE_TYPE;
- BOOL : BOOLEAN;
-
-BEGIN
-
- TEST ("CE3404A", "CHECK THAT END_OF_LINE RAISES MODE_ERROR " &
- "WHEN APPLIED TO AN OUT_FILE");
-
- BEGIN
- BOOL := END_OF_FILE (CURRENT_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT - 1");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "CURRENT_OUTPUT - 2");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (STANDARD_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "STANDARD_OUTPUT - 4");
- END;
-
- BEGIN
- CREATE (MY_FILE);
- BEGIN
- BOOL := END_OF_FILE (MY_FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR MY_FILE - 5");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "MY_FILE - 6");
-
- END;
-
- CLOSE (MY_FILE);
-
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-END CE3404A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada
deleted file mode 100644
index 87ae4b1..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- CE3404B.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 END_OF_LINE OPERATES ON THE CURRENT DEFAULT INPUT FILE
--- IF NO FILE IS SPECIFIED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/17/82
--- SPS 11/11/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 09/22/87 CREATED A NON-TEMP FILE, REMOVED DEPENDENCE ON
--- RESET, AND CHECKED THE VALUE OF THE CHAR READ.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3404B IS
-
- INCOMPLETE : EXCEPTION;
- MY_FILE : FILE_TYPE;
- LOOP_COUNT : INTEGER := 0;
- BOOL : BOOLEAN;
- CHAR : CHARACTER := ('C');
-
-BEGIN
-
- TEST ("CE3404B", "CHECK THAT END_OF_LINE OPERATES ON THE " &
- "CURRENT DEFAULT INPUT FILE IF NO FILE " &
- "IS SPECIFIED");
-
--- CREATE AND INITIALIZE THE FILE
-
- BEGIN
- CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE - 3");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..3 LOOP
- PUT (MY_FILE,CHAR);
- END LOOP;
- NEW_LINE (MY_FILE);
- PUT (MY_FILE,CHAR);
-
- CLOSE (MY_FILE);
-
- BEGIN
- OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE ERROR RAISED ON ATTEMPT TO " &
- "RE-OPEN WITH MODE OF IN_FILE - 4");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (MY_FILE);
-
--- START THE TEST
-
- LOOP
- GET (CHAR);
- IF CHAR /= 'C' THEN
- FAILED ("CHAR READ FROM FILE HAS WRONG VALUE - 5");
- RAISE INCOMPLETE;
- END IF;
- EXIT WHEN END_OF_LINE;
- LOOP_COUNT := LOOP_COUNT + 1;
- IF LOOP_COUNT > IDENT_INT (3) THEN
- FAILED ("END_OF_LINE ON DEFAULT INCORRECT - 6");
- EXIT;
- END IF;
- END LOOP;
-
- GET (CHAR);
- IF CHAR /= 'C' THEN
- FAILED ("FINAL CHAR READ FROM FILE HAS WRONG VALUE - 7");
- END IF;
-
- BEGIN
- DELETE (MY_FILE);
- EXCEPTION
- WHEN OTHERS =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3404B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada
deleted file mode 100644
index c03cf55..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada
+++ /dev/null
@@ -1,165 +0,0 @@
--- CE3404C.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 END_OF_LINE RETURNS THE CORRECT VALUE WHEN POSITIONED
--- AT THE BEGINNING AND THE END OF A LINE, AND WHEN POSITIONED JUST
--- BEFORE THE FILE TERMINATOR.
-
--- CASE 1) BOUNDED LINE LENGTH
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/17/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- GMT 09/22/87 REMOVED DEPENDENCE ON RESET AND MOVED THE CHECK
--- FOR UNBOUNDED LINE_LENGTH TO CE3404D.ADA.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3404C IS
- INCOMPLETE : EXCEPTION;
- MY_FILE : FILE_TYPE;
- ITEM_CHAR : CHARACTER;
- CHAR : CHARACTER := ('C');
- TEN : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(10));
- BLANK_COUNTER : NATURAL := 0;
-
-BEGIN
-
- TEST ("CE3404C", "CHECK THAT END_OF_LINE RETURNS THE CORRECT " &
- "VALUE WHEN POSITIONED AT THE BEGINNING " &
- "AND THE END OF A LINE, AND WHEN POSITIONED " &
- "JUST BEFORE THE FILE TERMINATOR");
-
--- CREATE AND INITIALIZE TEST FILE WITH BOUNDED LINE LENGTH
-
- BEGIN
- CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (MY_FILE,TEN);
-
- FOR I IN 1..5 LOOP
- PUT (MY_FILE, CHAR);
- END LOOP;
- NEW_LINE (MY_FILE);
- PUT (MY_FILE, 'B');
-
- CLOSE (MY_FILE);
-
- BEGIN
- OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- BEGIN THE TEST
-
- IF END_OF_LINE (MY_FILE) THEN
- FAILED ("END_OF_LINE: INCORRECT VALUE AT FIRST POSITION - 5");
- END IF;
-
- IF COL (MY_FILE) /= 1 THEN
- FAILED ("EOL MODIFIED COL NUMBER - 6");
- END IF;
-
- FOR I IN 1..4 LOOP
- GET (MY_FILE,ITEM_CHAR);
- END LOOP;
-
- IF END_OF_LINE (MY_FILE) THEN
- FAILED ("END_OF_LINE: INCORRECT VALUE AT FIFTH POSITION - 7");
- END IF;
-
- GET (MY_FILE,ITEM_CHAR);
-
- WHILE NOT END_OF_LINE (MY_FILE) LOOP
- GET (MY_FILE, ITEM_CHAR);
- IF ITEM_CHAR = ' ' THEN
- BLANK_COUNTER := BLANK_COUNTER + 1;
- ELSE
- FAILED ("STRING WAS PADDED WITH SOMETHING OTHER THAN " &
- "BLANKS - 8");
- END IF;
- END LOOP;
-
- IF BLANK_COUNTER > 5 THEN
- FAILED ("TOO MANY BLANKS WERE USED FOR PADDING - 9");
- END IF;
-
- IF LINE (MY_FILE) /= 1 THEN
- FAILED ("EOL SKIPPED LINE TERMINATOR - 10");
- END IF;
-
- IF NOT END_OF_LINE (MY_FILE) THEN
- FAILED ("EOL SKIPPED LINE TERMINATOR - 11");
- END IF;
-
- SKIP_PAGE (MY_FILE);
-
- IF PAGE (MY_FILE) /= 2 THEN
- FAILED ("INCORRECT PAGE NUMBER");
- END IF;
-
- IF NOT END_OF_LINE (MY_FILE) THEN
- FAILED ("INCORRECT VALUE WHEN POSITIONED JUST BEFORE FILE " &
- "TERMINATOR");
- END IF;
-
- BEGIN
- DELETE (MY_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3404C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada
deleted file mode 100644
index 33e1f72..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- CE3404D.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 END_OF_LINE RETURNS THE CORRECT VALUE WHEN POSITIONED
--- AT THE BEGINNING AND THE END OF A LINE, AND WHEN POSITIONED JUST
--- BEFORE THE FILE TERMINATOR.
-
--- CASE 2) UNBOUNDED LINE LENGTH
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- GMT 09/22/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3404D IS
- INCOMPLETE : EXCEPTION;
- MY_FILE : FILE_TYPE;
- ITEM_CHAR : CHARACTER;
- CHAR : CHARACTER := ('C');
- TEN : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(10));
- BLANK_COUNTER : NATURAL := 0;
-
-BEGIN
-
- TEST ("CE3404D", "CHECK THAT END_OF_LINE RETURNS THE CORRECT " &
- "VALUE WHEN POSITIONED AT THE BEGINNING AND " &
- "THE END OF A LINE, AND WHEN POSITIONED JUST " &
- "BEFORE THE FILE TERMINATOR");
-
--- CREATE AND INITIALIZE TEST FILE WITH BOUNDED LINE LENGTH
-
- BEGIN
- CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..5 LOOP
- PUT (MY_FILE, CHAR);
- END LOOP;
- NEW_LINE (MY_FILE);
- PUT (MY_FILE, 'B');
-
- CLOSE (MY_FILE);
-
- BEGIN
- OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- BEGIN THE TEST
-
- IF END_OF_LINE (MY_FILE) THEN
- FAILED ("END_OF_LINE: INCORRECT VALUE AT FIRST POSITION - 5");
- END IF;
-
- IF COL (MY_FILE) /= 1 THEN
- FAILED ("EOL MODIFIED COL NUMBER - 6");
- END IF;
-
- FOR I IN 1..4 LOOP
- GET (MY_FILE,ITEM_CHAR);
- END LOOP;
-
- IF END_OF_LINE (MY_FILE) THEN
- FAILED ("END_OF_LINE: INCORRECT VALUE AT FIFTH POSITION - 7");
- END IF;
-
- GET (MY_FILE,ITEM_CHAR);
-
- WHILE NOT END_OF_LINE (MY_FILE) LOOP
- GET (MY_FILE, ITEM_CHAR);
- IF ITEM_CHAR = ' ' THEN
- FAILED ("STRING WAS PADDED WITH SOMETHING OTHER THAN " &
- "BLANKS - 8");
- END IF;
- END LOOP;
-
- IF LINE (MY_FILE) /= 1 THEN
- FAILED ("EOL SKIPPED LINE TERMINATOR - 10");
- END IF;
-
- IF NOT END_OF_LINE (MY_FILE) THEN
- FAILED ("EOL SKIPPED LINE TERMINATOR - 11");
- END IF;
-
- SKIP_PAGE (MY_FILE);
-
- IF PAGE (MY_FILE) /= 2 THEN
- FAILED ("INCORRECT PAGE NUMBER");
- END IF;
-
- IF NOT END_OF_LINE (MY_FILE) THEN
- FAILED ("INCORRECT VALUE WHEN POSITIONED JUST BEFORE " &
- "TERMINATOR");
- END IF;
-
- BEGIN
- DELETE (MY_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3404D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada
deleted file mode 100644
index d035af7..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- CE3405A.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 NEW_PAGE OUTPUTS A LINE TERMINATOR FOLLOWED BY A PAGE
--- TERMINATOR IF THE CURRENT LINE IS NOT AT COLUMN 1 OR IF THE
--- CURRENT PAGE IS AT LINE 1; IF THE CURRENT LINE IS AT COLUMN 1,
--- OUTPUTS A PAGE TERMINATOR ONLY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 09/02/82
--- JBG 01/18/83
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/23/87 ADDED A CASE WHICH CALLS NEW_LINE AND NEW_PAGE
--- CONSECUTIVELY AND SEPARATED CASES INTO DIFFERENT
--- IF STATEMENTS. ADDED CHECK FOR USE_ERROR ON
--- DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3405A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4));
- CHAR : CHARACTER := ('C');
-
-BEGIN
-
- TEST ("CE3405A", "CHECK THAT NEW_PAGE OUTPUTS A LINE TERMINATOR " &
- "FOLLOWED BY A PAGE TERMINATOR IF THE CURRENT " &
- "LINE IS NOT AT COLUMN 1 OR IF THE CURRENT " &
- "PAGE IS AT LINE 1; IF THE CURRENT LINE IS AT " &
- "COLUMN 1, OUTPUTS A PAGE TERMINATOR ONLY");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- NEW_PAGE (FILE);
- NEW_PAGE (FILE); -- CURRENT PAGE TERMINATED
- IF PAGE (FILE) /= THREE THEN
- FAILED ("INITIAL PAGE COUNT INCORRECT");
- END IF;
-
- SET_LINE_LENGTH (FILE,THREE);
- PUT (FILE,CHAR);
- NEW_LINE (FILE);
-
- IF LINE (FILE) /= TWO THEN
- FAILED ("INCORRECT LINE NUMBER - 1");
- END IF;
-
- IF PAGE (FILE) /= THREE THEN
- FAILED ("INCORRECT PAGE NUMBER - 2");
- END IF;
-
- NEW_PAGE (FILE); -- CURRENT LINE TERMINATED (B)
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE NUMBER NOT INCREMENTED");
- END IF;
- IF PAGE (FILE) /= FOUR THEN
- FAILED ("PAGE NUMBER NOT INCREMENTED");
- END IF;
- PUT (FILE, IDENT_CHAR('E')); -- CURRENT LINE NOT TERM (C)
- NEW_PAGE (FILE);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
-
- CHECK_FILE (FILE, "#@#@C#@E#@#@%");
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3405A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada
deleted file mode 100644
index 27f1574..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada
+++ /dev/null
@@ -1,126 +0,0 @@
--- CE3405C.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 NEW_PAGE RAISES MODE_ERROR IF THE FILE SPECIFIED
--- HAS MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/23/87 CREATED AN EXTERNAL FILE, REMOVED DEPENDENCE ON
--- RESET, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3405C IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3405C", "CHECK THAT NEW_PAGE RAISES MODE_ERROR IF THE " &
- "FILE SPECIFIED HAS MODE IN_FILE");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "STUFF");
-
- CLOSE (FILE);
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- NEW_PAGE (FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR IN_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR IN_FILE");
- END;
-
- BEGIN
- NEW_PAGE (STANDARD_INPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_INPUT");
- END;
-
- BEGIN
- NEW_PAGE (CURRENT_INPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_INPUT");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3405C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada
deleted file mode 100644
index b21fb1d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada
+++ /dev/null
@@ -1,114 +0,0 @@
--- CE3405D.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 NEW_PAGE INCREMENTS THE CURRENT PAGE NUMBER AND
--- SETS THE CURRENT COLUMN AND LINE NUMBERS TO ONE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 08/28/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/23/87 CORRECTED EXCEPTION HANDLING AND ADDED CASES FOR
--- CONSECUTIVE NEW_LINE AND NEW_PAGE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3405D IS
- INCOMPLETE : EXCEPTION;
-BEGIN
-
- TEST ("CE3405D", "CHECK THAT NEW_PAGE INCREMENTS PAGE COUNT " &
- "AND SETS COLUMN AND LINE TO ONE");
-
- DECLARE
- FT : FILE_TYPE;
- CH : CHARACTER;
- PG_NUM : POSITIVE_COUNT;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILE WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "STRING");
- NEW_LINE (FT);
- PUT (FT, 'X');
- PG_NUM := PAGE (FT);
-
- NEW_PAGE (FT);
-
- IF COL(FT) /= 1 THEN
- FAILED ("COLUMN NUMBER NOT RESET - OUTPUT - 1");
- END IF;
- IF LINE (FT) /= 1 THEN
- FAILED ("LINE NUMBER NOT RESET - OUTPUT - 1");
- END IF;
- IF PAGE (FT) /= PG_NUM + 1 THEN
- FAILED ("PAGE NUMBER NOT INCREMENTED - OUTPUT - 1");
- END IF;
-
- PUT (FT, "MORE STUFF");
- NEW_LINE (FT);
- NEW_PAGE (FT);
-
- IF COL(FT) /= 1 THEN
- FAILED ("COLUMN NUMBER NOT RESET - OUTPUT - 2");
- END IF;
- IF LINE (FT) /= 1 THEN
- FAILED ("LINE NUMBER NOT RESET - OUTPUT - 2");
- END IF;
- IF PAGE (FT) /= PG_NUM + 2 THEN
- FAILED ("PAGE NUMBER NOT INCREMENTED - OUTPUT - 2");
- END IF;
-
- CHECK_FILE (FT, "STRING#X#@MORE STUFF#@%");
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3405D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada
deleted file mode 100644
index 1476518..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- CE3406A.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 SKIP_PAGE READS AND DISCARDS CHARACTERS AND LINE
--- TERMINATORS UNTIL A PAGE TERMINATOR IS READ, ADDS ONE TO THE
--- CURRENT PAGE NUMBER, AND SETS THE CURRENT COLUMN NUMBER AND LINE
--- NUMBER TO ONE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/17/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE
--- ON RESET, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3406A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- CHAR_X : CHARACTER := ('X');
- ITEM_CHAR : CHARACTER;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
-
-BEGIN
-
- TEST ("CE3406A", "CHECK THAT SKIP_LINE READS AND " &
- "SETS PAGE AND COLUMN CORRECTLY");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "CDE");
- NEW_LINE (FILE);
- PUT (FILE, "FGHI");
- NEW_LINE (FILE);
- PUT (FILE, "JK");
- NEW_PAGE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE,CHAR_X);
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF (LINE (FILE) /= ONE) THEN
- FAILED ("LINE NUMBER NOT EQUAL TO ONE");
- END IF;
-
- IF (PAGE (FILE) /= ONE) THEN
- FAILED ("PAGE NUMBER NOT EQUAL TO ONE");
- END IF;
-
- GET (FILE, ITEM_CHAR);
-
- IF ITEM_CHAR /= 'C' THEN
- FAILED ("INCORRECT VALUE READ FROM FILE - 1");
- END IF;
-
- SKIP_PAGE (FILE);
-
- IF COL (FILE) /= ONE THEN
- FAILED ("COLUMN NOT SET TO ONE - 1");
- END IF;
-
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE NOT SET TO ONE - 1");
- END IF;
-
- IF PAGE (FILE) /= TWO THEN
- FAILED ("PAGE NOT SET TO TWO");
- END IF;
-
- SKIP_PAGE (FILE);
-
- IF COL (FILE) /= ONE THEN
- FAILED ("COLUMN NOT SET TO ONE - 2");
- END IF;
-
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE NOT SET TO ONE - 2");
- END IF;
-
- IF PAGE (FILE) /= THREE THEN
- FAILED ("PAGE NOT SET TO THREE");
- END IF;
-
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'X' THEN
- FAILED ("INCORRECT VALUE READ FROM FILE - 2");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3406A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada
deleted file mode 100644
index 95e7c7a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada
+++ /dev/null
@@ -1,104 +0,0 @@
--- CE3406B.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 SKIP_PAGE CAN ONLY BE APPLIED TO FILES OF MODE
--- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILE CREATE WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/24/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3406B IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3406B", "CHECK THAT SKIP_PAGE CAN ONLY BE " &
- "APPLIED TO FILES OF MODE IN_FILE");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SKIP_PAGE (FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR OUT_FILE");
- END;
-
- BEGIN
- SKIP_PAGE (STANDARD_OUTPUT);
- FAILED ("MODE_ERROR RAISED FOR STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_OUTPUT");
- END;
-
- BEGIN
- SKIP_PAGE (CURRENT_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_OUTPUT");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3406B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada
deleted file mode 100644
index bc30274..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada
+++ /dev/null
@@ -1,148 +0,0 @@
--- CE3406C.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 SKIP_PAGE RAISES END_ERROR WHEN THE FILE IS POSITIONED
--- BEFORE THE FILE TERMINATOR BUT NOT WHEN THE FILE IS POSITIONED
--- BEFORE THE FINAL PAGE TERMINATOR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/17/82
--- JBG 01/24/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE
--- ON RESET, AND CHECKED CHARACTER READ IN.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3406C IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
-
-BEGIN
-
- TEST ("CE3406C", "CHECK THAT SKIP_PAGE RAISES END_ERROR WHEN " &
- "THE FILE IS POSITIONED BEFORE THE FILE " &
- "TERMINATOR BUT NOT WHEN THE FILE IS " &
- "POSITIONED BEFORE THE FINAL PAGE TERMINATOR");
-
--- CREATE AND INITIALIZE FILE
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..2 LOOP
- FOR I IN 1..3 LOOP
- PUT (FILE,CHAR);
- END LOOP;
- NEW_LINE (FILE);
- END LOOP;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- START TEST
-
--- TEST SKIP_PAGE BEFORE FINAL PAGE TERMINATOR
-
- WHILE NOT END_OF_PAGE (FILE) LOOP
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'C' THEN
- FAILED ("INCORRECT VALUE READ FROM FILE");
- END IF;
- END LOOP;
-
- BEGIN
- SKIP_PAGE (FILE);
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("RAISED END_ERROR BEFORE FINAL PAGE " &
- "TERMINATOR - 1");
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
- END;
-
- IF PAGE (FILE) /= TWO THEN
- FAILED ("PAGE NOT SET TO TWO");
- END IF;
-
--- TEST SKIP_PAGE BEFORE FILE TERMINATOR
- BEGIN
- SKIP_PAGE (FILE);
- FAILED ("END_ERROR NOT RAISED");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3406C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada
deleted file mode 100644
index fa1ba25..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CE3406D.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 SKIP_PAGE OPERATES ON THE CURRENT DEFAULT INPUT
--- FILE WHEN NO FILE IS SPECIFIED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- JBG 01/26/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE
--- ON RESET, AND CHECKED CHARACTER READ IN.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3406D IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ITEM_CHAR : CHARACTER;
- TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
-
-BEGIN
-
- TEST ("CE3406D", "CHECK THAT SKIP_PAGE OPERATES ON THE CURRENT " &
- "DEFAULT INPUT FILE WHEN NO FILE IS SPECIFIED");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "ABC");
- NEW_PAGE (FILE);
- PUT (FILE, "DEF");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE);
-
- SKIP_PAGE;
-
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'D' THEN
- FAILED ("INCORRECT VALUE READ FROM FILE");
- END IF;
-
- IF PAGE (CURRENT_INPUT) /= TWO THEN
- FAILED ("SKIP_PAGE NOT APPLIED TO CURRENT_INPUT");
- END IF;
-
- SKIP_PAGE (FILE);
-
- IF PAGE (CURRENT_INPUT) /= THREE THEN
- FAILED ("SKIP_PAGE NOT APPLIED TO CURRENT_INPUT");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3406D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada
deleted file mode 100644
index d3a0052..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- CE3407A.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 END_OF_PAGE RETURNS THE CORRECT VALUE WHEN POSITIONED
--- AT THE BEGINNING AND AT THE END OF THE PAGE, AND BEFORE A FILE
--- TERMINATOR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/22/82
--- JBG 01/26/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/28/87 REMOVED UNNECESSARY CODE, REMOVED DEPENDENCE
--- ON RESET AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3407A IS
-
- INCOMPLETE : EXCEPTION;
- FILE1 : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3407A", "CHECK THAT END_OF_PAGE RETURNS " &
- "THE CORRECT VALUE");
-
--- CREATE & INITIALIZE OUTPUT FILE
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..6 LOOP
- PUT (FILE1, CHAR);
- END LOOP;
-
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION - 1");
- END IF;
-
- IF END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION - 2");
- END IF;
-
--- TEST WHEN POSITIONED BEFORE LAST CHARACTER IN FILE
-
- FOR I IN 1..5 LOOP
- GET (FILE1, ITEM_CHAR);
- END LOOP;
-
- IF END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER");
- END IF;
-
--- TEST WHEN AT END OF FILE
-
- GET (FILE1, ITEM_CHAR);
- IF NOT END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE AT LAST POSITION");
- END IF;
-
- SKIP_PAGE (FILE1);
-
- IF NOT END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 1");
- END IF;
-
- IF NOT END_OF_PAGE (FILE1) THEN
- FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 2");
- END IF;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3407A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada
deleted file mode 100644
index c4a509c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- CE3407B.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 END_OF_PAGE CAN ONLY BE APPLIED TO FILES OF MODE
--- IN_FILE, THAT MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/22/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/28/87 CORRECTED EXCEPTION HANDLING AND ADDED CASE
--- FOR CURRENT_OUTPUT.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3407B IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- BOOL : BOOLEAN;
-
-BEGIN
-
- TEST ("CE3407B", "CHECK THAT END_OF_PAGE RAISES MODE_ERROR " &
- "FOR FILES OF MODE OUT_FILE");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " &
- "TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- BOOL := END_OF_PAGE (FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR OUT_FILE");
- END;
-
- BEGIN
- BOOL := END_OF_PAGE (STANDARD_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_OUTPUT");
- END;
-
- BEGIN
- BOOL := END_OF_PAGE (CURRENT_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_OUTPUT");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3407B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada
deleted file mode 100644
index 7be1f47..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CE3407C.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 FILE PARAMETER OF END_OF_PAGE IS OPTIONAL, AND
--- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT
--- FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/28/87 REMOVED DEPENDENCE ON RESET, ADDED MORE CASES FOR
--- END_OF_PAGE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3407C IS
-
- INCOMPLETE : EXCEPTION;
- FILE_IN : FILE_TYPE;
- CHAR : CHARACTER := 'C';
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3407C", "CHECK THAT THE FILE PARAMETER OF END_OF_PAGE " &
- "IS OPTIONAL, AND THAT THE FUNCTION IS THEN " &
- "APPLIED TO THE CURRENT DEFAULT INPUT FILE");
-
- BEGIN
- CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..3 LOOP
- PUT (FILE_IN, CHAR);
- END LOOP;
- NEW_PAGE (FILE_IN);
- PUT (FILE_IN, 'D');
-
- CLOSE (FILE_IN);
-
- BEGIN
- OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE_IN);
-
- IF END_OF_PAGE THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION");
- END IF;
-
- IF END_OF_PAGE /= END_OF_PAGE (FILE_IN) THEN
- FAILED ("END OF PAGE DOES NOT OPERATE WITH DEFAULT FILE");
- END IF;
-
- GET (ITEM_CHAR);
- GET (ITEM_CHAR);
- GET (ITEM_CHAR);
-
- IF END_OF_PAGE /= TRUE THEN
- FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR");
- END IF;
-
- IF END_OF_PAGE /= END_OF_PAGE (FILE_IN) THEN
- FAILED ("END_OF_PAGE WITHOUT PARAMETER DOES " &
- "NOT OPERATE ON THE DEFAULT INPUT FILE");
- END IF;
-
- GET (ITEM_CHAR);
-
- IF NOT (END_OF_PAGE) THEN
- FAILED ("INCORRECT VALUE AT LAST POSITION");
- END IF;
-
- BEGIN
- DELETE (FILE_IN);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3407C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada
deleted file mode 100644
index 2b0107e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- CE3408A.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 END_OF_FILE RETURNS TRUE ONLY IF POSITIONED BEFORE THE
--- FINAL PAGE TERMINATOR OR BEFORE THE FILE TERMINATOR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- JBG 01/26/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3408A IS
-
- INCOMPLETE : EXCEPTION;
- COUNT : INTEGER := 0;
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3408A", "CHECK THAT END_OF_FILE RETURNS " &
- "THE CORRECT VALUE");
-
--- CREATE & INITIALIZE OUTPUT FILE.
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..6 LOOP
- PUT (FILE, CHAR);
- END LOOP;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- TEST WHEN POSITIONED TO BEGINNING OF FILE.
-
- IF END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION - 1");
- END IF;
-
- IF END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION - 2");
- END IF;
-
--- TEST WHEN POSITIONED BEFORE LAST CHARACTER IN FILE.
-
- FOR I IN 1..5 LOOP
- GET (FILE, ITEM_CHAR);
- END LOOP;
-
- IF END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER");
- END IF;
-
--- TEST WHEN AT END OF FILE.
-
- GET (FILE, ITEM_CHAR);
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE AT LAST POSITION");
- END IF;
-
- SKIP_PAGE (FILE);
-
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 1");
- END IF;
-
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 2");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3408A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada
deleted file mode 100644
index a8269f7..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- CE3408B.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 END_OF_FILE CAN ONLY BE APPLIED TO FILES OF MODE
--- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3408B IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- BOOL : BOOLEAN;
-
-BEGIN
-
- TEST ("CE3408B", "CHECK THAT END_OF_FILE CAN ONLY BE " &
- "APPLIED TO FILES OF MODE IN_FILE");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " &
- "TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- BOOL := END_OF_FILE (FILE);
- FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR OUT_FILE");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (STANDARD_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "STANDARD_OUTPUT");
- END;
-
- BEGIN
- BOOL := END_OF_FILE (CURRENT_OUTPUT);
- FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR " &
- "CURRENT_OUTPUT");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3408B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada
deleted file mode 100644
index db74ac5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada
+++ /dev/null
@@ -1,138 +0,0 @@
--- CE3408C.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 FILE PARAMETER OF END_OF_FILE IS OPTIONAL, AND
--- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT
--- FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3408C IS
-
- INCOMPLETE : EXCEPTION;
- FILE_IN : FILE_TYPE;
- CHAR : CHARACTER := 'A';
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3408C", "CHECK THAT THE FILE PARAMETER OF END_OF_FILE " &
- "IS OPTIONAL, AND THAT THE FUNCTION IS THEN " &
- "APPLIED TO THE CURRENT DEFAULT INPUT FILE");
-
-
--- CREATE TEST FILE
-
- BEGIN
- CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1..3 LOOP
- PUT (FILE_IN, CHAR);
- END LOOP;
- NEW_PAGE (FILE_IN);
-
- PUT (FILE_IN, CHAR);
-
- CLOSE (FILE_IN);
-
- BEGIN
- OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE_IN);
- IF END_OF_FILE THEN
- FAILED ("INCORRECT VALUE AT FIRST POSITION");
- END IF;
-
- IF END_OF_FILE /= END_OF_FILE (FILE_IN) THEN
- FAILED ("END OF FILE DOES NOT OPERATE WITH DEFAULT FILE");
- END IF;
-
- WHILE NOT END_OF_PAGE (FILE_IN)
- LOOP
- GET (ITEM_CHAR);
- END LOOP;
-
- IF END_OF_FILE THEN
- FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER");
- END IF;
-
- IF END_OF_FILE /= END_OF_FILE (FILE_IN) THEN
- FAILED ("END_OF_FILE WITHOUT PARAMETER DOES " &
- "NOT OPERATE ON THE DEFAULT INPUT FILE");
- END IF;
-
- GET (ITEM_CHAR);
-
- IF NOT (END_OF_FILE) THEN
- FAILED ("INCORRECT VALUE AT LAST POSITION");
- END IF;
-
- BEGIN
- DELETE (FILE_IN);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3408C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada
deleted file mode 100644
index 6dd5d1c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CE3409A.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 SET_COL RAISES LAYOUT_ERROR IF THE LINE LENGTH IS
--- BOUNDED AND THE GIVEN COLUMN POSITION EXCEEDS THE LINE LENGTH
--- FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 CORRECTD EXCEPTION HANDLING AND ADDED NEW CASES
--- FOR OBJECTIVE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3409A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- FIVE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(5));
-
-BEGIN
-
- TEST ("CE3409A", "CHECK THAT SET_COL RAISES " &
- "LAYOUT_ERROR APPROPRIATELY");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " &
- "TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FILE, THREE);
-
- BEGIN
- SET_COL (FILE, FOUR);
- FAILED ("LAYOUT_ERROR NOT RAISED ON SET_COL - 1");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL - 1");
- END;
-
- IF COL (FILE) /= 1 THEN
- FAILED ("COLUMN LENGTH NOT INITIALLY ONE");
- END IF;
-
- PUT (FILE, 'A');
- PUT (FILE, 'B');
- PUT (FILE, 'C');
-
- SET_LINE_LENGTH (FILE, FOUR);
-
- BEGIN
- SET_COL (FILE, FIVE);
- FAILED ("LAYOUT_ERROR NOT RAISED ON SET_COL - 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL - 2");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3409A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada
deleted file mode 100644
index 1af3f07..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada
+++ /dev/null
@@ -1,76 +0,0 @@
--- CE3409B.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 SET_COL RAISES CONSTRAINT_ERROR IF THE GIVEN
--- COLUMN NUMBER IS ZERO, OR NEGATIVE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/22/82
--- JBG 01/27/83
--- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, REMOVED UNNECESSARY
--- CODE, AND ADDED CASE FOR COUNT'LAST.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS.
-
-WITH REPORT ;
-USE REPORT ;
-WITH TEXT_IO ;
-USE TEXT_IO ;
-
-PROCEDURE CE3409B IS
- FILE : FILE_TYPE;
-BEGIN
-
- TEST ("CE3409B", "CHECK THAT SET_COL RAISES CONSTRAINT_ERROR " &
- "IF THE GIVEN COLUMN NUMBER IS ZERO, OR NEGATIVE.");
-
- BEGIN
- SET_COL (FILE, POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO");
- END;
-
- BEGIN
- SET_COL (FILE, POSITIVE_COUNT(IDENT_INT(-2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR NEGATIVE " &
- "NUMBER");
- END;
-
- RESULT;
-
-END CE3409B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada
deleted file mode 100644
index 7085884..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada
+++ /dev/null
@@ -1,188 +0,0 @@
--- CE3409C.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 SET_COL SETS THE CURRENT COLUMN NUMBER TO THE VALUE
--- SPECIFIED BY TO FOR FILES OF MODES IN_FILE AND OUT_FILE.
--- CHECK THAT IT HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS
--- EQUAL TO THE CURRENT COLUMN NUMBER FOR BOTH IN_FILE AND OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- JBG 01/27/83
--- SPS 02/18/83
--- EG 05/22/85
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3409C IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3409C", "CHECK THAT SET_COL SETS THE CURRENT COLUMN " &
- "NUMBER TO THE VALUE SPECIFIED BY TO FOR FILES " &
- "OF MODES IN_FILE AND OUT_FILE. CHECK THAT IT " &
- "HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS " &
- "EQUAL TO THE CURRENT COLUMN NUMBER FOR BOTH " &
- "IN_FILE AND OUT_FILE");
-
- DECLARE
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_PAGE_LENGTH (FILE, TWO);
- SET_COL (FILE, FOUR);
- IF COL (FILE) /= FOUR THEN
- FAILED ("FOR OUT_FILE COLUMN NOT FOUR");
- ELSE
- PUT (FILE, 'C');
- SET_COL (FILE, 5);
- IF COL (FILE) /= FOUR+1 OR LINE (FILE) /= ONE THEN
- FAILED ("FOR OUT_FILE COLUMN UNNECESSARILY " &
- "CHANGED FROM FOUR");
- ELSE
- SET_COL (FILE, 8);
- PUT (FILE, "DE");
- SET_COL (FILE, TWO+1);
- IF COL (FILE) /= TWO+ONE OR LINE (FILE) /= TWO THEN
- FAILED ("FOR OUT_FILE COLUMN NOT TWO");
- END IF;
- PUT (FILE, 'B');
- SET_COL (FILE, TWO);
-
- IF PAGE (FILE) /= TWO THEN
- FAILED ("PAGE TERMINATOR NOT OUTPUT");
- END IF;
-
- IF LINE (FILE) /= ONE THEN
- FAILED ("LINE TERMINATOR NOT OUTPUT");
- END IF;
-
- IF COL (FILE) /= TWO THEN
- FAILED ("COL NOT TWO; IS" &
- COUNT'IMAGE(COL(FILE)));
- END IF;
-
- PUT (FILE, 'X');
- END IF;
- END IF;
-
- CHECK_FILE (FILE, " C DE# B#@ X#@%");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- SET_COL (FILE, FOUR);
- IF COL (FILE) /= FOUR THEN
- FAILED ("FOR IN_FILE COLUMN NOT FOUR");
- ELSE
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'C' THEN
- FAILED ("SET_COL FOR READ; ACTUALLY READ '" &
- ITEM_CHAR & "'");
- END IF;
-
- SET_COL (FILE, 5);
- IF COL (FILE) /= FOUR+1 OR LINE (FILE) /= ONE THEN
- FAILED ("FOR IN_FILE COLUMN UNNECESSARILY " &
- "CHANGED FROM FOUR");
- ELSE
- SET_COL (FILE, 9);
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'E' THEN
- FAILED ("SET_COL FOR READ 2; ACTUALLY READ '" &
- ITEM_CHAR & "'");
- END IF;
-
- SET_COL (FILE, 3);
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'B' THEN
- FAILED ("SET_COL FOR READ 3; ACTUALLY READ '" &
- ITEM_CHAR & "'");
- END IF;
-
- IF COL (FILE) /= 4 OR LINE (FILE) /= TWO THEN
- FAILED ("FOR IN_FILE COLUMN NOT TWO");
- END IF;
- END IF;
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3409C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada
deleted file mode 100644
index 97ecd9b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada
+++ /dev/null
@@ -1,140 +0,0 @@
--- CE3409D.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 FILES OF MODE IN_FILE, SET_COL READS UNTIL A
--- LINE FOUND HAVING A CHARACTER AT THE SPECIFIED COLUMN, SKIPPING
--- LINE AND PAGE TERMINATORS AS NECESSARY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JBG 01/27/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 REMOVED DEPENDENCE ON REST, REMOVED UNNECESSARY
--- CODE, CHECKED FOR USE_ERROR ON DELETE, AND ADDED
--- NEW CASES FOR SET_COL.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3409D IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3409D", "CHECK THAT SET_COL SKIPS LINE AND PAGE " &
- "TERMINATORS WHEN NECESSARY");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "ABC");
- NEW_LINE (FILE);
- PUT (FILE, "DEFGHI");
- NEW_PAGE (FILE);
- PUT (FILE, "XYZ");
- NEW_PAGE (FILE);
- PUT (FILE, "IJKL");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- SET_COL (FILE, FOUR);
- GET (FILE, ITEM_CHAR);
-
- IF ITEM_CHAR = ' ' THEN
- BEGIN
- COMMENT ("FILE PADS LINES WITH SPACES");
-
- SET_COL (FILE, FOUR);
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'G' THEN
- FAILED ("INCORRECT VALUE FROM SET_COL - 1");
- END IF;
-
- SET_COL (FILE, FOUR);
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= ' ' THEN
- FAILED ("LINES SHOULD STILL BE PADDED WITH BLANKS");
- END IF;
- END;
-
- ELSIF ITEM_CHAR /= 'G' THEN
- FAILED ("SET_COL DOESN'T SKIP LINE MARKS; " &
- "ACTUALLY READ '" & ITEM_CHAR & "'");
- ELSE
- BEGIN
- SET_COL (FILE, FOUR);
- GET (FILE, ITEM_CHAR);
-
- IF ITEM_CHAR /= 'L' THEN
- FAILED ("SET_COL DOESN'T SKIP PAGE MARKS; " &
- "ACTUALLY READ '" & ITEM_CHAR & "'");
- END IF;
- END;
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3409D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada
deleted file mode 100644
index 28d072d..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada
+++ /dev/null
@@ -1,115 +0,0 @@
--- CE3409E.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 SET_COL RAISES END_ERROR IF NO LINE BEFORE THE END OF
--- THE FILE IS LONG ENOUGH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- JBG 01/27/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3409E IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3409E", "CHECK THAT SET_COL RAISES END_ERROR " &
- "WHEN IT ATTEMPTS TO READ THE FILE TERMINATOR");
-
--- CREATE & INITIALIZE FILE
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "ABCD");
- NEW_LINE (FILE);
- PUT (FILE, "DEF");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SET_COL (FILE, 513);
- FAILED ("END ERROR NOT RAISED ON SET_COL");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3409E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada
deleted file mode 100644
index a4e3870..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada
+++ /dev/null
@@ -1,89 +0,0 @@
--- CE3410A.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 SET_LINE RAISES LAYOUT_ERROR IF THE PAGE LENGTH IS
--- BOUNDED AND THE GIVEN LINE POSITION EXCEEDS THE PAGE LENGTH
--- FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- ABW 08/26/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3410A IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
-
-BEGIN
-
- TEST ("CE3410A", "CHECK THAT SET_LINE RAISES " &
- "LAYOUT_ERROR APPROPRIATELY");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " &
- "TEMPORARY FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_PAGE_LENGTH (FILE, THREE);
-
- BEGIN
- SET_LINE (FILE, FOUR);
- FAILED ("LAYOUT ERROR NOT RAISED FOR SET_LINE");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR SET_LINE");
- END;
-
- CLOSE (FILE);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3410A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada
deleted file mode 100644
index 08f185f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada
+++ /dev/null
@@ -1,77 +0,0 @@
--- CE3410B.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 SET_LINE RAISES CONSTRAINT_ERROR IF THE GIVEN
--- LINE NUMBER IS ZERO, OR NEGATIVE.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/22/82
--- JBG 01/27/83
--- JLH 08/31/87 ADDED CASE FOR COUNT'LAST.
--- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3410B IS
-
- FILE : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3410B", "CHECK THAT SET_LINE RAISES CONSTRAINT_ERROR " &
- "IF THE GIVEN LINE NUMBER IS ZERO, OR NEGATIVE");
-
- BEGIN
- SET_LINE (FILE, POSITIVE_COUNT(IDENT_INT(0)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO");
- END;
-
- BEGIN
- SET_LINE (FILE, POSITIVE_COUNT(IDENT_INT(-2)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR NEGATIVE " &
- "NUMBER");
- END;
-
- RESULT;
-
-END CE3410B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada
deleted file mode 100644
index dc00489..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada
+++ /dev/null
@@ -1,205 +0,0 @@
--- CE3410C.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 SET_LINE SETS THE CURRENT LINE NUMBER TO THE VALUE
--- SPECIFIED BY TO FOR FILES OF MODES IN_FILE AND OUT_FILE.
--- CHECK THAT IT HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS
--- EQUAL TO THE CURRENT LINE NUMBER FOR BOTH IN_FILE AND OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- JBG 01/27/83
--- EG 05/22/85
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/01/87 REMOVED DEPENDENCE ON RESET, ADDED MORE TEST
--- CASES, AND CHECKED FOR USE_ERROR ON DELETE.
--- JRL 02/29/96 Added File parameter to call to Set_Page_Length.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3410C IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3410C", "CHECK THAT SET_LINE SETS LINE " &
- "NUMBER CORRECTLY");
-
- DECLARE
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
- ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1));
- TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3));
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE (FILE, FOUR);
- IF LINE (FILE) /= FOUR THEN
- FAILED ("FOR OUT_FILE LINE NOT FOUR");
- ELSE
- PUT (FILE, 'C');
- NEW_LINE (FILE);
- SET_LINE (FILE, 5);
- IF LINE (FILE) /= FOUR+1 THEN
- FAILED ("FOR OUT_FILE LINE UNNECESSARILY " &
- "CHANGED FROM FOUR");
- ELSE
- SET_LINE (FILE, 8);
- PUT (FILE, "DE");
- SET_LINE (FILE, TWO+1);
- IF LINE (FILE) /= TWO+ONE THEN
- FAILED ("FOR OUT_FILE LINE NOT THREE");
- END IF;
-
- SET_LINE (FILE, TWO);
-
- IF PAGE (FILE) /= ONE+TWO THEN
- FAILED ("PAGE TERMINATOR NOT OUTPUT - 2");
- END IF;
-
- IF LINE (FILE) /= TWO THEN
- FAILED ("LINE NOT TWO; IS" &
- COUNT'IMAGE(LINE(FILE)));
- END IF;
-
- SET_PAGE_LENGTH (FILE, TWO);
- PUT (FILE, 'X');
- SET_LINE (FILE, TWO);
- PUT (FILE, 'Y');
-
- IF LINE (FILE) /= TWO THEN
- FAILED ("LINE NOT TWO; IS " &
- COUNT'IMAGE(LINE(FILE)));
- END IF;
-
- IF PAGE (FILE) /= THREE THEN
- FAILED ("PAGE NOT THREE; IS " &
- COUNT'IMAGE(PAGE(FILE)));
- END IF;
-
- END IF;
- END IF;
-
- CHECK_FILE (FILE, "###C####DE#@##@#XY#@%");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED FOR TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE (FILE, FOUR);
- IF LINE (FILE) /= FOUR THEN
- FAILED ("FOR IN_FILE LINE NOT FOUR");
- ELSE
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'C' THEN
- FAILED ("SET_LINE FOR READ; ACTUALLY READ '" &
- ITEM_CHAR & "'");
- END IF;
-
- SKIP_LINE (FILE);
- SET_LINE (FILE, 5);
- IF LINE (FILE) /= FOUR+1 OR PAGE (FILE) /= ONE THEN
- FAILED ("INCORRECT LINE OR PAGE");
- ELSE
- SET_LINE (FILE, 8);
- GET (FILE, ITEM_CHAR);
- IF ITEM_CHAR /= 'D' THEN
- FAILED ("SET_LINE FOR READ 2; ACTUALLY READ '"&
- ITEM_CHAR & "'");
- END IF;
-
- SET_LINE (FILE, TWO);
- IF PAGE (FILE) /= TWO THEN
- FAILED ("FOR IN_FILE PAGE NOT TWO");
- END IF;
-
- SET_LINE (FILE, TWO);
- IF PAGE (FILE) /= TWO OR LINE (FILE) /= TWO THEN
- FAILED ("FOR IN_FILE PAGE NOT 2");
- END IF;
-
- SKIP_LINE (FILE);
- SET_LINE (FILE, TWO);
-
- GET (FILE, ITEM_CHAR);
-
- IF ITEM_CHAR /= 'X' THEN
- FAILED ("SET_LINE FOR READ 3; ACTUALLY READ '"&
- ITEM_CHAR & "'");
- END IF;
-
- END IF;
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3410C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada
deleted file mode 100644
index 09fa09e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CE3410D.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 FILES OF MODE IN_FILE, SET_LINE READS UNTIL A
--- PAGE IS FOUND HAVING A LINE AT THE SPECIFIED POSITION, SKIPPING
--- LINE AND PAGE TERMINATORS AS NECESSARY.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JBG 01/27/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/01/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR
--- USE_ERROR ON DELETE.
--- GJD 11/15/95 FIXED ADA 95 INCOMPATIBLE USE OF CHARACTER LITERALS.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3410D IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- ITEM_CHAR : CHARACTER;
-
-BEGIN
-
- TEST ("CE3410D", "CHECK THAT SET_LINE SKIPS PAGE " &
- "TERMINATORS WHEN NECESSARY");
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN CHARACTER RANGE 'A'..'C' LOOP
- PUT (FILE, I);
- NEW_LINE (FILE);
- END LOOP;
-
- NEW_PAGE (FILE);
-
- FOR I IN CHARACTER RANGE 'D'..'H' -- 5 LINES
- LOOP
- PUT (FILE, I);
- NEW_LINE (FILE);
- END LOOP;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE (FILE, FOUR);
- GET (FILE, ITEM_CHAR);
-
- IF ITEM_CHAR /= 'G' THEN
- FAILED ("SET_LINE DOESN'T SKIP PAGE MARKS; " &
- "ACTUALLY READ '" & ITEM_CHAR & "'");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3410D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada
deleted file mode 100644
index f86608b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- CE3410E.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 SET_LINE RAISES END_ERROR IF NO PAGE BEFORE THE END
--- OF THE FILE IS LONG ENOUGH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- JBG 01/27/83
--- JBG 08/30/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, ADDED NEW CASES FOR
--- OBJECTIVE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3410E IS
-
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- CHAR : CHARACTER := ('C');
- ITEM_CHAR : CHARACTER;
- FIVE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(5));
-
-BEGIN
-
- TEST ("CE3410E", "CHECK THAT SET_LINE RAISES END_ERROR " &
- "WHEN IT ATTEMPTS TO READ THE FILE TERMINATOR");
-
--- CREATE & INITIALIZE FILE
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "ABCD");
- NEW_LINE (FILE);
- PUT (FILE, "DEF");
- NEW_LINE (FILE, 3);
- NEW_PAGE (FILE);
- PUT_LINE (FILE, "HELLO");
- NEW_PAGE (FILE);
- PUT_LINE (FILE, "GH");
- PUT_LINE (FILE, "IJK");
- PUT_LINE (FILE, "HI");
- PUT_LINE (FILE, "TESTING");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- SET_LINE (FILE,FIVE);
- FAILED ("END ERROR NOT RAISED ON SET_LINE");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_LINE");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3410E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada
deleted file mode 100644
index 1b81316..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CE3411A.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 COL RETURNS THE VALUE OF THE CURRENT COLUMN NUMBER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 08/30/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/02/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3411A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3411A", "CHECK THAT COL RETURNS THE VALUE OF THE " &
- "CURRENT COLUMN NUMBER");
-
- DECLARE
- FT : FILE_TYPE;
- X : CHARACTER;
- NUM_CHARS : POSITIVE_COUNT;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "OUTPUT STRING");
- IF COL (FT) /= 14 THEN
- FAILED ("COL INCORRECT AFTER PUT; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- NEW_LINE (FT);
- IF COL (FT) /= 1 THEN
- FAILED ("COL INCORRECT AFTER NEW_LINE; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- PUT (FT, "MORE OUTPUT");
- NEW_PAGE (FT);
- IF COL (FT) /= 1 THEN
- FAILED ("COL INCORRECT AFTER NEW_PAGE; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- PUT (FT, "FINAL");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF COL (FT) /= 1 THEN
- FAILED ("COL INCORRECT AFTER REOPEN; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- FOR I IN 1 .. 4 LOOP
- GET (FT, X);
- END LOOP;
- IF COL (FT) /= 5 THEN
- FAILED ("COL INCORRECT AFTER GET; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- NUM_CHARS := COL(FT);
- WHILE NOT END_OF_LINE(FT) LOOP
- GET (FT, X);
- NUM_CHARS := NUM_CHARS + 1;
- END LOOP;
-
- IF COL(FT) /= NUM_CHARS THEN
- FAILED ("COL INCORRECT BEFORE END OF LINE; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- SKIP_LINE (FT);
- IF COL(FT) /= 1 THEN
- FAILED ("COL INCORRECT AFTER SKIP_LINE; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- SET_COL (FT, 2);
- IF COL (FT) /= 2 THEN
- FAILED ("COL INCORRECT AFTER SET_COL; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- SKIP_PAGE (FT);
- IF COL(FT) /= 1 THEN
- FAILED ("COL INCORRECT AFTER SKIP_PAGE; IS" &
- COUNT'IMAGE(COL(FT)));
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-END CE3411A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada
deleted file mode 100644
index fd95831..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada
+++ /dev/null
@@ -1,146 +0,0 @@
--- CE3411C.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 COL OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN
--- NO FILE IS SPECIFIED. CHECK THAT COL CAN OPERATE ON FILES OF
--- MODES IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT
--- INPUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 01/31/83
--- JBG 08/30/83
--- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3411C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3411C", "CHECK THAT COL OPERATES ON DEFAULT IN_FILE AND "&
- "OUT_FILE FILES");
-
- DECLARE
- F1, F2 : FILE_TYPE;
- C : POSITIVE_COUNT;
- X : CHARACTER;
- BEGIN
- IF COL /= COL (STANDARD_OUTPUT) THEN
- FAILED ("COL DEFAULT NOT STANDARD_OUTPUT");
- END IF;
-
- IF COL /= COL (STANDARD_INPUT) THEN
- FAILED ("COL DEFAULT NOT STANDARD_INPUT");
- END IF;
-
- IF COL /= COL (CURRENT_INPUT) THEN
- FAILED ("COL DEFAULT NOT CURRENT_INPUT");
- END IF;
-
- IF COL /= COL (CURRENT_OUTPUT) THEN
- FAILED ("COL DEFAULT NOT CURRENT_OUTPUT");
- END IF;
-
- BEGIN
- CREATE (F1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (F2, OUT_FILE);
-
- SET_OUTPUT (F2);
-
- PUT (F1, "STRING");
- IF COL (F1) /= 7 THEN
- FAILED ("COL INCORRECT SUBTEST 1");
- END IF;
-
- PUT (F2, "OUTPUT STRING");
- IF COL /= COL(F2) AND COL(F2) /= 14 THEN
- FAILED ("COL INCORRECT SUBTEST 2; WAS " &
- COUNT'IMAGE(COL) & " VS. " &
- COUNT'IMAGE(COL(F2)));
- END IF;
-
- CLOSE (F1);
-
- BEGIN
- OPEN (F1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (F1);
-
- GET (F1, X);
- GET (F1, X);
- GET (F1, X);
-
- IF X /= 'R' THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- IF COL (CURRENT_INPUT) /= 4 AND COL /= 4 THEN
- FAILED ("COL INCORRECT SUBTEST 3");
- END IF;
-
- BEGIN
- DELETE (F1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CLOSE (F2);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3411C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada
deleted file mode 100644
index 56b6744..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada
+++ /dev/null
@@ -1,149 +0,0 @@
--- CE3412A.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 LINE RETURNS THE VALUE OF THE CURRENT LINE NUMBER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 08/30/83
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/02/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3412A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3412A", "CHECK LINE RETURNS LINE NUMBER");
-
- DECLARE
- FT : FILE_TYPE;
- X : CHARACTER;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF LINE (FT) /= 1 THEN
- FAILED ("CURRENT LINE NUMBER NOT INITIALLY ONE");
- END IF;
-
- FOR I IN 1 .. 3 LOOP
- PUT (FT, "OUTPUT STRING");
- NEW_LINE (FT);
- END LOOP;
- IF LINE (FT) /= 4 THEN
- FAILED ("LINE INCORRECT AFTER PUT; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- NEW_PAGE (FT);
- IF LINE (FT) /= 1 THEN
- FAILED ("LINE INCORRECT AFTER NEW_PAGE; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- FOR I IN 1 .. 5 LOOP
- PUT (FT, "MORE OUTPUT");
- NEW_LINE(FT);
- END LOOP;
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF LINE (FT) /= 1 THEN
- FAILED ("LINE INCORRECT AFTER RESET; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- FOR I IN 1 .. 2 LOOP
- SKIP_LINE (FT);
- END LOOP;
- IF LINE (FT) /= 3 THEN
- FAILED ("LINE INCORRECT AFTER SKIP_LINE; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- SET_LINE (FT, 2);
- IF LINE (FT) /= 2 THEN
- FAILED ("LINE INCORRECT AFTER SET_LINE; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- SKIP_PAGE (FT);
- IF LINE (FT) /= 1 THEN
- FAILED ("LINE INCORRECT AFTER SKIP_PAGE; IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3412A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada
deleted file mode 100644
index 079da5e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- CE3413A.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 PAGE RETURNS THE VALUE OF THE CURRENT PAGE NUMBER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 08/30/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/04/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3413A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3413A", "CHECK THAT PAGE RETURNS THE CORRECT PAGE " &
- "NUMBER");
-
- DECLARE
- FT : FILE_TYPE;
- X : CHARACTER;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- IF PAGE (FT) /= 1 THEN
- FAILED ("CURRENT PAGE NOT INITIALLY ONE");
- END IF;
-
- FOR I IN 1 .. 6 LOOP
- PUT (FT, "OUTPUT STRING");
- NEW_PAGE (FT);
- END LOOP;
- IF PAGE (FT) /= 7 THEN
- FAILED ("PAGE INCORRECT AFTER PUT; IS" &
- COUNT'IMAGE(PAGE(FT)));
- END IF;
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF PAGE (FT) /= 1 THEN
- FAILED ("PAGE INCORRECT AFTER OPEN IS" &
- COUNT'IMAGE(PAGE(FT)));
- END IF;
-
- FOR I IN 1 .. 4 LOOP
- SKIP_PAGE (FT);
- END LOOP;
- IF PAGE (FT) /= 5 THEN
- FAILED ("PAGE INCORRECT AFTER SKIP_PAGE; IS" &
- COUNT'IMAGE(PAGE(FT)));
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3413A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada
deleted file mode 100644
index cb273ca..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- CE3413B.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 PAGE RAISES LAYOUT_ERROR WHEN THE VALUE OF THE
--- PAGE NUMBER EXCEEDS COUNT'LAST.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- *** 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:
--- JLH 07/27/88 CREATED ORIGINAL TEST.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-
-PROCEDURE CE3413B IS
-
- FILE : FILE_TYPE;
- INCOMPLETE, INAPPLICABLE : EXCEPTION;
- ITEM : STRING(1..3) := "ABC";
- LST : NATURAL;
-
-BEGIN
-
- TEST ("CE3413B", "CHECK THAT PAGE RAISES LAYOUT_ERROR WHEN THE " &
- "VALUE OF THE PAGE NUMBER EXCEEDS COUNT'LAST");
-
- BEGIN
-
- IF COUNT'LAST > 150000 THEN
- RAISE INAPPLICABLE;
- END IF;
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1 .. COUNT'LAST-1 LOOP
- NEW_PAGE (FILE);
- END LOOP;
-
- PUT (FILE, ITEM);
-
- NEW_PAGE (FILE);
- PUT (FILE, "DEF");
-
- BEGIN
- IF PAGE(FILE) <= POSITIVE_COUNT(COUNT'LAST) THEN
- FAILED ("PAGE NUMBER INCORRECT AFTER PAGE SET - 1");
- END IF;
- FAILED ("LAYOUT_ERROR NOT RAISED FOR PAGE - 1");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR PAGE - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR PAGE - 1");
- END;
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- FOR I IN 1 .. COUNT'LAST-1 LOOP
- SKIP_PAGE (FILE);
- END LOOP;
-
- IF PAGE(FILE) /= COUNT'LAST THEN
- FAILED ("INCORRECT PAGE NUMBER");
- END IF;
-
- GET_LINE (FILE, ITEM, LST);
- IF ITEM /= "ABC" THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- SKIP_PAGE (FILE);
-
- BEGIN
- IF PAGE(FILE) <= POSITIVE_COUNT(COUNT'LAST) THEN
- FAILED ("PAGE NUMBER INCORRECT AFTER PAGE SET - 2");
- END IF;
- FAILED ("LAYOUT_ERROR NOT RAISED FOR PAGE - 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED FOR PAGE - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED FOR PAGE - 2");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- WHEN INAPPLICABLE =>
- NOT_APPLICABLE ("THE VALUE OF COUNT'LAST IS GREATER " &
- "THAN 150000. THE CHECKING OF THIS " &
- "OBJECTIVE IS IMPRACTICAL");
-
- END;
-
- RESULT;
-
-END CE3413B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada
deleted file mode 100644
index dca4c2b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- CE3413C.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 PAGE OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN
--- NO FILE IS SPECIFIED. CHECK THAT PAGE CAN OPERATE ON FILES OF
--- MODES IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT
--- INPUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 08/30/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/04/87 REMOVED DEPENDENCE ON RESET, CORRECTED EXCEPTION
--- HANDLING, AND CHECKED FOR USE_ERROR ON DELETE.
-
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3413C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3413C", "CHECK THAT PAGE OPERATES ON DEFAULT IN_FILE " &
- "AND OUT_FILE FILES");
-
- DECLARE
- F1, F2 : FILE_TYPE;
- C : POSITIVE_COUNT;
- X : CHARACTER;
- BEGIN
-
- BEGIN
- CREATE (F1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CREATE (F2, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILES WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_OUTPUT (F2);
-
- IF PAGE (F2) /= 1 AND PAGE (STANDARD_OUTPUT) /= 1 THEN
- FAILED ("PAGE INCORRECT SUBTEST - 1");
- END IF;
-
- FOR I IN 1 .. 3 LOOP
- PUT (F1, "STRING");
- NEW_PAGE (F1);
- END LOOP;
-
- IF PAGE (F1) /= 4 THEN
- FAILED ("PAGE INCORRECT SUBTEST - 2");
- END IF;
-
- SET_LINE_LENGTH (F2, 3);
- SET_PAGE_LENGTH (F2, 1);
- PUT ("OUTPUT STRING");
- IF PAGE /= PAGE(F2) THEN
- FAILED ("PAGE INCORRECT SUBTEST - 3");
- END IF;
-
- CLOSE (F1);
-
- BEGIN
- OPEN (F1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (F1);
-
- IF PAGE (F1) /= 1 THEN
- FAILED ("PAGE INCORRECT SUBTEST - 4");
- END IF;
-
- SKIP_PAGE(F1);
- SKIP_PAGE(F1);
- IF PAGE (F1) /= PAGE (CURRENT_INPUT) THEN
- FAILED ("PAGE INCORRECT SUBTEST - 5");
- END IF;
-
- BEGIN
- DELETE (F1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CLOSE (F2);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3413C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada
deleted file mode 100644
index 8f236ca..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada
+++ /dev/null
@@ -1,204 +0,0 @@
--- CE3414A.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 STATUS_ERROR IS RAISED WHEN NEW_LINE, SKIP_LINE,
--- END_OF_LINE, NEW_PAGE, SKIP_PAGE, END_OF_PAGE, END_OF_FILE,
--- SET_COL, SET_LINE, COL, LINE, AND PAGE ARE CALLED AND THE FILE
--- IS NOT OPEN.
-
--- HISTORY:
--- BCB 10/27/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3414A IS
-
- FILE : FILE_TYPE;
-
- INCOMPLETE : EXCEPTION;
-
- X : POSITIVE_COUNT;
-
-BEGIN
- TEST ("CE3414A", "CHECK THAT STATUS_ERROR IS RAISED WHEN " &
- "NEW_LINE, SKIP_LINE, END_OF_LINE, NEW_PAGE, " &
- "SKIP_PAGE, END_OF_PAGE, END_OF_FILE, SET_COL, " &
- "SET_LINE, COL, LINE, AND PAGE ARE CALLED AND " &
- "THE FILE IS NOT OPEN");
-
- BEGIN
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, 'A');
-
- CLOSE (FILE);
-
- BEGIN
- NEW_LINE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- SKIP_LINE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- IF NOT END_OF_LINE (FILE) THEN
- NULL;
- END IF;
- FAILED ("STATUS_ERROR WAS NOT RAISED - 3");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- NEW_PAGE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 4");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- SKIP_PAGE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 5");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- IF NOT END_OF_PAGE (FILE) THEN
- NULL;
- END IF;
- FAILED ("STATUS_ERROR WAS NOT RAISED - 6");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 6");
- END;
-
- BEGIN
- IF NOT END_OF_FILE (FILE) THEN
- NULL;
- END IF;
- FAILED ("STATUS_ERROR WAS NOT RAISED - 7");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 7");
- END;
-
- BEGIN
- SET_COL (FILE, 2);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 8");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 8");
- END;
-
- BEGIN
- SET_LINE (FILE, 2);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 9");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 9");
- END;
-
- BEGIN
- X := COL (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 10");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 10");
- END;
-
- BEGIN
- X := LINE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 11");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 11");
- END;
-
- BEGIN
- X := PAGE (FILE);
- FAILED ("STATUS_ERROR WAS NOT RAISED - 12");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 12");
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE3414A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada
deleted file mode 100644
index c5b63fd..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada
+++ /dev/null
@@ -1,187 +0,0 @@
--- CE3601A.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 GET (FOR STRINGS AND CHARACTERS), PUT (FOR STRINGS AND
--- CHARACTERS), GET_LINE, AND PUT_LINE RAISE STATUS_ERROR WHEN
--- CALLED WITH AN UNOPEN FILE PARAMETER. ALSO CHECK NAMES OF FORMAL
--- PARAMETERS.
-
--- HISTORY:
--- SPS 08/27/82
--- VKG 02/15/83
--- JBG 03/30/83
--- JLH 09/04/87 ADDED CASE WHICH ATTEMPTS TO CREATE FILE AND THEN
--- RETESTED OBJECTIVE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3601A IS
-
-BEGIN
-
- TEST ("CE3601A", "STATUS_ERROR RAISED BY GET, PUT, GET_LINE, " &
- "PUT_LINE WHEN FILE IS NOT OPEN");
-
- DECLARE
- FILE1, FILE2 : FILE_TYPE;
- CH: CHARACTER := '%';
- LST: NATURAL;
- ST: STRING (1 .. 10);
- LN : STRING (1 .. 80);
- BEGIN
- BEGIN
- GET (FILE => FILE1, ITEM => CH);
- FAILED ("STATUS_ERROR NOT RAISED - GET CHARACTER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHARACTER");
- END;
-
- BEGIN
- GET (FILE => FILE1, ITEM => ST);
- FAILED ("STATUS_ERROR NOT RAISED - GET STRING");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING");
- END;
-
- BEGIN
- GET_LINE (FILE => FILE1, ITEM => LN, LAST => LST);
- FAILED ("STATUS_ERROR NOT RAISED - GET_LINE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET_LINE");
- END;
-
- BEGIN
- PUT (FILE => FILE1, ITEM => CH);
- FAILED ("STATUS_ERROR NOT RAISED - PUT CHARACTER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT CHARACTER");
- END;
-
- BEGIN
- PUT (FILE => FILE1, ITEM => ST);
- FAILED ("STATUS_ERROR NOT RAISED - PUT STRING");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT STRING");
- END;
-
- BEGIN
- PUT_LINE (FILE => FILE1, ITEM => LN);
- FAILED ("STATUS_ERROR NOT RAISED - PUT_LINE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT_LINE");
- END;
-
- BEGIN
- CREATE (FILE2, OUT_FILE); -- THIS IS ONLY AN ATTEMPT TO
- CLOSE (FILE2); -- CREATE A FILE. OK, WHETHER
- EXCEPTION -- SUCCESSFUL OR NOT.
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- GET (FILE => FILE2, ITEM => CH);
- FAILED ("STATUS_ERROR NOT RAISED - GET CHARACTER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHARACTER");
- END;
-
- BEGIN
- GET (FILE => FILE2, ITEM => ST);
- FAILED ("STATUS_ERROR NOT RAISED - GET STRING");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING");
- END;
-
- BEGIN
- GET_LINE (FILE => FILE2, ITEM => LN, LAST => LST);
- FAILED ("STATUS_ERROR NOT RAISED - GET_LINE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET_LINE");
- END;
-
- BEGIN
- PUT (FILE => FILE2, ITEM => CH);
- FAILED ("STATUS_ERROR NOT RAISED - PUT CHARACTER");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT CHARACTER");
- END;
-
- BEGIN
- PUT (FILE => FILE2, ITEM => ST);
- FAILED ("STATUS_ERROR NOT RAISED - PUT STRING");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT STRING");
- END;
-
- BEGIN
- PUT_LINE (FILE => FILE2, ITEM => LN);
- FAILED ("STATUS_ERROR NOT RAISED - PUT_LINE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT_LINE");
- END;
-
- END;
-
- RESULT;
-
-END CE3601A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada
deleted file mode 100644
index ff02803..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada
+++ /dev/null
@@ -1,189 +0,0 @@
--- CE3602A.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 GET FOR CHARACTERS AND STRINGS ALLOW A STRING TO SPAN
--- OVER MORE THAN ONE LINE, SKIPPING INTERVENING LINE AND PAGE
--- TERMINATORS. ALSO CHECK THAT GET ACCEPTS A NULL STRING ACTUAL
--- PARAMETER AND A STRING SLICE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 08/30/82
--- VKG 01/26/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/04/87 REMOVED DEPENDENCE ON RESET, CORRECTED EXCEPTION
--- HANDLING, AND ADDED NEW CASES FOR OBJECTIVE.
-
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3602A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3602A", "CHECK THAT GET FOR CHARACTERS AND STRINGS " &
- "ALLOWS A STRING TO SPAN OVER MORE THAN ONE " &
- "LINE, SKIPPING INTERVENING LINE AND PAGE " &
- "TERMINATORS. ALSO CHECK THAT GET ACCEPTS " &
- "A NULL STRING ACTUAL PARAMETER AND A STRING " &
- "SLICE");
-
- DECLARE
- FILE1 : FILE_TYPE;
- ST : STRING (1 .. 40);
- STR: STRING (1 .. 100);
- NST: STRING (1 .. 0);
- ORIGINAL_LINE_LENGTH : COUNT;
-
--- READ_CHARS RETURNS A STRING OF N CHARACTERS FROM A GIVEN FILE.
-
- FUNCTION READ_CHARS (FILE : FILE_TYPE;
- N : NATURAL )
- RETURN STRING IS
- C: CHARACTER;
- BEGIN
- IF N = 0 THEN RETURN "";
- ELSE
- GET (FILE,C);
- RETURN C&READ_CHARS (FILE,N-1);
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("ERROR ON READ_CHARS");
- END READ_CHARS;
-
-
- BEGIN
-
--- CREATE AND INITIALIZE TEST DATA FILE
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- ORIGINAL_LINE_LENGTH := LINE_LENGTH;
-
--- LINE_LENGTH SET IN CASE IMPLEMENTATION REQUIRES BOUNDED LENGTH LINES
-
- SET_LINE_LENGTH (16);
- PUT (FILE1, "THIS LINE SHALL ");
- SET_LINE_LENGTH (10);
- PUT (FILE1, "SPAN OVER ");
- SET_LINE_LENGTH (14);
- PUT (FILE1, "SEVERAL LINES.");
- CLOSE (FILE1);
- SET_LINE_LENGTH (ORIGINAL_LINE_LENGTH);
-
-
--- BEGIN TEST
-
- BEGIN
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN WITH IN_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- STR(1..40) := READ_CHARS (FILE1, 40);
- CLOSE (FILE1);
-
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
-
- GET (FILE1, ST);
- IF STR(1..40) /= ST THEN
- FAILED ("GET FOR STRING INCORRECT");
- END IF;
-
- IF STR(1..40) /= "THIS LINE SHALL SPAN OVER SEVERAL " &
- "LINES." THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
--- GET NULL STRING
-
- CLOSE (FILE1);
-
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
-
- BEGIN
- GET (FILE1, NST);
- EXCEPTION
- WHEN OTHERS =>
- FAILED (" GET FAILED ON NULL STRING");
- END;
-
--- GET NULL SLICE
-
- BEGIN
- GET (FILE1, STR (10 .. 1));
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("GET FAILED ON A NULL SLICE");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3602A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada
deleted file mode 100644
index 7148242..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada
+++ /dev/null
@@ -1,215 +0,0 @@
--- CE3602B.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 GET (FOR CHARACTER AND STRINGS) PROPERLY SETS THE
--- PAGE, LINE, AND COLUMN NUMBERS AFTER EACH OPERATION.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 08/30/82
--- SPS 12/17/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/04/87 REMOVED DEPENDENCE ON UNBOUNDED LINE LENGTH AND
--- CORRECTED EXCEPTION HANDLING.
--- BCB 11/13/87 GAVE SET_LINE_LENGTH PROCEDURE THE FILE VARIABLE
--- AS A PARAMETER. REMOVED LINE WHICH SAVED AND
--- RESTORED THE LINE LENGTH.
-
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3602B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3602B", "CHECK THAT GET PROPERLY SETS PAGE, LINE, AND " &
- "COLUMN NUMBERS");
-
- DECLARE
- FILE1 : FILE_TYPE;
- LINE1 : CONSTANT STRING := "LINE ONE OF TEST DATA FILE";
- LINE2 : CONSTANT STRING := "LINE TWO";
- LINE3 : CONSTANT STRING := "LINE THREE";
- CN, LN : POSITIVE_COUNT;
- CH : CHARACTER;
- ST: STRING (1 .. 5);
- ORIGINAL_LINE_LENGTH : COUNT;
-
- BEGIN
-
--- CREATE AND INITIALIZE TEST DATA FILE
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- ORIGINAL_LINE_LENGTH := LINE_LENGTH;
- SET_LINE_LENGTH (FILE1, LINE1'LENGTH);
-
- PUT (FILE1, LINE1);
- SET_LINE_LENGTH (FILE1, LINE2'LENGTH);
- PUT (FILE1, LINE2);
- NEW_LINE (FILE1, 2);
- NEW_PAGE (FILE1);
- SET_LINE_LENGTH (FILE1, LINE3'LENGTH);
- PUT (FILE1, LINE3);
- CLOSE (FILE1);
-
--- BEGIN TEST
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- IF COL (FILE1) /= 1 THEN
- FAILED ("COLUMN NUMBER NOT INITIALLY ONE");
- END IF;
-
- IF LINE (FILE1) /= 1 THEN
- FAILED ("LINE NUMBER NOT INITIALLY ONE");
- END IF;
-
- IF PAGE (FILE1) /= 1 THEN
- FAILED ("PAGE NUMBER NOT INITIALLY ONE");
- END IF;
-
--- TEST COLUMN NUMBER FOR CHARACTER
-
- GET (FILE1, CH);
- IF CH /= 'L' THEN
- FAILED ("CHARACTER NOT EQUAL TO L - 1");
- END IF;
- CN := COL (FILE1);
- IF CN /= 2 THEN
- FAILED ("COLUMN NUMBER NOT SET CORRECTLY " &
- "- GET CHARACTER. COL NUMBER IS" &
- COUNT'IMAGE(CN));
- END IF;
-
--- TEST COLUMN NUMBER FOR STRING
-
- GET (FILE1, ST);
- CN := COL (FILE1);
- IF CN /= 7 THEN
- FAILED ("COLUMN NUMBER NOT SET CORRECTLY " &
- "- GET STRING. COL NUMBER IS" &
- COUNT'IMAGE(CN));
- END IF;
-
--- POSITION CURRENT INDEX TO END OF LINE
-
- WHILE NOT END_OF_LINE (FILE1) LOOP
- GET (FILE1, CH);
- END LOOP;
-
- IF CH /= 'E' THEN
- FAILED ("CHARACTER NOT EQUAL TO E");
- END IF;
-
--- TEST LINE NUMBER FOR CHARACTER
-
- GET(FILE1, CH);
- IF CH /= 'L' THEN
- FAILED ("CHARACTER NOT EQUAL TO L - 2");
- END IF;
- LN := LINE (FILE1);
- IF LN /= 2 THEN
- FAILED ("LINE NUMBER NOT SET CORRECTLY " &
- "- GET CHARACTER. LINE NUMBER IS" &
- COUNT'IMAGE(LN));
- END IF;
- IF PAGE (FILE1) /= POSITIVE_COUNT(IDENT_INT(1)) THEN
- FAILED ("PAGE NUMBER NOT CORRECT - 1. PAGE IS" &
- COUNT'IMAGE(PAGE(FILE1)));
- END IF;
-
--- TEST LINE NUMBER FOR STRING
-
- WHILE NOT END_OF_LINE (FILE1) LOOP
- GET (FILE1, CH);
- END LOOP;
- GET (FILE1, ST);
- IF ST /= "LINE " THEN
- FAILED ("INCORRECT VALUE READ - ST");
- END IF;
- LN := LINE (FILE1);
- CN := COL (FILE1);
- IF CN /= 6 THEN
- FAILED ("COLUMN NUMBER NOT SET CORRECTLY " &
- "- GET STRING. COL NUMBER IS" &
- COUNT'IMAGE(CN));
- END IF;
- IF LN /= 1 THEN
- FAILED ("LINE NUMBER NOT SET CORRECTLY " &
- "- GET STRING. LINE NUMBER IS" &
- COUNT'IMAGE(LN));
- END IF;
- IF PAGE (FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN
- FAILED ("PAGE NUMBER NOT CORRECT - 2. PAGE IS" &
- COUNT'IMAGE(PAGE(FILE1)));
- END IF;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3602B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada
deleted file mode 100644
index 153fed7..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada
+++ /dev/null
@@ -1,202 +0,0 @@
--- CE3602C.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 GET RAISES MODE_ERROR FOR FILES OF MODE OUT_FILE.
-
--- APPLICABILITY CRITEIRA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 08/31/82
--- SPS 12/17/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3602C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3602C", "CHECK THAT MODE_ERROR IS RAISED BY GET FOR " &
- "FILES OF MODE OUT_FILE");
-
- DECLARE
- FILE1, FILE2 : FILE_TYPE;
- CH : CHARACTER;
- ST : STRING (1 .. 5);
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE - 1");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE - 2");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FILE1, CH);
- FAILED ("MODE_ERROR NOT RAISED - GET CHAR UN-NAMED " &
- "FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHAR " &
- "UN-NAMED FILE");
- END;
-
- BEGIN
- GET (FILE2, CH);
- FAILED ("MODE_ERROR NOT RAISED - GET CHAR NAMED FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHAR " &
- "NAMED FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, CH);
- FAILED ("MODE_ERROR NOT RAISED - GET CHAR " &
- "STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHAR " &
- "STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, CH);
- FAILED ("MODE_ERROR NOT RAISED - GET CHAR " &
- "CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET CHAR " &
- "CURRENT_OUTPUT");
- END;
-
- BEGIN
- GET (FILE1, ST);
- FAILED ("MODE_ERROR NOT RAISED - GET STRING UN-NAMED " &
- "FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING " &
- "UN-NAMED FILE");
- END;
-
- BEGIN
- GET (FILE2, ST);
- FAILED ("MODE_ERROR NOT RAISED - GET STRING NAMED FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING " &
- "NAMED FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, ST);
- FAILED ("MODE_ERROR NOT RAISED - GET STRING " &
- "STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING " &
- "STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, ST);
- FAILED ("MODE_ERROR NOT RAISED - GET STRING " &
- "CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET STRING " &
- "CURRENT_OUTPUT");
- END;
-
- CLOSE (FILE1);
-
- BEGIN
- DELETE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3602C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada
deleted file mode 100644
index 89b6a47..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada
+++ /dev/null
@@ -1,150 +0,0 @@
--- CE3602D.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 FILES ARE OF MODE IN_FILE AND THAT WHEN NO FILE IS
--- SPECIFIED THAT CURRENT DEFAULT INPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/06/82
--- SPS 12/17/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 REMOVED DEPENDENCE ON RESET AND CORRECTED
--- EXCEPTION HANDLING.
-
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3602D IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3602D", "CHECK THAT GET FOR STRINGS AND CHARACTERS " &
- "OPERATES ON IN_FILE FILES");
-
- DECLARE
- FT , FILE : FILE_TYPE;
- X : CHARACTER;
- ST: STRING (1 .. 3);
- BEGIN
-
--- CREATE AND INITIALIZE FILES
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "ABCE");
- NEW_LINE (FT);
- PUT (FT, "EFGHIJKLM");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FILE, "STRING");
- NEW_LINE (FILE);
- PUT (FILE, "END OF OUTPUT");
-
- CLOSE (FILE);
-
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2));
-
- SET_INPUT (FILE);
-
--- BEGIN TEST
-
- GET (FT, X);
- IF X /= IDENT_CHAR ('A') THEN
- FAILED ("CHARACTER FROM FILE INCORRECT, WAS '" &
- X & "'");
- END IF;
-
- GET (FT, ST);
- IF ST /= "BCE" THEN
- FAILED ("STRING FROM FILE INCORRECT; WAS """ &
- ST & """");
- END IF;
-
- GET (X);
- IF X /= IDENT_CHAR ('S') THEN
- FAILED ("CHARACTER FROM DEFAULT INCORRECT; WAS '" &
- X & "'");
- END IF;
-
- GET (ST);
- IF ST /= "TRI" THEN
- FAILED ("STRING FROM DEFAULT INCORRECT; WAS """ &
- ST & """");
- END IF;
-
- BEGIN
- DELETE (FT);
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3602D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada
deleted file mode 100644
index d9d4f1e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada
+++ /dev/null
@@ -1,217 +0,0 @@
--- CE3603A.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 END_ERROR IS NOT RAISED BY:
--- GET FOR CHARACTERS UNTIL ONLY LINE AND PAGE TERMINATORS REMAIN;
--- GET FROM STRING UNTIL FEWER CHARACTERS THAN NEEDED REMAIN;
--- GET_LINE UNTIL THE FINAL PAGE TERMINATOR HAS BEEN SKIPPED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 08/31/82
--- JBG 12/23/82
--- EG 05/22/85
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND REMOVED
--- DEPENDENCE ON RESET.
-
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3603A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3603A", "CHECK THAT END_ERROR IS RAISED BY GET AFTER " &
- "THE LAST CHARACTER IN THE FILE HAS BEEN READ");
-
- DECLARE
- FILE1 : FILE_TYPE;
- OLDCH, CH : CHARACTER;
- ST : STRING (1..10) := (1..10 => '.');
- COUNT : NATURAL;
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT" &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, "LINE ONE");
- NEW_LINE (FILE1);
- PUT (FILE1, "LINE TWO");
- NEW_LINE (FILE1, 3);
- NEW_PAGE (FILE1);
- NEW_PAGE (FILE1);
- CLOSE (FILE1);
-
- BEGIN
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SKIP_LINE (FILE1);
- GET (FILE1, ST(1..7));
- IF ST(1..7) /= "LINE TW" THEN
- FAILED ("NOT POSITIONED RIGHT - GET CHAR");
- END IF;
-
--- COUNT NUMBER OF CHARACTERS IN FIRST LINE (TO ALLOW FOR TRAILING
--- BLANKS)
-
- COUNT := 0;
- WHILE NOT END_OF_LINE(FILE1)
- LOOP
- GET (FILE1, CH);
- OLDCH := CH;
- COUNT := COUNT + 1;
- END LOOP;
-
- BEGIN
- GET (FILE1, CH);
- FAILED ("END_ERROR NOT RAISED - GET " &
- "CHARACTER");
- EXCEPTION
- WHEN END_ERROR =>
- IF CH /= OLDCH THEN
- FAILED ("CH MODIFIED ON END_" &
- "ERROR");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED " &
- "- GET CHARACTER");
- END;
-
- CLOSE (FILE1);
-
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
-
- SKIP_LINE (FILE1);
- GET (FILE1, ST(1..7));
- IF ST(1..7) /= "LINE TW" THEN
- FAILED ("WRONG LINE 2. ACTUALLY READ '" & ST(1..7) &
- "'");
- END IF;
-
- BEGIN
- GET (FILE1, ST(8..8+COUNT));
- FAILED ("END_ERROR NOT RAISED - GET " &
- "STRING");
- EXCEPTION
- WHEN END_ERROR =>
- IF ST(1..7) /= "LINE TW" THEN
- FAILED ("ST MODIFIED ON END_ERROR");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED " &
- "- GET STRING");
- END;
-
- CLOSE (FILE1);
-
- END;
-
- DECLARE
- LAST : NATURAL;
- BEGIN
-
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
-
- SKIP_LINE (FILE1);
- GET_LINE (FILE1, ST, LAST);
- IF LAST < 8 THEN
- FAILED ("LAST < 8. LAST IS" & INTEGER'IMAGE(LAST));
- ELSIF ST(1..8) /= "LINE TWO" THEN
- FAILED ("GET_LINE FAILED. ACTUALLY READ '" &
- ST(1..8) & "'");
- END IF;
-
- SKIP_PAGE (FILE1);
- SKIP_PAGE (FILE1);
-
- BEGIN
- GET_LINE (FILE1, ST(1..1), LAST);
- FAILED ("END_ERROR NOT RAISED - GET_LINE - 1");
- EXCEPTION
- WHEN END_ERROR =>
- IF LAST /= 8 THEN
- FAILED ("LAST MODIFIED BY GET_LINE " &
- "ON END_ERROR. LAST IS" &
- INTEGER'IMAGE(LAST));
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - GET_LINE - 1");
- END;
-
- BEGIN -- NULL ITEM ARGUMENT
- GET_LINE (FILE1, ST(1..0), LAST);
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("GET_LINE ATTEMPTED TO READ INTO A " &
- "NULL STRING");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION - GET_LINE - 2");
- END;
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3603A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada
deleted file mode 100644
index 380791f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada
+++ /dev/null
@@ -1,160 +0,0 @@
--- CE3604A.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 GET_LINE MAY BE CALLED TO RETURN AN ENTIRE LINE. ALSO
--- CHECK THAT GET_LINE MAY BE CALLED TO RETURN THE REMAINDER OF A
--- PARTLY READ LINE. ALSO CHECK THAT GET_LINE RETURNS IN THE
--- PARAMETER LAST, THE INDEX VALUE OF THE LAST CHARACTER READ.
--- WHEN NO CHARACTERS ARE READ, LAST IS ONE LESS THAN ITEM'S LOWER
--- BOUND.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 09/25/87 COMPLETELY REVISED TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3604A IS
-
-BEGIN
-
- TEST ("CE3604A", "CHECK THAT GET_LINE READS LINES APPROPRIATELY " &
- "AND CHECK THAT LAST RETURNS THE CORRECT INDEX " &
- "VALUE");
-
- DECLARE
- FILE : FILE_TYPE;
- STR : STRING (1 .. 25);
- LAST : NATURAL;
- ITEM1 : STRING (2 .. 6);
- ITEM2 : STRING (3 .. 6);
- CH : CHARACTER;
- INCOMPLETE : EXCEPTION;
-
- BEGIN
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "FIRST LINE OF INPUT");
- NEW_LINE (FILE);
- PUT (FILE, "SECOND LINE OF INPUT");
- NEW_LINE (FILE);
- PUT (FILE, "THIRD LINE OF INPUT");
- NEW_LINE (FILE);
- NEW_LINE (FILE);
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET_LINE (FILE, STR, LAST);
-
- BEGIN
- IF STR(1..LAST) /= "FIRST LINE OF INPUT" THEN
- FAILED ("GET_LINE - RETURN OF ENTIRE LINE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED AFTER " &
- "GET_LINE - 1");
- END;
-
- GET (FILE, ITEM1);
- GET_LINE (FILE, STR, LAST);
-
- BEGIN
- IF STR(1..LAST) /= "D LINE OF INPUT" THEN
- FAILED ("GET_LINE - REMAINDER OF PARTLY READ LINE");
- END IF;
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED AFTER " &
- "GET_LINE - 2");
- END;
-
- GET_LINE (FILE, ITEM1, LAST);
- IF LAST /= 6 THEN
- FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 1");
- END IF;
-
- WHILE NOT END_OF_LINE (FILE) LOOP
- GET (FILE, CH);
- END LOOP;
-
- GET_LINE (FILE, ITEM1, LAST);
- IF LAST /= 1 THEN
- FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 2");
- END IF;
-
- IF NOT END_OF_LINE (FILE) THEN
- FAILED ("END_OF_LINE NOT TRUE");
- END IF;
-
- GET_LINE (FILE, ITEM2, LAST);
- IF LAST /= 2 THEN
- FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 3");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3604A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada
deleted file mode 100644
index 5684b8a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- CE3604B.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 GET_LINE DOES NOT DO A SKIP_LINE AND NO CHARACTERS ARE
--- READ WHEN THE INPUT IS AT THEN END OF A LINE AND THE STRING
--- PARAMETER IS A NULL STRING. ALSO CHECK THAT GET_LINE DOES NOT
--- SKIP THE LINE TERMINATOR AFTER READING ALL THE CHARACTERS INTO
--- A STRING WHICH IS EXACTLY EQUAL TO THE NUMBER OF CHARACTERS
--- REMAINING ON THAT LINE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 10/13/87 CREATED ORIGINAL TEST.
-
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3604B IS
-
-BEGIN
-
- TEST ("CE3604B", "CHECK THAT GET_LINE READS LINES APPROPRIATELY");
-
- DECLARE
- INCOMPLETE : EXCEPTION;
- FILE : FILE_TYPE;
- ITEM1 : STRING (1 .. 19);
- ITEM2 : STRING (1 .. 20);
- NULL_ITEM : STRING (2 .. 1);
- LAST : NATURAL;
-
- BEGIN
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
-
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " &
- "CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "FIRST LINE OF INPUT");
- NEW_LINE (FILE);
- PUT (FILE, "SECOND LINE OF INPUT");
- NEW_LINE (FILE);
- PUT (FILE, "THIRD LINE OF INPUT");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM1);
- IF ITEM1 /= "FIRST LINE OF INPUT" THEN
- FAILED ("INCORRECT VALUE FOR GET");
- END IF;
-
- GET_LINE (FILE, NULL_ITEM, LAST);
-
- IF LINE (FILE) /= 1 THEN
- FAILED ("INCORRECT LINE NUMBER AFTER GET_LINE - 1");
- END IF;
-
- IF COL (FILE) /= 20 THEN
- FAILED ("INCORRECT COLUMN NUMBER AFTER GET_LINE - 1");
- END IF;
-
- SKIP_LINE (FILE);
- GET_LINE (FILE, ITEM2, LAST);
- IF ITEM2 /= "SECOND LINE OF INPUT" THEN
- FAILED ("INCORRECT VALUE FOR GET_LINE");
- END IF;
-
- IF LINE (FILE) /= 2 THEN
- FAILED ("INCORRECT LINE NUMBER AFTER GET_LINE - 2");
- END IF;
-
- IF COL (FILE) /= 21 THEN
- FAILED ("INCORRECT COLUMN NUMBER AFTER GET_LINE - 2");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3604B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada
deleted file mode 100644
index 41d1eae..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- CE3605A.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 PUT FOR CHARACTER AND STRING PARAMETERS DOES NOT
--- UPDATE THE LINE NUMBER WHEN THE LINE LENGTH IS UNBOUNDED,
--- ONLY THE COLUMN NUMBER.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- SPS 09/02/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND ADDED CHECKS
--- FOR COLUMN NUMBER.
--- RJW 03/28/90 REVISED NUMERIC LITERALS USED IN LOOPS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3605A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3605A", "CHECK THAT PUT FOR CHARACTER AND STRING " &
- "PARAMETERS DOES NOT UPDATE THE LINE NUMBER " &
- "WHEN THE LINE LENGTH IS UNBOUNDED, ONLY THE " &
- "COLUMN NUMBER");
-
- DECLARE
- FILE1 : FILE_TYPE;
- LN : POSITIVE_COUNT := 1;
- BEGIN
-
- BEGIN
- CREATE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILES WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- LN := LINE (FILE1);
-
- IF LN /= 1 THEN
- FAILED ("CURRENT LINE NUMBER NOT INITIALLY ONE");
- END IF;
-
- IF COL (FILE1) /= 1 THEN
- FAILED ("CURRENT COLUMN NUMBER NOT INITIALLY ONE");
- END IF;
-
- FOR I IN 1 .. IDENT_INT(240) LOOP
- PUT(FILE1, 'A');
- END LOOP;
- IF LINE (FILE1) /= LN THEN
- FAILED ("PUT ALTERED LINE NUMBER - CHARACTER");
- END IF;
-
- IF COL(FILE1) /= 241 THEN
- FAILED ("COLUMN NUMBER NOT UPDATED CORRECTLY - 1");
- END IF;
-
- NEW_LINE(FILE1);
- LN := LINE (FILE1);
-
- FOR I IN 1 .. IDENT_INT(40) LOOP
- PUT (FILE1, "STRING");
- END LOOP;
- IF LN /= LINE (FILE1) THEN
- FAILED ("PUT ALTERED LINE NUMBER - STRING");
- END IF;
-
- IF COL(FILE1) /= 241 THEN
- FAILED ("COLUMN NUMBER NOT UPDATED CORRECTLY - 2");
- END IF;
-
- CLOSE (FILE1);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3605A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada
deleted file mode 100644
index c0de3c5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- CE3605B.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 PUT OUTPUTS A LINE TERMINATOR, RESETS THE COLUMN
--- NUMBER AND INCREMENTS THE LINE NUMBER WHEN THE LINE LENGTH IS
--- BOUNDED AND THE COLUMN NUMBER EQUALS THE LINE LENGTH WHEN PUT
--- IS CALLED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/02/82
--- JBG 12/28/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 GAVE FILE A NAME AND REMOVED CODE WHICH RESETS
--- THE FILE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-PROCEDURE CE3605B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3605B", "CHECK THAT PUT PROPERLY MAINTAINS THE " &
- "LINE NUMBER AND COLUMN NUMBER WHEN THE " &
- "LINE LENGTH IS BOUNDED");
-
- DECLARE
- FILE1 : FILE_TYPE;
- LN_CNT : POSITIVE_COUNT;
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FILE1, 5);
- LN_CNT := LINE (FILE1);
-
- FOR I IN 1 .. 5 LOOP
- PUT (FILE1, 'X');
- END LOOP;
-
- IF COL(FILE1) /= 6 THEN
- FAILED ("COLUMN NUMBER NOT INCREMENTED - PUT; " &
- "VALUE WAS" & COUNT'IMAGE(COL(FILE1)));
- END IF;
-
- IF LINE(FILE1) /= LN_CNT THEN
- FAILED ("LINE COUNT MODIFIED - PUT CHARACTER; " &
- "VALUE WAS" & COUNT'IMAGE(LINE(FILE1)));
- END IF;
-
- PUT (FILE1, 'X');
- IF COL(FILE1) /= 2 THEN
- FAILED ("COLUMN NUMBER NOT RESET - PUT CHARACTER; " &
- "VALUE WAS" & COUNT'IMAGE(COL(FILE1)));
- END IF;
-
- IF LINE(FILE1) /= LN_CNT + 1 THEN
- FAILED("LINE NUMBER NOT INCREMENTED - PUT CHARACTER; " &
- "VALUE WAS" & COUNT'IMAGE(LINE(FILE1)));
- END IF;
-
- NEW_LINE (FILE1);
-
- SET_LINE_LENGTH (FILE1, 4);
- LN_CNT := LINE (FILE1);
-
- PUT (FILE1, "XXXX");
-
- IF COL(FILE1) /= 5 THEN
- FAILED ("COLUMN NUMBER NOT INCREMENTED - PUT STRING; " &
- "VALUE WAS" & COUNT'IMAGE(COL(FILE1)));
- END IF;
-
- IF LINE (FILE1) /= LN_CNT THEN
- FAILED ("LINE NUMBER INCREMENTED - PUT STRING; " &
- "VALUE WAS" & COUNT'IMAGE(LINE (FILE1)));
- END IF;
-
- PUT (FILE1, "STR");
-
- IF COL(FILE1) /= 4 THEN
- FAILED ("COLUMN NUMBER NOT SET CORRECTLY - PUT" &
- "STRING; VALUE WAS" & COUNT'IMAGE(COL(FILE1)));
- END IF;
-
- IF LINE (FILE1) /= LN_CNT + 1 THEN
- FAILED ("LINE NUMBER NOT INCREMENTED - PUT STRING; " &
- "VALUE WAS" & COUNT'IMAGE(LINE (FILE1)));
- END IF;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3605B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada
deleted file mode 100644
index 7dca978..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- CE3605C.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 PUT RAISES MODE_ERROR FOR FILES OF MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/02/82
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3605C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3605C", "MODE_ERROR RAISED BY PUT FOR IN_FILES");
-
- DECLARE
- FILE1 : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE1, 'A');
- CLOSE (FILE1);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FILE1, 'A');
- FAILED ("MODE_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- PUT (STANDARD_INPUT, 'A');
- FAILED ("MODE_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, 'A');
- FAILED ("MODE_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- PUT (FILE1, "STRING");
- FAILED ("MODE_ERROR NOT RAISED - 4");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- PUT (STANDARD_INPUT, "STRING");
- FAILED ("MODE_ERROR NOT RAISED - 5");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 5");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, "STRING");
- FAILED ("MODE_ERROR NOT RAISED - 6");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 6");
- END;
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3605C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada
deleted file mode 100644
index 1d52eae..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada
+++ /dev/null
@@ -1,192 +0,0 @@
--- CE3605D.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 PUT DOES NOT RAISE LAYOUT_ERROR WHEN THE NUMBER OF
--- CHARACTERS TO BE OUTPUT EXCEEDS THE LINE LENGTH.
--- CHECK THAT PUT HAS THE EFFECT OF NEW_LINE (AS WELL AS
--- OUTPUTTING THE ITEM) WHEN THE NUMBER OF CHARACTERS TO BE OUTPUT
--- OVERFLOWS A BOUNDED LINE LENGTH.
--- CHECK THAT PUT WITH A NULL STRING PERFORMS NO OPERATION.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/02/82
--- JBG 12/28/82
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-PROCEDURE CE3605D IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3605D", "CHECK THAT LAYOUT_ERROR IS NOT RAISED BY PUT " &
- "FOR STRING");
-
- DECLARE
- FT : FILE_TYPE;
- LC : POSITIVE_COUNT;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON " &
- "TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 5);
-
- BEGIN
- PUT (FT, "STRING");
-
- IF LINE(FT) /= 2 THEN
- FAILED ("LINE COUNT WAS" & COUNT'IMAGE(LINE(FT)) &
- " INSTEAD OF 2");
- END IF;
-
- IF COL(FT) /= 2 THEN
- FAILED ("COLUMN COUNT WAS" & COUNT'IMAGE(COL(FT)) &
- " INSTEAD OF 2");
- END IF;
-
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 1");
-
- END;
-
- PUT (FT, "NEW");
-
- IF LINE(FT) /= 2 THEN
- FAILED ("LINE COUNT WRONG - 2; WAS" &
- COUNT'IMAGE(LINE(FT)) &
- " INSTEAD OF 2");
- END IF;
-
- IF COL(FT) /= 5 THEN
- FAILED ("COL COUNT WRONG - 2; WAS" &
- COUNT'IMAGE(COL(FT)) &
- " INSTEAD OF 5");
- END IF;
-
- BEGIN
- PUT (FT, "STR");
- IF LINE (FT) /= 3 THEN
- FAILED ("PUT STRING WHEN IN MIDDLE OF " &
- "LINE DOES NOT HAVE EFFECT OF " &
- "NEW_LINE; LINE COUNT IS" &
- COUNT'IMAGE(LINE(FT)));
- END IF;
-
- IF COL(FT) /= 3 THEN
- FAILED ("COL COUNT WRONG - 3; WAS" &
- COUNT'IMAGE(COL(FT)) &
- " INSTEAD OF 3");
- END IF;
-
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
- END;
-
- PUT (FT, "ING");
-
- IF LINE(FT) /= 3 THEN
- FAILED ("LINE COUNT WRONG - 3; WAS" &
- COUNT'IMAGE(LINE(FT)) &
- " INSTEAD OF 3");
- END IF;
-
- IF COL(FT) /= 6 THEN
- FAILED ("COL COUNT WRONG - 3; WAS" &
- COUNT'IMAGE(COL(FT)) &
- " INSTEAD OF 6");
- END IF;
-
- BEGIN
- PUT (FT, "");
-
- IF LINE(FT) /= 3 THEN
- FAILED ("LINE COUNT WRONG - 3; WAS" &
- COUNT'IMAGE(LINE(FT)) &
- " INSTEAD OF 3");
- END IF;
-
- IF COL(FT) /= 6 THEN
- FAILED ("COL COUNT WRONG - 3; WAS" &
- COUNT'IMAGE(COL(FT)) &
- " INSTEAD OF 6");
- END IF;
-
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED - 3");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
- END;
-
- CHECK_FILE (FT,
- "STRIN#" &
- "GNEWS#" &
- "TRING#@%");
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3605D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada
deleted file mode 100644
index 5ea6f23..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CE3605E.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 PUT CAN BE CALLED WITH CHARACTER AND STRING
--- PARAMETERS. CHECK THAT FILES OF MODE OUT_FILE ARE USED AND
--- THAT WHEN NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE
--- IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- SPS 10/06/82
--- JBG 12/28/82
--- VKG 02/15/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/08/87 REMOVED UNNECESSARY CODE AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-PROCEDURE CE3605E IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3605E", "CHECK THAT PUT FOR STRINGS AND CHARACTERS " &
- "OPERATES ON OUT_FILE FILES");
-
- DECLARE
- FT , FILE : FILE_TYPE;
- X : CHARACTER;
- BEGIN
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FILE);
-
- SET_OUTPUT (FILE);
-
- PUT (FT, 'O');
-
- PUT (FT, "UTPUT STRING");
-
- PUT ('X');
-
- PUT ("UTPUT STRING");
-
--- CHECK OUTPUT
-
- SET_OUTPUT (STANDARD_OUTPUT);
- COMMENT ("CHECKING FT");
- CHECK_FILE (FT, "OUTPUT STRING#@%");
- COMMENT ("CHECKING FILE");
- CHECK_FILE (FILE, "XUTPUT STRING#@%");
-
- CLOSE (FT);
- CLOSE (FILE);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3605E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada
deleted file mode 100644
index 18b2af8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada
+++ /dev/null
@@ -1,91 +0,0 @@
--- CE3606A.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 PUT_LINE WILL OUTPUT A LINE TERMINATOR WHEN THE
--- STRING PARAMETER IS NULL.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEMPORARY TEXT FILES.
-
--- HISTORY:
--- SPS 09/02/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-PROCEDURE CE3606A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3606A", "PUT_LINE PUTS LINE TERMINATOR WHEN STRING " &
- "IS NULL");
-
- DECLARE
- FT : FILE_TYPE;
- NS1 : STRING (1 .. 0);
- NS2 : STRING (3 .. 1);
- LC : POSITIVE_COUNT := 1;
- BEGIN
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILES WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT_LINE (FT, NS1);
- IF LINE (FT) /= LC + 1 THEN
- FAILED ("PUT_LINE OF NULL STRING 1; LINE " &
- "COUNT WAS" & COUNT'IMAGE(LINE(FT)));
- END IF;
-
- PUT_LINE (FT, NS2);
- IF LINE (FT) /= LC + 2 THEN
- FAILED ("PUT_LINE OF NULL STRING 2; LINE " &
- "COUNT WAS" & COUNT'IMAGE(LINE(FT)));
- END IF;
-
- CHECK_FILE (FT, "##@%");
-
- CLOSE (FT);
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3606A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada
deleted file mode 100644
index 728a256..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada
+++ /dev/null
@@ -1,97 +0,0 @@
--- CE3606B.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 PUT_LINE WILL OUTPUT A LINE ON MORE THAN ONE LINE
--- WHEN THE LINE LENGTH IS BOUNDED, IF THE STRING IS GREATER
--- THAN THE LINE LENGTH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEMPORARY TEXT FILES.
-
--- HISTORY:
--- SPS 09/02/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-PROCEDURE CE3606B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3606B", "CHECK THAT PUT_LINE WILL OUTPUT A LINE " &
- "ON MORE THAN ONE LINE WHEN THE LINE " &
- "LENGTH IS BOUNDED, IF THE STRING IS " &
- "GREATER THAN THE LINE LENGTH");
-
- DECLARE
- FT : FILE_TYPE;
- LONG_LINE : CONSTANT STRING := "THIS LINE IS A LONG " &
- "LINE WHICH WHEN OUTPUT SHOULD SPAN OVER SEVERAL " &
- "LINES IN THE OUTPUT FILE";
- BEGIN
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILES WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 10);
-
- PUT_LINE (FT, LONG_LINE);
- PUT_LINE (FT, "AA");
-
- CHECK_FILE (FT, "THIS LINE #" &
- "IS A LONG #" &
- "LINE WHICH#" &
- " WHEN OUTP#" &
- "UT SHOULD #" &
- "SPAN OVER #" &
- "SEVERAL LI#" &
- "NES IN THE#" &
- " OUTPUT FI#" &
- "LE#" &
- "AA#@%");
-
- CLOSE (FT);
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3606B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada
deleted file mode 100644
index 0f9c52f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- CE3701A.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 GET AND PUT OF INTEGER_IO RAISE STATUS_ERROR IF
--- THE FILE IS NOT OPEN.
-
--- HISTORY:
--- ABW 08/27/82
--- JBG 08/30/83
--- DWC 09/09/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION
--- HANDLING, AND ATTEMPTED TO CREATE A FILE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3701A IS
-
- PACKAGE INT_IO IS NEW INTEGER_IO (INTEGER);
- USE INT_IO;
- FILE : FILE_TYPE;
- INT_ITEM : INTEGER := 7;
-
-BEGIN
-
- TEST ("CE3701A", "CHECK THAT GET AND PUT RAISE " &
- "STATUS_ERROR IF THE FILE " &
- "IS NOT OPEN");
-
- BEGIN
- PUT (FILE, IDENT_INT(8));
- FAILED ("STATUS_ERROR NOT RAISED WHEN PUT APPLIED " &
- "TO A NON-EXISTENT FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN PUT " &
- "APPLIED TO A NON-EXISTENT FILE");
- END;
-
- BEGIN
- GET (FILE, INT_ITEM);
- FAILED ("STATUS_ERROR NOT RAISED WHEN GET APPLIED " &
- "TO A NON-EXISTENT FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN GET " &
- "APPLIED TO A NON-EXISTENT FILE");
- END;
-
- BEGIN
- CREATE (FILE); -- THIS IS JUST AN ATTEMPT TO CREATE
- CLOSE (FILE); -- A FILE. WHETHER THIS IS SUCCESSFUL
- EXCEPTION -- OR NOT HAS NO EFFECT ON TEST
- WHEN USE_ERROR => -- OBJECTIVE.
- NULL;
- END;
-
- BEGIN
- PUT (FILE, IDENT_INT(8));
- FAILED ("STATUS_ERROR NOT RAISED WHEN PUT APPLIED " &
- "TO AN UNOPENED FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN PUT " &
- "APPLIED TO AN UNOPENED FILE");
- END;
-
- BEGIN
- GET (FILE, INT_ITEM);
- FAILED ("STATUS_ERROR NOT RAISED WHEN GET APPLIED " &
- "TO AN UNOPENED FILE");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED WHEN GET " &
- "APPLIED TO AN UNOPENED FILE");
- END;
-
- RESULT;
-
-END CE3701A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada
deleted file mode 100644
index f2325c0..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada
+++ /dev/null
@@ -1,134 +0,0 @@
--- CE3704A.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.
---*
--- HISTORY:
--- CHECK THAT GET FOR INTEGER_IO CAN OPERATE ON ANY FILE OF MODE
--- IN_FILE AND THAT IF NO FILE IS SPECIFIED THE CURRENT DEFAULT
--- INPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/01/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION
--- HANDLING, AND REMOVED DEPENDENCE ON RESET.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704A", "CHECK THAT GET FOR INTEGER_IO CAN OPERATE " &
- "ON ANY FILE OF MODE IN_FILE AND THAT IF " &
- "NO FILE IS SPECIFIED THE CURRENT DEFAULT " &
- "INPUT FILE IS USED");
-
- DECLARE
- FT : FILE_TYPE;
- FT2: FILE_TYPE;
- TYPE NI IS NEW INTEGER RANGE 1 .. 700;
- X : NI;
- PACKAGE IIO IS NEW INTEGER_IO (NI);
- USE IIO;
- BEGIN
-
--- CREATE AND INITIALIZE DATA FILES
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, '3');
- PUT (FT, '6');
- PUT (FT, '9');
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FT2, '6');
- PUT (FT2, '2');
- PUT (FT2, '4');
-
- CLOSE (FT2);
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- SET_INPUT (FT2);
-
- GET (FT, X);
-
- IF X /= 369 THEN
- FAILED ("GET RETURNED WRONG VALUE; VALUE WAS" &
- NI'IMAGE(X));
- END IF;
-
- GET (X);
-
- IF X /= 624 THEN
- FAILED ("GET FOR DEFAULT WAS WRONG; VALUE WAS" &
- NI'IMAGE(X));
- END IF;
-
- BEGIN
- DELETE (FT);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada
deleted file mode 100644
index 59f60c4..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada
+++ /dev/null
@@ -1,107 +0,0 @@
--- CE3704B.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 INTEGER_IO GET RAISES MODE_ERROR FOR FILES OF MODE
--- OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/04/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704B", "CHECK THAT INTEGER_IO GET RAISES " &
- "MODE_ERROR FOR FILES OF MODE OUT_FILE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE INT IS NEW INTEGER RANGE 1 .. 10;
- PACKAGE IIO IS NEW INTEGER_IO (INT);
- USE IIO;
- X : INT := 10;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE);
- PUT (FT, '3');
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("MODE_ERROR NOT RAISED - FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CURRENT_OUTPUT");
- END;
-
- CLOSE (FT);
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada
deleted file mode 100644
index b3567fa..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada
+++ /dev/null
@@ -1,176 +0,0 @@
--- CE3704C.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 INTEGER_IO GET RAISES CONSTRAINT_ERROR IF THE
--- WIDTH PARAMETER IS NEGATIVE, IF THE WIDTH PARAMETER IS
--- GREATER THAN FIELD'LAST WHEN FIELD'LAST IS LESS THAN
--- INTEGER'LAST, OR THE VALUE READ IS OUT OF THE RANGE OF
--- THE ITEM PARAMETER BUT WITHIN THE RANGE OF INSTANTIATED
--- TYPE.
-
--- HISTORY:
--- SPS 10/04/82
--- DWC 09/09/87 ADDED CASES FOR WIDTH BEING GREATER THAN
--- FIELD'LAST AND THE VALUE BEING READ IS OUT
--- OF ITEM'S RANGE BUT WITHIN INSTANTIATED
--- RANGE.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704C", "CHECK THAT INTEGER_IO GET RAISES " &
- "CONSTRAINT_ERROR IF THE WIDTH PARAMETER " &
- "IS NEGATIVE, IF THE WIDTH PARAMETER IS " &
- "GREATER THAN FIELD'LAST WHEN FIELD'LAST IS " &
- "LESS THAN INTEGER'LAST, OR THE VALUE READ " &
- "IS OUT OF THE RANGE OF THE ITEM PARAMETER " &
- "BUT WITHIN THE RANGE OF INSTANTIATED TYPE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE INT IS NEW INTEGER RANGE 1 .. 10;
- PACKAGE IIO IS NEW INTEGER_IO (INT);
- X : INT RANGE 1 .. 5;
- USE IIO;
- BEGIN
-
- BEGIN
- GET (FT, X, IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("RAISED STATUS_ERROR");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE");
- END;
-
- BEGIN
- GET (X, IDENT_INT(-6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - DEFAULT");
- END;
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, 1);
- NEW_LINE (FT);
- PUT (FT, 8);
- NEW_LINE (FT);
- PUT (FT, 2);
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR FOR OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X, IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- END;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "OUT OF RANGE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "OUT OF RANGE");
- END;
-
- SKIP_LINE (FT);
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- GET (FT, X, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- END;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE3704C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada
deleted file mode 100644
index 233b864..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada
+++ /dev/null
@@ -1,169 +0,0 @@
--- CE3704D.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 INTEGER_IO GET READS AT MOST WIDTH CHARACTERS
--- OR UP TO THE NEXT TERMINATOR; INCLUDING LEADING BLANKS
--- AND HORIZONTAL TABULATION CHARACTERS, WHEN WIDTH IS
--- NONZERO.
-
--- CHECK THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS
--- ENCOUNTERED AND THAT DATA_ERROR IS RAISED IF THE DATA
--- READ IS INVALID.
-
--- APPLICABILITY CRITERIA:
-
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/04/82
--- VKG 01/12/83
--- SPS 02/08/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/09/87 ADDED CASES FOR TABS, REMOVED UNNECESSARY
--- CODE, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704D IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704D", "CHECK THAT INTEGER_IO GET READS AT MOST " &
- "WIDTH CHARACTERS OR UP TO THE NEXT " &
- "TERMINATOR; INCLUDING LEADING BLANKS AND " &
- "HORIZONTAL TABULATION CHARACTERS, WHEN WIDTH " &
- "IS NONZERO");
-
- DECLARE
- FT : FILE_TYPE;
- X : INTEGER;
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- BEGIN
-
--- CREATE AND INITIALIZE FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, " 123");
- NEW_LINE (FT);
- PUT (FT, "-5678");
- NEW_LINE (FT);
- PUT (FT, " ");
- NEW_PAGE (FT);
- PUT (FT, ASCII.HT & "9");
- NEW_PAGE (FT);
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- BEGIN TEST
-
- GET (FT, X, 5);
- IF X /= IDENT_INT (123) THEN
- FAILED ("WIDTH CHARACTERS NOT READ - 1");
- ELSE
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED -1");
- END;
- SKIP_LINE (FT);
- GET (FT, X, 6);
- IF X /= IDENT_INT (-5678) THEN
- FAILED ("GET WITH WIDTH " &
- "INCORRECT - 2");
- ELSE
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
- SKIP_LINE(FT);
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
- SKIP_LINE(FT);
- GET (FT, X, 2);
- IF X /= IDENT_INT (9) THEN
- FAILED ("GET WITH WIDTH " &
- "INCORRECT - 3");
- END IF;
- END IF;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada
deleted file mode 100644
index 6fb0430..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada
+++ /dev/null
@@ -1,143 +0,0 @@
--- CE3704E.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 INTEGER_IO GET RAISES DATA_ERROR WHEN THE LEXICAL
--- ELEMENT IS NOT OF THE INTEGER TYPE EXPECTED. CHECK THAT ITEM
--- IS UNAFFECTED AND READING CAN CONTINUE AFTER THE EXCEPTION
--- HAS BEEN HANDLED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/04/82
--- VKG 01/14/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/10/87 REMOVED UNNECCESSARY CODE, CORRECTED EXCEPTION
--- HANDLING, AND CHECKED FOR USE_ERROR ON DELETE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704E IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704E", "CHECK THAT INTEGER_IO GET RAISES DATA_ERROR " &
- "WHEN THE LEXICAL ELEMENT IS NOT OF THE " &
- "INTEGER TYPE EXPECTED. CHECK THAT ITEM " &
- "IS UNAFFECTED AND READING CAN CONTINUE AFTER " &
- "THE EXCEPTION HAS BEEN HANDLED");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE INT IS NEW INTEGER RANGE 10 .. 20;
- PACKAGE IIO IS NEW INTEGER_IO (INT);
- USE IIO;
- X : INT := 16;
- BEGIN
-
--- CREATE AND INITIALIZE FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, " 101 12");
- CLOSE(FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 16 THEN
- FAILED ("ITEM AFFECTED BY GET WHEN DATA" &
- "_ERROR IS RAISED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- GET (FT, X, 3);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 16 THEN
- FAILED ("ITEM AFFECTED BY GET WHEN DATA" &
- "_ERROR IS RAISED");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- GET (FT, X, 2);
- IF X /= 12 THEN
- FAILED ("READING NOT CONTINUED CORRECTLY " &
- "AFTER EXCEPTION");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("GET OF CORRECT DATA RAISED EXCEPTION");
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada
deleted file mode 100644
index 22f0217..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada
+++ /dev/null
@@ -1,365 +0,0 @@
--- CE3704F.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 INTEGER_IO GET DOES NOT ALLOW EMBEDDED BLANKS OR
--- CONSECUTIVE UNDERSCORES TO BE INPUT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/04/82
--- VKG 01/14/83
--- CPP 07/30/84
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/10/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION
--- HANDLING, AND ADDED MORE CHECKS OF THE VALUES
--- OF CHARACTERS READ.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704F IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704F", "INTEGER_IO GET DOES NOT ALLOW EMBEDDED " &
- "BLANKS OR CONSECUTIVE UNDERSCORES");
-
- DECLARE
- FT : FILE_TYPE;
- X : INTEGER;
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- CH : CHARACTER;
- P : POSITIVE;
- BEGIN
-
--- CREATE AND INITIALIZE FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "12_345");
- NEW_LINE (FT);
- PUT (FT, "12 345");
- NEW_LINE (FT);
- PUT (FT, "1__345");
- NEW_LINE (FT);
- PUT (FT, "-56");
- NEW_LINE (FT);
- PUT (FT, "10E0");
- NEW_LINE (FT);
- PUT (FT, "10E-2X");
- NEW_LINE (FT);
- PUT (FT, "4E1__2");
- NEW_LINE (FT);
- PUT (FT, "1 0#99#");
- NEW_LINE (FT);
- PUT (FT, "1__0#99#");
- NEW_LINE (FT);
- PUT (FT, "10#9_9#");
- NEW_LINE (FT);
- PUT (FT, "10#9__9#");
- NEW_LINE (FT);
- PUT (FT, "10#9 9#");
- NEW_LINE (FT);
- PUT (FT, "16#E#E1");
- NEW_LINE (FT);
- PUT (FT, "2#110#E1_1");
- NEW_LINE (FT);
- PUT (FT, "2#110#E1__1");
- CLOSE(FT);
-
--- BEGIN TEST
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; " &
- "TEXT OPEN WITH IN_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= 12345 THEN
- FAILED ("GET WITH UNDERSCORE INCORRECT - (1)");
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 6);
- FAILED ("DATA_ERROR NOT RAISED - (2)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (2)");
- END;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (3)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (3)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (3)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(3): CHAR IS " & CH);
- END IF;
- GET (FT, CH);
- IF CH /= '3' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(3.5): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X);
- IF X /= (-56) THEN
- FAILED ("GET WITH GOOD CASE INCORRECT - (4)");
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X, 4);
- IF X /= 10 THEN
- FAILED ("GET WITH ZERO EXPONENT INCORRECT - (5)");
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (6)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (6)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (6)");
- ELSE
- GET (FT, CH);
- IF CH /= 'X' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(6): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (7)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (7)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (7)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(7): CHAR IS " & CH);
- END IF;
- GET (FT, CH);
- IF CH /= '2' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(7.5): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 7);
- FAILED ("DATA_ERROR NOT RAISED - (8)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (8)");
- END;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (9)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (9)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (9)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (9): CHAR IS " & CH);
- END IF;
- GET (FT, CH);
- IF CH /= '0' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (9.5): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X);
- IF X /= 99 THEN
- FAILED ("GET WITH UNDERSCORE IN " &
- "BASED LITERAL INCORRECT - (10)");
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (11)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (11)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (11)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(11): CHAR IS " & CH);
- END IF;
- GET (FT, CH);
- IF CH /= '9' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(11.5): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 6);
- FAILED ("DATA_ERROR NOT RAISED - (12)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (12)");
- END;
-
- SKIP_LINE (FT);
- GET (FT, X, 7);
- IF X /= 224 THEN
- FAILED ("GET WITH GOOD CASE OF " &
- "BASED LITERAL INCORRECT - (13)");
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X, 10);
- IF X /= (6 * 2 ** 11) THEN
- FAILED ("GET WITH UNDERSCORE IN EXPONENT" &
- "OF BASED LITERAL INCORRECT - (14)");
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (15)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (15)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (15)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(15): CHAR IS " & CH);
- END IF;
- GET (FT, CH);
- IF CH /= '1' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(15.5): CHAR IS " & CH);
- END IF;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada
deleted file mode 100644
index 2d6d3d4..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada
+++ /dev/null
@@ -1,198 +0,0 @@
--- CE3704M.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 GET FOR INTEGER_IO RAISES DATA_ERROR WHEN
--- THE INPUT CONTAINS
---
--- (1) INTEGER_IO DECIMAL POINT
--- (2) INTEGER_IO LEADING OR TRAILING UNDERSCORES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- VKG 02/10/83
--- CPP 07/30/84
--- EG 05/22/85
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 REMOVED UNNECESSARY CODE, CORRECTED
--- EXCEPTION HANDLING, AND ADDED CASES WHICH
--- CHECK GET AT THE END_OF_FILE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3704M IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3704M", "CHECK THAT DATA_ERROR IS RAISED FOR " &
- "INTEGER_IO WHEN A DECIMAL POINT, OR " &
- "LEADING OR TRAILING UNDERSCORES " &
- "ARE DETECTED");
-
- DECLARE
- FT : FILE_TYPE;
- CH : CHARACTER;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "3.14152");
- NEW_LINE (FT);
- PUT (FT, "2.15");
- NEW_LINE (FT);
- PUT (FT, "_312");
- NEW_LINE (FT);
- PUT (FT, "-312_");
-
- CLOSE (FT);
-
- DECLARE
- PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER);
- USE INT_IO;
- X : INTEGER := 402;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X, 3);
- FAILED ("DATA_ERROR NOT RAISED - (1)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - (1)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (1)");
- ELSE
- GET (FT, CH);
- IF CH /= '4' THEN
- FAILED ("GET STOPPED AT WRONG " &
- "POSITION - (1): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- IF X /= 2 THEN
- FAILED ("WRONG VALUE READ - (2)");
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - (2)");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - (2)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (2)");
- ELSE
- GET (FT, CH);
- IF CH /= '.' THEN
- FAILED ("GET STOPPED AT WRONG " &
- "POSITION - (2): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (3)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - (3)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (3)");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (3): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (4)");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - (4)");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- FAILED ("END_OF_LINE NOT TRUE AFTER (4)");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704M;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada
deleted file mode 100644
index 656b45a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada
+++ /dev/null
@@ -1,229 +0,0 @@
--- CE3704N.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 GET FOR INTEGER_IO RAISES DATA_ERROR WHEN:
--- (A) BASE LESS THAN 2 OR GREATER THAN 16
--- (B) THE LETTERS IN BASE ARE OUT OF THE BASE RANGE
--- (C) THERE IS NO CLOSING '#' SIGN FOR A BASED LITERAL
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- VKG 02/10/83
--- SPS 03/16/83
--- CPP 07/30/84
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 REMOVED UNNECESSARY CODE, CORRECTED
--- EXCEPTION HANDLING, AND CHECKED FOR
--- USE_ERROR ON DELETE.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT ; USE REPORT ;
-
-PROCEDURE CE3704N IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3704N" ,"CHECK THAT DATA_ERROR IS RAISED WHEN " &
- "A BASED LITERAL DOES NOT HAVE ITS BASE " &
- "IN THE RANGE 2 .. 16, DIGIT IS OUTSIDE " &
- "THE BASE RANGE, OR THERE IS NO CLOSING " &
- "'#' SIGN");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "1#0000#");
- NEW_LINE (FT);
- PUT (FT, "A#234567#");
- NEW_LINE (FT);
- PUT (FT, "17#123#1");
- NEW_LINE (FT);
- PUT (FT, "5#1253#2");
- NEW_LINE (FT);
- PUT (FT, "8#123");
- CLOSE (FT);
-
- DECLARE
- PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER);
- USE INT_IO;
- X : INTEGER := 1003;
- CH : CHARACTER;
- BEGIN
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (1)");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1003 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (1)");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(1): CHAR IS " & CH);
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (2)");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1003 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - (2)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (2)");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - (2)");
- ELSE
- GET (FT, CH);
- IF CH /= 'A' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (2): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (2A)");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1003 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - (2A)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (2A)");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- IF CH /= '1' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (2A): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (3)");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1003 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - (3)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (3)");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- IF CH /= '2' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - " &
- "(3): CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - (4)");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1003 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - (4)");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - (4)");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- (4): CHAR IS " & CH);
- END IF;
- END IF;
-
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3704N;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada b/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada
deleted file mode 100644
index f38b1e9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada
+++ /dev/null
@@ -1,161 +0,0 @@
--- CE3704O.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 GET WILL RAISE DATA_ERROR IF THE USE OF # AND :
--- IN BASED LITERALS IS MIXED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- VKG 02/10/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE3704O IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3704O", "CHECK THAT MIXED USE OF # AND : " &
- "IN BASED LITERALS WILL RAISE DATA_ERROR");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
-
- PUT_LINE (FT, "8#77#E+1");
- PUT_LINE (FT, "2:110:");
- PUT (FT, "2#11:");
- NEW_LINE (FT);
- PUT (FT, "4:223#");
- NEW_LINE (FT);
- CLOSE (FT);
-
-
- DECLARE
- PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER);
- USE INT_IO;
- X : INTEGER := 100;
- CH : CHARACTER;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= 8#77#E+1 THEN
- FAILED ("INCORRECT VALUE - 1");
- END IF;
-
- GET (FT, X);
- IF X /= 2#110# THEN
- FAILED ("INCORRECT VALUE - 2");
- END IF;
-
- BEGIN
- X := 100;
- GET (FT,X);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 100 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- IF CH /= ':' THEN
- FAILED ("GET STOPPED AT WRONG POSITION - 1");
- END IF;
- END IF;
-
- BEGIN
- X := 100;
- GET (FT,X);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 100 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- GET (FT, CH);
- IF CH /='#' THEN
- FAILED ("GET STOPPED AT WRONG " &
- "POSITION - 1");
- END IF;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
- RESULT;
-
-END CE3704O;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada
deleted file mode 100644
index 8cd848e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- CE3705A.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:
--- FOR GET FROM A FILE, CHECK THAT IF ONLY THE FILE TERMINATOR
--- REMAINS TO BE READ, THEN ANY CALL TO GET FOR AN INTEGER (EVEN
--- WITH WIDTH = 0) RAISES END_ERROR.
-
--- HISTORY:
--- BCB 10/28/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3705A IS
-
- FILE : FILE_TYPE;
-
- INCOMPLETE : EXCEPTION;
-
- I : INTEGER;
-
- PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER); USE INT_IO;
-
-BEGIN
- TEST ("CE3705A", "FOR GET FROM A FILE, CHECK THAT IF ONLY THE " &
- "FILE TERMINATOR REMAINS TO BE READ, THEN ANY " &
- "CALL TO GET FOR AN INTEGER (EVEN WITH WIDTH = " &
- "0) RAISES END_ERROR");
-
- BEGIN
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, 3);
-
- CLOSE (FILE);
-
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
-
- GET (FILE, I);
-
- BEGIN
- GET (FILE, I);
- FAILED ("END_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- GET (FILE, I, WIDTH => 0);
- FAILED ("END_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("OTHER EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE3705A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada
deleted file mode 100644
index a0357e3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- CE3705B.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 WIDTH IS ZERO, CHECK THAT END_ERROR IS RAISED IF THE ONLY
--- REMAINING CHARACTERS IN THE FILE CONSIST OF LINE TERMINATORS,
--- PAGE TERMINATORS, SPACES, AND HORIZONTAL TABULATION CHARACTERS.
--- AFTER END_ERROR IS RAISED, THE FILE SHOULD BE POSITIONED BEFORE
--- THE FILE TERMINATOR AND END_OF_FILE SHOULD BE TRUE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3705B IS
-
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
-
- FILE : FILE_TYPE;
- ITEM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3705B", "IF WIDTH IS ZERO, CHECK THAT END_ERROR IS " &
- "RAISED IF THE ONLY REMAINING CHARACTERS IN " &
- "THE FILE CONSIST OF LINE TERMINATORS, PAGE " &
- "TERMINATORS, SPACES, AND HORIZONTAL TAB " &
- "CHARACTERS. AFTER END_ERROR IS RAISED, THE " &
- "FILE SHOULD BE POSITIONED BEFORE THE FILE " &
- "TERMINATOR AND END_OF_FILE SHOULD BE TRUE");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, 2);
- NEW_LINE (FILE);
- PUT (FILE, 3);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE, ASCII.HT);
- NEW_LINE (FILE);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE, ' ');
- PUT (FILE, ASCII.HT);
- PUT (FILE, ' ');
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM);
- IF ITEM /= 2 THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- GET (FILE, ITEM);
- IF ITEM /= 3 THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- BEGIN
- GET (FILE, ITEM, WIDTH => 0);
- FAILED ("END_ERROR NOT RAISED FOR GET");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET");
- END;
-
- IF NOT END_OF_FILE(FILE) THEN
- FAILED ("END_OF_FILE NOT TRUE AFTER RAISING EXCEPTION");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3705B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada
deleted file mode 100644
index a9706da..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- CE3705C.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 LAST CHARACTER IN A FILE MAY BE READ WITHOUT
--- RAISING END_ERROR, AND THAT AFTER THE LAST CHARACTER OF THE
--- FILE HAS BEEN READ, ANY ATTEMPT TO READ FURTHER CHARACTERS
--- WILL RAISE END_ERROR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/18/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3705C IS
-
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
-
- FILE : FILE_TYPE;
- ITEM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3705C", "CHECK THAT THE LAST CHARACTER IN A FILE MAY " &
- "BE READ WITHOUT RAISING END_ERROR, AND THAT " &
- "AFTER THE LAST CHARACTER OF THE FILE HAS BEEN " &
- "READ, ANY ATTEMPT TO READ FURTHER CHARACTERS " &
- "WILL RAISE END_ERROR");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
-
- PUT (FILE, 2);
- PUT (FILE, 3);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE, 5);
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM);
- GET (FILE, ITEM);
-
- BEGIN
- GET (FILE, ITEM);
- IF ITEM /= 5 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
- BEGIN
- GET (FILE, ITEM);
- FAILED ("END_ERROR NOT RAISED AFTER LAST " &
- "CHARACTER OF FILE HAS BEEN READ");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET");
- END;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR RAISED WHEN READING LAST " &
- "CHARACTER OF FILE");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET - 2");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3705C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada
deleted file mode 100644
index b9af594..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- CE3705D.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 DATA_ERROR, NOT END_ERROR, IS RAISED WHEN WIDTH > 0,
--- FEWER THAN WIDTH CHARACTERS REMAIN IN THE FILE, A BASED LITERAL
--- IS BEING READ, AND THE CLOSING # OR : HAS NOT YET BEEN FOUND.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3705D IS
-
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
-
- FILE : FILE_TYPE;
- ITEM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3705D", "CHECK THAT DATA_ERROR, NOT END_ERROR, IS " &
- "RAISED WHEN WIDTH > 0, FEWER THAN WIDTH " &
- "CHARACTERS REMAIN IN THE FILE, A BASED " &
- "LITERAL IS BEING READ, AND THE CLOSING # " &
- "OR : HAS NOT YET BEEN FOUND");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "2#1111_1111#");
- NEW_LINE (FILE);
- PUT (FILE, "16#FFF");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN " &
- "WITH MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM);
- IF ITEM /= 255 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- BEGIN
- GET (FILE, ITEM, WIDTH => 7);
- FAILED ("DATA_ERROR NOT RAISED");
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR INSTEAD OF DATA_ERROR RAISED");
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3705D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada
deleted file mode 100644
index 22798b5..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- CE3705E.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 DATA_ERROR, NOT END_ERROR, IS RAISED WHEN FEWER THAN
--- WIDTH CHARACTERS REMAIN IN THE FILE, AND THE REMAINING CHARACTERS
--- SATISFY THE SYNTAX FOR A REAL LITERAL.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/20/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3705E IS
-
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
-
- FILE : FILE_TYPE;
- ITEM : INTEGER;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3705E", "CHECK THAT DATA_ERROR, NOT END_ERROR, IS " &
- "RAISED WHEN FEWER THAN WIDTH CHARACTERS " &
- "REMAIN IN THE FILE, AND THE REMAINING " &
- "CHARACTERS SATISFY THE SYNTAX FOR A REAL " &
- "LITERAL");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, "16#FFF#");
- NEW_LINE (FILE);
- PUT (FILE, "3.14159_26");
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN " &
- "WITH MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM);
- IF ITEM /= 4095 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- BEGIN
- GET (FILE, ITEM, WIDTH => 11);
- FAILED ("DATA_ERROR NOT RAISED");
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR INSTEAD OF DATA_ERROR RAISED");
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET");
- END;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3705E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada
deleted file mode 100644
index b7cdd16..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada
+++ /dev/null
@@ -1,164 +0,0 @@
--- CE3706C.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 INTEGER_IO PUT RAISES CONSTRAINT_ERROR IF:
--- A) THE BASE IS OUTSIDE THE RANGE 2..16.
--- B) THE VALUE OF WIDTH IS NEGATIVE OR GREATER THAN FIELD'LAST,
--- WHEN FIELD'LAST < INTEGER'LAST.
--- C) THE VALUE OF ITEM IS OUTSIDE THE RANGE OF THE INSTANTIATED
--- TYPE.
-
--- HISTORY:
--- SPS 10/05/82
--- JBG 08/30/83
--- JLH 09/10/87 ADDED CASES FOR THE VALUE OF THE WIDTH BEING LESS
--- THAN ZERO AND GREATER THAN FIELD'LAST AND CASES FOR
--- THE VALUE OF ITEM OUTSIDE THE RANGE OF THE
--- INSTANTIATED TYPE.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3706C IS
-BEGIN
-
- TEST ("CE3706C", "CHECK THAT INTEGER_IO PUT RAISES CONSTRAINT " &
- "ERROR APPROPRIATELY");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE INT IS NEW INTEGER RANGE 1 .. 10;
- PACKAGE IIO IS NEW INTEGER_IO (INT);
- USE IIO;
- ST : STRING (1 .. 10);
- BEGIN
-
- BEGIN
- PUT (FT, 2, 6, 1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE - 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE - 1");
- END;
-
- BEGIN
- PUT (3, 4, 17);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT - 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - DEFAULT - 1");
- END;
-
- BEGIN
- PUT (TO => ST, ITEM => 4, BASE => -3);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - STRING - 1");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STRING - 1");
- END;
-
- BEGIN
- PUT (ST, 5, 17);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - STRING - 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STRING - 2");
- END;
-
- BEGIN
- PUT (FT, 5, -1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE - 2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE - 2");
- END;
-
- BEGIN
- PUT (7, -3);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT - " &
- "2");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - DEFAULT - 2");
- END;
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- PUT (7, FIELD'LAST+Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR WIDTH " &
- "GREATER THAN FIELD'LAST");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR WIDTH " &
- "GREATER THAN FIELD'LAST");
- END;
-
- END IF;
-
- BEGIN
- PUT (FT, 11);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- END;
-
- BEGIN
- PUT (11);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- END;
-
- END;
-
- RESULT;
-END CE3706C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada
deleted file mode 100644
index 3696af3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada
+++ /dev/null
@@ -1,127 +0,0 @@
--- CE3706D.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 INTEGER_IO PUT RAISES MODE_ERROR FOR FILES OF MODE
--- IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/05/82
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/10/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, AND CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3706D IS
-
-BEGIN
-
- TEST ("CE3706D", "CHECK THAT INTEGER_IO PUT RAISES MODE_ERROR " &
- "FOR FILES OF MODE IN_FILE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE INT IS NEW INTEGER RANGE 1 .. 30;
- PACKAGE IIO IS NEW INTEGER_IO (INT);
- USE IIO;
- INCOMPLETE : EXCEPTION;
- BEGIN
-
- BEGIN
- PUT (STANDARD_INPUT, 26);
- FAILED ("MODE_ERROR NOT RAISED - STANDARD_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STANDARD_INPUT");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, 26);
- FAILED ("MODE_ERROR NOT RAISED - CURRENT_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CURRENT_INPUT");
- END;
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, 'A');
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FT, 26);
- FAILED ("MODE_ERROR NOT RAISED - FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE");
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3706D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada
deleted file mode 100644
index 833332e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada
+++ /dev/null
@@ -1,119 +0,0 @@
--- CE3706F.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 INTEGER_IO PUT RAISES LAYOUT_ERROR WHEN THE NUMBER OF
--- CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH. CHECK
--- THAT IT IS NOT RAISED WHEN THE NUMBER OF CHARACTERS TO BE OUTPUT
--- ADDED TO THE CURRENT COLUMN NUMBER EXCEEDS THE MAXIMUM LINE
--- LENGTH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- HISTORY:
--- SPS 10/05/82
--- VKG 01/14/83
--- SPS 02/18/83
--- JBG 08/30/83
--- EG 05/22/85
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/10/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION
--- HANDLING, AND ADDED CASE USING WIDTH OF FIVE.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3706F IS
-
-BEGIN
-
- TEST ("CE3706F", "CHECK THAT LAYOUT_ERROR IS RAISED CORRECTLY");
-
- DECLARE
- FT : FILE_TYPE;
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- INCOMPLETE : EXCEPTION;
- BEGIN
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILE WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 4);
-
- BEGIN
- PUT (FT, 32_000, WIDTH => 0);
- FAILED ("LAYOUT_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- PUT (FT, 32_000, WIDTH => 5);
- FAILED ("LAYOUT_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- PUT (FT, 123, WIDTH => 0); -- "123"
-
- BEGIN
- PUT (FT, 457, WIDTH => 0); -- "123#457"
- IF LINE (FT) /= 2 THEN
- FAILED ("OUTPUT INCORRECT");
- END IF;
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED INCORRECTLY");
- END;
-
- CHECK_FILE (FT, "123#457#@%");
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3706F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada b/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada
deleted file mode 100644
index 705c215..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CE3706G.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 INTEGER_IO PUT USES THE MINIMUM FIELD REQUIRED IF
--- WIDTH IS TOO SMALL AND THE LINE LENGTH IS SUFFICIENTLY LARGE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/05/82
--- JLH 09/17/87 COMPLETELY REVISED TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3706G IS
-
-BEGIN
-
- TEST ("CE3706G", "CHECK THAT INTEGER_IO PUT USES THE MINIMUM " &
- "FIELD REQUIRED IF WIDTH IS TOO SMALL AND THE " &
- "LINE LENGTH IS SUFFICIENTLY LARGE");
-
- DECLARE
- FILE : FILE_TYPE;
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- INCOMPLETE : EXCEPTION;
- NUM : INTEGER := 12345;
- CH : CHARACTER;
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, NUM, WIDTH => 3);
- TEXT_IO.PUT (FILE, ' ');
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, NUM);
- GET (FILE, CH);
- IF CH /= ' ' AND COL(FILE) /= 7 THEN
- FAILED ("INTEGER_IO PUT DOES NOT USE MINIMUM FIELD " &
- "REQUIRED WHEN WIDTH IS TOO SMALL");
- END IF;
-
- IF NUM /= 12345 THEN
- FAILED ("INCORREC VALUE READ");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3706G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada
deleted file mode 100644
index a338fbf..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada
+++ /dev/null
@@ -1,130 +0,0 @@
--- CE3707A.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 INTEGER_IO GET CAN READ A VALUE FROM A STRING. CHECK
--- THAT IT TREATS THE END OF THE STRING AS A FILE TERMINATOR. CHECK
--- THAT LAST CONTAINS THE INDEX VALUE OF THE LAST CHARACTER READ
--- FROM THE STRING.
-
--- HISTORY:
--- SPS 10/05/82
--- VKG 01/13/83
--- JLH 09/11/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3707A IS
-
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- X : INTEGER;
- L : POSITIVE;
- STR : STRING(1..6) := "123456" ;
-
-BEGIN
-
- TEST ("CE3707A", "CHECK THAT INTEGER_IO GET OPERATES CORRECTLY " &
- "ON STRINGS");
-
--- LEFT JUSTIFIED STRING NON NULL
-
- GET ("2362 ", X, L);
- IF X /= 2362 THEN
- FAILED ("VALUE FROM STRING INCORRECT - 1");
- END IF;
-
- IF L /= 4 THEN
- FAILED ("VALUE OF LAST INCORRECT - 1");
- END IF;
-
--- STRING LITERAL WITH BLANKS
-
- BEGIN
- GET (" ", X, L);
- FAILED ("END_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 4 THEN
- FAILED ("AFTER END ERROR VALUE OF LAST " &
- "INCORRECT - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
--- NULL STRING
-
- BEGIN
- GET ("", X, L);
- FAILED (" END_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 4 THEN
- FAILED ("AFTER END_ERROR VALUE OF LAST " &
- "INCORRECT - 3");
- END IF;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3");
- END;
-
--- NULL SLICE
-
- BEGIN
- GET(STR(5..IDENT_INT(2)), X, L);
- FAILED ("END_ERROR NOT RAISED - 4");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 4 THEN
- FAILED ("AFTER END_ERROR VALUE OF LAST " &
- "INCORRECT - 4");
- END IF;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 4");
- END;
-
--- NON-NULL SLICE
-
- GET (STR(2..3), X, L);
- IF X /= 23 THEN
- FAILED ("INTEGER VALUE INCORRECT - 5");
- END IF;
- IF L /= 3 THEN
- FAILED ("LAST INCORRECT FOR SLICE - 5");
- END IF;
-
--- RIGHT JUSTIFIED NEGATIVE NUMBER
-
- GET(" -2345",X,L);
- IF X /= -2345 THEN
- FAILED ("INTEGER VALUE INCORRECT - 6");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT FOR NEGATIVE NUMBER - 6");
- END IF;
-
- RESULT;
-
-END CE3707A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada
deleted file mode 100644
index 104bc20..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- CE3708A.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 INTEGER_IO PUT RAISES LAYOUT_ERROR WHEN THE MINIMUM
--- WIDTH REQUIRED FOR THE OUTPUT VALUE IS GREATER THAN THE LENGTH
--- OF THE STRING. ALSO CHECK THAT INTEGER_IO PUT PADS THE OUTPUT
--- ON THE LEFT WITH SPACES IF THE LENGTH OF THE STRING IS GREATER
--- THAN THE MINIMUM WIDTH REQUIRED.
-
--- HISTORY:
--- SPS 10/05/82
--- CPP 07/30/84
--- JLH 09/11/87 ADDED CASES FOR PADDING OF OUTPUT STRING.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3708A IS
-BEGIN
-
- TEST ("CE3708A", "CHECK THAT INTEGER_IO PUT RAISES LAYOUT_ERROR " &
- "WHEN THE MINIMUM WIDTH REQUIRED FOR THE " &
- "OUTPUT VALUE IS GREATER THAN THE LENGTH OF " &
- "THE STRING. ALSO CHECK THAT INTEGER_IO PUT " &
- "PADS THE OUTPUT ON THE LEFT WITH SPACES IF " &
- "THE LENGTH OF THE STRING IS GREATER THAN THE " &
- "MINIMUM WIDTH REQUIRED.");
-
- DECLARE
- PACKAGE IIO IS NEW INTEGER_IO (INTEGER);
- USE IIO;
- ST1 : STRING (1 .. 4);
- ST2 : STRING (1 .. 4);
- ST : STRING (1 .. 4) := "6382";
- BEGIN
- PUT (ST1, IDENT_INT(6382));
- IF ST1 /= ST THEN
- FAILED ("PUT TO STRING INCORRECT");
- END IF;
-
- BEGIN
- PUT (ST2, IDENT_INT(12345));
- FAILED ("LAYOUT_ERROR NOT RAISED");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- PUT (ST1, IDENT_INT(123));
- IF ST1 /= " 123" THEN
- FAILED ("PUT DID NOT PAD WITH BLANKS - 1");
- END IF;
-
- PUT (ST2, IDENT_INT(-2));
- IF ST2 /= " -2" THEN
- FAILED ("PUT DID NOT PAD WITH BLANKS - 2");
- END IF;
-
- END;
-
- RESULT;
-
-END CE3708A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada
deleted file mode 100644
index 0270936..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada
+++ /dev/null
@@ -1,112 +0,0 @@
--- CE3801A.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 EACH FLOAT_IO OPERATION RAISES STATUS_ERROR WHEN
--- CALLED WITH A FILE PARAMETER DESIGNATING AN UN-OPEN FILE.
-
--- HISTORY:
--- SPS 09/07/82
--- SPS 12/22/82
--- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS
--- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF
--- WHAT IS EXPECTED.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3801A IS
-BEGIN
-
- TEST ("CE3801A", "CHECK THAT EACH FLOAT_IO AND FIXED_IO " &
- "OPERATION RAISES STATUS_ERROR WHEN CALLED " &
- "WITH A FILE PARAMETER DESIGNATING AN " &
- "UN-OPEN FILE");
-
- DECLARE
- TYPE FLT IS NEW FLOAT RANGE 1.0 .. 10.0;
- PACKAGE FLT_IO IS NEW FLOAT_IO (FLT);
- USE FLT_IO;
- X : FLT := FLT'FIRST;
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET FLOAT_IO - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET " &
- "FLOAT_IO - 1");
- END;
-
- BEGIN
- PUT (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - PUT FLOAT_IO - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT " &
- "FLOAT_IO - 1");
- END;
-
- BEGIN
- CREATE (FT, OUT_FILE); -- THIS IS JUST AN ATTEMPT
- CLOSE (FT); -- TO CREATE A FILE.
- EXCEPTION -- OBJECTIVE MET EITHER WAY.
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET FLOAT_IO - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET " &
- "FLOAT_IO - 2");
- END;
-
- BEGIN
- PUT (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - PUT FLOAT_IO - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT " &
- "FLOAT_IO - 2");
- END;
- END;
-
- RESULT;
-
-END CE3801A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada
deleted file mode 100644
index 1eb3a8e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada
+++ /dev/null
@@ -1,108 +0,0 @@
--- CE3801B.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 EACH FIXED_IO OPERATION RAISES STATUS_ERROR
--- WHEN CALLED WITH A FILE PARAMETER DESIGNATING AN UN-OPEN FILE.
-
--- HISTORY:
--- DWC 09/11/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3801B IS
-BEGIN
-
- TEST ("CE3801B", "CHECK THAT EACH FIXED_IO " &
- "OPERATION RAISES STATUS_ERROR WHEN CALLED " &
- "WITH A FILE PARAMETER DESIGNATING AN " &
- "UN-OPEN FILE");
-
- DECLARE
- TYPE FIX IS DELTA 0.1 RANGE 1.0 .. 10.0;
- PACKAGE FIX_IO IS NEW FIXED_IO (FIX);
- USE FIX_IO;
- X : FIX := FIX'LAST;
- FT : FILE_TYPE;
-
- BEGIN
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET FIXED_IO - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET " &
- "FIXED_IO - 1");
- END;
-
- BEGIN
- PUT (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - PUT FIXED_IO - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT " &
- "FIXED_IO - 1");
- END;
-
- BEGIN
- CREATE (FT, OUT_FILE); -- THIS IS JUST AN ATTEMPT TO
- CLOSE (FT); -- CREATE A FILE. OBJECTIVE
- EXCEPTION -- IS MET EITHER WAY.
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET FIXED_IO - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET " &
- "FIXED_IO - 2");
- END;
-
- BEGIN
- PUT (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - PUT FIXED_IO - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT " &
- "FIXED_IO - 2");
- END;
- END;
-
- RESULT;
-
-END CE3801B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada
deleted file mode 100644
index c05a1ff..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada
+++ /dev/null
@@ -1,157 +0,0 @@
--- CE3804A.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 GET FOR FLOAT_IO READS A PLUS OR MINUS SIGN
--- IF PRESENT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS
--- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF WHAT
--- IS EXPECTED.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804A", "CHECK THAT GET FOR FLOAT_IO READS A PLUS OR " &
- "MINUS SIGN IF PRESENT");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE FL IS NEW FLOAT RANGE -3.0 .. 3.0;
- X : FL;
- ST1 : CONSTANT STRING := IDENT_STR ("-3.0");
- ST2 : CONSTANT STRING := IDENT_STR ("+2.0");
- ST3 : CONSTANT STRING := IDENT_STR ("1.0");
- BEGIN
-
--- CREATE AND INITIALIZE DATA FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, ST1);
- NEW_LINE(FT);
- PUT (FT, ST2);
- NEW_LINE(FT);
- PUT (FT, ST3);
- NEW_LINE(FT);
- CLOSE (FT);
-
--- BEGIN TEST
-
- DECLARE
- PACKAGE FL_IO IS NEW FLOAT_IO (FL);
- USE FL_IO;
- LST : POSITIVE;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X = 3.0 THEN
- FAILED ("MINUS SIGN NOT READ - 1");
- ELSIF X /= -3.0 THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- GET (FT, X);
- IF X = -2.0 THEN
- FAILED ("PLUS SIGN NOT READ - 2");
- ELSIF X /= +2.0 THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- GET (FT, X);
- IF X /= 1.0 THEN
- FAILED ("INCORRECT VALUE READ - 3");
- END IF;
-
- GET (ST1, X, LST);
- IF X = 3.0 THEN
- FAILED ("MINUS SIGN NOT READ - 4");
- ELSIF X /= -3.0 THEN
- FAILED ("INCORRECT VALUE READ - 4");
- END IF;
-
- GET (ST2, X, LST);
- IF X = -2.0 THEN
- FAILED ("PLUS SIGN NOT READ - 5");
- ELSIF X /= +2.0 THEN
- FAILED ("INCORRECT VALUE READ - 5");
- END IF;
-
- GET (ST3, X, LST);
- IF X /= 1.0 THEN
- FAILED ("INCORRECT VALUE READ - 6");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada
deleted file mode 100644
index c677d7e..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada
+++ /dev/null
@@ -1,147 +0,0 @@
--- CE3804B.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 GET FOR FIXED_IO READS A PLUS OR MINUS SIGN IF
--- PRESENT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS
--- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF
--- WHAT IS EXPECTED.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804B", "CHECK THAT GET FOR FIXED_IO READS A PLUS OR " &
- "MINUS SIGN IF PRESENT");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE FIX IS DELTA 0.01 RANGE -3.0 .. 3.0;
- X : FIX;
- ST1 : CONSTANT STRING := IDENT_STR("-3.0");
- ST2 : CONSTANT STRING := IDENT_STR("+2.0");
- ST3 : CONSTANT STRING := IDENT_STR("1.0");
- BEGIN
-
--- CREATE AND INITIALIZE DATA FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, ST1);
- NEW_LINE(FT);
- PUT (FT, ST2);
- NEW_LINE(FT);
- PUT (FT, ST3);
- NEW_LINE(FT);
- CLOSE (FT);
-
- DECLARE
- PACKAGE FIX_IO IS NEW FIXED_IO (FIX);
- USE FIX_IO;
- LST : POSITIVE;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= -3.0 THEN
- FAILED ("MINUS SIGN NOT READ - 1");
- END IF;
-
- GET (FT, X);
- IF X /= +2.0 THEN
- FAILED ("PLUS SIGN NOT READ - 2");
- END IF;
-
- GET (FT, X);
- IF X /= 1.0 THEN
- FAILED ("INCORRECT VALUE READ - 3");
- END IF;
-
- GET (ST1, X, LST);
- IF X /= -3.0 THEN
- FAILED ("MINUS SIGN NOT READ - 4");
- END IF;
-
- GET (ST2, X, LST);
- IF X /= +2.0 THEN
- FAILED ("PLUS SIGN NOT READ - 5");
- END IF;
-
- GET (ST3, X, LST);
- IF X /= 1.0 THEN
- FAILED ("INCORRECT VALUE READ - 6");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada
deleted file mode 100644
index b2be751c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- CE3804C.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.
---*
--- HISTORY:
--- CHECK THAT GET FOR FLOAT_IO RAISES MODE_ERROR WHEN THE
--- MODE IS NOT IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 SPLIT CASE FOR FIXED_IO INTO CE3804O.ADA
--- AND CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804C", "CHECK THAT GET FOR FLOAT_IO RAISES " &
- "MODE_ERROR WHEN THE MODE IS NOT IN_FILE");
-
- DECLARE
- FT2 : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT2, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILES WITH OUT_FILE " &
- "MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT);
- USE FL_IO;
- X : FLOAT;
- BEGIN
-
- BEGIN
- GET (FT2, X);
- FAILED ("MODE_ERROR NOT RAISED - FLOAT " &
- "UN-NAMED FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FLOAT UN-NAMED FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - FLOAT " &
- "STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FLOAT STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - FLOAT " &
- "CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FLOAT CURRENT_OUTPUT");
- END;
-
- END;
-
- CLOSE (FT2);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada
deleted file mode 100644
index 5187f8f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada
+++ /dev/null
@@ -1,153 +0,0 @@
--- CE3804D.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 FLOAT_IO GET RAISES DATA_ERROR WHEN THE DATA
--- READ IS OUT-OF-RANGE. CHECK THAT ITEM IS LEFT UNAFFECTED
--- AND THAT READING MAY CONTINUE AFTER THE EXCEPTION HAS
--- BEEN HANDLED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- SPS 02/10/83
--- JBG 08/30/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804D IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804D", "FLOAT_IO GET RAISES DATA_ERROR FOR " &
- "OUT-OF-RANGE DATA");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
--- CREATE AND INITIALIZE TEST FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "1.25");
- NEW_LINE (FT);
- PUT (FT, "-7.5");
- NEW_LINE (FT);
- PUT (FT, "3.5");
- NEW_LINE (FT);
- PUT (FT, "2.5");
- NEW_LINE (FT);
- CLOSE (FT);
-
--- BEGIN TEST
-
- DECLARE
- TYPE FL IS NEW FLOAT RANGE 1.0 .. 3.0;
- PACKAGE FL_IO IS NEW FLOAT_IO (FL);
- X : FL;
- USE FL_IO;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.25 THEN
- FAILED ("ITEM ALTERED WHEN DATA_ERROR " &
- "IS RAISED - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.25 THEN
- FAILED ("ITEM ALTERED WHEN DATA_ERROR " &
- "IS RAISED - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- GET (FT, X);
- IF X /= 2.5 THEN
- FAILED ("READING NOT CONTINUED CORRECTLY " &
- "AFTER DATA_ERROR");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada
deleted file mode 100644
index 021baba..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada
+++ /dev/null
@@ -1,154 +0,0 @@
--- CE3804E.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 FIXED_IO GET RAISES DATA_ERROR WHEN THE DATA READ IS
--- OUT-OF-RANGE CHECK THAT ITEM IS LEFT UNAFFECTED AND THAT
--- READING MAY CONTINUE AFTER THE EXCEPTION HAS BEEN HANDLED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- SPS 02/10/83
--- JBG 08/30/83
--- EG 11/02/84
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804E IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804E", "FIXED_IO GET RAISES DATA_ERROR FOR " &
- "OUT-OF-RANGE DATA");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
--- CREATE AND INITIALIZE TEST FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "1.25");
- NEW_LINE (FT);
- PUT (FT, "-7.5");
- NEW_LINE (FT);
- PUT (FT, "3.5");
- NEW_LINE (FT);
- PUT (FT, "2.5");
- NEW_LINE (FT);
- CLOSE (FT);
-
--- BEGIN TEST
-
- DECLARE
- TYPE FX IS DELTA 0.001 RANGE 1.0 .. 3.0;
- PACKAGE FX_IO IS NEW FIXED_IO (FX);
- X : FX;
- USE FX_IO;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X, 0);
-
- BEGIN
- GET (FT, X, 0);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.25 THEN
- FAILED ("ITEM ALTERED WHEN DATA_ERROR " &
- "IS RAISED - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- GET (FT, X, 0);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.25 THEN
- FAILED ("ITEM ALTERED WHEN DATA_ERROR " &
- "IS RAISED - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- GET (FT, X, 0);
- IF X /= 2.5 THEN
- FAILED ("READING NOT CONTINUED CORRECTLY " &
- "AFTER DATA_ERROR");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada
deleted file mode 100644
index 96a48d8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada
+++ /dev/null
@@ -1,206 +0,0 @@
--- CE3804F.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 FLOAT_IO GET RAISES CONSTRAINT_ERROR WHEN THE VALUE
--- SUPPLIED BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN FIELD'LAST
--- WHEN FIELD'LAST IS LESS THAN INTEGER'LAST, OR THE VALUE READ IS
--- OUT OF RANGE OF THE ITEM PARAMETER, BUT WITHIN THE RANGE OF THE
--- SUBTYPE USED TO INSTANTIATE FLOAT_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/07/82
--- JBG 08/30/83
--- DWC 09/11/87 SPLIT CASE FOR FIXED_IO INTO CE3804P.ADA AND
--- CORRECTED EXCEPTION HANDLING.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804F IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804F", "CHECK THAT FLOAT_IO GET RAISES " &
- "CONSTRAINT_ERROR WHEN THE VALUE SUPPLIED " &
- "BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN " &
- "FIELD'LAST WHEN FIELD'LAST IS LESS THAN " &
- "INTEGER'LAST, OR THE VALUE READ IS OUT OF " &
- "RANGE OF THE ITEM PARAMETER, BUT WITHIN THE " &
- "RANGE OF THE SUBTYPE USED TO INSTANTIATE " &
- "FLOAT_IO.");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE FLT IS NEW FLOAT RANGE 1.0 .. 10.0;
- PACKAGE FL_IO IS NEW FLOAT_IO (FLT);
- USE FL_IO;
- X : FLT RANGE 1.0 .. 5.0;
-
- BEGIN
- BEGIN
- GET (FT, X, IDENT_INT(-3));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE " &
- "WIDTH");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR FOR NEGATIVE WIDTH");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR NEGATIVE " &
- "WIDTH");
- END;
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- GET (X, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "FIELD'LAST + 1 WIDTH - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIELD'LAST + 1 WIDTH - DEFAULT");
- END;
- END IF;
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "1.0");
- NEW_LINE (FT);
- PUT (FT, "8.0");
- NEW_LINE (FT);
- PUT (FT, "2.0");
- NEW_LINE (FT);
- PUT (FT, "3.0");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= 1.0 THEN
- FAILED ("WRONG VALUE READ WITH EXTERNAL FILE");
- END IF;
-
- BEGIN
- GET (FT, X);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "VALUE OUT OF RANGE WITH EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "VALUE OUT OF RANGE WITH EXTERNAL FILE");
- END;
-
- BEGIN
- GET (FT, X, IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- END;
-
- SKIP_LINE (FT);
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- GET (FT, X, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- END;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 3);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED - " &
- "OUT OF RANGE WITH EXTERNAL FILE");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "OUT OF RANGE WITH EXTERNAL FILE");
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-END CE3804F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada
deleted file mode 100644
index e88e9dc..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada
+++ /dev/null
@@ -1,167 +0,0 @@
--- CE3804G.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 FLOAT_IO GET WHEN SUPPLIED WITH A WIDTH PARAMETER
--- GREATER THAN ZERO READS ONLY THAT MANY CHARACTERS. ALSO CHECK
--- THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS ENCOUNTERED AND
--- THAT DATA_ERROR IS RAISED WHEN THE DATA IS INVALID.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 09/08/82
--- SPS 12/14/82
--- VKG 01/13/83
--- SPS 02/08/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804H.ADA AND
--- CORRECTED EXCEPTION HANDLING.
--- LDC 06/01/88 CHANGED TEST VALUE FROM "3.525" TO "3.625".
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804G IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804G", "CHECK THAT FLOAT_IO GET WHEN SUPPLIED WITH " &
- "A WIDTH PARAMETER GREATER THAN ZERO READS " &
- "ONLY THAT MANY CHARACTERS. ALSO CHECK THAT " &
- "INPUT TERMINATES WHEN A LINE TERMINATOR IS " &
- "ENCOUNTERED AND THAT DATA_ERROR IS RAISED " &
- "WHEN THE DATA IS INVALID.");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT(FT, "3.259.5 8.52");
- NEW_LINE (FT);
- PUT (FT, " ");
- NEW_LINE (FT);
- PUT (FT, ASCII.HT & "9.0");
- NEW_LINE (FT);
- PUT (FT, "-3.625");
- NEW_LINE (FT);
- CLOSE (FT);
-
--- BEGIN TEST
-
- DECLARE
- TYPE FL IS DIGITS 4;
- PACKAGE FL_IO IS NEW FLOAT_IO (FL);
- USE FL_IO;
- X : FL;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT" &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X, 4);
- IF X /= 3.25 THEN
- FAILED ("WIDTH CHARACTERS NOT READ - FLOAT");
- ELSE
- GET (FT, X, 3);
- IF X /= 9.5 THEN
- FAILED ("WIDTH CHARACTERS NOT READ - " &
- "FLOAT 2");
- ELSE
- GET (FT, X, 4);
- IF X /= 8.5 THEN
- FAILED ("DIDN'T COUNT LEADING BLANKS " &
- "- FLOAT");
- ELSE
- SKIP_LINE(FT);
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - " &
- "FLOAT");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED"
- & " - FLOAT");
- END;
- SKIP_LINE(FT);
- GET (FT, X, 4);
- IF X /= 9.0 THEN
- FAILED ("GET WITH WIDTH " &
- "INCORRECT - 3");
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X, 7);
- IF X /= -3.625 THEN
- FAILED ("WIDTH CHARACTERS NOT " &
- "READ - FLOAT 3");
- END IF;
- END IF;
- END IF;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada
deleted file mode 100644
index 6f7d87cb..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada
+++ /dev/null
@@ -1,161 +0,0 @@
--- CE3804H.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 FIXED_IO GET WHEN SUPPLIED WITH A WIDTH PARAMETER
--- GREATER THAN ZERO READS ONLY THAT MANY CHARACTERS. ALSO CHECK
--- THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS ENCOUNTERED AND
--- THAT DATA_ERROR IS RAISED WHEN THE DATA IS INVALID.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- DWC 09/14/87 CREATED ORIGINAL TEST.
--- RJW 08/17/89 CHANGED THE VALUE '-3.525' TO '-3.625'.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804H IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804H", "CHECK THAT FIXED_IO GET WHEN SUPPLIED WITH " &
- "A WIDTH PARAMETER GREATER THAN ZERO READS " &
- "ONLY THAT MANY CHARACTERS. ALSO CHECK THAT " &
- "INPUT TERMINATES WHEN A LINE TERMINATOR IS " &
- "ENCOUNTERED AND THAT DATA_ERROR IS RAISED " &
- "WHEN THE DATA IS INVALID");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT(FT, "3.259.5 8.52");
- NEW_LINE (FT);
- PUT (FT, " ");
- NEW_LINE (FT);
- PUT (FT, ASCII.HT & "9.0");
- NEW_LINE (FT);
- PUT (FT, "-3.625");
- NEW_LINE (FT);
-
- CLOSE (FT);
-
--- BEGIN TEST
-
- DECLARE
- TYPE FIXED IS DELTA 0.001 RANGE -100.0 .. 100.0;
- PACKAGE FX_IO IS NEW FIXED_IO (FIXED);
- USE FX_IO;
- X : FIXED;
-
- BEGIN
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT" &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X, 4);
- IF X /= 3.25 THEN
- FAILED ("WIDTH CHARACTERS NOT READ - FIXED - 1");
- ELSE
- GET (FT, X, 3);
- IF X /= 9.5 THEN
- FAILED ("WIDTH CHARACTERS NOT READ - " &
- "FIXED 2");
- ELSE
- GET (FT, X, 4);
- IF X /= 8.5 THEN
- FAILED ("DIDN'T COUNT LEADING BLANKS " &
- "- FIXED");
- ELSE
- SKIP_LINE(FT);
- BEGIN
- GET (FT, X, 2);
- FAILED ("DATA_ERROR NOT RAISED - " &
- "FIXED");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED"
- & " - FIXED");
- END;
-
- SKIP_LINE(FT);
- GET (FT, X, 4);
- IF X /= 9.0 THEN
- FAILED ("GET WITH WIDTH " &
- "INCORRECT");
- END IF;
-
- SKIP_LINE (FT);
- GET (FT, X, 7);
- IF X /= -3.625 THEN
- FAILED ("WIDTH CHARACTERS NOT " &
- "READ");
- END IF;
- END IF;
- END IF;
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada
deleted file mode 100644
index 19e292f..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada
+++ /dev/null
@@ -1,141 +0,0 @@
--- CE3804I.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 FLOAT_IO GET OPERATES ON IN_FILE FILE AND WHEN
--- NO FILE IS SPECIFIED THE CURRENT DEFAULT INPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/06/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804J.ADA AND
--- CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804I IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804I", "CHECK THAT FLOAT_IO GET OPERATES ON " &
- "IN_FILE FILE AND WHEN NO FILE IS " &
- "SPECIFIED THE CURRENT DEFAULT INPUT " &
- "FILE IS USED.");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- BEGIN
-
--- CREATE AND INITIALIZE FILES
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FT1, "1.0");
- NEW_LINE (FT1);
-
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT2, "2.0");
- NEW_LINE (FT2);
-
- CLOSE (FT2);
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- SET_INPUT (FT2);
-
- DECLARE
- TYPE FL IS NEW FLOAT;
- PACKAGE FLIO IS NEW FLOAT_IO (FL);
- USE FLIO;
- X : FL;
- BEGIN
- BEGIN
- GET (FT1, X);
- IF X /= 1.0 THEN
- FAILED ("FLOAT FILE VALUE INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - FILE FLOAT");
- END;
-
- BEGIN
- GET (X);
- IF X /= 2.0 THEN
- FAILED ("FLOAT DEFAULT VALUE INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - DEFAULT FLOAT");
- END;
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804I;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada
deleted file mode 100644
index a7d4c84..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada
+++ /dev/null
@@ -1,137 +0,0 @@
--- CE3804J.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 FIXED_IO GET OPERATES ON IN_FILE FILE AND WHEN
--- NO FILE IS SPECIFIED THE CURRENT DEFAULT INPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- DWC 09/14/87 CREATED ORIGINAL TEST.
--- JRL 02/28/96 Changed upper bound of type FX from 1000.0 to 250.0.
--- Corrected TEST string.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804J IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804J", "CHECK THAT FIXED_IO GET OPERATES ON " &
- "IN_FILE FILE AND WHEN NO FILE IS " &
- "SPECIFIED THE CURRENT DEFAULT INPUT " &
- "FILE IS USED");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- BEGIN
-
--- CREATE AND INITIALIZE FILES
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FT1, "1.0");
- NEW_LINE (FT1);
-
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT2, "2.0");
- NEW_LINE (FT2);
-
- CLOSE (FT2);
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- SET_INPUT (FT2);
-
- DECLARE
- TYPE FX IS DELTA 0.0001 RANGE 1.0 .. 250.0;
- PACKAGE FXIO IS NEW FIXED_IO (FX);
- USE FXIO;
- X : FX;
- BEGIN
- BEGIN
- GET (FT1, X);
- IF X /= 1.0 THEN
- FAILED ("FIXED FILE VALUE INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - FILE FIXED");
- END;
-
- BEGIN
- GET (X);
- IF X /= 2.0 THEN
- FAILED ("FIXED DEFAULT VALUE INCORRECT");
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - DEFAULT FIXED");
- END;
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804J;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada
deleted file mode 100644
index d71d2fc..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada
+++ /dev/null
@@ -1,157 +0,0 @@
--- CE3804M.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 GET WILL RAISE DATA_ERROR IF THE USE OF # AND :
--- IN BASED LITERALS IS MIXED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- VKG 02/07/83
--- JBG 03/30/84
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804N.ADA AND
--- CORRECTED EXCEPTION HANDLING.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE3804M IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3804M", "CHECK THAT FLOAT_IO GET WILL RAISE " &
- "DATA_ERROR IF THE USE OF # AND : IN " &
- "BASED LITERALS IS MIXED");
-
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
-
- PUT_LINE (FT, "2#1.1#E+2"); -- 2#1.1#E+2
- PUT_LINE (FT, "8:1.1:E-2"); -- 8:1.1:E-2
- PUT (FT, "2#1.1:E+1"); -- 2#1.1:E+1
- NEW_LINE (FT);
- PUT (FT, "4:2.23#E+2"); -- 4:2.23#E+2
- NEW_LINE (FT);
- PUT (FT, "2#1.0#E+1"); -- 2#1.0#E+1
- NEW_LINE (FT);
- CLOSE (FT);
-
- DECLARE
- PACKAGE FL_IO IS NEW FLOAT_IO(FLOAT);
- USE FL_IO;
- X : FLOAT := 1.00E+10;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= 2#1.1#E+2 THEN
- FAILED ("DID NOT GET RIGHT VALUE - 1");
- END IF;
-
- GET (FT, X);
- IF X /= 8#1.1#E-2 THEN
- FAILED ("DID NOT GET RIGHT VALUE - 2");
- END IF;
-
- BEGIN
- X := 1.0E+10;
- GET (FT,X);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.00E+10 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT,X);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= 1.00E+10 THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- SKIP_LINE (FT);
-
- GET (FT, X);
- IF X /= 2#1.0#E+1 THEN
- FAILED ("DID NOT GET RIGHT VALUE - 3");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804M;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada
deleted file mode 100644
index a08e2c9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada
+++ /dev/null
@@ -1,121 +0,0 @@
--- CE3804O.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.
---*
--- HISTORY:
--- CHECK THAT GET FOR FIXED_IO RAISES MODE_ERROR WHEN THE
--- MODE IS NOT IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- DWC 09/14/87 CREATED ORIGINAL TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804O IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804O", "CHECK THAT GET FOR FIXED_IO RAISES " &
- "MODE_ERROR WHEN THE MODE IS NOT IN_FILE");
-
- DECLARE
- FT: FILE_TYPE;
- BEGIN
- BEGIN
- CREATE (FT, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE FOR TEMP FILES " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- DECLARE
- TYPE FIXED IS DELTA 0.25 RANGE 1.0 .. 3.0;
- PACKAGE FX_IO IS NEW FIXED_IO (FIXED);
- USE FX_IO;
- X : FIXED;
- BEGIN
-
- BEGIN
- GET (FT, X);
- FAILED ("MODE_ERROR NOT RAISED - FIXED " &
- "UN-NAMED FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIXED UN-NAMED FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - FIXED " &
- "STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIXED STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - FIXED " &
- "CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIXED CURRENT_OUTPUT");
- END;
-
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804O;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada b/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada
deleted file mode 100644
index d4afd2a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada
+++ /dev/null
@@ -1,206 +0,0 @@
--- CE3804P.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 FIXED_IO GET RAISES CONSTRAINT_ERROR WHEN THE VALUE
--- SUPPLIED BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN FIELD'LAST
--- WHEN FIELD'LAST IS LESS THAN INTEGER'LAST, OR THE VALUE READ IS
--- OUT OF RANGE OF THE ITEM PARAMETER, BUT WITHIN THE RANGE OF THE
--- SUBTYPE USED TO INSTANTIATE FIXED_IO.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- DWC 09/15/87 CREATED ORIGINAL TEST.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection. Corrected typo.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3804P IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3804P", "CHECK THAT FLOAT_IO GET RAISES " &
- "CONSTRAINT_ERROR WHEN THE VALUE SUPPLIED " &
- "BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN " &
- "FIELD'LAST WHEN FIELD'LAST IS LESS THAN " &
- "INTEGER'LAST, OR THE VALUE READ IS OUT OF " &
- "RANGE OF THE ITEM PARAMETER, BUT WITHIN THE " &
- "RANGE OF THE SUBTYPE USED TO INSTANTIATE " &
- "FLOAT_IO.");
-
- DECLARE
- TYPE FIXED IS DELTA 0.25 RANGE 0.0 .. 10.0;
- FT : FILE_TYPE;
- PACKAGE FX_IO IS NEW FIXED_IO (FIXED);
- USE FX_IO;
- X : FIXED RANGE 0.0 .. 5.0;
-
- BEGIN
- BEGIN
- GET (FT, X, IDENT_INT(-3));
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE " &
- "WIDTH");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR FOR NEGATIVE WIDTH");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR NEGATIVE " &
- "WIDTH");
- END;
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- GET (X, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "FIELD'LAST + 1 WIDTH - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIELD'LAST + 1 WIDTH - DEFAULT");
- END;
- END IF;
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "1.0");
- NEW_LINE (FT);
- PUT (FT, "8.0");
- NEW_LINE (FT);
- PUT (FT, "2.0");
- NEW_LINE (FT);
- PUT (FT, "3.0");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= 1.0 THEN
- FAILED ("WRONG VALUE READ WITH EXTERNAL FILE");
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 3);
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "OUT OF RANGE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "OUT OF RANGE");
- END;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "NEGATIVE WIDTH WITH EXTERNAL FILE");
- END;
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- GET (FT, X, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - " &
- "FIELD'LAST + 1 WIDTH WITH " &
- "EXTERNAL FILE");
- END;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X, 3);
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- FAILED ("CONSTRAINT_ERROR RAISED; VALID WIDTH " &
- "WITH EXTERNAL FILE");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED; VALID WIDTH " &
- "WITH EXTERNAL FILE");
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3804P;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada
deleted file mode 100644
index 74c8aff..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada
+++ /dev/null
@@ -1,162 +0,0 @@
--- CE3805A.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 FLOAT_IO GET MAY READ THE LAST CHARACTER IN THE FILE
--- WITHOUT RAISNG END_ERROR AND THAT SUBSEQUENT READING WILL RAISE
--- END_ERROR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATAIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/08/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/15/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3805A IS
-
-BEGIN
-
- TEST ("CE3805A", "CHECK THAT FLOAT_IO GET MAY READ THE LAST " &
- "CHARACTER IN THE FILE WITHOUT RAISING " &
- "END_ERROR AND THAT SUBSEQUENT READING WILL " &
- "RAISE END_ERROR");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT);
- X : FLOAT;
- USE FL_IO;
- INCOMPLETE : EXCEPTION;
-
- BEGIN
-
--- CREATE AND INITIALIZE TEST FILES
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FT1, "2.25");
- CLOSE (FT1);
-
- PUT (FT2, "2.50");
- NEW_LINE (FT2, 3);
- NEW_PAGE (FT2);
- NEW_LINE (FT2, 3);
- CLOSE (FT2);
-
--- BEGIN TEST
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- BEGIN
- GET (FT1, X);
- IF X /= 2.25 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
- BEGIN
- GET (FT1, X);
- FAILED ("END_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR RAISED PREMATURELY - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED - 1");
- END;
-
- BEGIN
- GET (FT2, X);
- IF X /= 2.50 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
- BEGIN
- GET (FT2, X);
- FAILED ("END_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR RAISED PREMATURELY - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED - 2");
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3805A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada
deleted file mode 100644
index 8091963..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada
+++ /dev/null
@@ -1,163 +0,0 @@
--- CE3805B.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 FIXED_IO GET MAY READ THE LAST CHARACTER IN THE FILE
--- WITHOUT RAISING END_ERROR AND THAT SUBSEQUENT READING WILL RAISE
--- END_ERROR.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/08/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/15/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3805B IS
-
-BEGIN
-
- TEST ("CE3805B", "CHECK THAT FIXED_IO GET MAY READ THE LAST "&
- "CHARACTER IN THE FILE WITHOUT RAISING " &
- "END_ERROR AND THAT SUBSEQUENT READING WILL " &
- "RAISE END_ERROR");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- TYPE FIXED IS DELTA 0.02 RANGE 0.0 .. 50.0;
- PACKAGE FX_IO IS NEW FIXED_IO (FIXED);
- X : FIXED;
- USE FX_IO;
- INCOMPLETE : EXCEPTION;
-
- BEGIN
-
--- CREATE AND INITIALIZE TEST FILES
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FT1, "2.25");
- CLOSE (FT1);
-
- PUT (FT2, "2.50");
- NEW_LINE (FT2, 3);
- NEW_PAGE (FT2);
- NEW_LINE (FT2, 3);
- CLOSE (FT2);
-
--- BEGIN TEST
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- BEGIN
- GET (FT1, X);
- IF X /= 2.25 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
- BEGIN
- GET (FT1, X);
- FAILED ("END_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR RAISED PREMATURELY - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED - 1");
- END;
-
- BEGIN
- GET (FT2, X);
- IF X /= 2.50 THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
- BEGIN
- GET (FT2, X);
- FAILED ("END_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("END_ERROR RAISED PREMATURELY - 2");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED ERROR RAISED - 2");
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3805B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada
deleted file mode 100644
index 09762f3..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- CE3806A.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 PUT FOR FLOAT_IO RAISES MODE_ERROR FOR FILES OF
--- MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 09/10/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/11/87 REMOVED DEPENDENCE ON RESET AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3806A IS
-
-BEGIN
-
- TEST ("CE3806A", "CHECK THAT PUT FOR FLOAT_IO RAISES MODE_ERROR " &
- "FOR FILES OF MODE IN_FILE");
-
- DECLARE
- FT1 : FILE_TYPE;
- PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT);
- USE FL_IO;
- INCOMPLETE : EXCEPTION;
- X : FLOAT := -34.267/19.2;
-
- BEGIN
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT1, 'A');
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FT1, X);
- FAILED ("MODE_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- PUT (STANDARD_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- DELETE (FT1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3806A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada
deleted file mode 100644
index 194f1a9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada
+++ /dev/null
@@ -1,124 +0,0 @@
--- CE3806B.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 PUT FOR FIXED_IO RAISES MODE_ERROR FOR FILES OF
--- MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 09/11/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3806B IS
-
-BEGIN
- TEST ("CE3806B", "CHECK THAT PUT FOR FIXED_IO RAISES MODE_ERROR " &
- "FOR FILES OF MODE IN_FILE");
-
- DECLARE
- FT1 : FILE_TYPE;
- TYPE FIXED IS DELTA 0.01 RANGE 0.0 .. 1.0;
- PACKAGE FX_IO IS NEW FIXED_IO (FIXED);
- USE FX_IO;
- INCOMPLETE : EXCEPTION;
- X : FIXED := 0.2;
-
- BEGIN
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT1, 'A');
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FT1, X);
- FAILED ("MODE_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- PUT (STANDARD_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- DELETE (FT1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3806B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada
deleted file mode 100644
index 6a7a793..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada
+++ /dev/null
@@ -1,197 +0,0 @@
--- CE3806C.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 PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE
--- VALUES SUPPLIED BY FORE, AFT, OR EXP ARE NEGATIVE OR GREATER
--- THAN FIELD'LAST WHEN FIELD'LAST < FIELD'BASE'LAST. ALSO CHECK
--- THAT PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE OF
--- ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE
--- FLOAT_IO.
-
--- HISTORY:
--- SPS 09/10/82
--- JBG 08/30/83
--- JLH 09/14/87 ADDED CASES FOR COMPLETE OBJECTIVE.
--- KAS 11/24/95 DELETED DIGITS CONSTRAINT FROM SUBTYPE
--- CHANGED STATIC EXPRESSIONS INVOLVING 'LAST
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3806C IS
-
- FIELD_LAST : TEXT_IO.FIELD := TEXT_IO.FIELD'LAST;
-
-BEGIN
-
- TEST ("CE3806C", "CHECK THAT PUT FOR FLOAT_IO RAISES " &
- "CONSTRAINT_ERROR APPROPRIATELY");
-
- DECLARE
- TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 2.0;
- SUBTYPE MY_FLOAT IS FLOAT RANGE 0.0 .. 1.0;
- PACKAGE NFL_IO IS NEW FLOAT_IO (MY_FLOAT);
- USE NFL_IO;
- FT : FILE_TYPE;
- Y : FLOAT := 1.8;
- X : MY_FLOAT := 26.3 / 26.792;
-
- BEGIN
- BEGIN
- PUT (FT, X, FORE => IDENT_INT(-6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " &
- "FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 1");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " &
- "FLOAT");
- END;
-
- BEGIN
- PUT (FT, X, AFT => IDENT_INT(-2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " &
- "FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 2");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " &
- "FLOAT");
- END;
-
- BEGIN
- PUT (FT, X, EXP => IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " &
- "FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 3");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " &
- "FLOAT");
- END;
-
- IF FIELD_LAST < FIELD'BASE'LAST THEN
-
- BEGIN
- PUT (FT, X, FORE => IDENT_INT(FIELD_LAST+1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 4");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FORE FLOAT");
- END;
-
- BEGIN
- PUT (FT, X, AFT => IDENT_INT(FIELD_LAST+1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 5");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - AFT FLOAT");
- END;
-
- BEGIN
- PUT (FT, X, EXP => IDENT_INT(FIELD_LAST+1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FLOAT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 6");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - EXP FLOAT");
- END;
- END IF;
-
- BEGIN
- PUT (FT, Y);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- END;
-
- BEGIN
- PUT (Y);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- END;
-
- END;
-
- RESULT;
-
-END CE3806C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada
deleted file mode 100644
index 6189ef1..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada
+++ /dev/null
@@ -1,129 +0,0 @@
--- CE3806D.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 FLOAT_IO PUT OPERATES ON FILES OF MODE OUT_FILE AND
--- IF NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE IS USED.
-
---- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/06/82
--- VKG 02/15/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/14/87 REMOVED DEPENDENCE ON RESET AND CORRECT EXCEPTION
--- HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3806D IS
-
-BEGIN
-
- TEST ("CE3806D", "CHECK THAT FLOAT_IO OPERATES ON FILES OF MODE " &
- "OUT_FILE AND IF NO FILE IS SPECIFIED THE " &
- "CURRENT DEFAULT OUTPUT FILE IS USED");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- TYPE FL IS DIGITS 3;
- PACKAGE FLIO IS NEW FLOAT_IO (FL);
- USE FLIO;
- INCOMPLETE : EXCEPTION;
- X : FL := -1.5;
-
- BEGIN
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- SET_OUTPUT (FT2);
-
- BEGIN
- PUT (FT1, X);
- PUT (X + 1.0);
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_OUTPUT (STANDARD_OUTPUT);
-
- CLOSE (FT2);
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- X := 0.0;
- GET (FT1, X);
- IF X /= -1.5 THEN
- FAILED ("VALUE INCORRECT - FLOAT FROM FILE");
- END IF;
- X := 0.0;
- GET (FT2, X);
- IF X /= -0.5 THEN
- FAILED (" VVALUE INCORRECT - FLOAT FROM DEFAULT");
- END IF;
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3806D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada
deleted file mode 100644
index 4865020..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada
+++ /dev/null
@@ -1,159 +0,0 @@
--- CE3806E.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 FLOAT_IO PUT RAISE LAYOUT_ERROR WHEN THE NUMBER
--- OF CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH.
--- CHECK THAT IT IS NOT RAISED, BUT RATHER NEW_LINE IS CALLED,
--- WHEN THE NUMBER DOES NOT EXCEED THE MAX, BUT WHEN ADDED TO
--- THE CURRENT COLUMN NUMBER, THE TOTAL EXCEEDS THE MAX.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/07/82
--- SPS 12/14/82
--- VKG 01/13/83
--- SPS 02/18/83
--- JBG 08/30/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 09/14/87 REMOVED DEPENDENCE ON RESET AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3806E IS
-
-BEGIN
-
- TEST ("CE3806E", "CHECK THAT FLOAT_IO PUT RAISES " &
- "LAYOUT_ERROR CORRECTLY");
-
- DECLARE
- TYPE FL IS DIGITS 3 RANGE 100.0 .. 200.0;
- PACKAGE FLIO IS NEW FLOAT_IO (FL);
- USE FLIO;
- X : FL := 126.0;
- Y : FL := 134.0;
- Z : FL := 120.0;
- INCOMPLETE : EXCEPTION;
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 8);
-
- BEGIN
- PUT (FT, X); -- " 1.26E+02"
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT");
-
- END;
-
- BEGIN
- PUT (FT, Y, FORE => 1); -- "1.34E+02"
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED SECOND PUT " &
- "- FLOAT");
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED SECOND PUT - FLOAT");
- END;
-
- BEGIN
- PUT (FT,Z, FORE => 1, AFT => 0); -- "1.2E+02"
- IF LINE (FT) /= 2 THEN
- FAILED ("NEW_LINE NOT CALLED - FLOAT");
- END IF;
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED THIRD " &
- "PUT - FLOAT");
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED THIRD PUT - FLOAT");
- END;
-
- SET_LINE_LENGTH ( FT,7);
-
- BEGIN
- PUT (FT, "X");
- PUT (FT, Y, FORE => 1, AFT => 2,
- EXP => 1); -- 1.34E+2
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED - 3 FLOAT");
- END;
-
- BEGIN
- PUT (FT, "Z");
- PUT (FT, Z, FORE => 1);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED - 3 FLOAT");
- END;
-
- CHECK_FILE (FT, "1.34E+02#1.2E+02#X#1.34E+2#Z#@%");
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3806E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada
deleted file mode 100644
index e013bbb..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada
+++ /dev/null
@@ -1,194 +0,0 @@
--- CE3806F.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 PUT FOR FIXED_IO RAISES CONSTRAINT_ERROR WHEN THE
--- VALUES SUPPLIED BY FORE, AFT, OR EXP ARE NEGATIVE OR GREATER
--- THAN FIELD'LAST WHEN FIELD'LAST < FIELD'BASE'LAST. ALSO CHECK
--- THAT PUT FOR FIXED_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE
--- OF ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE
--- FIXED_IO.
-
--- HISTORY:
--- JLH 09/15/87 CREATED ORIGINAL TEST.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3806F IS
-
-BEGIN
-
- TEST ("CE3806F", "CHECK THAT PUT FOR FIXED_IO RAISES " &
- "CONSTRAINT_ERROR APPROPRIATELY");
-
- DECLARE
- TYPE FIXED IS DELTA 0.01 RANGE 1.0 .. 2.0;
- SUBTYPE MY_FIXED IS FIXED DELTA 0.01 RANGE 1.0 .. 1.5;
- PACKAGE NFX_IO IS NEW FIXED_IO (MY_FIXED);
- USE NFX_IO;
- FT : FILE_TYPE;
- Y : FIXED := 1.8;
- X : MY_FIXED := 1.3;
-
- BEGIN
-
- BEGIN
- PUT (FT, X, FORE => IDENT_INT(-6));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " &
- "FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 1");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 1");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " &
- "FIXED");
- END;
-
- BEGIN
- PUT (FT, X, AFT => IDENT_INT(-2));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " &
- "FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 2");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " &
- "FIXED");
- END;
-
- BEGIN
- PUT (FT, X, EXP => IDENT_INT(-1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " &
- "FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 3");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 3");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " &
- "FIXED");
- END;
-
- IF FIELD'LAST < FIELD'BASE'LAST THEN
-
- BEGIN
- PUT (FT, X, FORE => IDENT_INT(FIELD'LAST+Ident_Int(1)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 4");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 4");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FORE FIXED");
- END;
-
- BEGIN
- PUT (FT, X, AFT => IDENT_INT(FIELD'LAST+Ident_Int(1)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 5");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 5");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - AFT FIXED");
- END;
-
- BEGIN
- PUT (FT, X, EXP => IDENT_INT(FIELD'LAST+Ident_Int(1)));
- FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FIXED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("STATUS_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 6");
- WHEN USE_ERROR =>
- FAILED ("USE_ERROR RAISED INSTEAD OF " &
- "CONSTRAINT_ERROR - 6");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - EXP FIXED");
- END;
-
- END IF;
-
- BEGIN
- PUT (FT, Y);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - FILE");
- END;
-
- BEGIN
- PUT (Y);
- FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " &
- "RANGE - DEFAULT");
- END;
-
- END;
-
- RESULT;
-
-END CE3806F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada
deleted file mode 100644
index edfcf6a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada
+++ /dev/null
@@ -1,125 +0,0 @@
--- CE3806G.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 FIXED_IO PUT OPERATES ON FILES OF MODE OUT_FILE AND
--- IF NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 09/13/87 CREATED ORIGINAL TEST.
--- BCB 10/03/90 ADDED THE STATEMENT "RAISE INCOMPLETE;" TO
--- NAME_ERROR EXCEPTION HANDLER.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3806G IS
-
-BEGIN
-
- TEST ("CE3806G", "CHECK THAT FIXED_IO PUT OPERATES ON FILES " &
- "OF MODE OUT_FILE AND IF NO FILE IS SPECIFIED " &
- "THE CURRENT DEFAULT OUTPUT FILE IS USED");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- TYPE FX IS DELTA 0.5 RANGE -10.0 .. 10.0;
- PACKAGE FXIO IS NEW FIXED_IO (FX);
- USE FXIO;
- INCOMPLETE : EXCEPTION;
- X : FX := -1.5;
-
- BEGIN
-
- BEGIN
- CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2));
-
- SET_OUTPUT (FT2);
-
- BEGIN
- PUT (FT1, X);
- PUT (X + 1.0);
-
- CLOSE (FT1);
-
- BEGIN
- OPEN (FT1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_OUTPUT (STANDARD_OUTPUT);
-
- CLOSE (FT2);
-
- OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2));
-
- X := 0.0;
- GET (FT1, X);
- IF X /= -1.5 THEN
- FAILED ("VALUE INCORRECT - FIXED FROM FILE");
- END IF;
- X := 0.0;
- GET (FT2, X);
- IF X /= -0.5 THEN
- FAILED ("VALUE INCORRECT - FIXED FROM DEFAULT");
- END IF;
- END;
-
- BEGIN
- DELETE (FT1);
- DELETE (FT2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3806G;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada b/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada
deleted file mode 100644
index daaef6a..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- CE3806H.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 FIXED_IO PUT RAISES LAYOUT_ERROR WHEN THE NUMBER OF
--- CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH. CHECK
--- THAT IT IS NOT RAISED, BUT RATHER NEW_LINE IS CALLED, WHEN THE
--- NUMBER DOES NOT EXCEED THE MAX, BUT WHEN ADDED TO THE CURRENT
--- COLUMN NUMBER, THE TOTAL EXCEEDS THE MAX.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 09/15/87 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3806H IS
-
-BEGIN
-
- TEST ("CE3806H", "CHECK THAT FIXED_IO PUT RAISES " &
- "LAYOUT_ERROR CORRECTLY");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE FX IS DELTA 0.01 RANGE -200.0 .. 200.0;
- PACKAGE FXIO IS NEW FIXED_IO (FX);
- USE FXIO;
- INCOMPLETE : EXCEPTION;
- X : FX := 126.5;
- Y : FX := -134.0;
- Z : FX := 120.0;
-
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 4);
-
- BEGIN
- PUT (FT, X, FORE => 3, AFT => 1);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED");
- END;
-
- SET_LINE_LENGTH (FT,7);
-
- BEGIN
- PUT (FT, Y, FORE => 3, AFT => 2);
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED SECOND PUT - " &
- "FIXED");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED SECOND PUT - " &
- "FIXED");
- END;
-
- BEGIN
- PUT (FT,Z, FORE => 4, AFT => 2);
- IF LINE (FT) /= 2 THEN
- FAILED ("NEW_LINE NOT CALLED - FIXED");
- END IF;
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED THIRD PUT - " &
- "FIXED");
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED THIRD PUT - FIXED");
- END;
-
- BEGIN
- PUT (FT, "Y");
- PUT (FT, Z, FORE => 3, AFT => 0);
- NEW_LINE (FT);
- PUT (FT, "Z");
- PUT (FT, Y, FORE => 3, AFT => 2);
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED LAST PUT - " &
- "FIXED");
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED LAST PUT - FIXED ");
- END;
-
- CHECK_FILE (FT, "-134.00# 120.00#Y120.0#Z#-134.00#@%");
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
-
- END;
-
- RESULT;
-
-END CE3806H;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada
deleted file mode 100644
index f854553..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada
+++ /dev/null
@@ -1,239 +0,0 @@
--- CE3809A.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 FLOAT I/O GET CAN READ A VALUE FROM A STRING.
--- CHECK THAT END_ERROR IS RAISED WHEN CALLED WITH A NULL STRING
--- OR A STRING CONTAINING SPACES AND/OR HORIZONTAL TABULATION
--- CHARACTERS. CHECK THAT LAST CONTAINS THE INDEX OF THE LAST
--- CHARACTER READ FROM THE STRING.
-
--- HISTORY:
--- SPS 10/07/82
--- SPS 12/14/82
--- JBG 12/21/82
--- DWC 09/15/87 ADDED CASE TO INCLUDE ONLY TABS IN STRING AND
--- CHECKED THAT END_ERROR IS RAISED.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3809A IS
-BEGIN
-
- TEST ("CE3809A", "CHECK THAT FLOAT_IO GET " &
- "OPERATES CORRECTLY ON STRINGS");
-
- DECLARE
- TYPE FL IS DIGITS 4;
- PACKAGE FLIO IS NEW FLOAT_IO (FL);
- USE FLIO;
- X : FL;
- STR : STRING (1..10) := " 10.25 ";
- L : POSITIVE;
- BEGIN
-
--- LEFT-JUSTIFIED IN STRING, POSITIVE, NO EXPONENT
- BEGIN
- GET ("896.5 ", X, L);
- IF X /= 896.5 THEN
- FAILED ("FLOAT VALUE FROM STRING INCORRECT");
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - FLOAT - 1");
- END;
-
- IF L /= IDENT_INT (5) THEN
- FAILED ("VALUE OF LAST INCORRECT - FLOAT - 1. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
-
--- STRING LITERAL WITH BLANKS
- BEGIN
- GET (" ", X, L);
- FAILED ("END_ERROR NOT RAISED - FLOAT - 2");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 2. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 2");
- END;
-
--- NULL STRING LITERAL
- BEGIN
- GET ("", X, L);
- FAILED ("END_ERROR NOT RAISED - FLOAT - 3");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 3. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 3");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 3");
- END;
-
--- NULL SLICE
- BEGIN
- GET (STR(5..IDENT_INT(2)), X, L);
- FAILED ("END_ERROR NOT RAISED - FLOAT - 4");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 4. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 4");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 4");
- END;
-
--- SLICE WITH BLANKS
- BEGIN
- GET (STR(IDENT_INT(9)..10), X, L);
- FAILED ("END_ERROR NOT RAISED - FLOAT - 5");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(5) THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 5. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 5");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 5");
- END;
-
--- NON-NULL SLICE
- BEGIN
- GET (STR(2..IDENT_INT(8)), X, L);
- IF X /= 10.25 THEN
- FAILED ("FLOAT VALUE INCORRECT - 6");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT FOR SLICE - 6. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 6");
- END;
-
--- LEFT-JUSTIFIED, POSITIVE EXPONENT
- BEGIN
- GET ("1.34E+02", X, L);
- IF X /= 134.0 THEN
- FAILED ("FLOAT WITH EXP FROM STRING INCORRECT - 7");
- END IF;
-
- IF L /= 8 THEN
- FAILED ("VALUE OF LAST INCORRECT - FLOAT - 7. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_EROR RAISED - FLOAT - 7");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - FLOAT - 7");
- END;
-
--- RIGHT-JUSTIFIED, NEGATIVE EXPONENT
- BEGIN
- GET (" 25.0E-2", X, L);
- IF X /= 0.25 THEN
- FAILED ("NEG EXPONENT INCORRECT - 8");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT - 8. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 8");
- END;
-
--- RIGHT-JUSTIFIED, NEGATIVE
- GET (" -1.50", X, L);
- IF X /= -1.5 THEN
- FAILED ("FLOAT IN RIGHT JUSTIFIED STRING INCORRECT - 9");
- END IF;
- IF L /= 7 THEN
- FAILED ("LAST INCORRECT - 9. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
-
--- HORIZONTAL TAB WITH BLANKS
- BEGIN
- GET (" " & ASCII.HT & "2.3E+2", X, L);
- IF X /= 230.0 THEN
- FAILED ("FLOAT WITH TAB IN STRING INCORRECT - 10");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT FOR TAB - 10. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR FOR STRING WITH TAB - 10");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED FOR STRING WITH " &
- "TAB - 10");
- END;
-
--- HORIZONTAL TABS ONLY
- BEGIN
- GET (ASCII.HT & ASCII.HT, X, L);
- FAILED ("END_ERROR NOT RAISED - FLOAT - 11");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(8) THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 11. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FLOAT - 11");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 11");
- END;
- END;
-
- RESULT;
-
-END CE3809A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada
deleted file mode 100644
index 45aca86..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada
+++ /dev/null
@@ -1,239 +0,0 @@
--- CE3809B.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.
---*
--- HISTORY:
--- CHECK THAT FIXED I/O GET CAN READ A VALUE FROM A STRING.
--- CHECK THAT END_ERROR IS RAISED WHEN CALLED WITH A NULL STRING
--- OR A STRING CONTAINING SPACES AND/OR HORIZONTAL TABULATION
--- CHARACTERS. CHECK THAT LAST CONTAINS THE INDEX OF THE LAST
--- CHARACTER READ FROM THE STRING.
-
--- HISTORY:
--- SPS 10/07/82
--- SPS 12/14/82
--- JBG 12/21/82
--- DWC 09/15/87 ADDED CASE TO INCLUDE ONLY TABS IN STRING AND
--- CHECKED THAT END_ERROR IS RAISED.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3809B IS
-BEGIN
-
- TEST ("CE3809B", "CHECK THAT FIXED_IO GET " &
- "OPERATES CORRECTLY ON STRINGS");
-
- DECLARE
- TYPE FX IS DELTA 0.001 RANGE -2.0 .. 1000.0;
- PACKAGE FXIO IS NEW FIXED_IO (FX);
- USE FXIO;
- X : FX;
- L : POSITIVE;
- STR : STRING (1..10) := " 10.25 ";
- BEGIN
-
--- LEFT-JUSTIFIED IN STRING, POSITIVE, NO EXPONENT
- BEGIN
- GET ("896.5 ", X, L);
- IF X /= 896.5 THEN
- FAILED ("FIXED VALUE FROM STRING INCORRECT");
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 1");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - FIXED - 1");
- END;
-
- IF L /= IDENT_INT (5) THEN
- FAILED ("VALUE OF LAST INCORRECT - FIXED - 1. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
-
--- STRING LITERAL WITH BLANKS
- BEGIN
- GET (" ", X, L);
- FAILED ("END_ERROR NOT RAISED - FIXED - 2");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 2. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 2");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 2");
- END;
-
--- NULL STRING LITERAL
- BEGIN
- GET ("", X, L);
- FAILED ("END_ERROR NOT RAISED - FIXED - 3");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 3. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 3");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 3");
- END;
-
--- NULL SLICE
- BEGIN
- GET (STR(5..IDENT_INT(2)), X, L);
- FAILED ("END_ERROR NOT RAISED - FIXED - 4");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= 5 THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 4. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 4");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 4");
- END;
-
--- SLICE WITH BLANKS
- BEGIN
- GET (STR(IDENT_INT(9)..10), X, L);
- FAILED ("END_ERROR NOT RAISED - FIXED - 5");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(5) THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 5. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 5");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 5");
- END;
-
--- NON-NULL SLICE
- BEGIN
- GET (STR(2..IDENT_INT(8)), X, L);
- IF X /= 10.25 THEN
- FAILED ("FIXED VALUE INCORRECT - 6");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT FOR SLICE - 6. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 6");
- END;
-
--- LEFT-JUSTIFIED, POSITIVE EXPONENT
- BEGIN
- GET ("1.34E+02", X, L);
- IF X /= 134.0 THEN
- FAILED ("FIXED WITH EXP FROM STRING INCORRECT - 7");
- END IF;
-
- IF L /= 8 THEN
- FAILED ("VALUE OF LAST INCORRECT - FIXED - 7. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_EROR RAISED - FIXED - 7");
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED - FIXED - 7");
- END;
-
--- RIGHT-JUSTIFIED, NEGATIVE EXPONENT
- BEGIN
- GET (" 25.0E-2", X, L);
- IF X /= 0.25 THEN
- FAILED ("NEG EXPONENT INCORRECT - 8");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT - 8. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("EXCEPTION RAISED - 8");
- END;
-
--- RIGHT-JUSTIFIED, NEGATIVE
- GET (" -1.50", X, L);
- IF X /= -1.5 THEN
- FAILED ("FIXED IN RIGHT JUSTIFIED STRING INCORRECT - 9");
- END IF;
- IF L /= 7 THEN
- FAILED ("LAST INCORRECT - 9. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
-
--- HORIZONTAL TAB WITH BLANK
- BEGIN
- GET (" " & ASCII.HT & "2.3E+2", X, L);
- IF X /= 230.0 THEN
- FAILED ("FIXED WITH TAB IN STRING INCORRECT - 10");
- END IF;
- IF L /= 8 THEN
- FAILED ("LAST INCORRECT FOR TAB - 10. " &
- "LAST IS" & INTEGER'IMAGE(L));
- END IF;
- EXCEPTION
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR FOR STRING WITH TAB - 10");
- WHEN OTHERS =>
- FAILED ("EXCEPTION FOR STRING WITH TAB - 10");
- END;
-
--- HORIZONTAL TABS ONLY
-
- BEGIN
- GET (ASCII.HT & ASCII.HT, X, L);
- FAILED ("END_ERROR NOT RAISED - FIXED - 11");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(8) THEN
- FAILED ("AFTER END_ERROR, VALUE OF LAST " &
- "INCORRECT - 11. LAST IS" &
- INTEGER'IMAGE(L));
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED - FIXED - 11");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 11");
- END;
- END;
-
- RESULT;
-
-END CE3809B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada
deleted file mode 100644
index f51728c..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada
+++ /dev/null
@@ -1,114 +0,0 @@
--- CE3810A.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 FLOAT_IO PUT CAN OPERATE ON STRINGS. ALSO CHECK THAT
--- LAYOUT_ERROR IS RAISED WHEN THE STRING IS INSUFFICIENTLY LONG.
-
--- HISTORY:
--- SPS 10/07/82
--- VKG 01/20/83
--- SPS 02/18/83
--- DWC 09/15/87 SPLIT CASE FOR FIXED_IO INTO CE3810B.ADA AND
--- ADDED CASED FOR AFT AND EXP TO RAISE LAYOUT_ERROR.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3810A IS
-BEGIN
-
- TEST ("CE3810A", "CHECK THAT FLOAT_IO PUT " &
- "OPERATES ON STRINGS CORRECTLY");
-
- DECLARE
- TYPE FL IS DIGITS 4;
- PACKAGE FLIO IS NEW FLOAT_IO (FL);
- USE FLIO;
- ST : STRING (1 .. 2 + (FL'DIGITS-1) + 3 + 2);
- ST1 : STRING (1 .. 10) := " 2.345E+02";
- ST2 : STRING (1 .. 2);
- BEGIN
- PUT (ST, 234.5);
- IF ST /= ST1 THEN
- FAILED ("PUT FLOAT TO STRING INCORRECT; OUTPUT WAS """ &
- ST & """");
- END IF;
-
- BEGIN
- PUT (ST(1 .. 8), 234.5);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 1");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 1");
- END;
-
- BEGIN
- PUT (ST, 2.3, 9, 0);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 2");
- END;
-
- BEGIN
- PUT (ST2, 2.0, 0, 0);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 3");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 3");
- END;
-
- BEGIN
- PUT (ST, 2.345, 6, 2);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 4");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 4");
- END;
-
- BEGIN
- PUT (ST, 2.0, 0, 7);
- FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 5");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FLOAT - 5");
- END;
- END;
-
- RESULT;
-
-END CE3810A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada
deleted file mode 100644
index dfdbd56..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada
+++ /dev/null
@@ -1,122 +0,0 @@
--- CE3810B.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 FIXED_IO PUT CAN OPERATE ON STRINGS. ALSO CHECK THAT
--- LAYOUT_ERROR IS RAISED WHEN THE STRING IS INSUFFICIENTLY LONG.
-
--- HISTORY:
--- DWC 09/15/87 CREATE ORIGINAL TEST.
--- JRL 02/28/96 Changed upper bound of type FX from 1000.0 to 250.0.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3810B IS
-BEGIN
-
- TEST ("CE3810B", "CHECK THAT FIXED_IO PUT CAN OPERATE ON " &
- "STRINGS. ALSO CHECK THAT LAYOUT_ERROR IS " &
- "RAISED WHEN THE STRING IS INSUFFICIENTLY LONG");
-
- DECLARE
- TYPE FX IS DELTA 0.0001 RANGE 0.0 .. 250.0;
- PACKAGE FXIO IS NEW FIXED_IO (FX);
- USE FXIO;
- ST1 : CONSTANT STRING := " 234.5000";
- ST : STRING (ST1'RANGE);
- ST2 : STRING (1 .. 2);
-
- BEGIN
- BEGIN
- PUT (ST, 234.5);
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- FAILED ("LAYOUT_ERROR RAISED ON PUT" &
- "TO STRING - FIXED");
- WHEN OTHERS =>
- FAILED ("SOME EXCEPTION RAISED ON PUT" &
- "TO STRING -FIXED");
- END;
-
- IF ST /= ST1 THEN
- FAILED ("PUT FIXED TO STRING INCORRECT; OUTPUT " &
- "WAS """ & ST & """");
- END IF;
-
- BEGIN
- PUT (ST (1..7), 234.5000);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 1");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 1");
- END;
-
- BEGIN
- PUT (ST, 2.3, 9, 0);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 2");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 2");
- END;
-
- BEGIN
- PUT (ST2, 2.0, 0, 0);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 3");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 3");
- END;
-
- BEGIN
- PUT (ST, 2.345, 6, 2);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 4");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 4");
- END;
-
- BEGIN
- PUT (ST, 2.0, 0, 7);
- FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 5");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FIXED - 5");
- END;
- END;
-
- RESULT;
-END CE3810B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada
deleted file mode 100644
index 196ff86..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- CE3815A.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 OPERATIONS IN GENERIC PACKAGE FLOAT_IO ALL HAVE
--- THE CORRECT PARAMETER NAMES.
-
--- HISTORY:
--- JET 10/28/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-PROCEDURE CE3815A IS
-
- STR : STRING(1..20) := (OTHERS => ' ');
- FIN, FOUT : FILE_TYPE;
- F : FLOAT;
- L : POSITIVE;
- FILE_OK : BOOLEAN := FALSE;
-
- PACKAGE FIO IS NEW FLOAT_IO(FLOAT);
- USE FIO;
-
-BEGIN
- TEST ("CE3815A", "CHECK THAT THE OPERATIONS IN GENERIC PACKAGE " &
- "FLOAT_IO ALL HAVE THE CORRECT PARAMETER NAMES");
-
- PUT (TO => STR, ITEM => 1.0, AFT => 3, EXP => 3);
- GET (FROM => STR, ITEM => F, LAST => L);
-
- BEGIN
- CREATE(FOUT, OUT_FILE, LEGAL_FILE_NAME);
- FILE_OK := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- COMMENT("OUTPUT FILE COULD NOT BE CREATED");
- END;
-
- IF FILE_OK THEN
- BEGIN
- PUT (FILE => FOUT, ITEM => 1.0, FORE => 3, AFT => 3,
- EXP => 3);
- NEW_LINE(FOUT);
-
- CLOSE(FOUT);
- EXCEPTION
- WHEN OTHERS =>
- FAILED("OUTPUT FILE COULD NOT BE WRITTEN");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- BEGIN
- OPEN(FIN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN OTHERS =>
- FAILED("INPUT FILE COULD NOT BE OPENED");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- BEGIN
- GET (FILE => FIN, ITEM => F, WIDTH => 10);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("DATA COULD NOT BE READ FROM FILE");
- END;
-
- BEGIN
- DELETE(FIN);
- EXCEPTION
- WHEN USE_ERROR =>
- COMMENT("FILE COULD NOT BE DELETED");
- WHEN OTHERS =>
- FAILED("UNEXPECTED ERROR AT DELETION");
- END;
- END IF;
-
- RESULT;
-END CE3815A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada
deleted file mode 100644
index 1760dd9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada
+++ /dev/null
@@ -1,106 +0,0 @@
--- CE3901A.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 GET AND PUT FOR ENUMERATED TYPES RAISE STATUS ERROR
--- IF THE FILE IS NOT OPEN.
-
--- HISTORY:
--- SPS 10/07/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- DWC 09/16/87 ADDED AN ATTEMPT TO CREATE A FILE AND THEN
--- RETESTED OBJECTIVE.
--- BCB 10/03/90 ADDED NAME_ERROR AS A CHOICE TO THE EXCEPTION
--- HANDLER FOR CREATE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3901A IS
-BEGIN
-
- TEST ("CE3901A", "CHECK THAT GET AND PUT FOR ENUMERATED TYPES " &
- "RAISE STATUS ERROR IF THE FILE IS NOT OPEN.");
-
- DECLARE
- TYPE COLOR IS (RED, BLUE, GREEN, ORANGE, YELLOW);
- FT : FILE_TYPE;
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- X : COLOR;
- BEGIN
- BEGIN
- PUT (FT, RED);
- FAILED ("STATUS_ERROR NOT RAISED - PUT - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT - 1");
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET - 1");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET - 1");
- END;
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); -- THIS IS JUST
- CLOSE (FT); -- AN ATTEMPT TO CREATE A
- EXCEPTION -- FILE. OBJECTIVE IS MET
- WHEN USE_ERROR -- EITHER WAY.
- | NAME_ERROR => NULL;
- END;
-
- BEGIN
- PUT (FT, RED);
- FAILED ("STATUS_ERROR NOT RAISED - PUT - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - PUT - 2");
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("STATUS_ERROR NOT RAISED - GET - 2");
- EXCEPTION
- WHEN STATUS_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - GET - 2");
- END;
- END;
-
- RESULT;
-
-END CE3901A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada
deleted file mode 100644
index 9f53599..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE3902B.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 OPERATIONS IN GENERIC PACKAGE ENUMERATION_IO
--- ALL HAVE THE CORRECT PARAMETER NAMES.
-
--- HISTORY:
--- JLH 08/25/88 CREATED ORIGINAL TEST.
--- RJW 02/28/90 ADDED CODE TO PREVENT MODE_ERROR FROM BEING RAISED.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3902B IS
-
- TYPE COLOR IS (RED, BLUE, GREEN);
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
-
- FILE1 : FILE_TYPE;
- CRAYON : COLOR := RED;
- INDEX : POSITIVE;
- NUM : FIELD := 5;
- COLOR_STRING : STRING (1..5);
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3902B", "CHECK THAT THE OPERATIONS IN GENERIC PACKAGE " &
- "ENUMERATION_IO ALL HAVE THE CORRECT PARAMETER " &
- "NAMES");
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- SET_OUTPUT (FILE1);
-
- PUT (FILE => FILE1, ITEM => CRAYON, WIDTH => NUM,
- SET => UPPER_CASE);
-
- PUT (ITEM => GREEN, WIDTH => 5, SET => LOWER_CASE);
-
- PUT (TO => COLOR_STRING, ITEM => BLUE, SET => UPPER_CASE);
-
- CLOSE (FILE1);
-
- SET_OUTPUT (STANDARD_OUTPUT);
-
- BEGIN
- OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE1);
-
- GET (FILE => FILE1, ITEM => CRAYON);
-
- GET (ITEM => CRAYON);
-
- GET (FROM => COLOR_STRING, ITEM => CRAYON, LAST => INDEX);
-
- BEGIN
- DELETE (FILE1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3902B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada
deleted file mode 100644
index 7fe900b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada
+++ /dev/null
@@ -1,117 +0,0 @@
--- CE3904A.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 LAST NONBLANK CHARACTER IN A FILE MAY BE READ BY
--- 'GET' IN ENUMERATION_IO WITHOUT RAISING END_ERROR, AND THAT AFTER
--- THE LAST CHARACTER OF THE FILE HAS BEEN READ, ANY ATTEMPT TO READ
--- FURTHER CHARACTERS WILL RAISE END_ERROR.
-
--- HISTORY:
--- JET 08/19/88 CREATED ORIGINAL TEST.
-
-WITH REPORT, TEXT_IO; USE REPORT, TEXT_IO;
-PROCEDURE CE3904A IS
-
- TYPE ENUM IS (THE, QUICK, BROWN, X);
- E : ENUM;
-
- PACKAGE EIO IS NEW ENUMERATION_IO(ENUM);
- USE EIO;
-
- F : FILE_TYPE;
-
- FILE_OK : BOOLEAN := FALSE;
-
-BEGIN
- TEST ("CE3904A", "CHECK THAT THE LAST NONBLANK CHARACTER IN A " &
- "FILE MAY BE READ BY 'GET' IN ENUMERATION_IO " &
- "WITHOUT RAISING END_ERROR, AND THAT AFTER THE " &
- "LAST CHARACTER OF THE FILE HAS BEEN READ, ANY " &
- "ATTEMPT TO READ FURTHER CHARACTERS WILL RAISE " &
- "END_ERROR");
-
- BEGIN
- CREATE(F, OUT_FILE, LEGAL_FILE_NAME);
- FILE_OK := TRUE;
- EXCEPTION
- WHEN OTHERS =>
- NOT_APPLICABLE("DATA FILE COULD NOT BE OPENED FOR " &
- "WRITING");
- END;
-
- IF FILE_OK THEN
- BEGIN
- PUT(F, THE); NEW_LINE(F);
- PUT(F, QUICK); NEW_LINE(F);
- PUT(F, BROWN); NEW_LINE(F);
- PUT(F, X); NEW_LINE(F);
- CLOSE(F);
- EXCEPTION
- WHEN OTHERS =>
- NOT_APPLICABLE("DATA FILE COULD NOT BE WRITTEN");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- BEGIN
- OPEN(F, IN_FILE, LEGAL_FILE_NAME);
- FOR I IN 0..3 LOOP
- GET(F, E);
- IF E /= ENUM'VAL(I) THEN
- FAILED("INCORRECT VALUE READ -" &
- INTEGER'IMAGE(I));
- END IF;
- END LOOP;
- EXCEPTION
- WHEN OTHERS =>
- FAILED("UNEXPECTED EXCEPTION RAISED BEFORE END " &
- "OF FILE");
- FILE_OK := FALSE;
- END;
- END IF;
-
- IF FILE_OK THEN
- BEGIN
- GET(F, E);
- FAILED("NO EXCEPTION RAISED AFTER END OF FILE");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED("INCORRECT EXCEPTION RAISED AFTER END OF " &
- "FILE");
- END;
-
- BEGIN
- DELETE(F);
- EXCEPTION
- WHEN OTHERS =>
- COMMENT("DATA FILE COULD NOT BE DELETED");
- END;
- END IF;
-
- RESULT;
-END CE3904A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada
deleted file mode 100644
index 408e590..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada
+++ /dev/null
@@ -1,142 +0,0 @@
--- CE3904B.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 END_ERROR IS RAISED BY GET WITH AN ENUMERATION TYPE
--- WHEN THE ONLY REMAINING CHARACTERS IN THE FILE ARE SPACES,
--- HORIZONTAL TABULATION CHARACTERS, LINE TERMINATORS, AND PAGE
--- TERMINATORS.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- JLH 07/15/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE CE3904B IS
-
- TYPE COLOR IS (RED, BLUE, GREEN);
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
-
- FILE : FILE_TYPE;
- ITEM : COLOR;
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3904B", "CHECK THAT END_ERROR IS RAISED BY GET WITH " &
- "AN ENUMERATION TYPE WHEN THE ONLY REMAINING " &
- "CHARACTERS IN THE FILE ARE SPACES, HORIZONTAL " &
- "TABULATION CHARACTERS, LINE TERMINATORS, AND " &
- "PAGE TERMINATORS");
-
- BEGIN
-
- BEGIN
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE, RED);
- NEW_LINE (FILE);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE, ASCII.HT);
- PUT (FILE, GREEN);
- NEW_LINE (FILE);
- NEW_LINE (FILE);
- NEW_PAGE (FILE);
- PUT (FILE, ' ');
- PUT (FILE, ASCII.HT);
- PUT (FILE, ' ');
-
- CLOSE (FILE);
-
- BEGIN
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "MODE IN_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN");
- RAISE INCOMPLETE;
- END;
-
- GET (FILE, ITEM);
- IF ITEM /= RED THEN
- FAILED ("INCORRECT VALUE READ - 1");
- END IF;
-
- GET (FILE, ITEM);
- IF ITEM /= GREEN THEN
- FAILED ("INCORRECT VALUE READ - 2");
- END IF;
-
- BEGIN
- GET (FILE, ITEM);
- FAILED ("END_ERROR NOT RAISED FOR GET");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON GET");
- END;
-
- IF NOT END_OF_FILE (FILE) THEN
- FAILED ("END_OF_FILE NOT TRUE AFTER RAISING EXCEPTION");
- END IF;
-
- BEGIN
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3904B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada
deleted file mode 100644
index 4fa69ef..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada
+++ /dev/null
@@ -1,145 +0,0 @@
--- CE3905A.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 GET FOR ENUMERATION TYPES OPERATES ON FILE OF MODE
--- IN_FILE AND THAT WHEN NO FILE IS SPECIFIED IT OPERATES ON THE
--- CURRENT DEFAULT INPUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/07/82
--- SPS 12/22/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/16/87 REMOVED DEPENDENCE ON RESET AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3905A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3905A", "CHECK THAT GET FOR ENUMERATION TYPES " &
- "OPERATES ON FILE OF MODE IN_FILE AND THAT " &
- "WHEN NO FILE IS SPECIFIED IT OPERATES ON " &
- "THE CURRENT DEFAULT INPUT_FILE");
-
- DECLARE
- TYPE DAY IS (MONDAY, TUESDAY, WEDNESDAY, THURSDAY, FRIDAY);
- PACKAGE DAY_IO IS NEW ENUMERATION_IO (DAY);
- FT : FILE_TYPE;
- FILE : FILE_TYPE;
- USE DAY_IO;
- X : DAY;
- BEGIN
-
--- CREATE AND INITIALIZE DATA FILES.
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "WEDNESDAY");
- NEW_LINE (FT);
- PUT (FT, "FRIDAY");
-
- CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME(2));
-
- PUT (FILE, "TUESDAY");
- NEW_LINE (FILE);
- PUT (FILE, "THURSDAY");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "FOR IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CLOSE (FILE);
- OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2));
-
- SET_INPUT (FILE);
-
--- BEGIN TEST
-
- GET (FT, X);
- IF X /= WEDNESDAY THEN
- FAILED ("VALUE FROM FILE INCORRECT");
- END IF;
-
- GET (X);
- IF X /= TUESDAY THEN
- FAILED ("VALUE FROM DEFAULT INCORRECT");
- END IF;
-
- GET (FT, X);
- IF X /= FRIDAY THEN
- FAILED ("VALUE FROM FILE INCORRECT");
- END IF;
-
- GET (FILE, X);
- IF X /= THURSDAY THEN
- FAILED ("VALUE FROM DEFAULT INCORRECT");
- END IF;
-
- BEGIN
- DELETE (FT);
- DELETE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3905A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada
deleted file mode 100644
index 5823f29..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CE3905B.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 GET FOR ENUMERATION TYPES RAISE MODE_ERROR WHEN THE
--- MODE OF THE FILE SPECIFIED IS OUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT CREATE FOR TEMP FILES WITH OUT_FILE.
-
--- HISTORY:
--- SPS 10/07/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/16/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3905B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3905B", "CHECK THAT ENUMERATION_IO GET RAISES " &
- "MODE_ERROR WHEN THE MODE OF THE FILE IS " &
- "OUT_FILE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE COLOR IS (RED, BLUE, GREEN, YELLOW);
- X : COLOR;
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILES WITH OUT_FILE " &
- "MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("MODE_ERROR NOT RAISED - FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE");
- END;
-
- BEGIN
- GET (STANDARD_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - STANDARD_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STANDARD_OUTPUT");
- END;
-
- BEGIN
- GET (CURRENT_OUTPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - CURRENT_OUTPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CURRENT_OUTPUT");
- END;
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3905B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada
deleted file mode 100644
index 226abb9..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada
+++ /dev/null
@@ -1,202 +0,0 @@
--- CE3905C.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 GET FOR ENUMERATION TYPES RAISES DATA_ERROR WHEN THE
--- ELEMENT RETRIEVED IS NOT OF THE TYPE EXPECTED OR IS OUT OF THE
--- RANGE OF A SUBTYPE. ALSO CHECK THAT CONSTRAINT_ERROR IS RAISED
--- IF THE VALUE READ IS OUT OF RANGE OF THE ITEM PARAMETER, BUT
--- WITHIN THE RANGE OF THE INSTANTIATED TYPE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/08/82
--- SPS 12/14/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/16/87 REMOVED DEPENDENCE ON RESET AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3905C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3905C", "CHECK THAT GET FOR ENUMERATION TYPES RAISES " &
- "DATA_ERROR WHEN THE ELEMENT RETRIEVED IS NOT " &
- "OF THE TYPE EXPECTED OR IS OUT OF THE RANGE " &
- "OF A SUBTYPE. ALSO CHECK THAT " &
- "CONSTRAINT_ERROR IS RAISED IF THE VALUE READ " &
- "IS OUT OF RANGE OF THE ITEM PARAMETER, BUT " &
- "WITHIN THE RANGE OF THE INSTANTIATED TYPE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE COLOR IS (RED, BLUE, YELLOW, WHITE, ORANGE, GREEN,
- PURPLE, BLACK);
- SUBTYPE P_COLOR IS COLOR RANGE RED .. YELLOW;
- CRAYON : COLOR := BLACK;
- PAINT : P_COLOR := BLUE;
- ST : STRING (1 .. 2);
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- BEGIN
-
--- CREATE AND INITIALIZE DATA FILE
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "BROWN");
- NEW_LINE (FT);
- PUT (FT, "ORANGE");
- NEW_LINE (FT);
- PUT (FT, "GREEN");
- NEW_LINE (FT);
- PUT (FT, "WHITE");
- NEW_LINE (FT);
- PUT (FT, "WHI");
- NEW_LINE (FT);
- PUT (FT, "TE");
- NEW_LINE (FT);
- PUT (FT, "RED");
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
--- START TEST
-
- BEGIN
- GET (FT, CRAYON); -- BROWN
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF CRAYON /= BLACK THEN
- FAILED ("ITEM CRAYON AFFECTED - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- BEGIN
- GET (FT, PAINT); -- ORANGE
- FAILED ("CONSTRAINT_ERROR NOT RAISED");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- IF PAINT /= BLUE THEN
- FAILED ("ITEM PAINT AFFECTED - 2");
- END IF;
- WHEN DATA_ERROR =>
- FAILED ("DATA_ERROR RAISED FOR ITEM SUBTYPE");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- DECLARE
- PACKAGE P_COLOR_IO IS NEW ENUMERATION_IO (P_COLOR);
- USE P_COLOR_IO;
- BEGIN
- BEGIN
- P_COLOR_IO.GET (FT, PAINT); -- GREEN
- FAILED ("DATA_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF PAINT /= BLUE THEN
- FAILED ("ITEM PAINT AFFECTED - 3");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
- BEGIN
- P_COLOR_IO.GET (FT, PAINT); -- WHITE
- FAILED ("DATA_ERROR NOT RAISED - 3A");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3A");
- END;
- END;
-
- BEGIN
- GET (FT, CRAYON); -- WHI
- FAILED ("DATA_ERROR NOT RAISED - 4");
- EXCEPTION
- WHEN DATA_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 4");
- END;
-
- GET (FT, ST); -- TE
-
- GET (FT, CRAYON); -- RED
- IF CRAYON /= RED THEN
- FAILED ("READING NOT CONTINUED CORRECTLY AFTER" &
- "DATA_ERROR EXCEPTION");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3905C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada b/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada
deleted file mode 100644
index 759c7de..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada
+++ /dev/null
@@ -1,311 +0,0 @@
--- CE3905L.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 DATA_ERROR IS RAISED, BY GET, WHEN THE INPUT CONTAINS
---
--- 1. EMBEDDED BLANKS.
--- 2. SINGLY QUOTED CHARACTER LITERALS.
--- 3. IDENTIFIERS BEGINNING WITH NON LETTERS.
--- 4. IDENTIFIERS CONTAINING SPECIAL CHARACTERS.
--- 5. CONSECUTIVE UNDERSCORES.
--- 6. LEADING OR TRAILING UNDERSCORES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- VKG 02/14/83
--- SPS 03/16/83
--- CPP 07/30/84
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/16/87 REMOVED UNNECESSARY CODE AND CORRECTED
--- EXCEPTION HANDLING.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-
-PROCEDURE CE3905L IS
-
- INCOMPLETE : EXCEPTION;
-
-BEGIN
- TEST ("CE3905L", "CHECK GET FOR ENUMERATION_IO " &
- "WITH LEXICAL ERRORS");
- DECLARE
- FT : FILE_TYPE;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, "RED ISH");
- NEW_LINE (FT);
- PUT (FT, "'A ");
- NEW_LINE (FT);
- PUT (FT, "2REDISH");
- NEW_LINE (FT);
- PUT (FT, "BLUE$%ISH");
- NEW_LINE (FT);
- PUT (FT, "RED__ISH");
- NEW_LINE (FT);
- PUT (FT, "_YELLOWISH");
- NEW_LINE (FT);
- PUT (FT, "GREENISH_");
- NEW_LINE (FT);
-
- CLOSE (FT);
-
- DECLARE
- TYPE COLOUR IS
- ( GREYISH,
- REDISH ,
- BLUEISH,
- YELLOWISH,
- GREENISH, 'A');
- PACKAGE COLOUR_IO IS NEW ENUMERATION_IO(COLOUR);
- USE COLOUR_IO;
- X : COLOUR := GREYISH;
- CH : CHARACTER;
- BEGIN
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "OPEN WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 1");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 1");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 1");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 1");
- ELSE
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 1: CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 2");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 2");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 2");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 2");
- ELSE
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 2: CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 3");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 3");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 3");
- ELSE
- GET (FT, CH);
- IF CH /= '2' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 3: CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 4");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 4");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 4");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 4");
- ELSE
- GET (FT, CH);
- IF CH /= '$' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 4: CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 5");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 5");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 5");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 5");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 5: CHAR IS " & CH);
- ELSE
- GET (FT, CH);
- IF CH /= 'I' THEN
- FAILED ("ERROR READING DATA - 5");
- END IF;
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 6");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 6");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 6");
- END;
-
- IF END_OF_LINE (FT) THEN
- FAILED ("GET STOPPED AT END OF LINE - 6");
- ELSE
- GET (FT, CH);
- IF CH /= '_' THEN
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 6: CHAR IS " & CH);
- END IF;
- END IF;
-
- SKIP_LINE (FT);
-
- BEGIN
- GET (FT, X);
- FAILED ("DATA_ERROR NOT RAISED - 7");
- EXCEPTION
- WHEN DATA_ERROR =>
- IF X /= GREYISH THEN
- FAILED ("ACTUAL PARAMETER TO GET " &
- "AFFECTED ON DATA_ERROR - 7");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 7");
- END;
-
- IF NOT END_OF_LINE (FT) THEN
- BEGIN
- GET (FT, X);
- FAILED ("GET STOPPED AT WRONG POSITION " &
- "- 7");
- EXCEPTION
- WHEN END_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED FOR " &
- "EMPTY FILE - 7");
- END;
- END IF;
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3905L;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada
deleted file mode 100644
index a2dc879..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada
+++ /dev/null
@@ -1,110 +0,0 @@
--- CE3906A.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 PUT FOR ENUMERATION TYPES CAN OPERATE ON FILES OF
--- MODE OUT_FILE AND THAT WHEN NO FILE PARAMETER IS SPECIFIED
--- THE CURRENT DEFAULT OUTPUT FILE IS USED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEMPORARY TEXT FILES.
-
--- HISTORY:
--- SPS 10/08/82
--- SPS 01/03/83
--- SPS 02/18/83
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/17/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION
--- HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3906A IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3906A", "CHECK THAT PUT FOR ENUMERATION TYPES CAN " &
- "OPERATE ON FILES OF MODE OUT_FILE AND THAT " &
- "WHEN NO FILE PARAMETER IS SPECIFIED THE " &
- "CURRENT DEFAULT OUTPUT FILE IS USED. CHECK " &
- "THAT ENUMERATION_IO PUT OPERATES ON OUT_FILE " &
- "FILES");
-
- DECLARE
- FT1, FT2 : FILE_TYPE;
- TYPE COLOR IS (ROSE, VANILLA, CHARCOAL, CHOCOLATE);
- CRAYON : COLOR := ROSE;
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- BEGIN
-
- BEGIN
- CREATE (FT1, OUT_FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "FOR TEMP FILES WITH OUT_FILE " &
- "MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FT2, OUT_FILE);
-
- SET_OUTPUT (FT2);
-
- PUT (FT1, CRAYON);
- NEW_LINE (FT1);
- PUT (FT1, CHOCOLATE);
-
- CRAYON := CHARCOAL;
-
- PUT (CRAYON);
- NEW_LINE;
- PUT (VANILLA);
-
--- CHECK OUTPUT
-
- SET_OUTPUT (STANDARD_OUTPUT);
- COMMENT ("CHECKING FT1");
- CHECK_FILE (FT1, "ROSE#CHOCOLATE#@%");
-
- COMMENT ("CHECKING FT2");
- CHECK_FILE (FT2, "CHARCOAL#VANILLA#@%");
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3906A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada
deleted file mode 100644
index 3e02340..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada
+++ /dev/null
@@ -1,133 +0,0 @@
--- CE3906B.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 PUT FOR ENUMERATION TYPES RAISES MODE_ERROR WHEN
--- APPLIED TO FILES OF MODE IN_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/08/82
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/17/87 REMOVED DEPENDENCY ON RESET AND CORRECTED
--- EXCEPTION HANDLERS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3906B IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3906B", "CHECK THAT PUT FOR ENUMERATION TYPES RAISES " &
- "MODE_ERROR WHEN APPLIED TO FILES OF MODE " &
- "IN_FILE");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE FLOWER IS (ROSE, DAISY, SNAPDRAGON, VIOLET, CARNATION);
- PACKAGE FLOWER_IO IS NEW ENUMERATION_IO (FLOWER);
- USE FLOWER_IO;
- X : FLOWER := DAISY;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FT, X);
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- PUT (FT, X);
- FAILED ("MODE_ERROR NOT RAISED - FILE");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - FILE");
- END;
-
- BEGIN
- PUT (STANDARD_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - STANDARD_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - STANDARD_INPUT");
- END;
-
- BEGIN
- PUT (CURRENT_INPUT, X);
- FAILED ("MODE_ERROR NOT RAISED - CURRENT_INPUT");
- EXCEPTION
- WHEN MODE_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - CURRENT_INPUT");
- END;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3906B;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada
deleted file mode 100644
index 0cf93a4..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada
+++ /dev/null
@@ -1,177 +0,0 @@
--- CE3906C.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 PUT FOR ENUMERATION TYPES OUTPUTS THE ENUMERATION
--- LITERAL WITH NO TRAILING OR PRECEDING BLANKS WHEN WIDTH IS
--- NOT SPECIFIED OR IS SPECIFIED TO BE LESS THAN OR EQUAL TO THE
--- LENGTH OF THE STRING. CHECK THAT WHEN WIDTH IS SPECIFIED TO
--- BE GREATER THAN THE LENGTH OF THE STRING, TRAILING BLANKS ARE
--- OUTPUT.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- HISTORY:
--- SPS 10/08/82
--- SPS 01/03/83
--- VKG 01/07/83
--- JBG 02/22/84 CHANGED TO .ADA TEST.
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/18/87 REMOVED CALL TO CHECKFILE. CLOSED AND REOPENED
--- FILE AND CHECKED CONTENTS OF FILE USING
--- ENUMERATION_IO GETS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3906C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3906C", "CHECK THAT ENUMERATION_IO PUT OUTPUTS " &
- "ENUMERATION LITERALS CORRECTLY WITH AND " &
- "WITHOUT WIDTH PARAMETERS");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE MOOD IS (ANGRY, HAPPY, BORED, SAD);
- X : MOOD := BORED;
- PACKAGE MOOD_IO IS NEW ENUMERATION_IO (MOOD);
- CH : CHARACTER;
- USE MOOD_IO;
- BEGIN
-
- BEGIN
- CREATE (FT, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- DEFAULT_WIDTH := FIELD(IDENT_INT(5));
-
- IF DEFAULT_WIDTH /= FIELD(IDENT_INT(5)) THEN
- FAILED ("DEFAULT_WIDTH NOT SET CORRECTLY");
- END IF;
-
- PUT (FT, X, 3); -- BORED
- X := HAPPY;
- NEW_LINE(FT);
- PUT (FILE => FT, ITEM => X, WIDTH => 5); -- HAPPY
- NEW_LINE (FT);
- PUT (FT, SAD, 5); -- SAD
- DEFAULT_WIDTH := FIELD(IDENT_INT(6));
- PUT (FT, X); -- HAPPY
- PUT (FT, SAD, 3); -- SAD
- NEW_LINE(FT);
- DEFAULT_WIDTH := FIELD(IDENT_INT(2));
- PUT (FT, SAD); -- SAD
-
- CLOSE (FT);
-
- BEGIN
- OPEN (FT, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN FOR " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- GET (FT, X);
- IF X /= BORED THEN
- FAILED ("BORED NOT READ CORRECTLY");
- END IF;
-
- GET (FT, X);
- IF X /= HAPPY THEN
- FAILED ("HAPPY NOT READ CORRECTLY - 1");
- END IF;
-
- SKIP_LINE (FT);
-
- GET (FT, X);
- IF X /= SAD THEN
- FAILED ("SAD NOT READ CORRECTLY - 1");
- END IF;
-
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("BLANKS NOT POSITIONED CORRECTLY - 1");
- END IF;
-
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("BLANKS NOT POSITIONED CORRECTLY - 2");
- END IF;
-
- GET (FT, X);
- IF X /= HAPPY THEN
- FAILED ("HAPPY NOT READ CORRECTLY - 2");
- END IF;
-
- GET (FT, CH);
- IF CH /= ' ' THEN
- FAILED ("BLANKS NOT POSITIONED CORRECTLY - 3");
- END IF;
-
- GET (FT, X);
- IF X /= SAD THEN
- FAILED ("SAD NOT READ CORRECTLY - 2");
- END IF;
-
- SKIP_LINE (FT);
-
- GET (FT, X);
- IF X /= SAD THEN
- FAILED ("SAD NOT READ CORRECTLY - 3");
- END IF;
-
- BEGIN
- DELETE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3906C;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada
deleted file mode 100644
index 954b4f8..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada
+++ /dev/null
@@ -1,152 +0,0 @@
--- CE3906D.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 CONSTRAINT_ERROR IS RAISED BY PUT FOR ENUMERATION
--- TYPES WHEN THE VALUE OF WIDTH IS NEGATIVE, WHEN WIDTH IS
--- GREATER THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM IS OUTSIDE
--- THE RANGE OF THE SUBTYPE USED TO INSTANTIATE ENUMERATION_IO.
-
--- HISTORY:
--- SPS 10/08/82
--- DWC 09/17/87 ADDED CASES FOR CONSTRAINT_ERROR.
--- JRL 06/07/96 Added call to Ident_Int in expressions involving
--- Field'Last, to make the expressions non-static and
--- prevent compile-time rejection.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3906D IS
-BEGIN
-
- TEST ("CE3906D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT " &
- "FOR ENUMERATION TYPES WHEN THE VALUE OF " &
- "WIDTH IS NEGATIVE, WHEN WIDTH IS GREATER " &
- "THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM " &
- "IS OUTSIDE THE RANGE OF THE SUBTYPE USED TO " &
- "INSTANTIATE ENUMERATION_IO");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE DAY IS (SUNDAY, MONDAY, TUESDAY, WEDNESDAY,
- THURSDAY, FRIDAY, SATURDAY);
- TODAY : DAY := FRIDAY;
- SUBTYPE WEEKDAY IS DAY RANGE MONDAY .. FRIDAY;
- PACKAGE DAY_IO IS NEW ENUMERATION_IO (WEEKDAY);
- USE DAY_IO;
- BEGIN
-
- BEGIN
- PUT (FT, TODAY, -1);
- FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " &
- "WIDTH - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("RAISED STATUS_ERROR");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " &
- "WIDTH - FILE");
- END;
-
- IF FIELD'LAST < INTEGER'LAST THEN
- BEGIN
- PUT (FT, TODAY, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " &
- "GREATER THAN FIELD'LAST + 1- FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; WIDTH " &
- "GREATER THAN FIELD'LAST + 1 - FILE");
- END;
-
- BEGIN
- PUT (TODAY, FIELD'LAST + Ident_Int(1));
- FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " &
- "GREATER THAN FIELD'LAST + 1 - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; WIDTH " &
- "GREATER THAN FIELD'LAST + 1 " &
- "- DEFAULT");
- END;
-
- END IF;
-
- TODAY := SATURDAY;
-
- BEGIN
- PUT (FT, TODAY);
- FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " &
- "OUT OF RANGE - FILE");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " &
- "OUT OF RANGE - FILE");
- END;
-
- TODAY := FRIDAY;
-
- BEGIN
- PUT (TODAY, -3);
- FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " &
- "WIDTH - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN STATUS_ERROR =>
- FAILED ("RAISED STATUS_ERROR");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " &
- "WIDTH - DEFAULT");
- END;
-
- TODAY := SATURDAY;
-
- BEGIN
- PUT (TODAY);
- FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " &
- "OUT OF RANGE - DEFAULT");
- EXCEPTION
- WHEN CONSTRAINT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " &
- "OUT OF RANGE - DEFAULT");
- END;
- END;
-
- RESULT;
-
-END CE3906D;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada
deleted file mode 100644
index 29ac3ea..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada
+++ /dev/null
@@ -1,109 +0,0 @@
--- CE3906E.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.
---*
--- HISTORY:
--- CHECK THAT PUT FOR ENUMERATION TYPES RAISES LAYOUT_ERROR WHEN
--- THE NUMBER OF CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE
--- LENGTH. CHECK THAT LAYOUT_ERROR IS NOT RAISED WHEN THE NUMBER
--- OF CHARACTERS TO BE OUTPUT DOES NOT EXCEED THE MAXIMUM LINE
--- LENGTH, BUT WHEN ADDED TO THE CURRENT COLUMN NUMBER, THE TOTAL
--- EXCEEDS THE MAXIMUM LINE LENGTH.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMETATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- SPS 10/11/82
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/18/87 CORRECTED EXCEPTION HANDLING.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CE3906E IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("CE3906E", "CHECK THAT ENUMERATION_IO PUT RAISES " &
- "LAYOUT_ERROR CORRECTLY");
-
- DECLARE
- FT : FILE_TYPE;
- TYPE COLOR IS (RED, BLU, YELLOW, ORANGE, RD);
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- CRAYON : COLOR := ORANGE;
- BEGIN
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE FOR TEMP FILES WITH " &
- "OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- SET_LINE_LENGTH (FT, 5);
-
- BEGIN
- PUT (FT, CRAYON);
- FAILED("LAYOUT_ERROR NOT RAISED");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- PUT (FT, RED);
-
- PUT (FT, BLU);
- IF LINE (FT) /= 2 THEN
- FAILED ("PUT DID NOT CAUSE NEW_LINE EFFECT");
- END IF;
-
- PUT (FT, RD);
-
- CHECK_FILE (FT, "RED#" &
- "BLURD#@%");
-
- CLOSE (FT);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END CE3906E;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada b/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada
deleted file mode 100644
index 484514b..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada
+++ /dev/null
@@ -1,102 +0,0 @@
--- CE3906F.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 SET PARAMETER AFFECTS THE CASE OF IDENTIFIERS,
--- BUT NOT CHARACTER LITERALS. CHECK THAT CHARACTER LITERALS ARE
--- ENCLOSED IN APOSTROPHES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH
--- SUPPORT TEXT FILES.
-
--- HISTORY:
--- JBG 12/30/82
--- VKG 01/12/83
--- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 09/18/87 CORRECTED EXCEPTION HANDLING.
-
-WITH TEXT_IO; USE TEXT_IO;
-WITH REPORT; USE REPORT;
-WITH CHECK_FILE;
-
-PROCEDURE CE3906F IS
-
- TYPE ENUM IS (REDISH,GREENISH,YELLOWISH);
- PACKAGE ENUM_IO IS NEW ENUMERATION_IO(ENUM);
- PACKAGE CHAR_IO IS NEW ENUMERATION_IO(CHARACTER);
- USE ENUM_IO; USE CHAR_IO;
- INCOMPLETE : EXCEPTION;
- FT : FILE_TYPE;
-
-BEGIN
-
- TEST ("CE3906F", "CHECK THE CASE OF ENUMERATION IO OUTPUT");
-
- BEGIN
- CREATE (FT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " &
- "CREATE FOR TEMP FILE WITH " &
- "OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- END;
-
- IF ENUM_IO.DEFAULT_WIDTH /= 0 THEN
- FAILED ("INITIAL DEFAULT WIDTH INCORRECT");
- END IF;
-
- IF CHAR_IO.DEFAULT_SETTING /= UPPER_CASE THEN
- FAILED ("INITIAL DEFAULT_SETTING INCORRECT");
- END IF;
-
- PUT (FT, 'A', SET => LOWER_CASE);
- NEW_LINE (FT);
- PUT (FT, 'a', SET => LOWER_CASE);
- NEW_LINE (FT);
- PUT (FT, REDISH, SET => LOWER_CASE);
- NEW_LINE (FT);
- ENUM_IO.DEFAULT_SETTING := LOWER_CASE;
- CHAR_IO.PUT (FT, 'C');
- NEW_LINE (FT);
- CHAR_IO.PUT (FT, 'b');
- NEW_LINE (FT);
- PUT (FT, REDISH);
- NEW_LINE (FT);
- PUT (FT, GREENISH, SET => LOWER_CASE);
- NEW_LINE (FT);
- PUT (FT, YELLOWISH, SET => UPPER_CASE);
-
- CHECK_FILE (FT, "'A'#'a'#redish#'C'#'b'#redish#greenish#"
- & "YELLOWISH#@%");
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END CE3906F;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada
deleted file mode 100644
index 0765c42..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- CE3907A.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 PUT FOR ENUMERATION TYPES CAN BE APPLIED TO A STRING.
--- CHECK THAT IT RAISES LAYOUT_ERROR WHEN THE ENUMERATION LITERAL TO BE
--- PLACED IN THE STRING IS LONGER THAN THE STRING.
-
--- SPS 10/11/82
--- JBG 2/22/84 CHANGED TO .ADA TEST
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3907A IS
-BEGIN
-
- TEST ("CE3907A", "CHECK THAT ENUMERATION_IO PUT OPERATES ON " &
- "STRINGS CORRECTLY");
-
- DECLARE
- TYPE COLOR IS (RED, BLUE, GREEN);
- ST : STRING (1..4);
- PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR);
- USE COLOR_IO;
- CRAYON : COLOR := GREEN;
- BEGIN
- PUT (ST, RED);
- IF ST /= "RED " THEN
- FAILED ("PUT TO STRING, LENGTH LESS THAN STRING " &
- "INCORRECT");
- END IF;
-
- PUT (ST, BLUE);
- IF ST /= "BLUE" THEN
- FAILED ("PUT TO STRING, LENGTH EQUAL TO STRING " &
- "INCORRECT");
- END IF;
-
- BEGIN
- PUT (ST, CRAYON);
- FAILED ("LAYOUT_ERROR NOT RAISED");
- EXCEPTION
- WHEN LAYOUT_ERROR =>
- NULL;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED");
- END;
-
- END;
-
- RESULT;
-END CE3907A;
diff --git a/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada b/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada
deleted file mode 100644
index 44c3954..0000000
--- a/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada
+++ /dev/null
@@ -1,140 +0,0 @@
--- CE3908A.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 GET FOR ENUMERATION TYPES CAN OPERATE ON STRINGS.
--- CHECK THAT IT RAISES END_ERROR WHEN THE STRING IS NULL OR
--- EMPTY. CHECK THAT LAST CONTAINS THE INDEX VALUE OF THE LAST
--- CHARACTER READ FROM THE STRING.
-
--- HISTORY:
--- SPS 10/11/82
--- VKG 01/06/83
--- JBG 02/22/84 CHANGED TO .ADA TEST
--- DWC 09/18/87 ADDED CASES WHICH CONTAIN TABS WITH AND WITHOUT
--- ENUMERATION LITERALS.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE CE3908A IS
-BEGIN
-
- TEST ("CE3908A", "CHECK THAT GET FOR ENUMERATION TYPES CAN " &
- "OPERATE ON STRINGS. CHECK THAT IT RAISES " &
- "END_ERROR WHEN THE STRING IS NULL OR EMPTY. " &
- "CHECK THAT LAST CONTAINS THE INDEX VALUE OF " &
- "THE LAST CHARACTER READ FROM THE STRING");
-
- DECLARE
- TYPE FRUIT IS (APPLE, PEAR, ORANGE, STRAWBERRY);
- DESSERT : FRUIT;
- PACKAGE FRUIT_IO IS NEW ENUMERATION_IO (FRUIT);
- USE FRUIT_IO;
- L : POSITIVE;
- BEGIN
- GET ("APPLE ", DESSERT, L);
- IF DESSERT /= APPLE THEN
- FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 1");
- END IF;
-
- IF L /= IDENT_INT (5) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 1");
- END IF;
-
- GET ("APPLE", DESSERT, L);
- IF DESSERT /= APPLE THEN
- FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 2");
- END IF;
-
- IF L /= IDENT_INT (5) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 2");
- END IF;
-
- BEGIN
- GET (ASCII.HT & "APPLE", DESSERT, L);
- IF DESSERT /= APPLE THEN
- FAILED ("ENUMERATION VALUE FROM STRING " &
- "INCORRECT - 3");
- END IF;
- IF L /= IDENT_INT(6) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE AFTER " &
- "GET - 3");
- END IF;
- EXCEPTION
- WHEN END_ERROR =>
- FAILED ("GET DID NOT SKIP LEADING TABS");
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 3");
- END;
-
--- NULL STRING LITERAL.
-
- BEGIN
- GET ("", DESSERT, L);
- FAILED ("END_ERROR NOT RAISED - 4");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(6) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE " &
- "AFTER GET - 4");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 4");
- END;
-
- BEGIN
- GET (ASCII.HT & "", DESSERT, L);
- FAILED ("END_ERROR NOT RAISED - 5");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(6) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE " &
- "AFTER GET - 5");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 5");
- END;
-
--- STRING LITERAL WITH BLANKS.
-
- BEGIN
- GET(" ", DESSERT, L);
- FAILED ("END ERROR NOT RAISED - 6");
- EXCEPTION
- WHEN END_ERROR =>
- IF L /= IDENT_INT(6) THEN
- FAILED ("LAST CONTAINS INCORRECT VALUE " &
- "AFTER GET - 6");
- END IF;
- WHEN OTHERS =>
- FAILED ("WRONG EXCEPTION RAISED - 6");
- END;
-
- END;
-
- RESULT;
-END CE3908A;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a
deleted file mode 100644
index 9c7e25b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a
+++ /dev/null
@@ -1,507 +0,0 @@
--- CXA3001.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 character classification functions defined in
--- package Ada.Characters.Handling produce correct results when provided
--- constant arguments from package Ada.Characters.Latin_1.
---
--- TEST DESCRIPTION:
--- This test checks the character classification functions of package
--- Ada.Characters.Handling. In the evaluation of each function, loops
--- are constructed to examine the function with as many values of type
--- Character (Ada.Characters.Latin_1 constants) as possible in an
--- amount of code that is about equal to the amount of code required
--- to examine the function with a few representative input values and
--- endpoint values.
--- The usage paradigm being demonstrated by this test is that of the
--- functions being used to assign to boolean variables, as well as
--- serving as boolean conditions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Apr 95 SAIC Fixed subtest checking Is_Graphic function.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3001 is
-
-begin
-
- Report.Test ("CXA3001", "Check that the character classification " &
- "functions defined in package " &
- "Ada.Characters.Handling produce " &
- "correct results when provided constant " &
- "arguments from package Ada.Characters.Latin_1");
-
- Test_Block:
- declare
-
- package AC renames Ada.Characters;
- package ACH renames Ada.Characters.Handling;
-
- TC_Boolean : Boolean := False;
-
- begin
-
- -- Over the next six statements/blocks of code, evaluate functions
- -- Is_Control and Is_Graphic with control character and non-control
- -- character values.
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.US) loop
- if not ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 1");
- end if;
- if ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 1");
- end if;
- end loop;
-
-
- for i in Character'Pos(AC.Latin_1.Space) ..
- Character'Pos(AC.Latin_1.Tilde) loop
- if not ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 2");
- end if;
- if ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 2");
- end if;
- end loop;
-
-
- for i in Character'Pos(AC.Latin_1.Reserved_128) ..
- Character'Pos(AC.Latin_1.APC) loop
- if not ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 3");
- end if;
- TC_Boolean := ACH.Is_Graphic(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect result from function Is_Graphic - 3");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.No_Break_Space) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- TC_Boolean := ACH.Is_Control(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect result from function Is_Control - 4");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 4");
- end if;
- end loop;
-
- -- Check renamed constants.
-
- if not (ACH.Is_Control(AC.Latin_1.IS4) and
- ACH.Is_Control(AC.Latin_1.IS3) and
- ACH.Is_Control(AC.Latin_1.IS2) and
- ACH.Is_Control(AC.Latin_1.IS1)) or
- (ACH.Is_Control(AC.Latin_1.NBSP) or
- ACH.Is_Control(AC.Latin_1.Paragraph_Sign) or
- ACH.Is_Control(AC.Latin_1.Minus_Sign) or
- ACH.Is_Control(AC.Latin_1.Ring_Above))
- then
- Report.Failed ("Incorrect result from function Is_Control - 5");
- end if;
-
- if (ACH.Is_Graphic(AC.Latin_1.IS4) or
- ACH.Is_Graphic(AC.Latin_1.IS3) or
- ACH.Is_Graphic(AC.Latin_1.IS2) or
- ACH.Is_Graphic(AC.Latin_1.IS1)) or
- not (ACH.Is_Graphic(AC.Latin_1.NBSP) and
- ACH.Is_Graphic(AC.Latin_1.Paragraph_Sign) and
- ACH.Is_Graphic(AC.Latin_1.Minus_Sign) and
- ACH.Is_Graphic(AC.Latin_1.Ring_Above))
- then
- Report.Failed ("Incorrect result from function Is_Graphic - 5");
- end if;
-
-
- -- Evaluate function Is_Letter with letter/non-letter inputs.
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 3");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 4");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 5");
- end if;
- end loop;
-
- -- Check for rejection of non-letters.
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.Commercial_At) loop
- if ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 6");
- end if;
- end loop;
-
-
- -- Evaluate function Is_Lower with lower case/non-lower case inputs.
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A_Grave) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 3");
- end if;
- end loop;
-
- if ACH.Is_Lower('A') or
- ACH.Is_Lower(AC.Latin_1.UC_Icelandic_Eth) or
- ACH.Is_Lower(AC.Latin_1.Number_Sign) or
- ACH.Is_Lower(AC.Latin_1.Cedilla) or
- ACH.Is_Lower(AC.Latin_1.SYN) or
- ACH.Is_Lower(AC.Latin_1.ESA)
- then
- Report.Failed ("Incorrect Is_Lower result - 4");
- end if;
-
-
- -- Evaluate function Is_Upper with upper case/non-upper case inputs.
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.UC_Icelandic_Thorn) loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 3");
- end if;
- end loop;
-
- if ACH.Is_Upper('8') or
- ACH.Is_Upper(AC.Latin_1.LC_A_Ring ) or
- ACH.Is_Upper(AC.Latin_1.Dollar_Sign) or
- ACH.Is_Upper(AC.Latin_1.Broken_Bar) or
- ACH.Is_Upper(AC.Latin_1.ETB) or
- ACH.Is_Upper(AC.Latin_1.VTS)
- then
- Report.Failed ("Incorrect Is_Upper result - 4");
- end if;
-
-
- for i in Character'Pos('a') .. Character'Pos('z') loop
- if ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 5");
- end if;
- end loop;
-
-
- -- Evaluate function Is_Basic with basic/non-basic inputs.
- -- (Note: Basic letters are those without diacritical marks.)
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 2");
- end if;
- end loop;
-
-
- if not (ACH.Is_Basic(AC.Latin_1.UC_AE_Diphthong) and
- ACH.Is_Basic(AC.Latin_1.LC_AE_Diphthong) and
- ACH.Is_Basic(AC.Latin_1.LC_German_Sharp_S) and
- ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Eth) and
- ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Thorn) and
- ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Eth) and
- ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Thorn))
- then
- Report.Failed ("Incorrect Is_Basic result - 3");
- end if;
-
- -- Check for rejection of non-basics.
- if ACH.Is_Basic(AC.Latin_1.UC_A_Tilde) or
- ACH.Is_Basic(AC.Latin_1.LC_A_Grave) or
- ACH.Is_Basic(AC.Latin_1.Ampersand) or
- ACH.Is_Basic(AC.Latin_1.Yen_Sign) or
- ACH.Is_Basic(AC.Latin_1.NAK) or
- ACH.Is_Basic(AC.Latin_1.SS2)
- then
- Report.Failed ("Incorrect Is_Basic result - 4");
- end if;
-
-
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.Commercial_At) loop
- if ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 5");
- end if;
- end loop;
-
-
- -- Evaluate functions Is_Digit and Is_Decimal_Digit (a rename of
- -- Is_Digit) with decimal digit/non-digit inputs.
-
-
- if not (ACH.Is_Digit('0') and
- ACH.Is_Decimal_Digit('9')) or
- ACH.Is_Digit ('a') or -- Hex digits.
- ACH.Is_Decimal_Digit ('f') or
- ACH.Is_Decimal_Digit ('A') or
- ACH.Is_Digit ('F')
- then
- Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 1");
- end if;
-
- if ACH.Is_Digit (AC.Latin_1.Full_Stop) or
- ACH.Is_Decimal_Digit (AC.Latin_1.Dollar_Sign) or
- ACH.Is_Digit (AC.Latin_1.Number_Sign) or
- ACH.Is_Decimal_Digit (AC.Latin_1.Left_Parenthesis) or
- ACH.Is_Digit (AC.Latin_1.Right_Parenthesis)
- then
- Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 2");
- end if;
-
-
- -- Evaluate functions Is_Hexadecimal_Digit with hexadecimal digit and
- -- non-hexadecimal digit inputs.
-
- for i in Character'Pos('0') .. Character'Pos('9') loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 1");
- end if;
- end loop;
-
- for i in Character'Pos('A') .. Character'Pos('F') loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_F) loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 3");
- end if;
- end loop;
-
-
- if ACH.Is_Hexadecimal_Digit (AC.Latin_1.Minus_Sign) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Hyphen) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_G) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_Z) or
- ACH.Is_Hexadecimal_Digit ('G') or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Cent_Sign) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Pound_Sign)
- then
- Report.Failed ("Incorrect Is_HexaDecimal_Digit result - 4");
- end if;
-
-
- -- Evaluate functions Is_Alphanumeric and Is_Special with
- -- letters, digits, and non-alphanumeric inputs.
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.US) loop
- if ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 1");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 1");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.Reserved_128) ..
- Character'Pos(AC.Latin_1.APC) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 2");
- TC_Boolean := False;
- end if;
- if ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.Space) ..
- Character'Pos(AC.Latin_1.Solidus) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 3");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 3");
- end if;
- end loop;
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 4");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 4");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos('0') .. Character'Pos('9') loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 5");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 5");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 6");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 6");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.No_Break_Space) ..
- Character'Pos(AC.Latin_1.Inverted_Question) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 7");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 7");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 8");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 8");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 9");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 9");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 10");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 10");
- TC_Boolean := False;
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised during processing");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a
deleted file mode 100644
index 12d98fd..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a
+++ /dev/null
@@ -1,318 +0,0 @@
--- CXA3002.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 conversion functions for Characters and Strings
--- defined in package Ada.Characters.Handling provide correct results
--- when given character/string input parameters.
---
--- TEST DESCRIPTION:
--- This test checks the output of the To_Lower, To_Upper, and
--- To_Basic functions for both Characters and Strings. Each function
--- is called with input parameters that are within the appropriate
--- range of values, and also with values outside the specified
--- range (i.e., lower case 'a' to To_Lower). The functions are also
--- used in combination with one another, with the result of one function
--- providing the actual input parameter value to another.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Corrected evaluations of Functions In Combination.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3002 is
-
- package AC renames Ada.Characters;
- package ACH renames Ada.Characters.Handling;
-
-begin
-
- Report.Test ("CXA3002", "Check that the conversion functions for " &
- "Characters and Strings defined in package " &
- "Ada.Characters.Handling provide correct " &
- "results when given character/string input " &
- "parameters");
-
-
- Character_Block:
- declare
- Offset : constant Integer := Character'Pos('a') - Character'Pos('A');
- begin
-
- -- Function To_Lower for Characters
-
- if ACH.To_Lower('A') /= 'a' or ACH.To_Lower('Z') /= 'z' then
- Report.Failed ("Incorrect operation of function To_Lower - 1");
- end if;
-
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if ACH.To_Lower(Character'Val(i)) /= Character'Val(i + Offset) then
- Report.Failed ("Incorrect operation of function To_Lower - 2");
- end if;
- end loop;
-
-
- if (ACH.To_Lower(AC.Latin_1.UC_A_Grave) /=
- AC.Latin_1.LC_A_Grave) or
- (ACH.To_Lower(AC.Latin_1.UC_Icelandic_Thorn) /=
- AC.Latin_1.LC_Icelandic_Thorn)
- then
- Report.Failed ("Incorrect operation of function To_Lower - 3");
- end if;
-
-
- if ACH.To_Lower('c') /= 'c' or
- ACH.To_Lower('w') /= 'w' or
- ACH.To_Lower(AC.Latin_1.CR) /= AC.Latin_1.CR or
- ACH.To_Lower(AC.Latin_1.LF) /= AC.Latin_1.LF or
- ACH.To_Lower(AC.Latin_1.Comma) /= AC.Latin_1.Comma or
- ACH.To_Lower(AC.Latin_1.Question) /= AC.Latin_1.Question or
- ACH.To_Lower('0') /= '0' or
- ACH.To_Lower('9') /= '9'
- then
- Report.Failed ("Incorrect operation of function To_Lower - 4");
- end if;
-
-
- --- Function To_Upper for Characters
-
-
- if not (ACH.To_Upper('b') = 'B') and (ACH.To_Upper('y') = 'Y') then
- Report.Failed ("Incorrect operation of function To_Upper - 1");
- end if;
-
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if ACH.To_Upper(Character'Val(i)) /= Character'Val(i - Offset) then
- Report.Failed ("Incorrect operation of function To_Upper - 2");
- end if;
- end loop;
-
-
- if (ACH.To_Upper(AC.Latin_1.LC_U_Diaeresis) /=
- AC.Latin_1.UC_U_Diaeresis) or
- (ACH.To_Upper(AC.Latin_1.LC_A_Ring) /=
- AC.Latin_1.UC_A_Ring)
- then
- Report.Failed ("Incorrect operation of function To_Upper - 3");
- end if;
-
-
- if not (ACH.To_Upper('F') = 'F' and
- ACH.To_Upper('U') = 'U' and
- ACH.To_Upper(AC.Latin_1.LC_German_Sharp_S) =
- AC.Latin_1.LC_German_Sharp_S and
- ACH.To_Upper(AC.Latin_1.LC_Y_Diaeresis) =
- AC.Latin_1.LC_Y_Diaeresis)
- then
- Report.Failed ("Incorrect operation of function To_Upper - 4");
- end if;
-
-
- --- Function To_Basic for Characters
-
-
- if ACH.To_Basic(AC.Latin_1.LC_A_Circumflex) /=
- ACH.To_Basic(AC.Latin_1.LC_A_Tilde) or
- ACH.To_Basic(AC.Latin_1.LC_E_Grave) /=
- ACH.To_Basic(AC.Latin_1.LC_E_Acute) or
- ACH.To_Basic(AC.Latin_1.LC_I_Circumflex) /=
- ACH.To_Basic(AC.Latin_1.LC_I_Diaeresis) or
- ACH.To_Basic(AC.Latin_1.UC_O_Tilde) /=
- ACH.To_Basic(AC.Latin_1.UC_O_Acute) or
- ACH.To_Basic(AC.Latin_1.UC_U_Grave) /=
- ACH.To_Basic(AC.Latin_1.UC_U_Acute) or
- ACH.To_Basic(AC.Latin_1.LC_Y_Acute) /=
- ACH.To_Basic(AC.Latin_1.LC_Y_Diaeresis)
- then
- Report.Failed ("Incorrect operation of function To_Basic - 1");
- end if;
-
-
- if ACH.To_Basic('Y') /= 'Y' or
- ACH.To_Basic(AC.Latin_1.LC_E_Acute) /= 'e' or
- ACH.To_Basic('6') /= '6' or
- ACH.To_Basic(AC.Latin_1.LC_R) /= 'r'
- then
- Report.Failed ("Incorrect operation of function To_Basic - 2");
- end if;
-
-
- -- Using Functions (for Characters) in Combination
-
-
- if (ACH.To_Upper(ACH.To_Lower('A')) /= 'A' ) or
- (ACH.To_Upper(ACH.To_Lower(AC.Latin_1.UC_A_Acute)) /=
- AC.Latin_1.UC_A_Acute )
- then
- Report.Failed("Incorrect operation of functions in combination - 1");
- end if;
-
-
- if ACH.To_Basic(ACH.To_Lower(ACH.To_Upper(AC.Latin_1.LC_U_Grave))) /=
- 'u'
- then
- Report.Failed("Incorrect operation of functions in combination - 2");
- end if;
-
-
- if ACH.To_Lower (ACH.To_Basic
- (ACH.To_Upper(AC.Latin_1.LC_O_Diaeresis))) /= 'o'
- then
- Report.Failed("Incorrect operation of functions in combination - 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Character_Block");
- end Character_Block;
-
-
- String_Block:
- declare
-
- LC_String : constant String := "az" &
- AC.Latin_1.LC_A_Grave &
- AC.Latin_1.LC_C_Cedilla;
-
- UC_String : constant String := "AZ" &
- AC.Latin_1.UC_A_Grave &
- AC.Latin_1.UC_C_Cedilla;
-
- LC_Basic_String : constant String := "aei" & 'o' & 'u';
-
- LC_NonBasic_String : constant String := AC.Latin_1.LC_A_Diaeresis &
- AC.Latin_1.LC_E_Circumflex &
- AC.Latin_1.LC_I_Acute &
- AC.Latin_1.LC_O_Tilde &
- AC.Latin_1.LC_U_Grave;
-
- UC_Basic_String : constant String := "AEIOU";
-
- UC_NonBasic_String : constant String := AC.Latin_1.UC_A_Tilde &
- AC.Latin_1.UC_E_Acute &
- AC.Latin_1.UC_I_Grave &
- AC.Latin_1.UC_O_Diaeresis &
- AC.Latin_1.UC_U_Circumflex;
-
- LC_Special_String : constant String := "ab" &
- AC.Latin_1.LC_German_Sharp_S &
- AC.Latin_1.LC_Y_Diaeresis;
-
- UC_Special_String : constant String := "AB" &
- AC.Latin_1.LC_German_Sharp_S &
- AC.Latin_1.LC_Y_Diaeresis;
-
- begin
-
- -- Function To_Lower for Strings
-
-
- if ACH.To_Lower (UC_String) /= LC_String or
- ACH.To_Lower (LC_String) /= LC_String
- then
- Report.Failed ("Incorrect result from To_Lower for strings - 1");
- end if;
-
-
- if ACH.To_Lower (UC_Basic_String) /= LC_Basic_String then
- Report.Failed ("Incorrect result from To_Lower for strings - 2");
- end if;
-
-
- -- Function To_Upper for Strings
-
-
- if not (ACH.To_Upper (LC_String) = UC_String) then
- Report.Failed ("Incorrect result from To_Upper for strings - 1");
- end if;
-
-
- if ACH.To_Upper (LC_Basic_String) /= UC_Basic_String or
- ACH.To_Upper (UC_String) /= UC_String
- then
- Report.Failed ("Incorrect result from To_Upper for strings - 2");
- end if;
-
-
- if ACH.To_Upper (LC_Special_String) /= UC_Special_String then
- Report.Failed ("Incorrect result from To_Upper for strings - 3");
- end if;
-
-
-
- -- Function To_Basic for Strings
-
-
- if (ACH.To_Basic (LC_String) /= "azac") or
- (ACH.To_Basic (UC_String) /= "AZAC")
- then
- Report.Failed ("Incorrect result from To_Basic for Strings - 1");
- end if;
-
-
- if ACH.To_Basic (LC_NonBasic_String) /= LC_Basic_String then
- Report.Failed ("Incorrect result from To_Basic for Strings - 2");
- end if;
-
-
- if ACH.To_Basic (UC_NonBasic_String) /= UC_Basic_String then
- Report.Failed ("Incorrect result from To_Basic for Strings - 3");
- end if;
-
-
- -- Using Functions (for Strings) in Combination
-
-
- if ACH.To_Upper(ACH.To_Lower(UC_Basic_String)) /= UC_Basic_String or
- ACH.To_Lower(ACH.To_Upper(LC_Basic_String)) /= LC_Basic_String
- then
- Report.Failed ("Incorrect operation of functions in combination - 4");
- end if;
-
-
- if (ACH.To_Basic(ACH.To_Lower(UC_NonBasic_String)) /= LC_Basic_String) or
- (ACH.To_Basic(ACH.To_Upper(LC_NonBasic_String)) /= UC_Basic_String)
- then
- Report.Failed ("Incorrect operation of functions in combination - 5");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in String_Block");
- end String_Block;
-
-
- Report.Result;
-
-end CXA3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a
deleted file mode 100644
index f469ef8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXA3003.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 functions defined in package Ada.Characters.Handling
--- for use in classifying and converting characters between the ISO 646
--- and type Character sets produce the correct results with both
--- Character and String input values.
---
--- TEST DESCRIPTION:
--- This test is designed to exercise the classification and conversion
--- functions (between Character and ISO_646 types) found in package
--- Ada.Characters.Handling. Two subprograms are defined, a procedure for
--- characters, a function for strings, that will utilize these functions
--- to validate and change characters in variables. In the procedure, if
--- a character argument is found to be outside the subtype ISO_646, this
--- character is evaluated to determine whether it is also a letter.
--- If it is a letter, the character is converted to a basic character and
--- returned. If it is not a letter, the character is exchanged with an
--- asterisk. In the case of the function subprogram designed for strings,
--- if a character component of a string argument is outside the subtype
--- ISO_646, that character is substituted with an asterisk.
---
--- Arguments for the defined subprograms consist of ISO_646 characters,
--- non-ISO_646 characters, strings with only ISO_646 characters, and
--- strings with non-ISO_646 characters. The character and string values
--- are then validated to determine that the expected results were
--- obtained.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Apr 95 SAIC Modified identifier string lengths.
--- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3003 is
-
-begin
-
- Report.Test ("CXA3003", "Check that the functions defined in package " &
- "Ada.Characters.Handling for use in " &
- "classifying and converting characters " &
- "between the ISO 646 and type Character sets " &
- "produce the correct results with both " &
- "Character and String input values" );
-
- Test_Block:
- declare
-
- -- ISO_646 Characters
-
- Char_1,
- TC_Char_1 : Character := Ada.Characters.Latin_1.NUL; -- Control Char
- Char_2,
- TC_Char_2 : Character := Ada.Characters.Latin_1.Colon; -- Graphic Char
- Char_3,
- TC_Char_3 : Character := '4';
- Char_4,
- TC_Char_4 : Character := 'Z';
- Char_5,
- TC_Char_5 : Character := Ada.Characters.Latin_1.LC_W; -- w
-
- New_ISO_646_Char : Character := '*';
-
-
- -- Non-ISO_646 Characters
-
- Char_Array : array (6..10) of Character :=
- (Ada.Characters.Latin_1.SSA,
- Ada.Characters.Latin_1.Cent_Sign,
- Ada.Characters.Latin_1.Cedilla,
- Ada.Characters.Latin_1.UC_A_Ring,
- Ada.Characters.Latin_1.LC_A_Ring);
-
- TC_Char : constant Character := '*';
-
- -- ISO_646 Strings
-
- Str_1,
- TC_Str_1 : String (1..5) := "ABCDE";
-
- Str_2,
- TC_Str_2 : String (1..5) := "#$%^&";
-
-
- -- Non-ISO_646 Strings
-
- Str_3 : String (1..8) := "$123.45" &
- Ada.Characters.Latin_1.Cent_Sign;
- TC_Str_3 : String (1..8) := "$123.45*";
-
- Str_4 : String (1..7) := "abc" &
- Ada.Characters.Latin_1.Cedilla &
- "efg";
- TC_Str_4 : String (1..7) := "abc*efg";
-
- Str_5 : String (1..3) := Ada.Characters.Latin_1.LC_E_Grave &
- Ada.Characters.Latin_1.LC_T &
- Ada.Characters.Latin_1.LC_E_Acute;
- TC_Str_5 : String (1..3) := "*t*";
-
- ---
-
- procedure Validate_Character (Char : in out Character) is
- -- If parameter Char is an ISO_646 character, Char will be returned,
- -- otherwise the following constant will be returned.
- Star : constant Ada.Characters.Handling.ISO_646 :=
- Ada.Characters.Latin_1.Asterisk;
- begin
- if Ada.Characters.Handling.Is_ISO_646(Char) then
- -- Check that the Is_ISO_646 function provide a correct result.
- if Character'Pos(Char) > 127 then
- Report.Failed("Is_ISO_646 returns a false positive result");
- end if;
- else
- if Character'Pos(Char) < 128 then
- Report.Failed("Is_ISO_646 returns a false negative result");
- end if;
- end if;
- -- Cross-check Is_ISO_646 with To_ISO_646. '*' will be returned
- -- if Char is not in the ISO_646 set.
- Char := Ada.Characters.Handling.To_ISO_646(Char, Star);
- exception
- when others => Report.Failed ("Exception in Validate_Character");
- end Validate_Character;
-
- ---
-
- function Validate_String (Str : String) return String is
- New_ISO_646_Char : constant Ada.Characters.Handling.ISO_646 :=
- Ada.Characters.Latin_1.Asterisk;
- begin
- -- Checking that the string contains non-ISO_646 characters at this
- -- point is not strictly necessary, since the function To_ISO_646
- -- will perform that check as part of its processing, and would
- -- return the original string if no modification were necessary.
- -- However, this format allows for the testing of both functions.
-
- if not Ada.Characters.Handling.Is_ISO_646(Str) then
- return Ada.Characters.Handling.To_ISO_646
- (Item => Str, Substitute => New_ISO_646_Char);
- else
- return Str;
- end if;
- exception
- when others => Report.Failed ("Exception in Validate_String");
- return Str;
- end Validate_String;
-
-
- begin
-
- -- Check each character in turn, and if the character does not belong
- -- to the ISO_646 subset of type Character, replace it with an
- -- asterisk. If the character is a member of the subset, the character
- -- should be returned unchanged.
-
- Validate_Character (Char_1);
- Validate_Character (Char_2);
- Validate_Character (Char_3);
- Validate_Character (Char_4);
- Validate_Character (Char_5);
-
- if Char_1 /= TC_Char_1 or Char_2 /= TC_Char_2 or
- Char_3 /= TC_Char_3 or Char_4 /= TC_Char_4 or
- Char_5 /= TC_Char_5
- then
- Report.Failed ("Incorrect ISO_646 character substitution");
- end if;
-
- -- Non-ISO_646 characters
-
- for i in 6..10 loop
- Validate_Character (Char_Array(i));
- end loop;
-
- for i in 6..10 loop
- if Char_Array(i) /= TC_Char then
- Report.Failed ("Character position " & Integer'Image(i) &
- " not replaced correctly");
- end if;
- end loop;
-
-
-
- -- Check each string, and if the string contains characters that do not
- -- belong to the ISO_646 subset of type Character, replace that character
- -- in the string with an asterisk. If the string is comprised of only
- -- ISO_646 characters, the string should be returned unchanged.
-
-
- Str_1 := Validate_String (Str_1);
- Str_2 := Validate_String (Str_2);
- Str_3 := Validate_String (Str_3);
- Str_4 := Validate_String (Str_4);
- Str_5 := Validate_String (Str_5);
-
-
- if Str_1 /= TC_Str_1 or
- Str_2 /= TC_Str_2 or
- Str_3 /= TC_Str_3 or
- Str_4 /= TC_Str_4 or
- Str_5 /= TC_Str_5
- then
- Report.Failed ("Incorrect ISO_646 character substitution in string");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a
deleted file mode 100644
index ed2023e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a
+++ /dev/null
@@ -1,235 +0,0 @@
--- CXA3004.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 functions defined in package Ada.Characters.Handling
--- for classification of and conversion between Wide_Character and
--- Character values produce correct results when given the appropriate
--- Character and String inputs.
---
--- TEST DESCRIPTION:
--- This test demonstrates the functions defined in package
--- Ada.Characters.Handling which provide for the classification of and
--- conversion between Wide_Characters and Characters, in character
--- variables and strings.
--- Each of the functions is provided with input values that are of the
--- appropriate range. The results of the function processing are
--- subsequently evaluated.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations using the Latin_1 set as the
--- definition of Character.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Dec 94 SAIC Corrected variable names.
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-
-procedure CXA3004 is
-begin
-
- Report.Test ("CXA3004", "Check that the functions defined in package " &
- "Ada.Characters.Handling for classification " &
- "of and conversion between Wide_Character and " &
- "Character values produce correct results " &
- "when given the appropriate Character " &
- "and String inputs");
-
- Test_Block:
- declare
-
- package ACH renames Ada.Characters.Handling;
-
- Char_End : Integer := 255;
- WC_Start : Integer := 256;
- Sub_Char : Character := '*';
-
- Blank : Character := ' ';
- First_Char : Character := Character'First;
- Last_Char : Character := Character'Last;
- F_Char : Character := 'F';
-
-
- First_Wide_Char : Wide_Character := Wide_Character'First;
- Last_Non_Wide_Char : Wide_Character := Wide_Character'Val(Char_End);
- First_Unique_Wide_Char : Wide_Character := Wide_Character'Val(WC_Start);
- Last_Wide_Char : Wide_Character := Wide_Character'Last;
-
- A_String : String (1..3) := First_Char & 'X' & Last_Char;
- A_Wide_String : Wide_String (1..3) := First_Wide_Char &
- ACH.To_Wide_Character('X') &
- ACH.To_Wide_Character(Last_Char);
-
- Unique_Wide_String : Wide_String (1..2) := First_Unique_Wide_Char &
- Last_Wide_Char;
-
- Mixed_Wide_String : Wide_String (1..6) := ACH.To_Wide_Character('A') &
- First_Wide_Char &
- Last_Non_Wide_Char &
- First_Unique_Wide_Char &
- Last_Wide_Char &
- ACH.To_Wide_Character('Z');
-
-
- Basic_Char : Character := 'A';
- Basic_Wide_Char : Wide_Character := 'A';
- Basic_String : String (1..6) := "ABCXYZ";
- Basic_Wide_String : Wide_String (1..6) := "ABCXYZ";
-
- begin
-
-
- -- Function Is_Character
-
-
- if not ACH.Is_Character(First_Wide_Char) then
- Report.Failed ("Incorrect result from Is_Character - 1");
- end if;
-
-
- if ACH.Is_Character(First_Unique_Wide_Char) or
- ACH.Is_Character(Last_Wide_Char)
- then
- Report.Failed ("Incorrect result from Is_Character - 2");
- end if;
-
-
- -- Function Is_String
-
-
- if not ACH.Is_String(A_Wide_String) then
- Report.Failed ("Incorrect result from Is_String - 1");
- end if;
-
-
- if ACH.Is_String(Unique_Wide_String) or
- ACH.Is_String(Mixed_Wide_String)
- then
- Report.Failed ("Incorrect result from Is_String - 2");
- end if;
-
-
- -- Function To_Character
-
-
- -- Use default substitution character in call of To_Character.
-
- if ACH.To_Character(First_Wide_Char) /= First_Char or
- ACH.To_Character(Last_Non_Wide_Char) /= Last_Char
- then
- Report.Failed ("Incorrect result from To_Character - 1");
- end if;
-
-
- -- Provide a substitution character for use with To_Character.
-
- if ACH.To_Character(First_Unique_Wide_Char, Blank) /= Blank or
- ACH.To_Character(First_Unique_Wide_Char, Sub_Char) /= Sub_Char or
- ACH.To_Character(Last_Wide_Char) /= ' ' -- default
- then
- Report.Failed ("Incorrect result from To_Character - 2");
- end if;
-
-
- -- Function To_String
-
-
- if ACH.To_String(A_Wide_String) /= A_String then
- Report.Failed ("Incorrect result from To_String - 1");
- end if;
-
-
- if ACH.To_String(Unique_Wide_String, Sub_Char) /= "**" then
- Report.Failed ("Incorrect result from To_String - 2");
- end if;
-
-
-
- if ACH.To_String(Mixed_Wide_String, Sub_Char) /=
- ('A' & First_Char & Last_Char & "**" & 'Z') or
- ACH.To_String(Mixed_Wide_String, Sub_Char) /=
- (ACH.To_Character(Mixed_Wide_String(1), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(2), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(3), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(4), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(5), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(6), Sub_Char))
- then
- Report.Failed ("Incorrect result from To_String - 3");
- end if;
-
-
- -- Function To_Wide_Character
-
-
- if ACH.To_Wide_Character(Basic_Char) /= Basic_Wide_Char then
- Report.Failed ("Incorrect result from To_Wide_Character");
- end if;
-
-
- -- Function To_Wide_String
-
-
- if not (ACH.To_Wide_String(Basic_String) = Basic_Wide_String) then
- Report.Failed ("Incorrect result from To_Wide_String");
- end if;
-
-
- -- Functions Used In Combination
-
- if not ACH.Is_Character (ACH.To_Wide_Character (
- ACH.To_Character(First_Wide_Char)))
- then
- Report.Failed ("Incorrect result from functions in combination - 1");
- end if;
-
-
- if not ACH.Is_String(ACH.To_Wide_String(ACH.To_String(A_Wide_String)))
- then
- Report.Failed ("Incorrect result from functions in combination - 2");
- end if;
-
-
- if ACH.To_String(ACH.To_Wide_Character('A') &
- ACH.To_Wide_Character(F_Char) &
- ACH.To_Wide_Character('Z')) /= "AFZ"
- then
- Report.Failed ("Incorrect result from functions in combination - 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA3004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a
deleted file mode 100644
index 52fabc3..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a
+++ /dev/null
@@ -1,230 +0,0 @@
--- CXA4001.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 types, operations, and other entities defined within
--- the package Ada.Strings.Maps are available and/or produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test demonstrates the availability and function of the types and
--- operations defined in package Ada.Strings.Maps. It demonstrates the
--- use of these types and functions as they would be used in common
--- programming practice.
--- Character set creation, assignment, and comparison are evaluated
--- in this test. Each of the functions provided in package
--- Ada.Strings.Maps is utilized in creating or manipulating set objects,
--- and the function results are evaluated for correctness.
--- Character sequences are examined using the functions provided for
--- manipulating objects of this type. Likewise, character maps are
--- created, and their contents evaluated. Exception raising conditions
--- from the function To_Mapping are also created.
--- Note: Throughout this test, the set logical operators are printed in
--- capital letters to enhance their visibility.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4001 is
-
- use Ada.Strings;
- use type Maps.Character_Set;
-
-begin
-
- Report.Test ("CXA4001", "Check that the types, operations, and other " &
- "entities defined within the package " &
- "Ada.Strings.Maps are available and/or produce " &
- "correct results");
-
- Test_Block:
- declare
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Maps.Character_Sequence := "aeiou";
- Quasi_Vowel : constant Character := 'y';
-
- Alphabet : Maps.Character_Sequence (1..Last_Letter);
- Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter);
- Inverse_Alphabet : Maps.Character_Sequence (1..Last_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- Full_Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Maps.Character_Set;
-
- begin
-
- -- Load the alphabet string for use in creating sets.
-
-
- for i in 0..12 loop
- Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- for i in 0..25 loop
- Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
-
- -- Initialize a series of Character_Set objects.
-
- Alphabet_Set := Maps.To_Set(Alphabet);
- Vowel_Set := Maps.To_Set(Vowels);
- Full_Vowel_Set := Vowel_Set OR Maps.To_Set(Quasi_Vowel);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- First_Half_Set := Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
- -- Evaluation of Set objects, operators, and functions.
-
- if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then
- Report.Failed("Incorrect set combinations using OR operator");
- end if;
-
-
- for i in 1..5 loop
- if not Maps.Is_In(Vowels(i), Vowel_Set) or
- not Maps.Is_In(Vowels(i), Alphabet_Set) or
- Maps.Is_In(Vowels(i), Consonant_Set)
- then
- Report.Failed("Incorrect function Is_In use with set " &
- "combinations - " & Integer'Image(i));
- end if;
- end loop;
-
-
- if Maps.Is_Subset(Vowel_Set, First_Half_Set) or
- Maps."<="(Vowel_Set, Second_Half_Set) or
- not Maps.Is_Subset(Vowel_Set, Alphabet_Set)
- then
- Report.Failed("Incorrect set evaluation using Is_Subset function");
- end if;
-
-
- if not (Full_Vowel_Set = Maps.To_Set("aeiouy")) then
- Report.Failed("Incorrect result for ""="" set operator");
- end if;
-
-
- if not ((Vowel_Set AND First_Half_Set) OR
- (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then
- Report.Failed
- ("Incorrect result for AND, OR, or ""="" set operators");
- end if;
-
-
- if (Alphabet_Set AND Maps.Null_Set) /= Maps.Null_Set or
- (Alphabet_Set OR Maps.Null_Set) /= Alphabet_Set
- then
- Report.Failed("Incorrect result for AND or OR set operators");
- end if;
-
-
- Vowel_Set := Full_Vowel_Set;
- Vowel_Set := Vowel_Set AND (NOT Maps.To_Set(Quasi_Vowel));
-
- if not (Vowels = Maps.To_Sequence(Vowel_Set)) then
- Report.Failed("Incorrect Set to Sequence translation");
- end if;
-
-
- for i in 1..26 loop
- Inverse_Alphabet(i) := Alphabet(27-i);
- end loop;
-
- declare
- Inverse_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(Alphabet, Inverse_Alphabet);
- begin
- if Maps.Value(Maps.Identity, 'b') /= Maps.Value(Inverse_Map,'y')
- then
- Report.Failed("Incorrect Inverse mapping");
- end if;
- end;
-
-
- -- Check that Translation_Error is raised when a character is
- -- repeated in the parameter "From" string.
- declare
- Bad_Map : Maps.Character_Mapping;
- begin
- Bad_Map := Maps.To_Mapping(From => "aa", To => "yz");
- Report.Failed("Exception not raised with repeated character");
-
- if Report.Equal (Character'Pos('y'),
- Character'Pos(Maps.Value(Bad_Map, 'a'))) then
- -- Use the map to avoid optimization.
- Report.Comment ("Shouldn't get here.");
- end if;
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "a repeated character");
- end;
-
-
- -- Check that Translation_Error is raised when the parameters of the
- -- function To_Mapping are of unequal lengths.
- declare
- Bad_Map : Maps.Character_Mapping;
- begin
- Bad_Map := Maps.To_Mapping("abc", "yz");
- Report.Failed("Exception not raised with unequal parameter lengths");
-
- if Report.Equal (Character'Pos('y'),
- Character'Pos(Maps.Value(Bad_Map, 'a'))) then
- -- Use the map to avoid optimization.
- Report.Comment ("Shouldn't get here.");
- end if;
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "unequal parameter lengths");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a
deleted file mode 100644
index 583621a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a
+++ /dev/null
@@ -1,182 +0,0 @@
--- CXA4002.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 subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Index, "*" (string constructor function),
--- Count, Trim, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain Fixed string functions are used
--- to eliminate specific substrings from portions of text. A procedure
--- is defined that will take as parameters a source string along with
--- a substring that is to be completely removed from the source string.
--- The source string is parsed using the Index function, and any substring
--- slices are replaced in the source string by a series of X's (based on
--- the length of the substring.)
--- Three lines of text are provided to this procedure, and the resulting
--- substitutions are compared with expected results to validate the
--- string processing.
--- A global accumulator is updated with the number of occurrences of the
--- substring in the source string.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4002 is
-
-begin
-
- Report.Test ("CXA4002", "Check that the subprograms defined in package " &
- "Ada.Strings.Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- TC_Total : Natural := 0;
- Number_Of_Lines : constant := 3;
-
- type Restricted_Words_Array_Type is array (1..10) of String (1..10);
-
- Restricted_Words : Restricted_Words_Array_Type :=
- (" platoon", " marines ", " Marines ",
- "north ", "south ", " east",
- " beach ", " airport", "airfield ",
- " road ");
-
- subtype Line_Of_Text_Type is String(1..25);
- type Page_Of_Text_Type is array (1..Number_Of_Lines)
- of Line_Of_Text_Type;
-
- Text_Page : Page_Of_Text_Type := ("The platoon of Marines ",
- "moved south on the south ",
- "road to the airfield. ");
-
- TC_Revised_Line_1 : constant String := "The XXXXXXX of XXXXXXX ";
- TC_Revised_Line_2 : constant String := "moved XXXXX on the XXXXX ";
- TC_Revised_Line_3 : constant String := "XXXX to the XXXXXXXX. ";
-
- ---
-
- procedure Censor (Source_String : in out String;
- Pattern_String : in String) is
-
- -- Create a replacement string that is the same length as the
- -- pattern string being removed.
- Replacement : constant String := -- "*"
- Ada.Strings.Fixed."*"(Pattern_String'Length, 'X');
-
- Going : Ada.Strings.Direction := Ada.Strings.Forward;
- Map : constant Ada.Strings.Maps.Character_Mapping :=
- Ada.Strings.Maps.Identity;
- Start_Pos,
- Index : Natural := Source_String'First;
-
-
- begin -- Censor
-
- -- Accumulate count of total replacement operations.
-
- TC_Total := TC_Total + -- Count
- Ada.Strings.Fixed.Count (Source => Source_String,
- Pattern => Pattern_String,
- Mapping => Map);
- loop
-
- Index := Ada.Strings.Fixed.Index -- Index
- (Source_String(Start_Pos..Source_String'Last),
- Pattern_String,
- Going,
- Map);
-
- exit when Index = 0; -- No matches, exit loop.
-
- -- if a match was found, modify the substring.
- Ada.Strings.Fixed.Replace_Slice -- Replace_Slice
- (Source_String,
- Index,
- Index + Pattern_String'Length - 1,
- Replacement);
- Start_Pos := Index + Pattern_String'Length;
-
- end loop;
-
- end Censor;
-
-
- begin
-
- -- Invoke Censor subprogram to cleanse text.
- -- Loop through each line of text, and check for the presence of each
- -- restricted word.
- -- Use the Trim function to eliminate leading or trailing blanks from
- -- the restricted word parameters.
-
- for Line in 1..Number_Of_Lines loop
- for Word in Restricted_Words'Range loop
- Censor (Text_Page(Line),
- Ada.Strings.Fixed.Trim(Restricted_Words(Word), -- Trim
- Ada.Strings.Both));
- end loop;
- end loop;
-
-
- -- Validate results.
-
- if TC_Total /= 6 then
- Report.Failed ("Incorrect number of substitutions performed");
- end if;
-
- if Text_Page(1) /= TC_Revised_Line_1 then
- Report.Failed ("Incorrect substitutions on Line 1");
- end if;
-
- if Text_Page(2) /= TC_Revised_Line_2 then
- Report.Failed ("Incorrect substitutions on Line 2");
- end if;
-
- if Text_Page(3) /= TC_Revised_Line_3 then
- Report.Failed ("Incorrect substitutions on Line 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a
deleted file mode 100644
index cd57a92..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a
+++ /dev/null
@@ -1,326 +0,0 @@
--- CXA4003.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 subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Index, Index_Non_Blank, Head, Tail, Translate,
--- Find_Token, Move, Overwrite, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain fixed string operations could be
--- used in string information processing. A procedure is defined that
--- will extract portions of a 50 character string that correspond to
--- certain data items (i.e., name, address, state, zip code). These
--- parsed items will then be added to the appropriate fields of data
--- base elements. These data base elements are then compared for
--- accuracy against a similar set of predefined data base elements.
---
--- A variety of fixed string processing subprograms are used in this
--- test. Each parsing operation uses a different combination
--- of the available subprograms to accomplish the same goal, therefore
--- continuity of approach to string parsing is not seen in this test.
--- However, a wide variety of possible approaches are demonstrated, while
--- exercising a large number of the total predefined subprograms of
--- package Ada.Strings.Fixed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4003 is
-
-begin
-
- Report.Test ("CXA4003", "Check that the subprograms defined in package " &
- "Ada.Strings.Fixed are available, and that they " &
- "produce correct results");
-
- Test_Block:
- declare
-
- Number_Of_Info_Strings : constant Natural := 3;
- DB_Size : constant Natural := Number_Of_Info_Strings;
- Count : Natural := 0;
- Finished_Processing : Boolean := False;
- Blank_String : constant String := " ";
-
- subtype Info_String_Type is String (1..50);
- type Info_String_Storage_Type is
- array (1..Number_Of_Info_Strings) of Info_String_Type;
-
-
- subtype Name_Type is String (1..10);
- subtype Street_Number_Type is String (1..5);
- subtype Street_Name_Type is String (1..10);
- subtype City_Type is String (1..10);
- subtype State_Type is String (1..2);
- subtype Zip_Code_Type is String (1..5);
-
- type Data_Base_Element_Type is
- record
- Name : Name_Type := (others => ' ');
- Street_Number : Street_Number_Type := (others => ' ');
- Street_Name : Street_Name_Type := (others => ' ');
- City : City_Type := (others => ' ');
- State : State_Type := (others => ' ');
- Zip_Code : Zip_Code_Type := (others => ' ');
- end record;
-
- type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type;
-
- Data_Base : Data_Base_Type;
-
- ---
-
- Info_String_1 : Info_String_Type :=
- "Joe_Jones 123 Sixth_St San_Diego CA 98765";
-
- Info_String_2 : Info_String_Type :=
- "Sam_Smith 56789 S._Seventh Carlsbad CA 92177";
-
- Info_String_3 : Info_String_Type :=
- "Jane_Brown 1219 Info_Lane Tuscon AZ 85643";
-
-
- Info_Strings : Info_String_Storage_Type := (1 => Info_String_1,
- 2 => Info_String_2,
- 3 => Info_String_3);
-
-
-
- TC_DB_Element_1 : Data_Base_Element_Type :=
- ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765");
-
- TC_DB_Element_2 : Data_Base_Element_Type :=
- ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177");
-
- TC_DB_Element_3 : Data_Base_Element_Type :=
- ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643");
-
- TC_Data_Base : Data_Base_Type := (TC_DB_Element_1,
- TC_DB_Element_2,
- TC_DB_Element_3);
-
- ---
-
-
- procedure Store_Information
- (Info_String : in Info_String_Type;
- DB_Record : in out Data_Base_Element_Type) is
-
- package AS renames Ada.Strings;
- use type AS.Maps.Character_Set;
-
- UnderScore : AS.Maps.Character_Sequence := "_";
- Blank : AS.Maps.Character_Sequence := " ";
-
- Start,
- Stop : Natural := 0;
-
- Underscore_to_Blank_Map : constant AS.Maps.Character_Mapping :=
- AS.Maps.To_Mapping(From => UnderScore,
- To => Blank);
-
- Numeric_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("0123456789");
-
- Cal : constant AS.Maps.Character_Sequence := "CA";
- California_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set(Cal);
- Arizona_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("AZ");
- Nevada_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("NV");
-
- begin
-
- -- Find the starting position of the name field (first non-blank),
- -- then, from that position, find the end of the name field (first
- -- blank).
-
- Start := AS.Fixed.Index_Non_Blank(Info_String);
- Stop := AS.Fixed.Index (Info_String(Start..Info_String'Length),
- AS.Maps.To_Set(' '),
- AS.Inside,
- AS.Forward) - 1 ;
-
- -- Store the name field in the data base element field for "Name".
-
- DB_Record.Name := AS.Fixed.Head(Info_String(1..Stop),
- DB_Record.Name'Length);
-
- -- Replace any underscore characters in the name field
- -- that were used to separate first/middle/last names.
-
- AS.Fixed.Translate (DB_Record.Name, Underscore_to_Blank_Map);
-
-
- -- Continue the extraction process; now find the position of
- -- the street number in the string.
-
- Start := Stop + 1;
-
- AS.Fixed.Find_Token(Info_String(Start..Info_String'Length),
- Numeric_Set,
- AS.Inside,
- Start,
- Stop);
-
- -- Store the street number field in the appropriate data base
- -- element.
- -- No modification of the default parameters of procedure Move
- -- is required.
-
- AS.Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.Street_Number);
-
-
- -- Continue the extraction process; find the street name in the
- -- info string. Skip blanks to the start of the street name, then
- -- search for the index of the next blank character in the string.
-
- Start :=
- AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_String) - 1;
-
- -- Store the street name in the appropriate data base element field.
-
- AS.Fixed.Overwrite(DB_Record.Street_Name,
- 1,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the street name field
- -- that were used as word separation.
-
- DB_Record.Street_Name := AS.Fixed.Translate(DB_Record.Street_Name,
- Underscore_to_Blank_Map);
-
-
- -- Continue the extraction; remove the city name from the string.
-
- Start :=
- AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_String) - 1;
-
- -- Store the city name field in the appropriate data base element.
-
- AS.Fixed.Replace_Slice(DB_Record.City,
- 1,
- DB_Record.City'Length,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the city name field
- -- that were used as word separation.
-
- AS.Fixed.Translate (DB_Record.City, Underscore_to_Blank_Map);
-
-
- -- Continue the extraction; remove the state identifier from the
- -- info string.
-
- Start := Stop + 1;
-
- AS.Fixed.Find_Token(Info_String(Start..Info_String'Length),
- AS.Maps."OR"(California_Set,
- AS.Maps."OR"(Nevada_Set, Arizona_Set)),
- AS.Inside,
- Start,
- Stop);
-
- -- Store the state indicator into the data base element.
-
- AS.Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.State,
- Drop => Ada.Strings.Right,
- Justify => Ada.Strings.Left,
- Pad => AS.Space);
-
-
- -- Continue the extraction process; remove the final data item in
- -- the info string, the zip code, and place it into the
- -- corresponding data base element.
-
- DB_Record.Zip_Code := AS.Fixed.Tail(Info_String,
- DB_Record.Zip_Code'Length);
-
- exception
- when AS.Length_Error =>
- Report.Failed ("Length_Error raised in procedure");
- when AS.Pattern_Error =>
- Report.Failed ("Pattern_Error raised in procedure");
- when AS.Translation_Error =>
- Report.Failed ("Translation_Error raised in procedure");
- when others =>
- Report.Failed ("Exception raised in procedure");
- end Store_Information;
-
-
- begin
-
- -- Loop thru the information strings, extract the name and address
- -- information, place this info into elements of the data base.
-
- while not Finished_Processing loop
-
- Count := Count + 1;
-
- Store_Information (Info_Strings(Count), Data_Base(Count));
-
- Finished_Processing := (Count = Number_Of_Info_Strings);
-
- end loop;
-
-
- -- Verify that the string processing was successful.
-
- for i in 1..DB_Size loop
- if Data_Base(i) /= TC_Data_Base(i) then
- Report.Failed
- ("Data processing error on record " & Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a
deleted file mode 100644
index ec11f7d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a
+++ /dev/null
@@ -1,431 +0,0 @@
--- CXA4004.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 subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Count, Find_Token, Index, Index_Non_Blank, and Move.
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4002,3, and 5 will provide
--- thorough coverage of the functionality found in Ada.Strings.Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected subtest for Move, Drop=Right.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-
-procedure CXA4004 is
-begin
-
- Report.Test("CXA4004", "Check that the subprograms defined in " &
- "package Ada.Strings.Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASF renames Ada.Strings.Fixed;
- package Maps renames Ada.Strings.Maps;
-
- Result_String : String(1..10) := (others => Ada.Strings.Space);
-
- Source_String1 : String(1..5) := "abcde"; -- odd length string
- Source_String2 : String(1..6) := "abcdef"; -- even length string
- Source_String3 : String(1..12) := "abcdefghijkl";
- Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Move
-
- -- Evaluate the Procedure Move with various combinations of
- -- parameters.
-
- -- Justify = Left (default case)
-
- ASF.Move(Source => Source_String1, -- "abcde"
- Target => Result_String);
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Move with Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Move(Source => Source_String2, -- "abcdef"
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Move with Justify = Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Move(Source_String1, -- "abcde"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result from Move with Justify = Center-1");
- end if;
-
- ASF.Move(Source_String2, -- "abcdef"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Move with Justify = Center-2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASF.Move(Source => Source_String3, -- "abcdefghijkl"
- Target => Result_String,
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Move with Drop = Left");
- end if;
-
- -- Drop = Right
-
- ASF.Move(Source_String3, Result_String, Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Move with Drop = Right");
- end if;
-
- -- Drop = Error
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Move(Source => Source_String4, -- "abcdefghij "
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Move(Source_String5, -- " cdefghijkl"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Move(Source_String3, -- 12 characters, no Pad.
- Result_String, -- 10 characters
- Ada.Strings.Error,
- Ada.Strings.Left);
-
- Report.Failed("Length_Error not raised by Move - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised by Move - 1");
- end;
-
-
-
- -- Function Index
- -- (Other usage examples of this function found in CXA4002-3.)
- -- Check when the pattern is not found in the source.
-
- if ASF.Index("abcdef", "gh") /= 0 or
- ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source
- ASF.Index("xyz",
- "abcde",
- Ada.Strings.Backward) /= 0 or
- ASF.Index("", "ab") /= 0 or -- null source string.
- ASF.Index("abcde", " ") /= 0 -- blank pattern.
- then
- Report.Failed("Incorrect result from Index, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is the
- -- null string.
- begin
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "", -- null pattern string.
- Ada.Strings.Forward);
- Report.Failed("Pattern_Error not raised by Index");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Index, null pattern");
- end;
-
- -- Use the search direction "backward" to locate the particular
- -- pattern within the source string.
-
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "de", -- slice 4..5, 10..11
- Ada.Strings.Backward); -- search from right end.
-
- if Location /= 10 then
- Report.Failed("Incorrect result from Index going Backward");
- end if;
-
- -- Using the version of Index testing character set membership,
- -- check combinations of forward/backward, inside/outside parameter
- -- configurations.
-
- if ASF.Index(Source => Source_String1, -- "abcde"
- Set => CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3.
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 12 or -- 'f' at position 12
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 10 or -- 'd' at position 10
- ASF.Index("cdcdcdcdacdcdcdcd",
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 9 -- 'a' at position 9
- then
- Report.Failed("Incorrect result from function Index for sets - 1");
- end if;
-
- -- Additional interesting uses/combinations using Index for sets.
-
- if ASF.Index("cd", -- same size, str-set
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Forward) /= 1 or -- 'c' at position 1
- ASF.Index("abcd", -- same size, str-set,
- Maps.To_Set("efgh"), -- different contents.
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 1 or
- ASF.Index("abccd", -- set > string
- Maps.To_Set("acegik"),
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 or -- 'c' at position 4
- ASF.Index("abcde",
- Maps.Null_Set) /= 0 or
- ASF.Index("", -- Null string.
- CD_Set) /= 0 or
- ASF.Index("abc ab", -- blank included
- Maps.To_Set("e "), -- in string and set.
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 -- blank in string.
- then
- Report.Failed("Incorrect result from function Index for sets - 2");
- end if;
-
-
-
- -- Function Index_Non_Blank.
- -- (Other usage examples of this function found in CXA4002-3.)
-
-
- if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij "
- Going => Ada.Strings.Backward) /= 10 or
- ASF.Index_Non_Blank("abc def ghi jkl ",
- Ada.Strings.Backward) /= 15 or
- ASF.Index_Non_Blank(" abcdef") /= 3 or
- ASF.Index_Non_Blank(" ") /= 0
- then
- Report.Failed("Incorrect result from Index_Non_Blank");
- end if;
-
-
-
- -- Function Count
- -- (Other usage examples of this function found in CXA4002-3.)
-
- if ASF.Count("abababa", "aba") /= 2 or
- ASF.Count("abababa", "ab" ) /= 3 or
- ASF.Count("babababa", "ab") /= 3 or
- ASF.Count("abaabaaba", "aba") /= 3 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20
- then
- Report.Failed("Incorrect result from Function Count");
- end if;
-
- -- Determine the number of slices of Source that when mapped to a
- -- non-identity map, match the pattern string.
-
- Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef"
- "xy",
- CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y'
-
- if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6
- Report.Failed("Incorrect result from Count with non-identity map");
- end if;
-
- -- If the pattern supplied to Function Count is the null string, then
- -- Pattern_Error is propagated.
-
- declare
- The_Null_String : constant String := "";
- begin
- Slice_Count := ASF.Count(Source_String6, The_Null_String);
- Report.Failed("Pattern_Error not raised by Function Count");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Count with null pattern");
- end;
-
-
- -- Function Count returning the number of characters in a particular
- -- set that are found in source string.
-
- if ASF.Count(Source_String6, CD_Set) /= 4 then -- 2 'c' and 'd' chars.
- Report.Failed("Incorrect result from Count with set");
- end if;
-
-
-
- -- Function Find_Token.
- -- (Other usage examples of this function found in CXA4002-3.)
-
- ASF.Find_Token(Source => Source_String6, -- First slice with no
- Set => ABCD_Set, -- 'a', 'b', 'c', or 'd'
- Test => Ada.Strings.Outside, -- is "ef" at 5..6.
- First => Slice_Start,
- Last => Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 6 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
- -- If no appropriate slice is contained by the source string, then the
- -- value returned in Last is zero, and the value in First is
- -- Source'First.
-
- ASF.Find_Token(Source_String6, -- "abcdefabcdef"
- A_to_F_Set, -- Set of characters 'a' thru 'f'.
- Ada.Strings.Outside, -- No characters outside this set.
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= Source_String6'First or Slice_End /= 0 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
- -- Additional testing of Find_Token.
-
- ASF.Find_Token("eabcdabcddcab",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 2 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
- ASF.Find_Token("efghijklabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 8 then
- Report.Failed("Incorrect result from Find_Token - 4");
- end if;
-
- ASF.Find_Token("abcdefgabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 7 then
- Report.Failed("Incorrect result from Find_Token - 5");
- end if;
-
- ASF.Find_Token("abcdcbabcdcba",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 6");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a
deleted file mode 100644
index d61f853..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a
+++ /dev/null
@@ -1,683 +0,0 @@
--- CXA4005.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 subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice,
--- Tail, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4002-4 will provide coverage
--- of the functionality found in Ada.Strings.Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test. They represent
--- individual usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Apr 95 SAIC Corrected acceptance conditions of certain
--- subtests.
--- 06 Nov 95 SAIC Fixed bugs for ACVC 2.0.1.
--- 22 Feb 01 PHL Check that the lower bound of the result is 1.
--- 13 Mar 01 RLB Fixed a couple of ACATS style violations;
--- removed pointless checks of procedures.
--- Added checks of other functions. These changes
--- were made to test Defect Report 8652/0049, as
--- reflected in Technical Corrigendum 1.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-
-procedure CXA4005 is
-
- type TC_Name_Holder is access String;
- Name : TC_Name_Holder;
-
- function TC_Check (S : String) return String is
- begin
- if S'First /= 1 then
- Report.Failed ("Lower bound of result of function " & Name.all &
- " is" & Integer'Image (S'First));
- end if;
- return S;
- end TC_Check;
-
- procedure TC_Set_Name (N : String) is
- begin
- Name := new String'(N);
- end TC_Set_Name;
-
-begin
-
- Report.Test("CXA4005", "Check that the subprograms defined in " &
- "package Ada.Strings.Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASF renames Ada.Strings.Fixed;
- package Maps renames Ada.Strings.Maps;
-
- Result_String,
- Delete_String,
- Insert_String,
- Trim_String,
- Overwrite_String : String(1..10) := (others => Ada.Strings.Space);
-
- Source_String1 : String(1..5) := "abcde"; -- odd length string
- Source_String2 : String(1..6) := "abcdef"; -- even length string
- Source_String3 : String(1..12) := "abcdefghijkl";
- Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- X_Set : Maps.Character_Set := Maps.To_Set('x');
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Replace_Slice
- -- The functionality of this procedure
- -- is similar to procedure Move, and
- -- is tested here in the same manner, evaluated
- -- with various combinations of parameters.
-
- -- Index_Error propagation when Low > Source'Last + 1
-
- begin
- ASF.Replace_Slice(Result_String,
- Result_String'Last + 2, -- should raise exception
- Result_String'Last,
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 1");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 1");
- end;
-
- -- Index_Error propagation when High < Source'First - 1
-
- begin
- ASF.Replace_Slice(Result_String(5..10),
- 5,
- 3, -- should raise exception since < 'First - 1.
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 2");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 2");
- end;
-
- -- Justify = Left (default case)
-
- Result_String := "XXXXXXXXXX";
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => 10,
- By => Source_String1); -- "abcde"
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Replace_Slice - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Replace_Slice - Justify=Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String1, -- "abcde"
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1");
- end if;
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String2, -- "abcdef"
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Replace_Slice with " &
- "Justify = Center - 2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Replace_Slice - Drop=Left");
- end if;
-
- -- Drop = Right
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result, Replace_Slice with Drop=Right");
- end if;
-
- -- Drop = Error
-
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String4, -- "abcdefghij "
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String5, -- " cdefghijkl"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Error);
-
- Report.Failed("Length_Error not raised by Replace_Slice - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 3");
- end;
-
-
- -- Function Replace_Slice
-
- TC_Set_Name ("Replace_Slice");
-
- if TC_Check (ASF.Replace_Slice("abcde", 3, 3, "x"))
- /= "abxde" or -- High = Low
- TC_Check (ASF.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or
- TC_Check (ASF.Replace_Slice("abcd", 4, 1, "xy"))
- /= "abcxyd" or -- High < Low
- TC_Check (ASF.Replace_Slice("abc", 2, 3, "x")) /= "ax" or
- TC_Check (ASF.Replace_Slice("a", 1, 1, "z")) /= "z"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 1");
- end if;
-
- if TC_Check (ASF.Replace_Slice("abcde", 5, 5, "z"))
- /= "abcdz" or -- By length 1
- TC_Check (ASF.Replace_Slice("abc", 1, 3, "xyz"))
- /= "xyz" or -- High > Low
- TC_Check (ASF.Replace_Slice("abc", 3, 2, "xy"))
- /= "abxyc" or -- insert
- TC_Check (ASF.Replace_Slice("a", 1, 1, "xyz")) /= "xyz"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 2");
- end if;
-
-
-
- -- Function Insert.
-
- TC_Set_Name ("Insert");
-
- declare
- New_String : constant String :=
- TC_Check (
- ASF.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => 3,
- New_Item => Source_String2)); -- "abcdef"
- begin
- if New_String /= "babcdefcde" then
- Report.Failed("Incorrect result from Function Insert - 1");
- end if;
- end;
-
- if TC_Check (ASF.Insert("a", 1, "z")) /= "za" or
- TC_Check (ASF.Insert("abc", 3, "")) /= "abc" or
- TC_Check (ASF.Insert("abc", 1, "z")) /= "zabc"
- then
- Report.Failed("Incorrect result from Function Insert - 2");
- end if;
-
- begin
- if TC_Check (ASF.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => Report.Ident_Int(7),
- New_Item => Source_String2)) -- "abcdef"
- /= "babcdefcde" then
- Report.Failed("Index_Error not raised by Insert - 3A");
- else
- Report.Failed("Index_Error not raised by Insert - 3B");
- end if;
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Insert - 3");
- end;
-
-
- -- Procedure Insert
-
- -- Drop = Right
-
- ASF.Insert(Source => Insert_String,
- Before => 6,
- New_Item => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Right);
-
- if Insert_String /= " abcde" then -- last char of New_Item dropped.
- Report.Failed("Incorrect result from Insert with Drop = Right");
- end if;
-
- -- Drop = Left
-
- ASF.Insert(Source => Insert_String, -- 10 char string
- Before => 2, -- 9 chars, 2..10 available
- New_Item => Source_String3, -- 12 characters long.
- Drop => Ada.Strings.Left); -- truncate from Left.
-
- if Insert_String /= "l abcde" then -- 10 chars, leading blank.
- Report.Failed("Incorrect result from Insert with Drop=Left");
- end if;
-
- -- Drop = Error
-
- begin
- ASF.Insert(Source => Result_String, -- 10 chars
- Before => Result_String'Last,
- New_Item => "abcdefghijk",
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Insert");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
-
-
- -- Function Overwrite
-
- TC_Set_Name ("Overwrite");
-
- Overwrite_String := TC_Check (
- ASF.Overwrite(Result_String, -- 10 chars
- 1, -- starting at pos=1
- Source_String3(1..10)));
-
- if Overwrite_String /= Source_String3(1..10) then
- Report.Failed("Incorrect result from Function Overwrite - 1");
- end if;
-
-
- if TC_Check (ASF.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or
- TC_Check (ASF.Overwrite("a", 1, "xyz"))
- /= "xyz" or -- chars appended
- TC_Check (ASF.Overwrite("abc", 3, " "))
- /= "ab " or -- blanks appended
- TC_Check (ASF.Overwrite("abcde", 1, "z" )) /= "zbcde"
- then
- Report.Failed("Incorrect result from Function Overwrite - 2");
- end if;
-
-
-
- -- Procedure Overwrite, with truncation.
-
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Left);
-
- if Overwrite_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Overwrite with Drop=Left");
- end if;
-
- -- The default drop value is Right, used here.
-
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3); -- 12 characters.
-
- if Overwrite_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Overwrite with Drop=Right");
- end if;
-
- -- Drop = Error
-
- begin
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Overwrite");
- end;
-
- Overwrite_String := "ababababab";
- ASF.Overwrite(Overwrite_String, Overwrite_String'Last, "z");
- ASF.Overwrite(Overwrite_String, Overwrite_String'First,"z");
- ASF.Overwrite(Overwrite_String, 5, "zz");
-
- if Overwrite_String /= "zbabzzabaz" then
- Report.Failed("Incorrect result from Procedure Overwrite");
- end if;
-
-
-
- -- Function Delete
-
- TC_Set_Name ("Delete");
-
- declare
- New_String1 : constant String := -- This returns a 4 char string.
- TC_Check (ASF.Delete(Source => Source_String3,
- From => 3,
- Through => 10));
- New_String2 : constant String := -- This returns Source.
- TC_Check (ASF.Delete(Source_String3, 10, 3));
- begin
- if New_String1 /= "abkl" or
- New_String2 /= Source_String3
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
- end;
-
- if TC_Check (ASF.Delete("a", 1, 1))
- /= "" or -- Source length = 1
- TC_Check (ASF.Delete("abc", 1, 2))
- /= "c" or -- From = Source'First
- TC_Check (ASF.Delete("abc", 3, 3))
- /= "ab" or -- From = Source'Last
- TC_Check (ASF.Delete("abc", 3, 1))
- /= "abc" -- From > Through
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Procedure Delete
-
- -- Justify = Left
-
- Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij"
-
- ASF.Delete(Source => Delete_String,
- From => 6,
- Through => Delete_String'Last,
- Justify => Ada.Strings.Left,
- Pad => 'x'); -- pad with char 'x'
-
- if Delete_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Delete - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Delete(Source => Delete_String, -- Remove x"s from end and
- From => 6, -- shift right.
- Through => Delete_String'Last,
- Justify => Ada.Strings.Right,
- Pad => 'x'); -- pad with char 'x' on left.
-
- if Delete_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Delete - Justify = Right");
- end if;
-
- -- Justify = Center
-
- ASF.Delete(Source => Delete_String,
- From => 1,
- Through => 5,
- Justify => Ada.Strings.Center,
- Pad => 'z');
-
- if Delete_String /= "zzabcdezzz" then -- extra pad char on right side.
- Report.Failed("Incorrect result from Delete - Justify = Center");
- end if;
-
-
-
- -- Function Trim
- -- Use non-identity character sets to perform the trim operation.
-
- TC_Set_Name ("Trim");
-
- Trim_String := "cdabcdefcd";
-
- -- Remove the "cd" from each end of the string. This will not effect
- -- the "cd" slice at 5..6.
-
- declare
- New_String : constant String :=
- TC_Check (ASF.Trim(Source => Trim_String,
- Left => CD_Set, Right => CD_Set));
- begin
- if New_String /= Source_String2 then -- string "abcdef"
- Report.Failed("Incorrect result from Trim with character sets");
- end if;
- end;
-
- if TC_Check (ASF.Trim("abcdef", Maps.Null_Set, Maps.Null_Set))
- /= "abcdef" then
- Report.Failed("Incorrect result from Trim with Null sets");
- end if;
-
- if TC_Check (ASF.Trim("cdxx", CD_Set, X_Set)) /= "" then
- Report.Failed("Incorrect result from Trim, string removal");
- end if;
-
-
- -- Procedure Trim
-
- -- Justify = Right
-
- ASF.Trim(Source => Trim_String,
- Left => CD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxabcdef" then
- Report.Failed("Incorrect result from Trim with Justify = Right");
- end if;
-
- -- Justify = Left
-
- ASF.Trim(Source => Trim_String,
- Left => X_Set,
- Right => Maps.Null_Set,
- Justify => Ada.Strings.Left,
- Pad => Ada.Strings.Space);
-
- if Trim_String /= "abcdef " then -- Padded with 4 blanks on right.
- Report.Failed("Incorrect result from Trim with Justify = Left");
- end if;
-
- -- Justify = Center
-
- ASF.Trim(Source => Trim_String,
- Left => ABCD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Center,
- Pad => 'x');
-
- if Trim_String /= "xxef xx" then -- Padded with 2 pad chars on L/R
- Report.Failed("Incorrect result from Trim with Justify = Center");
- end if;
-
-
-
- -- Function Head, demonstrating use of padding.
-
- TC_Set_Name ("Head");
-
- -- Use the characters of Source_String1 ("abcde") and pad the
- -- last five characters of Result_String with 'x' characters.
-
-
- Result_String := TC_CHeck (ASF.Head(Source_String1, 10, 'x'));
-
- if Result_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Function Head with padding");
- end if;
-
- if TC_Check (ASF.Head(" ab ", 2)) /= " " or
- TC_Check (ASF.Head("a", 6, 'A')) /= "aAAAAA" or
- TC_Check (ASF.Head("abcdefgh", 3, 'x')) /= "abc" or
- TC_Check (ASF.Head(ASF.Head("abc ", 7, 'x'), 10, 'X'))
- /= "abc xxXXX"
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail, demonstrating use of padding.
-
- TC_Set_Name ("Tail");
-
- -- Use the characters of Source_String1 ("abcde") and pad the
- -- first five characters of Result_String with 'x' characters.
-
- Result_String := TC_Check (ASF.Tail(Source_String1, 10, 'x'));
-
- if Result_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Function Tail with padding");
- end if;
-
- if TC_Check (ASF.Tail("abcde ", 5))
- /= "cde " or -- blanks, back
- TC_Check (ASF.Tail(" abc ", 8, ' '))
- /= " abc " or -- blanks, front/back
- TC_Check (ASF.Tail("", 5, 'Z'))
- /= "ZZZZZ" or -- pad characters only
- TC_Check (ASF.Tail("abc", 0))
- /= "" or -- null result
- TC_Check (ASF.Tail("abcdefgh", 3))
- /= "fgh" or
- TC_Check (ASF.Tail(ASF.Tail(" abc ", 6, 'x'),
- 10,
- 'X')) /= "XXXXx abc "
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
- -- Function "*" - with (Natural, String) parameters
-
- TC_Set_Name ("""*""");
-
- if TC_Check (ASF."*"(3, Source_String1)) /= "abcdeabcdeabcde" or
- TC_Check (ASF."*"(2, Source_String2)) /= Source_String6 or
- TC_Check (ASF."*"(4, Source_String1(1..2))) /= "abababab" or
- TC_Check (ASF."*"(0, Source_String1)) /= ""
- then
- Report.Failed("Incorrect result from Function ""*"" with strings");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4005;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a
deleted file mode 100644
index e1d7f46..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a
+++ /dev/null
@@ -1,319 +0,0 @@
--- CXA4006.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 subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Length, Slice, "&", To_Bounded_String, Append, Index,
--- To_String, Replace_Slice, Trim, Overwrite, Delete, Insert, and
--- Translate.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of a variety of the string functions
--- found in the package Ada.Strings.Bounded, simulating the operations
--- found in a text processing package.
--- With bounded strings, the length of each "line" of text can vary up
--- to the instantiated maximum, allowing one to view a page of text as
--- a series of expandable lines. This provides flexibility in text
--- formatting of individual lines (strings).
--- Several subprograms are defined, all of which attempt to take advantage
--- of as many different bounded string utilities as possible. Often,
--- an operation that is being performed in a subprogram using a certain
--- bounded string utility could more efficiently be performed using a
--- a different utility. However, in the interest of including as broad
--- coverage as possible, a mixture of utilities is invoked in this test.
--- A simulated page of text is provided as a parameter to the test
--- defined subprograms, and the appropriate processing performed. The
--- processed page of text is then compared to a predefined "finished"
--- page, and test passage/failure is based on the results of this
--- comparison.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4006 is
-
-begin
-
- Report.Test ("CXA4006", "Check that the subprograms defined in package " &
- "Ada.Strings.Bounded are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- Characters_Per_Line : constant Positive := 40;
- Lines_Per_Page : constant Natural := 4;
-
- package BS_40 is new
- Ada.Strings.Bounded.Generic_Bounded_Length(Characters_Per_Line);
- use type BS_40.Bounded_String;
-
- type Page_Type is array (1..Lines_Per_Page) of BS_40.Bounded_String;
-
- -- Note: Misspellings below are intentional.
-
- Line1 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("ada is a progrraming language designed");
- Line2 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("to support the construction of long-");
- Line3 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("lived, highly reliabel software ");
- Line4 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("systems");
-
- Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4);
-
- Finished_Page : Page_Type :=
- (BS_40.To_Bounded_String("Ada is a programming language designed"),
- BS_40.To_Bounded_String("to support the construction of long-"),
- BS_40.To_Bounded_String("lived, HIGHLY RELIABLE software systems."),
- BS_40.To_Bounded_String(""));
-
- ---
-
- procedure Compress (Page : in out Page_Type) is
- Clear_Line : Natural := Lines_Per_Page;
- begin
- -- If two consecutive lines on the page are together less than the
- -- maximum line length, then append those two lines, move up all
- -- lower lines on the page, and blank out the last line.
- for i in 1..Lines_Per_Page - 1 loop
- if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <=
- BS_40.Max_Length
- then
- Page(i) := BS_40."&"(Page(i),
- Page(i+1)); -- "&" (bounded, bounded)
-
- for j in i+1..Lines_Per_Page - 1 loop
- Page(j) :=
- BS_40.To_Bounded_String
- (BS_40.Slice(Page(j+1),
- 1,
- BS_40.Length(Page(j+1))));
- Clear_Line := j + 1;
- end loop;
- Page(Clear_Line) := BS_40.Null_Bounded_String;
- end if;
- end loop;
- end Compress;
-
- ---
-
- procedure Format (Page : in out Page_Type) is
- Sm_Ada : BS_40.Bounded_String := BS_40.To_Bounded_String("ada");
- Cap_Ada : constant String := "Ada";
- Char_Pos : Natural := 0;
- Finished : Boolean := False;
- Line : Natural := Page_Type'Last;
- begin
-
- -- Add a period to the end of the last line.
- while Line >= Page_Type'First and not Finished loop
- if Page(Line) /= BS_40.Null_Bounded_String and
- BS_40.Length(Page(Line)) <= BS_40.Max_Length
- then
- Page(Line) := BS_40.Append(Page(Line), '.');
- Finished := True;
- end if;
- Line := Line - 1;
- end loop;
-
- -- Replace all occurrences of "ada" with "Ada".
- for Line in Page_Type'First .. Page_Type'Last loop
- Finished := False;
- while not Finished loop
- Char_Pos := BS_40.Index(Source => Page(Line),
- Pattern => BS_40.To_String(Sm_Ada),
- Going => Ada.Strings.Backward);
- -- A zero is returned by function Index if no occurrences of
- -- the pattern string are found.
- Finished := (Char_Pos = 0);
- if not Finished then
- BS_40.Replace_Slice
- (Source => Page(Line),
- Low => Char_Pos,
- High => Char_Pos + BS_40.Length(Sm_Ada) - 1,
- By => Cap_Ada);
- end if;
- end loop; -- while loop
- end loop; -- for loop
-
- end Format;
-
- ---
-
- procedure Spell_Check (Page : in out Page_Type) is
- type Spelling_Type is (Incorrect, Correct);
- type Word_Array_Type is array (Spelling_Type)
- of BS_40.Bounded_String;
- type Dictionary_Type is array (1..2) of Word_Array_Type;
-
- -- Note that the "words" in the dictionary will require various
- -- amounts of Trimming prior to their use in the string functions.
- Dictionary : Dictionary_Type :=
- (1 => (BS_40.To_Bounded_String(" reliabel "),
- BS_40.To_Bounded_String(" reliable ")),
- 2 => (BS_40.To_Bounded_String(" progrraming "),
- BS_40.To_Bounded_String(" programming ")));
-
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
-
- begin
-
- for Line in Page_Type'Range loop
-
- -- Search for the first incorrectly spelled word in the Dictionary,
- -- if it is found, replace it with the correctly spelled word,
- -- using the Overwrite function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_String(
- BS_40.Trim(Dictionary(1)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
- Finished := (Pos = 0);
- if not Finished then
- Page(Line) :=
- BS_40.Overwrite(Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Trim(Dictionary(1)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- -- Search for the second incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Delete procedure and Insert function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_String(
- BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
-
- Finished := (Pos = 0);
-
- if not Finished then
- BS_40.Delete
- (Page(Line),
- Pos,
- Pos + BS_40.To_String
- (BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both))'Length-1);
- Page(Line) :=
- BS_40.Insert(Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Trim(Dictionary(2)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- end loop;
- end Spell_Check;
-
- ---
-
- procedure Bold (Page : in out Page_Type) is
- Key_Word : constant String := "highly reliable";
- Bold_Mapping : constant Ada.Strings.Maps.Character_Mapping :=
- Ada.Strings.Maps.To_Mapping(From => " abcdefghijklmnopqrstuvwxyz",
- To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ");
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
- begin
- -- This procedure is designed to change the case of the phrase
- -- "highly reliable" into upper case (a type of "Bolding").
- -- All instances of the phrase on all lines of the page will be
- -- modified.
-
- for Line in Page_Type'First .. Page_Type'Last loop
- while not Finished loop
- Pos := BS_40.Index(Page(Line), Key_Word);
- Finished := (Pos = 0);
- if not Finished then
-
- BS_40.Overwrite
- (Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Translate
- (BS_40.To_Bounded_String
- (BS_40.Slice(Page(Line),
- Pos,
- Pos + Key_Word'Length - 1)),
- Bold_Mapping)));
-
- end if;
- end loop;
- Finished := False;
- end loop;
- end Bold;
-
-
- begin
-
- Compress(Page);
- Format(Page);
- Spell_Check(Page);
- Bold(Page);
-
- for i in 1..Lines_Per_Page loop
- if BS_40.To_String(Page(i)) /= BS_40.To_String(Finished_Page(i)) or
- BS_40.Length(Page(i)) /= BS_40.Length(Finished_Page(i))
- then
- Report.Failed("Incorrect modification of Page, Line " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4006;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a
deleted file mode 100644
index fca15d3..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXA4007.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 subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Append, Count, Element, Find_Token, Head,
--- Index_Non_Blank, Replace_Element, Replicate, Tail, To_Bounded_String,
--- "&", ">", "<", ">=", "<=", and "*".
---
--- TEST DESCRIPTION:
--- This test, when taken in conjunction with tests CXA400[6,8,9], will
--- constitute a test of all the functionality contained in package
--- Ada.Strings.Bounded. This test uses a variety of the
--- subprograms defined in the bounded string package in ways typical
--- of common usage. Different combinations of available subprograms
--- are used to accomplish similar bounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Ada.Strings.Space.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4007 is
-
-begin
-
- Report.Test ("CXA4007", "Check that the subprograms defined in package " &
- "Ada.Strings.Bounded are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
- use type BS80.Bounded_String;
-
- Part1 : constant String := "Rum";
- Part2 : Character := 'p';
- Part3 : BS80.Bounded_String := BS80.To_Bounded_String("el");
- Part4 : Character := 's';
- Part5 : BS80.Bounded_String := BS80.To_Bounded_String("tilt");
- Part6 : String(1..3) := "ski";
-
- Full_Catenate_String,
- Full_Append_String,
- Constructed_String,
- Drop_String,
- Replicated_String,
- Token_String : BS80.Bounded_String;
-
- CharA : Character := 'A';
- CharB : Character := 'B';
- CharC : Character := 'C';
- CharD : Character := 'D';
- CharE : Character := 'E';
- CharF : Character := 'F';
-
- ABStr : String(1..15) := "AAAAABBBBBBBBBB";
- StrB : String(1..2) := "BB";
- StrE : String(1..2) := "EE";
-
-
- begin
-
- -- Evaluation of the overloaded forms of the "&" operator defined
- -- for instantiations of Bounded Strings.
-
- Full_Catenate_String :=
- BS80."&"(Part2, -- Char & Bnd Str
- BS80."&"(Part3, -- Bnd Str & Bnd Str
- BS80."&"(Part4, -- Char & Bnd Str
- BS80."&"(Part5, -- Bnd Str & Bnd Str
- BS80.To_Bounded_String(Part6)))));
-
- Full_Catenate_String :=
- Part1 & Full_Catenate_String; -- Str & Bnd Str
- Full_Catenate_String :=
- Full_Catenate_String & 'n'; -- Bnd Str & Char
-
-
- -- Evaluation of the overloaded forms of function Append.
-
- Full_Append_String :=
- BS80.Append(Part2, -- Char,Bnd
- BS80.Append(Part3, -- Bnd, Bnd
- BS80.Append(Part4, -- Char,Bnd
- BS80.Append(BS80.To_String(Part5), -- Str,Bnd
- BS80.To_Bounded_String(Part6)))));
-
- Full_Append_String :=
- BS80.Append(BS80.To_Bounded_String(Part1), -- Bnd , Str
- BS80.To_String(Full_Append_String));
-
- Full_Append_String :=
- BS80.Append(Left => Full_Append_String,
- Right => 'n'); -- Bnd, Char
-
-
- -- Validate the resulting bounded strings.
-
- if Full_Catenate_String < Full_Append_String or
- Full_Catenate_String > Full_Append_String or
- not (Full_Catenate_String = Full_Append_String and
- Full_Catenate_String <= Full_Append_String and
- Full_Catenate_String >= Full_Append_String)
- then
- Report.Failed("Incorrect results from bounded string catenation" &
- " and comparison");
- end if;
-
-
- -- Evaluate the overloaded forms of the Constructor function "*" and
- -- the Replicate function.
-
- Constructed_String :=
- (2 * CharA) & -- "AA"
- (2 * StrB) & -- "AABBBB"
- (3 * BS80."*"(2, CharC)) & -- "AABBBBCCCCCC"
- BS80.Replicate(3,
- BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD"
- BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE"
- BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF"
-
-
- -- Use of Function Replicate that involves dropping characters. The
- -- attempt to replicate the 15 character string six times will exceed
- -- the 80 character bound of the string. Therefore, the result should
- -- be the catenation of 5 copies of the 15 character string, followed
- -- by 5 'A' characters (the first five characters of the 6th
- -- replication) with the remaining characters of the 6th replication
- -- dropped.
-
- Drop_String :=
- BS80.Replicate(Count => 6,
- Item => ABStr, -- "AAAAABBBBBBBBBB"
- Drop => Ada.Strings.Right);
-
- if BS80.Element(Drop_String, 1) /= 'A' or
- BS80.Element(Drop_String, 6) /= 'B' or
- BS80.Element(Drop_String, 76) /= 'A' or
- BS80.Element(Drop_String, 80) /= 'A'
- then
- Report.Failed("Incorrect result from Replicate with Drop");
- end if;
-
-
- -- Use function Index_Non_Blank in the evaluation of the
- -- Constructed_String.
-
- if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /=
- BS80.To_String(Constructed_String)'First or
- BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /=
- BS80.Length(Constructed_String)
- then
- Report.Failed("Incorrect results from constructor functions");
- end if;
-
-
-
- declare
-
- -- Define character set objects for use with the Count function.
- -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above.
-
- A_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,1));
- B_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,3));
- C_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,7));
- D_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,13));
- E_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,19));
- F_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,23));
-
-
- Start : Positive;
- Stop : Natural := 0;
-
- begin
-
- -- Evaluate the results from function Count by comparing the number
- -- of A's to the number of F's, B's to E's, and C's to D's in the
- -- Constructed_String.
- -- There should be an equal number of each of the characters that
- -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc)
-
- if BS80.Count(Constructed_String, A_Set) /=
- BS80.Count(Constructed_String, F_Set) or
- BS80.Count(Constructed_String, B_Set) /=
- BS80.Count(Constructed_String, E_Set) or
- not (BS80.Count(Constructed_String, C_Set) =
- BS80.Count(Constructed_String, D_Set))
- then
- Report.Failed("Incorrect result from function Count");
- end if;
-
-
- -- Evaluate the functions Head, Tail, and Find_Token.
- -- Create the Token_String from the Constructed_String above.
-
- Token_String :=
- BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" &
- BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" &
- BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF"
-
- if Token_String /= BS80.To_Bounded_String("ABCDEF") then
- Report.Failed("Incorrect result from Catenation of Token_String");
- end if;
-
-
- -- Find the starting/ending position of the first A in the
- -- Token_String (both should be 1, only one A appears in string).
- -- The Function Head uses the default pad character to return a
- -- bounded string longer than its input parameter bounded string.
-
- BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad.
- A_Set,
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 1 and Stop /= 1 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
-
- -- Find the starting/ending position of the first non-AB slice in
- -- the "head" five characters of Token_String (slice CDE at
- -- positions 3-5)
-
- BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE"
- Ada.Strings.Maps."OR"(A_Set, B_Set), -- Set (AB)
- Ada.Strings.Outside,
- Start,
- Stop);
-
- if Start /= 3 and Stop /= 5 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
-
- -- Find the starting/ending position of the first CD slice in
- -- the "tail" eight characters (including two pad characters)
- -- of Token_String (slice CD at positions 5-6 of the tail
- -- portion specified)
-
- BS80.Find_Token(BS80.Tail(Token_String, 8,
- Ada.Strings.Space), -- " ABCDEF"
- Ada.Strings.Maps."OR"(C_Set, D_Set), -- Set (CD)
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 5 and Stop /= 6 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
-
- -- Evaluate the Replace_Element procedure.
-
- -- Token_String = "ABCDEF"
-
- BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4));
-
- -- Token_String = "ABDDEF"
-
- BS80.Replace_Element(Source => Token_String,
- Index => 2,
- By => BS80.Element(Token_String, 5));
-
- -- Token_String = "AEDDEF"
-
- BS80.Replace_Element(Token_String,
- 1,
- BS80.Element(BS80.Tail(Token_String, 2), 2));
-
- -- Token_String = "FEDDEF"
- -- Evaluate this result.
-
- if BS80.Element(Token_String, BS80.To_String(Token_String)'First) /=
- BS80.Element(Token_String, BS80.To_String(Token_String)'Last) or
- BS80.Count(Token_String, D_Set) /=
- BS80.Count(Token_String, E_Set) or
- BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /=
- BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or
- BS80.Head(Token_String, 1) /=
- BS80.Tail(Token_String, 1)
- then
- Report.Failed("Incorrect result from operations in combination");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4007;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a
deleted file mode 100644
index 629305f..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a
+++ /dev/null
@@ -1,662 +0,0 @@
--- CXA4008.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 subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Append, Count with non-Identity maps, Index with
--- non-Identity maps, Index with Set parameters, Insert (function and
--- procedure), Replace_Slice (function and procedure), To_Bounded_String,
--- and Translate.
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4006, CXA4007, and CXA4009,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected acceptance condition of subtest for
--- Function Append with Truncation = Left.
--- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Maps.Constants;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-
-procedure CXA4008 is
-
-begin
-
- Report.Test("CXA4008", "Check that the subprograms defined in " &
- "package Ada.Strings.Bounded are available, " &
- "and that they produce correct results, " &
- "especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Bounded;
- package ASC renames Ada.Strings.Maps.Constants;
- package Maps renames Ada.Strings.Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_String;
-
- Result_String : B10.Bounded_String;
- Test_String : B10.Bounded_String;
- AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde");
- FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij");
- AtoJ_Bnd_Str : B10.Bounded_String :=
- B10.To_Bounded_String("abcdefghij");
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
-
- AB_to_YZ_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "ab", To => "yz");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
-
- begin
- -- Function To_Bounded_String with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- Test_String :=
- B10.To_Bounded_String("Much too long for this bounded string");
- Report.Failed("Length Error not raised by To_Bounded_String");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by To_Bounded_String");
- end;
-
- -- Drop = Left
-
- Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn",
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_String("efghijklmn") then
- Report.Failed
- ("Incorrect result from To_Bounded_String, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn",
- Drop => Ada.Strings.Right);
-
- if not(Test_String = AtoJ_Bnd_Str) then
- Report.Failed
- ("Incorrect result from To_Bounded_String, Drop = Right");
- end if;
-
-
-
-
- -- Function Append with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- -- Append (Bnd Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcde"),
- B10.To_Bounded_String("fghijk")); -- 11 char
- Report.Failed("Length_Error not raised by Append - 1");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 1");
- end;
-
- begin
- -- Append (Str, Bnd Str);
- Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str),
- B10.To_Bounded_String("fghijk"),
- AS.Error);
- Report.Failed("Length_Error not raised by Append - 2");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 2");
- end;
-
- begin
- -- Append (Bnd Str, Char);
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcdefghij"), 'k');
- Report.Failed("Length_Error not raised by Append - 3");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 3");
- end;
-
- -- Drop = Left
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(B10.To_Bounded_String("abcdefgh"), -- 8 chs
- B10.To_Bounded_String("ijklmn"), -- 6 chs
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("efghijklmn") then -- 10 chars
- Report.Failed("Incorrect truncation performed by Append - 4");
- end if;
-
- -- Append (Bnd Str, Str)
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcdefghij"),
- "xyz",
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("defghijxyz") then
- Report.Failed("Incorrect truncation performed by Append - 5");
- end if;
-
- -- Append (Char, Bnd Str)
-
- Result_String := B10.Append('A',
- B10.To_Bounded_String("abcdefghij"),
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("abcdefghij") then
- Report.Failed("Incorrect truncation performed by Append - 6");
- end if;
-
- -- Drop = Right
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(FtoJ_Bnd_Str,
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("fghijabcde") then
- Report.Failed("Incorrect truncation performed by Append - 7");
- end if;
-
- -- Append (Str, Bnd Str)
- Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str),
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("abcdeabcde") then
- Report.Failed("Incorrect truncation performed by Append - 8");
- end if;
-
- -- Append (Char, Bnd Str)
- Result_String := B10.Append('A', AtoJ_Bnd_Str, Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("Aabcdefghi") then
- Report.Failed("Incorrect truncation performed by Append - 9");
- end if;
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location := B10.Index(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Pattern => "xy",
- Going => Ada.Strings.Forward,
- Mapping => CD_to_XY_Map); -- change "cd" to "xy"
-
- if Location /= 3 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location := B10.Index(B10.To_Bounded_String("AND IF MAN"),
- "an",
- Ada.Strings.Backward,
- ASC.Lower_Case_Map);
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- Location := B10.Index(Source => B10.To_Bounded_String("The the"),
- Pattern => "the",
- Going => Ada.Strings.Forward,
- Mapping => ASC.Lower_Case_Map);
-
- if Location /= 1 then
- Report.Failed("Incorrect result from Index, non-Identity map - 3");
- end if;
-
-
- if B10.Index(B10.To_Bounded_String("abcd"), -- Pattern = Source
- "abcd") /= 1 or
- B10.Index(B10.To_Bounded_String("abc"), -- Pattern < Source
- "abcd") /= 0 or
- B10.Index(B10.Null_Bounded_String, -- Source = Null
- "abc") /= 0
- then
- Report.Failed("Incorrect result from Index with string patterns");
- end if;
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- B10.Index(Source => B10.To_Bounded_String("abcdeabcde"),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward);
-
- if not (Location = 3) then -- position of first 'c' in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward.
- Location := B10.Index(B10.To_Bounded_String("deddacd"),
- CD_Set,
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward);
-
- if Location /= 2 then -- position of 'e' in source.
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Test = Outside, Going = Backward.
- Location := B10.Index(B10.To_Bounded_String("deddacd"),
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward);
-
- if Location /= 5 then -- correct position of 'a'.
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
- if B10.Index(B10.To_Bounded_String("cd"), -- Source = Set
- CD_Set) /= 1 or
- B10.Index(B10.To_Bounded_String("c"), -- Source < Set
- CD_Set) /= 1 or
- B10.Index(B10.Null_Bounded_String, -- Source = Null
- CD_Set) /= 0 or
- B10.Index(AtoE_Bnd_Str, -- "abcde"
- Maps.Null_Set) /= 0 or -- Null set
- B10.Index(AtoE_Bnd_Str,
- Maps.To_Set('x')) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 5");
- end if;
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_String("abbabaabab"),
- Pattern => "yz",
- Mapping => AB_to_YZ_Map);
-
- if Total_Count /= 4 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- -- And a few with identity maps as well.
-
- if B10.Count(B10.To_Bounded_String("ABABABABAB"),
- "ABA",
- Maps.Identity) /= 2 or
- B10.Count(B10.To_Bounded_String("ADCBADABCD"),
- "AB",
- Maps.To_Mapping("CD", "AB")) /= 5 or
- B10.Count(B10.To_Bounded_String("aaaaaaaaaa"),
- "aaa") /= 3 or
- B10.Count(B10.To_Bounded_String("XX"), -- Source < Pattern
- "XXX",
- Maps.Identity) /= 0 or
- B10.Count(AtoE_Bnd_Str, -- Source = Pattern
- "abcde") /= 1 or
- B10.Count(B10.Null_Bounded_String, -- Source = Null
- " ") /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
- -- Procedure Translate
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_String("abcdeabcab");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_String("yzcdeyzcyz") then
- Report.Failed("Incorrect result from procedure Translate - 1");
- end if;
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_String("abbaaababb");
-
- B10.Translate(Source => Test_String, Mapping => ASC.Upper_Case_Map);
-
- if Test_String /= B10.To_Bounded_String("ABBAAABABB") then
- Report.Failed("Incorrect result from procedure Translate - 2");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_String("xyzsypcc");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_String("xyzsypcc") then
- Report.Failed("Incorrect result from procedure Translate - 3");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := B10.To_Bounded_String("have faith");
-
- B10.Translate(Test_String,
- Maps.To_Mapping("aeiou", "AEIOU"));
-
- if Test_String /= B10.To_Bounded_String("hAvE fAIth") then
- Report.Failed("Incorrect result from procedure Translate - 4");
- end if;
-
-
- -- Function Replace_Slice
- -- Evaluate function Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => "xxxxxx"); -- more than 3.
- Report.Failed("Length_Error not raised by Function Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 7,
- High => 10, -- 7-10, 4 chars.
- By => "xxxxxx", -- 6 chars.
- Drop => Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("cdefxxxxxx") then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 2,
- High => 5, -- 2-5, 4 chars.
- By => "xxxxxx", -- 6 chars.
- Drop => Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("axxxxxxfgh") then -- drop i,j
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Right");
- end if;
-
- -- Low = High = Source'Last, "By" length = 1.
-
- if B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'Last,
- B10.To_String(AtoE_Bnd_Str)'Last,
- "X",
- Ada.Strings.Error) /=
- B10.To_Bounded_String("abcdX")
- then
- Report.Failed("Incorrect result from Function Replace_Slice");
- end if;
-
-
-
- -- Procedure Replace_Slice
- -- Evaluate procedure Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => "xxxxxx"); -- more than 3.
- Report.Failed("Length_Error not raised by Procedure Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Replace_Slice");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 7,
- High => 9, -- 7-9, 3 chars.
- By => "xxxxx", -- 5 chars.
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_String("cdefxxxxxj") then -- drop a,b
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 1,
- High => 3, -- 1-3, 3chars.
- By => "xxxx", -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_String("xxxxdefghi") then -- drop j
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Right");
- end if;
-
- -- High = Source'First, Low > High (Insert before Low).
-
- Test_String := AtoE_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcde"
- Low => B10.To_String(Test_String)'Last,
- High => B10.To_String(Test_String)'First,
- By => "XXXX", -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_String("abcdXXXXe") then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice");
- end if;
-
-
-
- -- Function Insert with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 2,
- New_Item => "xyz");
- Report.Failed("Length_Error not raised by Function Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Insert");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 5,
- New_Item => "xyz", -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Result_String) /= "dxyzefghij" then -- drop a, b, c
- Report.Failed("Incorrect result from Function Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Insert(Source => B10.To_Bounded_String("abcdef"),
- Before => 2,
- New_Item => "vwxyz", -- 5 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_String(Result_String) /= "avwxyzbcde" then -- drop f.
- Report.Failed("Incorrect result from Function Insert, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Insert(B10.To_Bounded_String("a"), 1, " B") /=
- B10.To_Bounded_String(" Ba") or
- B10.Insert(B10.Null_Bounded_String, 1, "abcde") /=
- AtoE_Bnd_Str or
- B10.Insert(B10.To_Bounded_String("ab"), 2, "") /=
- B10.To_Bounded_String("ab")
- then
- Report.Failed("Incorrect result from Function Insert");
- end if;
-
-
- -- Procedure Insert
-
- -- Drop = Error (Default).
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String, -- "abcdefghij"
- Before => 9,
- New_Item => "wxyz",
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Procedure Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String, -- "abcdefghij"
- Before => B10.Length(Test_String), -- before last char
- New_Item => "xyz", -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Test_String) /= "defghixyzj" then -- drop a, b, c
- Report.Failed("Incorrect result from Procedure Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 4,
- New_Item => "yz", -- 2 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_String(Test_String) /= "abcyzdefgh" then -- drop i,j
- Report.Failed
- ("Incorrect result from Procedure Insert, Drop = Right");
- end if;
-
- -- Before = Source'First, New_Item length = 1.
-
- Test_String := B10.To_Bounded_String(" abc ");
- B10.Insert(Test_String,
- B10.To_String(Test_String)'First,
- "Z");
-
- if Test_String /= B10.To_Bounded_String("Z abc ") then
- Report.Failed("Incorrect result from Procedure Insert");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4008;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a
deleted file mode 100644
index f02ef03..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a
+++ /dev/null
@@ -1,619 +0,0 @@
--- CXA4009.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 subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Overwrite (function and procedure), Delete,
--- Function Trim (blanks), Trim (Set characters, function and procedure),
--- Head, Tail, and Replicate (characters and strings).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4006, CXA4007, and CXA4008,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected errors in Procedure Overwrite subtests.
--- 01 Nov 95 SAIC Fixed bugs for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-
-procedure CXA4009 is
-
-begin
-
- Report.Test("CXA4009", "Check that the subprograms defined in " &
- "package Ada.Strings.Bounded are available, " &
- "and that they produce correct results, " &
- "especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Bounded;
- package Maps renames Ada.Strings.Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_String;
-
- Result_String : B10.Bounded_String;
- Test_String : B10.Bounded_String;
- AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde");
- FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij");
- AtoJ_Bnd_Str : B10.Bounded_String :=
- B10.To_Bounded_String("abcdefghij");
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- XY_Set : Maps.Character_Set := Maps.To_Set("xy");
-
-
- begin
-
- -- Function Overwrite with Truncation
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 9,
- New_Item => "xyz",
- Drop => AS.Error);
- Report.Failed("Exception not raised by Function Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Overwrite");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String), -- 10
- New_Item => "xyz",
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Result_String) /= "cdefghixyz" then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- "xxxyyyzzz",
- Ada.Strings.Right);
-
- if B10.To_String(Result_String) /= "abxxxyyyzz" then -- one 'z' dropped
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Right");
- end if;
-
- -- Additional cases of function Overwrite.
-
- if B10.Overwrite(B10.To_Bounded_String("a"), -- Source length = 1
- 1,
- " abc ") /=
- B10.To_Bounded_String(" abc ") or
- B10.Overwrite(B10.Null_Bounded_String, -- Null source
- 1,
- "abcdefghij") /=
- AtoJ_Bnd_Str or
- B10.Overwrite(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'First,
- " ") /= -- New_Item = 1
- B10.To_Bounded_String(" bcde")
- then
- Report.Failed("Incorrect result from Function Overwrite");
- end if;
-
-
-
- -- Procedure Overwrite
- -- Correct usage, no truncation.
-
- Test_String := AtoE_Bnd_Str; -- "abcde"
- B10.Overwrite(Test_String, 2, "xyz");
-
- if Test_String /= B10.To_Bounded_String("axyze") then
- Report.Failed("Incorrect result from Procedure Overwrite - 1");
- end if;
-
- Test_String := B10.To_Bounded_String("abc");
- B10.Overwrite(Test_String, 2, ""); -- New_Item is null string.
-
- if Test_String /= B10.To_Bounded_String("abc") then
- Report.Failed("Incorrect result from Procedure Overwrite - 2");
- end if;
-
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 8,
- New_Item => "uvwxyz");
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Overwrite");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String) - 2, -- 8
- New_Item => "uvwxyz",
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Test_String) /= "defguvwxyz" then -- drop a-c
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- "xxxyyyzzz",
- Ada.Strings.Right);
-
- if B10.To_String(Test_String) /= "abxxxyyyzz" then -- one 'z' dropped
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Right");
- end if;
-
-
-
- -- Function Delete
-
- if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- From => 3,
- Through => 8) /=
- B10."&"(B10.Head(AtoJ_Bnd_Str, 2),
- B10.Tail(AtoJ_Bnd_Str, 2)) or
- B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoJ_Bnd_Str, 1, 5) /=
- FtoJ_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str, 4, 5) /=
- B10.Delete(AtoJ_Bnd_Str, 4, B10.Length(AtoJ_Bnd_Str))
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
-
- if B10.Delete(B10.To_Bounded_String("a"), 1, 1) /=
- B10.Null_Bounded_String or
- B10.Delete(AtoE_Bnd_Str,
- 5,
- B10.To_String(AtoE_Bnd_Str)'First) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'Last,
- B10.To_String(AtoE_Bnd_Str)'Last) /=
- B10.To_Bounded_String("abcd")
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Function Trim
-
- declare
-
- Text : B10.Bounded_String := B10.To_Bounded_String("Text");
- type Bnd_Array_Type is array (1..5) of B10.Bounded_String;
- Bnd_Array : Bnd_Array_Type :=
- (B10.To_Bounded_String(" Text"),
- B10.To_Bounded_String("Text "),
- B10.To_Bounded_String(" Text "),
- B10.To_Bounded_String("Text Text"), -- Ensure no inter-string
- B10.To_Bounded_String(" Text Text")); -- trimming of blanks.
-
- begin
-
- for i in Bnd_Array_Type'Range loop
- case i is
- when 4 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- Bnd_Array(i) then -- no change
- Report.Failed("Incorrect result from Function Trim - 4");
- end if;
- when 5 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- B10."&"(Text, B10."&"(' ', Text)) then
- Report.Failed("Incorrect result from Function Trim - 5");
- end if;
- when others =>
- if B10.Trim(Bnd_Array(i), AS.Both) /= Text then
- Report.Failed("Incorrect result from Function Trim - " &
- Integer'Image(i));
- end if;
- end case;
- end loop;
-
- end;
-
-
-
- -- Function Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded string.
- if B10.Trim(Source => B10.To_Bounded_String("ddabbaxx"),
- Left => CD_Set,
- Right => XY_Set) /=
- B10.To_Bounded_String("abba")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- string; likewise for the opposite side. Only "cd" trimmed from left
- -- side, and only "xy" trimmed from right side.
-
- if B10.Trim(B10.To_Bounded_String("cdxyabcdxy"), CD_Set, XY_Set) /=
- B10.To_Bounded_String("xyabcd")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded string, just the appropriate ends.
-
- if B10.Trim(B10.To_Bounded_String("cdabdxabxy"), CD_Set, XY_Set) /=
- B10.To_Bounded_String("abdxab")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from right side only. No change to Left side.
-
- if B10.Trim(B10.To_Bounded_String("abxyzddcd"), XY_Set, CD_Set) /=
- B10.To_Bounded_String("abxyz")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Right side");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set);
- if Result_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Fn Trim - Sets, Neither side");
- end if;
-
- if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /=
- AtoE_Bnd_Str or
- B10.Trim(B10.To_Bounded_String("dcddcxyyxx"),
- CD_Set,
- XY_Set) /=
- B10.Null_Bounded_String
- then
- Report.Failed("Incorrect result from Function Trim");
- end if;
-
-
-
- -- Procedure Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded string.
-
- Test_String := B10.To_Bounded_String("dcabbayx");
- B10.Trim(Source => Test_String,
- Left => CD_Set,
- Right => XY_Set);
-
- if Test_String /= B10.To_Bounded_String("abba") then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- string; likewise for the opposite side. Only "cd" trimmed from left
- -- side, and only "xy" trimmed from right side.
-
- Test_String := B10.To_Bounded_String("cdxyabcdxy");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_String("xyabcd") then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded string, just the appropriate ends.
-
- Test_String := B10.To_Bounded_String("cdabdxabxy");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if not (Test_String = B10.To_Bounded_String("abdxab")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from Left side only. No change to Right side.
-
- Test_String := B10.To_Bounded_String("cccdabxyz");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_String("abxyz") then
- Report.Failed
- ("Incorrect result from Proc Trim for Sets, Left side only");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Test_String := AtoJ_Bnd_Str;
- B10.Trim(Test_String, CD_Set, CD_Set);
-
- if Test_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Proc Trim-Sets, Neither side");
- end if;
-
-
-
- -- Function Head with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => 'X');
- Report.Failed("Length_Error not raised by Function Head");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Head");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the right end of the string
- -- (which is initially at its maximum length), then the first five
- -- characters of the intermediate result are dropped to conform to
- -- the maximum size limit of the bounded string (10).
-
- Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHIJ"),
- 15,
- 'x',
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("FGHIJxxxxx") then
- Report.Failed("Incorrect result from Function Head, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (6) are appended to the left end of the string
- -- (which is initially at one less than its maximum length), then the
- -- last five characters of the intermediate result are dropped
- -- (which in this case are the pad characters) to conform to the
- -- maximum size limit of the bounded string (10).
-
- Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHI"),
- 15,
- 'x',
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("ABCDEFGHIx") then
- Report.Failed("Incorrect result from Function Head, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Head(B10.Null_Bounded_String, 5) /=
- B10.To_Bounded_String(" ") or
- B10.Head(AtoE_Bnd_Str,
- B10.Length(AtoE_Bnd_Str)) /=
- AtoE_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail with Truncation
- -- Drop = Error (Default Case)
-
- begin
- Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Ada.Strings.Space,
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Function Tail");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Tail");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the left end of the string
- -- (which is initially at two less than its maximum length), then
- -- the first three characters of the intermediate result (in this
- -- case, 3 pad characters) are dropped.
-
- Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGH"), -- 8 ch
- 13,
- 'x',
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("xxABCDEFGH") then
- Report.Failed("Incorrect result from Function Tail, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (3) are appended to the left end of the string
- -- (which is initially at its maximum length), then the last three
- -- characters of the intermediate result are dropped.
-
- Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGHIJ"),
- 13,
- 'x',
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("xxxABCDEFG") then
- Report.Failed("Incorrect result from Function Tail, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Tail(B10.Null_Bounded_String, 3, ' ') /=
- B10.To_Bounded_String(" ") or
- B10.Tail(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'First) /=
- B10.To_Bounded_String("e")
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function Replicate (#, Char) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => B10.Max_Length + 5,
- Item => 'A',
- Drop => AS.Error);
- Report.Failed
- ("Length_Error not raised by Replicate for characters");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for characters");
- end;
-
- -- Drop = Left, Right
- -- Since this version of Replicate uses character parameters, the
- -- result after truncation from left or right will appear the same.
- -- The result will be a 10 character bounded string, composed of 10
- -- "Item" characters.
-
- if B10.Replicate(Count => 20, Item => 'A', Drop => Ada.Strings.Left) /=
- B10.Replicate(15, 'A', Ada.Strings.Right)
- then
- Report.Failed("Incorrect result from Replicate for characters - 1");
- end if;
-
- -- Blank-filled 10 character bounded strings.
-
- if B10.Replicate(B10.Max_Length + 1, ' ', Drop => Ada.Strings.Left) /=
- B10.Replicate(B10.Max_Length, Ada.Strings.Space)
- then
- Report.Failed("Incorrect result from Replicate for characters - 2");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(0, 'a') /= B10.Null_Bounded_String or
- B10.Replicate(1, 'a') /= B10.To_Bounded_String("a")
- then
- Report.Failed("Incorrect result from Replicate for characters - 3");
- end if;
-
-
-
- -- Function Replicate (#, String) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => 5, -- result would be 15.
- Item => "abc");
- Report.Failed
- ("Length_Error not raised by Replicate for strings");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for strings");
- end;
-
- -- Drop = Left
-
- Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("cdabcdabcd") then
- Report.Failed
- ("Incorrect result from Replicate for strings, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("abcdabcdab") then
- Report.Failed
- ("Incorrect result from Replicate for strings, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(10, "X") /= B10.To_Bounded_String("XXXXXXXXXX") or
- B10.Replicate(10, "") /= B10.Null_Bounded_String or
- B10.Replicate( 0, "ab") /= B10.Null_Bounded_String
- then
- Report.Failed("Incorrect result from Replicate for strings");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4009;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a
deleted file mode 100644
index 8646b12..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- CXA4010.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 subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms To_String, To_Unbounded_String, Insert, "&",
--- "*", Length, Slice, Replace_Slice, Overwrite, Index, Index_Non_Blank,
--- Head, Tail, and "=", "<=", ">=".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be used
--- to simulate paragraphs of text. Modifications could be easily be
--- performed using the provided subprograms (although in this test, the
--- main modification performed was the addition of more text to the
--- string). One would not have to worry about the formatting of the
--- paragraph until it was finished and correct in content. Then, once
--- all required editing is complete, the unbounded strings can be divided
--- up into the appropriate lengths based on particular formatting
--- requirements. The test then compares the formatted text product
--- with a predefined "finished product".
---
--- This test uses a large number of the subprograms provided
--- by package Ada.Strings.Unbounded. Often, the processing involved
--- could have been performed more efficiently using a minimum number
--- of the subprograms, in conjunction with loops, etc. However, for
--- testing purposes, and in the interest of minimizing the number of
--- tests developed, subprogram variety and feature mixing was stressed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4010 is
-begin
-
- Report.Test ("CXA4010", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASUnb renames Ada.Strings.Unbounded;
- use type ASUnb.Unbounded_String;
- use Ada.Strings;
-
- Pamphlet_Paragraph_Count : constant := 2;
- Lines : constant := 4;
- Line_Length : constant := 40;
-
- type Document_Type is array (Positive range <>)
- of ASUnb.Unbounded_String;
-
- type Camera_Ready_Copy_Type is array (1..Lines)
- of String (1..Line_Length);
-
- Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count);
-
- Camera_Ready_Copy : Camera_Ready_Copy_Type :=
- (others => (others => Ada.Strings.Space));
-
- TC_Finished_Product : Camera_Ready_Copy_Type :=
- ( 1 => "Ada is a programming language designed ",
- 2 => "to support long-lived, reliable software",
- 3 => " systems. ",
- 4 => "Go with Ada! ");
-
- -----
-
-
- procedure Enter_Text_Into_Document (Document : in out Document_Type) is
- begin
-
- -- Fill in both "paragraphs" of the document. Each unbounded string
- -- functions as an individual paragraph, containing an unspecified
- -- number of characters.
- -- Use a variety of different unbounded string subprograms to load
- -- the data.
-
- Document(1) := ASUnb.To_Unbounded_String("Ada is a language");
-
- -- Insert the word "programming" prior to "language".
- Document(1) :=
- ASUnb.Insert(Document(1),
- ASUnb.Index(Document(1),
- "language"),
- ASUnb.To_String("progra" & -- Str &
- ASUnb."*"(2,'m') & -- Unbd &
- "ing ")); -- Str
-
-
- -- Overwrite the word "language" with "language" + additional text.
- Document(1) :=
- ASUnb.Overwrite(Document(1),
- ASUnb.Index(Document(1),
- ASUnb.To_String(
- ASUnb.Tail(Document(1), 8, ' ')),
- Ada.Strings.Backward),
- "language designed to support long-lifed");
-
-
- -- Replace the word "lifed" with "lived".
- Document(1) :=
- ASUnb.Replace_Slice(Document(1),
- ASUnb.Index(Document(1), "lifed"),
- ASUnb.Length(Document(1)),
- "lived");
-
-
- -- Overwrite the word "lived" with "lived" + additional text.
- Document(1) :=
- ASUnb.Overwrite(Document(1),
- ASUnb.Index(Document(1),
- ASUnb.To_String(
- ASUnb.Tail(Document(1), 5, ' ')),
- Ada.Strings.Backward),
- "lived, reliable software systems.");
-
-
- -- Use several of the overloaded versions of "&" to form this
- -- unbounded string.
-
- Document(2) := 'G' &
- ASUnb.To_Unbounded_String("o ") &
- ASUnb.To_Unbounded_String("with") &
- ' ' &
- "Ada!";
-
- end Enter_Text_Into_Document;
-
-
- -----
-
-
- procedure Create_Camera_Ready_Copy
- (Document : in Document_Type;
- Camera_Copy : out Camera_Ready_Copy_Type) is
- begin
- -- Break the unbounded strings into fixed lengths.
-
- -- Search the first unbounded string for portions of text that
- -- are less than or equal to the length of a string in the
- -- Camera_Ready_Copy_Type object.
-
- Camera_Copy(1) := -- Take characters 1-39,
- ASUnb.Slice(Document(1), -- and append a blank space.
- 1,
- ASUnb.Index(ASUnb.To_Unbounded_String(
- ASUnb.Slice(Document(1),
- 1,
- Line_Length)),
- Ada.Strings.Maps.To_Set(' '),
- Ada.Strings.Inside,
- Ada.Strings.Backward)) & ' ';
-
- Camera_Copy(2) := -- Take characters 40-79.
- ASUnb.Slice(Document(1),
- 40,
- (ASUnb.Index_Non_Blank -- Should return 79
- (ASUnb.To_Unbounded_String
- (ASUnb.Slice(Document(1), -- Slice (40..79)
- 40,
- 79)),
- Ada.Strings.Backward) + 39)); -- Increment since
- -- this slice starts
- -- at 40.
-
- Camera_Copy(3)(1..9) := ASUnb.Slice(Document(1), -- Characters 80-88
- 80,
- ASUnb.Length(Document(1)));
-
-
- -- Break the second unbounded string into the appropriate length.
- -- It is only twelve characters in length, so the entire unbounded
- -- string will be placed on one string of the output object.
-
- Camera_Copy(4)(1..ASUnb.Length(Document(2))) :=
- ASUnb.To_String(ASUnb.Head(Document(2),
- ASUnb.Length(Document(2))));
-
- end Create_Camera_Ready_Copy;
-
-
- -----
-
-
- function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type)
- return Boolean is
- begin
-
- -- Evaluate strings for equality, using the operators defined in
- -- package Ada.Strings.Unbounded. The less than/greater than or
- -- equal comparisons should evaluate to "equals => True".
-
- if ASUnb.To_Unbounded_String(Draft(1)) = -- "="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(1)) and
- ASUnb.To_Unbounded_String(Draft(2)) <= -- "<="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(2)) and
- ASUnb.To_Unbounded_String(Draft(3)) >= -- ">="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(3)) and
- ASUnb.To_Unbounded_String(Draft(4)) = -- "="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(4))
- then
- return True;
- else
- return False;
- end if;
-
- end Valid_Proofread;
-
-
- -----
-
-
- begin
-
- -- Enter text into the unbounded string paragraphs of the document.
-
- Enter_Text_Into_Document (Pamphlet);
-
-
- -- Reformat the unbounded strings into fixed string format.
-
- Create_Camera_Ready_Copy (Document => Pamphlet,
- Camera_Copy => Camera_Ready_Copy);
-
-
- -- Verify the conversion process.
-
- if not Valid_Proofread (Draft => Camera_Ready_Copy,
- Master => TC_Finished_Product)
- then
- Report.Failed ("Incorrect string processing result");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4010;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a
deleted file mode 100644
index 05388a0..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXA4011.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 subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms To_Unbounded_String, "&", ">", "<", Element,
--- Replace_Element, Count, Find_Token, Translate, Trim, Delete, and
--- "*".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the subprograms provided in this package.
---
--- This test uses a variety of the subprograms defined in the unbounded
--- string package in ways typical of common usage, with different
--- combinations of available subprograms being used to accomplish
--- similar unbounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 95 SAIC Test description modification.
--- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4011 is
-begin
-
- Report.Test ("CXA4011", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASUnb renames Ada.Strings.Unbounded;
- use Ada.Strings;
- use type Maps.Character_Set;
- use type ASUnb.Unbounded_String;
-
- Cad_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("cad");
-
- Complete_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Incomplete") &
- Ada.Strings.Space &
- ASUnb.To_Unbounded_String("String");
-
- Incomplete_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("ncomplete Strin");
-
- Incorrect_Spelling : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Guob Dai");
-
- Magic_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("abracadabra");
-
- Incantation : ASUnb.Unbounded_String := Magic_String;
-
-
- A_Small_G : Character := 'g';
- A_Small_D : Character := 'd';
-
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- B_Set : Maps.Character_Set := Maps.To_Set('b');
- AB_Set : Maps.Character_Set := Maps."OR"(Maps.To_Set('a'), B_Set);
-
- Code_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "abcd", To => "wxyz");
- Reverse_Code_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "wxyz", To => "abcd");
- Non_Existent_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "jkl", To => "mno");
-
-
- Token_Start : Positive;
- Token_End : Natural := 0;
- Matching_Letters : Natural := 0;
-
-
- begin
-
- -- "&"
-
- -- Prepend an 'I' and append a 'g' to the string.
- Incomplete_String := ASUnb."&"('I', Incomplete_String); -- Char & Unb
- Incomplete_String := ASUnb."&"(Incomplete_String,
- A_Small_G); -- Unb & Char
-
- if Incomplete_String < Complete_String or
- Incomplete_String > Complete_String or
- Incomplete_String /= Complete_String
- then
- Report.Failed("Incorrect result from use of ""&"" operator");
- end if;
-
-
- -- Element
-
- -- Last element of the unbounded string should be a 'g'.
- if ASUnb.Element(Incomplete_String, ASUnb.Length(Incomplete_String)) /=
- A_Small_G
- then
- Report.Failed("Incorrect result from use of Function Element - 1");
- end if;
-
- if ASUnb.Element(Incomplete_String, 2) /=
- ASUnb.Element(ASUnb.Tail(Incomplete_String, 2), 1) or
- ASUnb.Element(ASUnb.Head(Incomplete_String, 4), 2) /=
- ASUnb.Element(ASUnb.To_Unbounded_String("wnqz"), 2)
- then
- Report.Failed("Incorrect result from use of Function Element - 2");
- end if;
-
-
- -- Replace_Element
-
- -- The unbounded string Incorrect_Spelling starts as "Guob Dai", and
- -- is transformed by the following three procedure calls to "Good Day".
-
- ASUnb.Replace_Element(Incorrect_Spelling, 2, 'o');
-
- ASUnb.Replace_Element(Incorrect_Spelling,
- ASUnb.Index(Incorrect_Spelling, B_Set),
- A_Small_D);
-
- ASUnb.Replace_Element(Source => Incorrect_Spelling,
- Index => ASUnb.Length(Incorrect_Spelling),
- By => 'y');
-
- if Incorrect_Spelling /= ASUnb.To_Unbounded_String("Good Day") then
- Report.Failed("Incorrect result from Procedure Replace_Element");
- end if;
-
-
- -- Count
-
- -- Determine the number of characters in the unbounded string that
- -- are contained in the set.
-
- Matching_Letters := ASUnb.Count(Source => Magic_String,
- Set => ABCD_Set);
-
- if Matching_Letters /= 9 then
- Report.Failed
- ("Incorrect result from Function Count with Set parameter");
- end if;
-
- -- Determine the number of occurrences of the following pattern strings
- -- in the unbounded string Magic_String.
-
- if ASUnb.Count(Magic_String, "ab") /=
- (ASUnb.Count(Magic_String, "ac") + ASUnb.Count(Magic_String, "ad")) or
- ASUnb.Count(Magic_String, "ab") /= 2
- then
- Report.Failed
- ("Incorrect result from Function Count with String parameter");
- end if;
-
-
- -- Find_Token
-
- ASUnb.Find_Token(Magic_String, -- Find location of first "ab".
- AB_Set, -- Should be (1..2).
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Natural(Token_Start) /= ASUnb.To_String(Magic_String)'First or
- Token_End /= ASUnb.Index(Magic_String, B_Set)
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 1");
- end if;
-
-
- ASUnb.Find_Token(Source => Magic_String, -- Find location of char 'r'
- Set => ABCD_Set, -- in string, should be (3..3)
- Test => Ada.Strings.Outside,
- First => Token_Start,
- Last => Token_End);
-
- if Natural(Token_Start) /= 3 or
- Token_End /= 3 then
- Report.Failed("Incorrect result from Procedure Find_Token - 2");
- end if;
-
-
- ASUnb.Find_Token(Magic_String, -- No 'g' is in the string, so
- Maps.To_Set(A_Small_G), -- the result parameters should
- Ada.Strings.Inside, -- be First = Source'First and
- First => Token_Start, -- Last = 0.
- Last => Token_End);
-
- if Token_Start /= ASUnb.To_String(Magic_String)'First or
- Token_End /= 0
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 3");
- end if;
-
-
- -- Translate
-
- -- Use a mapping ("abcd" -> "wxyz") to transform the contents of
- -- the unbounded string.
- -- Magic_String = "abracadabra"
-
- Incantation := ASUnb.Translate(Magic_String, Code_Map);
-
- if Incantation /= ASUnb.To_Unbounded_String("wxrwywzwxrw") then
- Report.Failed("Incorrect result from Function Translate");
- end if;
-
- -- Use the inverse mapping of the one above to return the "translated"
- -- unbounded string to its original form.
-
- ASUnb.Translate(Incantation, Reverse_Code_Map);
-
- -- The map contained in the following call to Translate contains one
- -- element, and this element is not found in the unbounded string, so
- -- this call to Translate should have no effect on the unbounded string.
-
- if Incantation /= ASUnb.Translate(Magic_String, Non_Existent_Map) then
- Report.Failed("Incorrect result from Procedure Translate");
- end if;
-
-
- -- Trim
-
- Trim_Block:
- declare
-
- XYZ_Set : Maps.Character_Set := Maps.To_Set("xyz");
- PQR_Set : Maps.Character_Set := Maps.To_Set("pqr");
-
- Pad : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Pad");
-
- The_New_Ada : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Ada9X");
-
- Space_Array : array (1..4) of ASUnb.Unbounded_String :=
- (ASUnb.To_Unbounded_String(" Pad "),
- ASUnb.To_Unbounded_String("Pad "),
- ASUnb.To_Unbounded_String(" Pad"),
- Pad);
-
- String_Array : array (1..5) of ASUnb.Unbounded_String :=
- (ASUnb.To_Unbounded_String("xyzxAda9Xpqr"),
- ASUnb.To_Unbounded_String("Ada9Xqqrp"),
- ASUnb.To_Unbounded_String("zxyxAda9Xqpqr"),
- ASUnb.To_Unbounded_String("xxxyAda9X"),
- The_New_Ada);
-
- begin
-
- -- Examine the version of Trim that removes blanks from
- -- the left and/or right of a string.
-
- for i in 1..4 loop
- if ASUnb.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then
- Report.Failed("Incorrect result from Trim for spaces - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- Examine the version of Trim that removes set characters from
- -- the left and right of a string.
-
- for i in 1..5 loop
- if ASUnb.Trim(String_Array(i),
- Left => XYZ_Set,
- Right => PQR_Set) /= The_New_Ada then
- Report.Failed
- ("Incorrect result from Trim for set characters - " &
- Integer'Image(i));
- end if;
- end loop;
-
- end Trim_Block;
-
-
- -- Delete
-
- -- Use the Delete function to remove the first four and last four
- -- characters from the string.
-
- if ASUnb.Delete(Source => ASUnb.Delete(Magic_String,
- 8,
- ASUnb.Length(Magic_String)),
- From => ASUnb.To_String(Magic_String)'First,
- Through => 4) /=
- Cad_String
- then
- Report.Failed("Incorrect results from Function Delete");
- end if;
-
-
- -- Constructors ("*")
-
- Constructor_Block:
- declare
-
- SOS : ASUnb.Unbounded_String;
-
- Dot : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Dot_");
- Dash : constant String := "Dash_";
-
- Distress : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Dot_Dot_Dot_") &
- ASUnb.To_Unbounded_String("Dash_Dash_Dash_") &
- ASUnb.To_Unbounded_String("Dot_Dot_Dot");
-
- Repeat : constant Natural := 3;
- Separator : constant Character := '_';
-
- Separator_Set : Maps.Character_Set := Maps.To_Set(Separator);
-
- begin
-
- -- Use the following constructor forms to construct the string
- -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the
- -- trailing underscore in the string is removed in the call to
- -- Trim in the If statement condition.
-
- SOS := ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str)
-
- SOS := SOS &
- ASUnb."*"(Repeat, Dash) & -- "*"(#, Str)
- ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str)
-
- if ASUnb.Trim(SOS, Maps.Null_Set, Separator_Set) /= Distress then
- Report.Failed("Incorrect results from Function ""*""");
- end if;
-
- end Constructor_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a
deleted file mode 100644
index 5ab12b6..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CXA4012.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 types, operations, and other entities defined within
--- the package Ada.Strings.Wide_Maps are available and produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test demonstrates the availability and function of the types and
--- operations defined in package Ada.Strings.Wide_Maps. It demonstrates
--- the use of these types and functions as they would be used in common
--- programming practice.
--- Wide_Character set creation, assignment, and comparison are evaluated
--- in this test. Each of the functions provided in package
--- Ada.Strings.Wide_Maps is utilized in creating or manipulating set
--- objects, and the function results are evaluated for correctness.
--- Wide_Character sequences are examined using the functions provided for
--- manipulating objects of this type. Likewise, Wide_Character maps are
--- created, and their contents evaluated. Exception raising conditions
--- from the function To_Mapping are also created.
--- Note: Throughout this test, the set logical operators are printed in
--- capital letters to enhance their visibility.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-
-package CXA40120 is
-
- function Equiv (Ch : Character) return Wide_Character;
- function Equiv (Str : String)
- return Ada.Strings.Wide_Maps.Wide_Character_Sequence;
- function X_Map(From : Wide_Character) return Wide_Character;
-
-end CXA40120;
-
-package body CXA40120 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to certain Wide_Map
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Character_Sequences in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
- function Equiv (Str : String)
- return Ada.Strings.Wide_Maps.Wide_Character_Sequence is
- use Ada.Strings;
- WS : Wide_Maps.Wide_Character_Sequence(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
- function X_Map(From : Wide_Character) return Wide_Character is
- begin
- return Equiv('X');
- end X_Map;
-
-end CXA40120;
-
-
-
-with CXA40120;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4012 is
-
- use CXA40120;
- use Ada.Strings;
-
-begin
-
- Report.Test ("CXA4012", "Check that the types, operations, and other " &
- "entities defined within the package " &
- "Ada.Strings.Wide_Maps are available and " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use type Wide_Maps.Wide_Character_Set;
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Wide_Maps.Wide_Character_Sequence :=
- Equiv("aeiou");
- Quasi_Vowel : constant Wide_Character := Equiv('y');
-
- Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter);
- Half_Alphabet : Wide_Maps.Wide_Character_Sequence(1..MidPoint_Letter);
- Inverse_Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- Full_Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Wide_Maps.Wide_Character_Set := Wide_Maps.Null_Set;
-
- begin
-
- -- Load the alphabet string for use in creating sets.
-
- for i in 0..MidPoint_Letter-1 loop
- Half_Alphabet(i+1) :=
- Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i);
- end loop;
-
- for i in 0..Last_Letter-1 loop
- Alphabet(i+1) :=
- Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i);
- end loop;
-
-
- -- Initialize a series of Wide_Character_Set objects.
-
- Alphabet_Set := Wide_Maps.To_Set(Alphabet);
- Vowel_Set := Wide_Maps.To_Set(Vowels);
- Full_Vowel_Set := Vowel_Set OR Wide_Maps.To_Set(Quasi_Vowel);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- First_Half_Set := Wide_Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
- -- Evaluation of Set objects, operators, and functions.
-
- if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then
- Report.Failed("Incorrect set combinations using OR operator");
- end if;
-
-
- for i in Vowels'First .. Vowels'Last loop
- if not Wide_Maps.Is_In(Vowels(i), Vowel_Set) or
- not Wide_Maps.Is_In(Vowels(i), Alphabet_Set) or
- Wide_Maps.Is_In(Vowels(i), Consonant_Set)
- then
- Report.Failed("Incorrect function Is_In use with set " &
- "combinations - " & Integer'Image(i));
- end if;
- end loop;
-
-
- if Wide_Maps.Is_Subset(Vowel_Set, First_Half_Set) or
- Wide_Maps."<="(Vowel_Set, Second_Half_Set) or
- not Wide_Maps.Is_Subset(Vowel_Set, Alphabet_Set)
- then
- Report.Failed
- ("Incorrect set evaluation using Is_Subset function");
- end if;
-
-
- if not (Full_Vowel_Set = Wide_Maps.To_Set(Equiv("aeiouy"))) then
- Report.Failed("Incorrect result for ""="" set operator");
- end if;
-
-
- if not ((Vowel_Set AND First_Half_Set) OR
- (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then
- Report.Failed
- ("Incorrect result for AND, OR, or ""="" set operators");
- end if;
-
-
- if (Alphabet_Set AND Wide_Maps.Null_Set) /= Wide_Maps.Null_Set or
- (Alphabet_Set OR Wide_Maps.Null_Set) /= Alphabet_Set
- then
- Report.Failed("Incorrect result for AND or OR set operators");
- end if;
-
-
- Vowel_Set := Full_Vowel_Set;
- Vowel_Set := Vowel_Set AND (NOT Wide_Maps.To_Set(Quasi_Vowel));
-
- if not (Vowels = Wide_Maps.To_Sequence(Vowel_Set)) then
- Report.Failed("Incorrect Set to Sequence translation");
- end if;
-
-
- for i in 0..Last_Letter-1 loop
- Inverse_Alphabet(i+1) := Alphabet(Last_Letter-i);
- end loop;
-
-
- -- Wide_Character_Mapping
-
- declare
- Inverse_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Alphabet, Inverse_Alphabet);
- begin
- if Wide_Maps.Value(Wide_Maps.Identity, Equiv('b')) /=
- Wide_Maps.Value(Inverse_Map, Equiv('y'))
- then
- Report.Failed("Incorrect Inverse mapping");
- end if;
- end;
-
-
- -- Check that Translation_Error is raised when a character is
- -- repeated in the parameter "From" string.
- declare
- Bad_Map : Wide_Maps.Wide_Character_Mapping;
- begin
- Bad_Map := Wide_Maps.To_Mapping(From => Equiv("aa"),
- To => Equiv("yz"));
- Report.Failed("Exception not raised with repeated character");
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "a repeated character");
- end;
-
-
- -- Check that Translation_Error is raised when the parameters of the
- -- function To_Mapping are of unequal lengths.
- declare
- Bad_Map : Wide_Maps.Wide_Character_Mapping;
- begin
- Bad_Map := Wide_Maps.To_Mapping(Equiv("abc"), Equiv("yz"));
- Report.Failed
- ("Exception not raised with unequal parameter lengths");
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "unequal parameter lengths");
- end;
-
-
- -- Check that the access-to-subprogram type is defined and available.
- -- This provides for one Wide_Character mapping capability only.
- -- The actual mapping functionality will be tested in conjunction with
- -- the tests of subprograms defined for Wide_String handling.
-
- declare
-
- X_Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- X_Map'Access;
-
- begin
- if X_Map_Ptr(Equiv('A')) /= -- both return 'X'
- X_Map_Ptr.all(Equiv('Q'))
- then
- Report.Failed
- ("Incorrect result using access-to-subprogram values");
- end if;
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a
deleted file mode 100644
index 0f93e9d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CXA4013.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 subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Index, "*" (Wide_String constructor function),
--- Count, Trim, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain Wide_Fixed string functions
--- are used to eliminate specific substrings from portions of text.
--- A procedure is defined that will take as parameters a source
--- Wide_String along with a substring that is to be completely removed
--- from the source string. The source Wide_String is parsed using the
--- Index function, and any substring slices are replaced in the source
--- Wide_String by a series of X's (based on the length of the substring.)
--- Three lines of text are provided to this procedure, and the resulting
--- substitutions are compared with expected results to validate the
--- string processing.
--- A global accumulator is updated with the number of occurrences of the
--- substring in the source string.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4013 is
-
-begin
-
- Report.Test ("CXA4013", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- TC_Total : Natural := 0;
- Number_Of_Lines : constant := 3;
- WC : Wide_Character :=
- Wide_Character'Val(Character'Pos('X') +
- Character'Pos(Character'Last) +
- 1 );
-
- subtype WS is Wide_String (1..25);
-
- type Restricted_Words_Array_Type is
- array (1..10) of Wide_String (1..10);
-
- Restricted_Words : Restricted_Words_Array_Type :=
- (" platoon", " marines ", " Marines ",
- "north ", "south ", " east",
- " beach ", " airport", "airfield ",
- " road ");
-
- type Page_Of_Text_Type is array (1..Number_Of_Lines) of WS;
-
- Text_Page : Page_Of_Text_Type := ("The platoon of Marines ",
- "moved south on the south ",
- "road to the airfield. ");
-
- TC_Revised_Line_1 : constant Wide_String := "The XXXXXXX of XXXXXXX ";
- TC_Revised_Line_2 : constant Wide_String := "moved XXXXX on the XXXXX ";
- TC_Revised_Line_3 : constant Wide_String := "XXXX to the XXXXXXXX. ";
-
-
- function Equivalent (Left : WS; Right : Wide_String)
- return Boolean is
- begin
- for i in WS'range loop
- if Left(i) /= Right(i) then
- if Left(i) /= WC or Right(i) /= 'X' then
- return False;
- end if;
- end if;
- end loop;
- return True;
- end Equivalent;
-
- ---
-
- procedure Censor (Source_String : in out Wide_String;
- Pattern_String : in Wide_String) is
-
- use Ada.Strings.Wide_Fixed; -- allows infix notation of "*" below.
-
- -- Create a replacement string that is the same length as the
- -- pattern string being removed. Use the infix notation of the
- -- wide string constructor function.
-
- Replacement : constant Wide_String :=
- Pattern_String'Length * WC; -- "*"
-
- Going : Ada.Strings.Direction := Ada.Strings.Forward;
- Start_Pos,
- Index : Natural := Source_String'First;
-
- begin -- Censor
-
- -- Accumulate count of total replacement operations.
-
- TC_Total := TC_Total +
- Ada.Strings.Wide_Fixed.Count -- Count
- (Source => Source_String,
- Pattern => Pattern_String,
- Mapping => Ada.Strings.Wide_Maps.Identity);
- loop
-
- Index := Ada.Strings.Wide_Fixed.Index -- Index
- (Source_String(Start_Pos..Source_String'Last),
- Pattern_String,
- Going,
- Ada.Strings.Wide_Maps.Identity);
-
- exit when Index = 0; -- No matches, exit loop.
-
- -- if a match was found, modify the substring.
- Ada.Strings.Wide_Fixed.Replace_Slice -- Replace_Slice
- (Source_String,
- Index,
- Index + Pattern_String'Length - 1,
- Replacement);
- Start_Pos := Index + Pattern_String'Length;
-
- end loop;
-
- end Censor;
-
-
- begin
-
- -- Invoke Censor subprogram to cleanse text.
- -- Loop through each line of text, and check for the presence of each
- -- restricted word.
- -- Use the Trim function to eliminate leading or trailing blanks from
- -- the restricted word parameters.
-
- for Line in 1..Number_Of_Lines loop
- for Word in Restricted_Words'Range loop
- Censor (Text_Page(Line), -- Trim
- Ada.Strings.Wide_Fixed.Trim(Restricted_Words(Word),
- Ada.Strings.Both));
- end loop;
- end loop;
-
-
- -- Validate results.
-
- if TC_Total /= 6 then
- Report.Failed ("Incorrect number of substitutions performed");
- end if;
-
- if not Equivalent (Text_Page(1), TC_Revised_Line_1) then
- Report.Failed ("Incorrect substitutions on Line 1");
- end if;
-
- if not Equivalent (Text_Page(2), TC_Revised_Line_2) then
- Report.Failed ("Incorrect substitutions on Line 2");
- end if;
-
- if not Equivalent (Text_Page(3), TC_Revised_Line_3) then
- Report.Failed ("Incorrect substitutions on Line 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4013;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a
deleted file mode 100644
index 6e26a03..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a
+++ /dev/null
@@ -1,359 +0,0 @@
--- CXA4014.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 subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Find_Token, Head, Index, Index_Non_Blank, Move,
--- Overwrite, and Replace_Slice, Tail, and Translate.
--- Use the access-to-subprogram mapping version of Translate (function
--- and procedure).
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain wide fixed string operations could
--- be used in wide string information processing. A procedure is defined
--- that will extract portions of a 50 character string that correspond to
--- certain data items (i.e., name, address, state, zip code). These
--- parsed items will then be added to the appropriate fields of data
--- base elements. These data base elements are then compared for
--- accuracy against a similar set of predefined data base
--- elements.
--- A variety of wide fixed string processing subprograms are used in this
--- test. Each parsing operation attempts to use a different combination
--- of the available subprograms to accomplish the same goal, therefore
--- continuity of approach to wide string parsing is not seen in this
--- test.
--- However, a wide variety of possible approaches are demonstrated, while
--- exercising a large number of the total predefined subprograms of
--- package Ada.Strings.Wide_Fixed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-package CXA40140 is
-
- UnderScore : Wide_Character := '_';
- Blank : Wide_Character := ' ';
-
- -- Function providing a mapping to a blank Wide_Character.
- function US_to_Blank_Map (From : Wide_Character) return Wide_Character;
-
-end CXA40140;
-
-package body CXA40140 is
-
- function US_to_Blank_Map (From : Wide_Character) return Wide_Character is
- begin
- if From = UnderScore then
- return Blank;
- else
- return From;
- end if;
- end US_to_Blank_Map;
-
-end CXA40140;
-
-
-with CXA40140;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4014 is
- use CXA40140;
-begin
-
- Report.Test ("CXA4014", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- Number_Of_Info_Strings : constant Natural := 3;
- DB_Size : constant Natural := Number_Of_Info_Strings;
- Count : Natural := 0;
- Finished_Processing : Boolean := False;
- Blank_Wide_String : constant Wide_String := " ";
-
- subtype Info_Wide_String_Type is Wide_String (1..50);
- type Info_Wide_String_Storage_Type is
- array (1..Number_Of_Info_Strings) of Info_Wide_String_Type;
-
-
- subtype Name_Type is Wide_String (1..10);
- subtype Street_Number_Type is Wide_String (1..5);
- subtype Street_Name_Type is Wide_String (1..10);
- subtype City_Type is Wide_String (1..10);
- subtype State_Type is Wide_String (1..2);
- subtype Zip_Code_Type is Wide_String (1..5);
-
- type Data_Base_Element_Type is
- record
- Name : Name_Type := (others => ' ');
- Street_Number : Street_Number_Type := (others => ' ');
- Street_Name : Street_Name_Type := (others => ' ');
- City : City_Type := (others => ' ');
- State : State_Type := (others => ' ');
- Zip_Code : Zip_Code_Type := (others => ' ');
- end record;
-
- type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type;
-
- Data_Base : Data_Base_Type;
-
- ---
-
- Info_String_1 : Info_Wide_String_Type :=
- "Joe_Jones 123 Sixth_St San_Diego CA 98765";
-
- Info_String_2 : Info_Wide_String_Type :=
- "Sam_Smith 56789 S._Seventh Carlsbad CA 92177";
-
- Info_String_3 : Info_Wide_String_Type :=
- "Jane_Brown 1219 Info_Lane Tuscon AZ 85643";
-
-
- Info_Strings : Info_Wide_String_Storage_Type :=
- (1 => Info_String_1,
- 2 => Info_String_2,
- 3 => Info_String_3);
-
-
-
- TC_DB_Element_1 : Data_Base_Element_Type :=
- ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765");
-
- TC_DB_Element_2 : Data_Base_Element_Type :=
- ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177");
-
- TC_DB_Element_3 : Data_Base_Element_Type :=
- ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643");
-
- TC_Data_Base : Data_Base_Type := (TC_DB_Element_1,
- TC_DB_Element_2,
- TC_DB_Element_3);
-
- ---
-
-
- procedure Store_Information
- (Info_String : in Info_Wide_String_Type;
- DB_Record : in out Data_Base_Element_Type) is
-
- package AS renames Ada.Strings;
- use type AS.Wide_Maps.Wide_Character_Set;
-
- Start,
- Stop : Natural := 0;
-
- Numeric_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("0123456789");
-
- Cal : constant
- AS.Wide_Maps.Wide_Character_Sequence := "CA";
- California_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set(Cal);
- Arizona_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("AZ");
- Nevada_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("NV");
-
- Blank_Ftn_Ptr : AS.Wide_Maps.Wide_Character_Mapping_Function :=
- US_to_Blank_Map'Access;
-
- begin
-
- -- Find the starting position of the name field (first non-blank),
- -- then, from that position, find the end of the name field (first
- -- blank).
-
- Start := AS.Wide_Fixed.Index_Non_Blank(Info_String);
- Stop := AS.Wide_Fixed.Index (Info_String(Start..Info_String'Length),
- AS.Wide_Maps.To_Set(Blank),
- AS.Inside,
- AS.Forward) - 1 ;
-
- -- Store the name field in the data base element field for "Name".
-
- DB_Record.Name := AS.Wide_Fixed.Head(Info_String(1..Stop),
- DB_Record.Name'Length);
-
- -- Replace any underscore characters in the name field
- -- that were used to separate first/middle/last names.
- -- Use the overloaded version of Translate that takes an
- -- access-to-subprogram value.
-
- AS.Wide_Fixed.Translate (DB_Record.Name, Blank_Ftn_Ptr);
-
-
- -- Continue the extraction process; now find the position of
- -- the street number in the string.
-
- Start := Stop + 1;
-
- AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length),
- Numeric_Set,
- AS.Inside,
- Start,
- Stop);
-
- -- Store the street number field in the appropriate data base
- -- element.
- -- No modification of the default parameters of procedure Move
- -- is required.
-
- AS.Wide_Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.Street_Number);
-
-
- -- Continue the extraction process; find the street name in the
- -- info string. Skip blanks to the start of the street name, then
- -- search for the index of the next blank character in the string.
-
- Start := AS.Wide_Fixed.Index_Non_Blank
- (Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_Wide_String) - 1;
-
- -- Store the street name in the appropriate data base element field.
-
- AS.Wide_Fixed.Overwrite(DB_Record.Street_Name,
- 1,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the street name field
- -- that were used as word separation with blanks. Again, use the
- -- access-to-subprogram value to provide the mapping.
-
- DB_Record.Street_Name :=
- AS.Wide_Fixed.Translate(DB_Record.Street_Name,
- Blank_Ftn_Ptr);
-
-
- -- Continue the extraction; remove the city name from the string.
-
- Start := AS.Wide_Fixed.Index_Non_Blank
- (Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_Wide_String) - 1;
-
- -- Store the city name field in the appropriate data base element.
-
- AS.Wide_Fixed.Replace_Slice(DB_Record.City,
- 1,
- DB_Record.City'Length,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the city name field
- -- that were used as word separation.
-
- AS.Wide_Fixed.Translate (DB_Record.City,
- Blank_Ftn_Ptr);
-
-
- -- Continue the extraction; remove the state identifier from the
- -- info string.
-
- Start := Stop + 1;
-
- AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length),
- AS.Wide_Maps."OR"(California_Set,
- AS.Wide_Maps."OR"(Nevada_Set,
- Arizona_Set)),
- AS.Inside,
- Start,
- Stop);
-
- -- Store the state indicator into the data base element.
-
- AS.Wide_Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.State,
- Drop => Ada.Strings.Right,
- Justify => Ada.Strings.Left,
- Pad => AS.Wide_Space);
-
-
- -- Continue the extraction process; remove the final data item in
- -- the info string, the zip code, and place it into the
- -- corresponding data base element.
-
- DB_Record.Zip_Code :=
- AS.Wide_Fixed.Tail(Info_String, DB_Record.Zip_Code'Length);
-
- exception
- when AS.Length_Error =>
- Report.Failed ("Length_Error raised in procedure");
- when AS.Pattern_Error =>
- Report.Failed ("Pattern_Error raised in procedure");
- when AS.Translation_Error =>
- Report.Failed ("Translation_Error raised in procedure");
- when others =>
- Report.Failed ("Exception raised in procedure");
- end Store_Information;
-
-
- begin
-
- -- Loop thru the information strings, extract the name and address
- -- information, place this info into elements of the data base.
-
- while not Finished_Processing loop
-
- Count := Count + 1;
-
- Store_Information (Info_Strings(Count), Data_Base(Count));
-
- Finished_Processing := (Count = Number_Of_Info_Strings);
-
- end loop;
-
-
- -- Verify that the string processing was successful.
-
- for i in 1..DB_Size loop
- if Data_Base(i) /= TC_Data_Base(i) then
- Report.Failed
- ("Data processing error on record " & Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4014;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a
deleted file mode 100644
index 83fad3a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a
+++ /dev/null
@@ -1,580 +0,0 @@
--- CXA4015.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 subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Count, Find_Token, Index, Index_Non_Blank, and
--- Move.
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4013,14,16 will provide
--- coverage of the functionality found in Ada.Strings.Wide_Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC Corrected various accesssibility problems and
--- expected result strings for ACVC 2.0.1.
---
---!
-
-package CXA40150 is
-
- -- Wide Character mapping function defined for use with specific
- -- versions of functions Index and Count.
-
- function AK_to_ZQ_Mapping (From : Wide_Character) return Wide_Character;
-
-end CXA40150;
-
-package body CXA40150 is
-
- function AK_to_ZQ_Mapping (From : Wide_Character)
- return Wide_Character is
- begin
- if From = 'a' then
- return 'z';
- elsif From = 'k' then
- return 'q';
- else
- return From;
- end if;
- end AK_to_ZQ_Mapping;
-
-end CXA40150;
-
-
-with CXA40150;
-with Report;
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4015 is
-begin
-
- Report.Test("CXA4015", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Fixed are available, " &
- "and that they produce correct results");
-
-
- Test_Block:
- declare
-
- use CXA40150;
-
- package ASF renames Ada.Strings.Wide_Fixed;
- package Maps renames Ada.Strings.Wide_Maps;
-
- Result_String : Wide_String(1..10) :=
- (others => Ada.Strings.Wide_Space);
-
- Source_String1 : Wide_String(1..5) := "abcde"; -- odd len Wide_String
- Source_String2 : Wide_String(1..6) := "abcdef"; -- even len Wide_String
- Source_String3 : Wide_String(1..12) := "abcdefghijkl";
- Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last 2 ch pad
- Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first 2 ch pad
- Source_String6 : Wide_String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd");
- ABCD_Set : Maps.Wide_Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Wide_Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
-
- -- Access-to-Subprogram object defined for use with specific versions of
- -- functions Index and Count.
-
- Map_Ptr : Maps.Wide_Character_Mapping_Function :=
- AK_to_ZQ_Mapping'Access;
-
-
- begin
-
-
- -- Procedure Move
- -- Evaluate the Procedure Move with various combinations of
- -- parameters.
-
- -- Justify = Left (default case)
-
- ASF.Move(Source => Source_String1, -- "abcde"
- Target => Result_String);
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Move with Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Move(Source => Source_String2, -- "abcdef"
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Move with Justify = Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Move(Source_String1, -- "abcde"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result from Move with Justify = Center-1");
- end if;
-
- ASF.Move(Source_String2, -- "abcdef"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Move with Justify = Center-2");
- end if;
-
- -- When the source Wide_String is longer than the target Wide_String,
- -- several cases can be examined, with the results depending on the
- -- value of the Drop parameter.
-
- -- Drop = Left
-
- ASF.Move(Source => Source_String3, -- "abcdefghijkl"
- Target => Result_String,
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Move with Drop = Left");
- end if;
-
- -- Drop = Right
-
- ASF.Move(Source_String3, Result_String, Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Move with Drop = Right");
- end if;
-
- -- Drop = Error
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Move(Source => Source_String4, -- "abcdefghij "
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Move(Source_String5, -- " cdefghijkl"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Move(Source_String3, -- 12 characters, no Pad.
- Result_String, -- 10 characters
- Ada.Strings.Error,
- Ada.Strings.Left);
-
- Report.Failed("Length_Error not raised by Move - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised by Move - 1");
- end;
-
-
-
- -- Function Index
- -- (Other usage examples of this function found in CXA4013-14.)
- -- Check when the pattern is not found in the source.
-
- if ASF.Index("abcdef", "gh") /= 0 or
- ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source
- ASF.Index("xyz",
- "abcde",
- Ada.Strings.Backward) /= 0 or
- ASF.Index("", "ab") /= 0 or -- null source Wide_String.
- ASF.Index("abcde", " ") /= 0 -- blank pattern.
- then
- Report.Failed("Incorrect result from Index, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is the
- -- null Wide_String.
- begin
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "", -- null pattern Wide_String.
- Ada.Strings.Forward);
- Report.Failed("Pattern_Error not raised by Index");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Index, null pattern");
- end;
-
- -- Use the search direction "backward" to locate the particular
- -- pattern within the source Wide_String.
-
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "de", -- slice 4..5, 10..11
- Ada.Strings.Backward); -- search from right end.
-
- if Location /= 10 then
- Report.Failed("Incorrect result from Index going Backward");
- end if;
-
-
-
- -- Function Index
- -- Use the version of Index that takes a Wide_Character_Mapping_Function
- -- parameter.
- -- Use the search directions Forward and Backward to locate the
- -- particular pattern wide string within the source wide string.
-
- Location := ASF.Index("akzqefakzqef",
- "qzq", -- slice 8..10
- Ada.Strings.Backward,
- Map_Ptr); -- perform 'a' to 'z', 'k' to 'q'
- -- translation.
- if Location /= 8 then
- Report.Failed
- ("Incorrect result from Index w/map ptr going Backward");
- end if;
-
- Location := ASF.Index("ddkkddakcdakdefcadckdfzaaqd",
- "zq", -- slice 7..8
- Ada.Strings.Forward,
- Map_Ptr); -- perform 'a' to 'z', 'k' to 'q'
- -- translation.
- if Location /= 7 then
- Report.Failed
- ("Incorrect result from Index w/map ptr going Forward");
- end if;
-
-
- if ASF.Index("aakkzq", "zq", Ada.Strings.Forward, Map_Ptr) /= 2 or
- ASF.Index("qzedka", "qz", Ada.Strings.Backward, Map_Ptr) /= 5 or
- ASF.Index("zazaza", "zzzz", Ada.Strings.Backward, Map_Ptr) /= 3 or
- ASF.Index("kka", "qqz", Ada.Strings.Forward, Map_Ptr) /= 1
- then
- Report.Failed("Incorrect result from Index w/map ptr");
- end if;
-
-
- -- Check when the pattern wide string is not found in the source.
-
- if ASF.Index("akzqef", "kzq", Ada.Strings.Forward, Map_Ptr) /= 0 or
- ASF.Index("abcde", "abcdef", Ada.Strings.Backward, Map_Ptr) /= 0 or
- ASF.Index("xyz", "akzde", Ada.Strings.Backward, Map_Ptr) /= 0 or
- ASF.Index("", "zq", Ada.Strings.Forward, Map_Ptr) /= 0 or
- ASF.Index("akcde", " ", Ada.Strings.Backward, Map_Ptr) /= 0
- then
- Report.Failed
- ("Incorrect result from Index w/map ptr, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is a
- -- null Wide_String.
- begin
- Location := ASF.Index("akzqefakqzef",
- "", -- null pattern Wide_String.
- Ada.Strings.Forward,
- Map_Ptr);
- Report.Failed("Pattern_Error not raised by Index w/map ptr");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Index w/map ptr, null pattern");
- end;
-
-
-
- -- Function Index
- -- Using the version of Index testing wide character set membership,
- -- check combinations of forward/backward, inside/outside parameter
- -- configurations.
-
- if ASF.Index(Source => Source_String1, -- "abcde"
- Set => CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3.
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 12 or -- 'f' at position 12
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 10 or -- 'd' at position 10
- ASF.Index("cdcdcdcdacdcdcdcd",
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 9 -- 'a' at position 9
- then
- Report.Failed("Incorrect result from function Index for sets - 1");
- end if;
-
- -- Additional interesting uses/combinations using Index for sets.
-
- if ASF.Index("cd", -- same size, str-set
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Forward) /= 1 or -- 'c' at position 1
- ASF.Index("abcd", -- same size, str-set,
- Maps.To_Set("efgh"), -- different contents.
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 1 or
- ASF.Index("abccd", -- set > Wide_String
- Maps.To_Set("acegik"),
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 or -- 'c' at position 4
- ASF.Index("abcde",
- Maps.Null_Set) /= 0 or
- ASF.Index("", -- Null string.
- CD_Set) /= 0 or
- ASF.Index("abc ab", -- blank included
- Maps.To_Set("e "), -- in Wide_String and
- Ada.Strings.Inside, -- set.
- Ada.Strings.Backward) /= 4 -- blank in Wide_Str.
- then
- Report.Failed("Incorrect result from function Index for sets - 2");
- end if;
-
-
-
- -- Function Index_Non_Blank.
- -- (Other usage examples of this function found in CXA4013-14.)
-
-
- if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij "
- Going => Ada.Strings.Backward) /= 10 or
- ASF.Index_Non_Blank("abc def ghi jkl ",
- Ada.Strings.Backward) /= 15 or
- ASF.Index_Non_Blank(" abcdef") /= 3 or
- ASF.Index_Non_Blank(" ") /= 0
- then
- Report.Failed("Incorrect result from Index_Non_Blank");
- end if;
-
-
-
- -- Function Count
- -- (Other usage examples of this function found in CXA4013-14.)
-
- if ASF.Count("abababa", "aba") /= 2 or
- ASF.Count("abababa", "ab" ) /= 3 or
- ASF.Count("babababa", "ab") /= 3 or
- ASF.Count("abaabaaba", "aba") /= 3 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20
- then
- Report.Failed("Incorrect result from Function Count");
- end if;
-
- -- Determine the number of slices of Source that when mapped to a
- -- non-identity map, match the pattern Wide_String.
-
- Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef"
- "xy",
- CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y'
-
- if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6
- Report.Failed("Incorrect result from Count with non-identity map");
- end if;
-
- -- If the pattern supplied to Function Count is the null Wide_String,
- -- then Pattern_Error is propagated.
- declare
- The_Null_Wide_String : constant Wide_String := "";
- begin
- Slice_Count := ASF.Count(Source_String6, The_Null_Wide_String);
- Report.Failed("Pattern_Error not raised by Function Count");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Count with null pattern");
- end;
-
-
-
-
- -- Function Count
- -- Use the version of Count that takes a Wide_Character_Mapping_Function
- -- value as the basis of its source mapping.
-
- if ASF.Count("akakaka", "zqz", Map_Ptr) /= 2 or
- ASF.Count("akakaka", "qz", Map_Ptr) /= 3 or
- ASF.Count("kakakaka", "q", Map_Ptr) /= 4 or
- ASF.Count("zzqaakzaqzzk", "zzq", Map_Ptr) /= 4 or
- ASF.Count(" ", "z", Map_Ptr) /= 0 or
- ASF.Count("", "qz", Map_Ptr) /= 0 or
- ASF.Count("abbababab", "zq", Map_Ptr) /= 0 or
- ASF.Count("aaaaaaaaaaaaaaaaaakk", "zqq", Map_Ptr) /= 1 or
- ASF.Count("azaazaazzzaaaaazzzza", "z", Map_Ptr) /= 20
- then
- Report.Failed("Incorrect result from Function Count w/map ptr");
- end if;
-
- -- If the pattern supplied to Function Count is a null Wide_String,
- -- then Pattern_Error is propagated.
- declare
- The_Null_Wide_String : constant Wide_String := "";
- begin
- Slice_Count := ASF.Count(Source_String6,
- The_Null_Wide_String,
- Map_Ptr);
- Report.Failed
- ("Pattern_Error not raised by Function Count w/map ptr");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed
- ("Incorrect exception from Count w/map ptr, null pattern");
- end;
-
-
-
-
- -- Function Count returning the number of characters in a particular
- -- set that are found in source Wide_String.
-
- if ASF.Count(Source_String6, CD_Set) /= 4 or -- 2 'c' and 'd' chars.
- ASF.Count("cddaccdaccdd", CD_Set) /= 10
- then
- Report.Failed("Incorrect result from Count with set");
- end if;
-
-
-
- -- Function Find_Token.
- -- (Other usage examples of this function found in CXA4013-14.)
-
- ASF.Find_Token(Source => Source_String6, -- First slice with no
- Set => ABCD_Set, -- 'a', 'b', 'c', or 'd'
- Test => Ada.Strings.Outside, -- is "ef" at 5..6.
- First => Slice_Start,
- Last => Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 6 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
- -- If no appropriate slice is contained by the source Wide_String,
- -- then the value returned in Last is zero, and the value in First is
- -- Source'First.
-
- ASF.Find_Token(Source_String6, -- "abcdefabcdef"
- A_to_F_Set, -- Set of characters 'a' thru 'f'.
- Ada.Strings.Outside, -- No characters outside this set.
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= Source_String6'First or Slice_End /= 0 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
- -- Additional testing of Find_Token.
-
- ASF.Find_Token("eabcdabcddcab",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 2 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
- ASF.Find_Token("efghijklabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 8 then
- Report.Failed("Incorrect result from Find_Token - 4");
- end if;
-
- ASF.Find_Token("abcdefgabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 7 then
- Report.Failed("Incorrect result from Find_Token - 5");
- end if;
-
- ASF.Find_Token("abcdcbabcdcba",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 6");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a
deleted file mode 100644
index 00dcdcd..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a
+++ /dev/null
@@ -1,685 +0,0 @@
--- CXA4016.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 subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice,
--- Tail, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4013-15 will provide
--- coverage of the functionality found in package Ada.Strings.Wide_Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test. They represent
--- individual usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 94 SAIC Modified comments in a subtest failure message.
--- 06 Nov 95 SAIC Corrected subtest results for ACVC 2.0.1
--- 14 Mar 01 RLB Added checks that the lower bound is 1, similar
--- to CXA4005. These changes were made to test
--- Defect Report 8652/0049, as reflected in
--- Technical Corrigendum 1.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4016 is
-
- type TC_Name_Holder is access String;
- Name : TC_Name_Holder;
-
- function TC_Check (S : Wide_String) return Wide_String is
- begin
- if S'First /= 1 then
- Report.Failed ("Lower bound of result of function " & Name.all &
- " is" & Integer'Image (S'First));
- end if;
- return S;
- end TC_Check;
-
- procedure TC_Set_Name (N : String) is
- begin
- Name := new String'(N);
- end TC_Set_Name;
-
-begin
-
- Report.Test("CXA4016", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASW renames Ada.Strings.Wide_Fixed;
- package Wide_Maps renames Ada.Strings.Wide_Maps;
-
- Result_String,
- Delete_String,
- Insert_String,
- Trim_String,
- Overwrite_String : Wide_String(1..10) :=
- (others => Ada.Strings.Wide_Space);
- Replace_String : Wide_String(10..30) :=
- (others => Ada.Strings.Wide_Space);
-
- Source_String1 : Wide_String(1..5) := "abcde"; -- odd len wd str
- Source_String2 : Wide_String(1..6) := "abcdef"; -- even len wd str
- Source_String3 : Wide_String(1..12) := "abcdefghijkl";
- Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : Wide_String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("cd");
- X_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set('x');
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("abcd");
- A_to_F_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Replace_Slice
- -- The functionality of this procedure is similar to procedure Move,
- -- and is tested here in the same manner, evaluated with various
- -- combinations of parameters.
-
- -- Index_Error propagation when Low > Source'Last + 1
-
- begin
- ASW.Replace_Slice(Result_String,
- Result_String'Last + 2, -- should raise exception
- Result_String'Last,
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 1");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 1");
- end;
-
- -- Index_Error propagation when High < Source'First - 1
-
- begin
- ASW.Replace_Slice(Replace_String(20..30),
- Replace_String'First,
- Replace_String'First - 2, -- should raise exception
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 2");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 2");
- end;
-
- -- Justify = Left (default case)
-
- Result_String := "XXXXXXXXXX";
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => 10,
- By => Source_String1); -- "abcde"
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Replace_Slice - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Replace_Slice - Justify=Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String1, -- "abcde"
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1");
- end if;
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String2, -- "abcdef"
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Replace_Slice with " &
- "Justify = Center - 2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Replace_Slice - Drop=Left");
- end if;
-
- -- Drop = Right
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result, Replace_Slice with Drop=Right");
- end if;
-
- -- Drop = Error
-
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String4, -- "abcdefghij "
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String5, -- " cdefghijkl"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Error);
-
- Report.Failed("Length_Error not raised by Replace_Slice - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 3");
- end;
-
-
- -- Function Replace_Slice
-
- TC_Set_Name ("Replace_Slice");
-
- if TC_Check (ASW.Replace_Slice("abcde", 3, 3, "x"))
- /= "abxde" or -- High = Low
- TC_Check (ASW.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or
- TC_Check (ASW.Replace_Slice("abcd", 4, 1, "xy"))
- /= "abcxyd" or -- High < Low
- TC_Check (ASW.Replace_Slice("abc", 2, 3, "x")) /= "ax" or
- TC_Check (ASW.Replace_Slice("a", 1, 1, "z")) /= "z"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 1");
- end if;
-
- if TC_Check (ASW.Replace_Slice("abcde", 5, 5, "z"))
- /= "abcdz" or -- By length 1
- TC_Check (ASW.Replace_Slice("abc", 1, 3, "xyz"))
- /= "xyz" or -- High > Low
- TC_Check (ASW.Replace_Slice("abc", 3, 2, "xy"))
- /= "abxyc" or -- insert
- TC_Check (ASW.Replace_Slice("a", 1, 1, "xyz")) /= "xyz"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 2");
- end if;
-
-
-
- -- Function Insert.
-
- TC_Set_Name ("Insert");
-
- declare
- New_String : constant Wide_String :=
- TC_Check (
- ASW.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => 2,
- New_Item => Source_String2)); -- "abcdef"
- begin
- if New_String /= "abcdefbcde" then
- Report.Failed("Incorrect result from Function Insert - 1");
- end if;
- end;
-
- if TC_Check (ASW.Insert("a", 1, "z")) /= "za" or
- TC_Check (ASW.Insert("abc", 3, "")) /= "abc" or
- TC_Check (ASW.Insert("abc", 4, "z")) /= "abcz"
- then
- Report.Failed("Incorrect result from Function Insert - 2");
- end if;
-
- begin
- if TC_Check (ASW.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => Report.Ident_Int(7),
- New_Item => Source_String2)) -- "abcdef"
- /= "babcdefcde" then
- Report.Failed("Index_Error not raised by Insert - 3A");
- else
- Report.Failed("Index_Error not raised by Insert - 3B");
- end if;
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Insert - 3");
- end;
-
-
- -- Procedure Insert
-
- -- Drop = Right
-
- ASW.Insert(Source => Insert_String,
- Before => 6,
- New_Item => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Right);
-
- if Insert_String /= " abcde" then -- last char of New_Item dropped.
- Report.Failed("Incorrect result from Insert with Drop = Right");
- end if;
-
- -- Drop = Left
-
- ASW.Insert(Source => Insert_String, -- 10 char string
- Before => 2, -- 9 chars, 2..10 available
- New_Item => Source_String3, -- 12 characters long.
- Drop => Ada.Strings.Left); -- truncate from Left.
-
- if Insert_String /= "l abcde" then -- 10 chars, leading blank.
- Report.Failed("Incorrect result from Insert with Drop=Left");
- end if;
-
- -- Drop = Error
-
- begin
- ASW.Insert(Source => Result_String, -- 10 chars
- Before => Result_String'Last,
- New_Item => "abcdefghijk",
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Insert");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
-
-
- -- Function Overwrite
-
- TC_Set_Name ("Overwrite");
-
- Overwrite_String := TC_Check (
- ASW.Overwrite(Result_String, -- 10 chars
- 1, -- starting at pos=1
- Source_String3(1..10)));
-
- if Overwrite_String /= Source_String3(1..10) then
- Report.Failed("Incorrect result from Function Overwrite - 1");
- end if;
-
-
- if TC_Check (ASW.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or
- TC_Check (ASW.Overwrite("a", 1, "xyz"))
- /= "xyz" or -- chars appended
- TC_Check (ASW.Overwrite("abc", 3, " "))
- /= "ab " or -- blanks appended
- TC_Check (ASW.Overwrite("abcde", 1, "z" )) /= "zbcde"
- then
- Report.Failed("Incorrect result from Function Overwrite - 2");
- end if;
-
-
-
- -- Procedure Overwrite, with truncation.
-
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Left);
-
- if Overwrite_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Overwrite with Drop=Left");
- end if;
-
- -- The default drop value is Right, used here.
-
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3); -- 12 characters.
-
- if Overwrite_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Overwrite with Drop=Right");
- end if;
-
- -- Drop = Error
-
- begin
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Overwrite");
- end;
-
- Overwrite_String := "ababababab";
- ASW.Overwrite(Overwrite_String, Overwrite_String'Last, "z");
- ASW.Overwrite(Overwrite_String, Overwrite_String'First,"z");
- ASW.Overwrite(Overwrite_String, 5, "zz");
-
- if Overwrite_String /= "zbabzzabaz" then
- Report.Failed("Incorrect result from Procedure Overwrite");
- end if;
-
-
-
- -- Function Delete
-
- TC_Set_Name ("Delete");
-
- declare
- New_String1 : constant Wide_String := -- Returns a 4 char wide str.
- TC_Check (ASW.Delete(Source => Source_String3,
- From => 3,
- Through => 10));
- New_String2 : constant Wide_String := -- This returns Source.
- TC_Check (ASW.Delete(Source_String3, 10, 3));
- begin
- if New_String1 /= "abkl" or
- New_String2 /= Source_String3
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
- end;
-
- if TC_Check (ASW.Delete("a", 1, 1))
- /= "" or -- Source length = 1
- TC_Check (ASW.Delete("abc", 1, 2))
- /= "c" or -- From = Source'First
- TC_Check (ASW.Delete("abc", 3, 3))
- /= "ab" or -- From = Source'Last
- TC_Check (ASW.Delete("abc", 3, 1))
- /= "abc" -- From > Through
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Procedure Delete
-
- -- Justify = Left
-
- Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij"
-
- ASW.Delete(Source => Delete_String,
- From => 6,
- Through => Delete_String'Last,
- Justify => Ada.Strings.Left,
- Pad => 'x'); -- pad with char 'x'
-
- if Delete_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Delete - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASW.Delete(Source => Delete_String, -- Remove x"s from end and
- From => 6, -- shift right.
- Through => Delete_String'Last,
- Justify => Ada.Strings.Right,
- Pad => 'x'); -- pad with char 'x' on left.
-
- if Delete_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Delete - Justify = Right");
- end if;
-
- -- Justify = Center
-
- ASW.Delete(Source => Delete_String,
- From => 1,
- Through => 5,
- Justify => Ada.Strings.Center,
- Pad => 'z');
-
- if Delete_String /= "zzabcdezzz" then -- extra pad char on right side.
- Report.Failed("Incorrect result from Delete - Justify = Center");
- end if;
-
-
-
- -- Function Trim
- -- Use non-identity character sets to perform the trim operation.
-
- TC_Set_Name ("Trim");
-
- Trim_String := "cdabcdefcd";
-
- -- Remove the "cd" from each end of the string. This will not effect
- -- the "cd" slice at 5..6.
-
- declare
- New_String : constant Wide_String :=
- TC_Check (ASW.Trim(Source => Trim_String,
- Left => CD_Set, Right => CD_Set));
- begin
- if New_String /= Source_String2 then -- string "abcdef"
- Report.Failed
- ("Incorrect result from Trim with wide character sets");
- end if;
- end;
-
- if TC_Check (ASW.Trim("abcdef", Wide_Maps.Null_Set, Wide_Maps.Null_Set))
- /= "abcdef" then
- Report.Failed("Incorrect result from Trim with Null sets");
- end if;
-
- if TC_Check (ASW.Trim("cdxx", CD_Set, X_Set)) /= "" then
- Report.Failed("Incorrect result from Trim, wide string removal");
- end if;
-
-
- -- Procedure Trim
-
- -- Justify = Right
-
- ASW.Trim(Source => Trim_String,
- Left => CD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxabcdef" then
- Report.Failed("Incorrect result from Trim with Justify = Right");
- end if;
-
- -- Justify = Left
-
- ASW.Trim(Source => Trim_String,
- Left => X_Set,
- Right => Wide_Maps.Null_Set,
- Justify => Ada.Strings.Left,
- Pad => ' ');
-
- if Trim_String /= "abcdef " then -- Padded with 4 blanks on right.
- Report.Failed("Incorrect result from Trim with Justify = Left");
- end if;
-
- -- Justify = Center
-
- ASW.Trim(Source => Trim_String,
- Left => ABCD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Center,
- Pad => 'x');
-
- if Trim_String /= "xxef xx" then -- Padded with 4 pad chars on L/R
- Report.Failed("Incorrect result from Trim with Justify = Center");
- end if;
-
-
-
- -- Function Head, testing use of padding.
-
- TC_Set_Name ("Head");
-
- -- Use the wide characters of Source_String1 ("abcde") and pad the
- -- last five wide characters of Result_String with 'x' wide characters.
-
- Result_String := TC_CHeck (ASW.Head(Source_String1, 10, 'x'));
-
- if Result_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Function Head with padding");
- end if;
-
- if TC_Check (ASW.Head(" ab ", 2)) /= " " or
- TC_Check (ASW.Head("a", 6, 'A')) /= "aAAAAA" or
- TC_Check (ASW.Head(ASW.Head("abc ", 7, 'x'), 10, 'X'))
- /= "abc xxXXX"
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail, testing use of padding.
-
- TC_Set_Name ("Tail");
-
- -- Use the wide characters of Source_String1 ("abcde") and pad the
- -- first five wide characters of Result_String with 'x' wide characters.
-
- Result_String := TC_Check (ASW.Tail(Source_String1, 10, 'x'));
-
- if Result_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Function Tail with padding");
- end if;
-
- if TC_Check (ASW.Tail("abcde ", 5))
- /= "cde " or -- blanks, back
- TC_Check (ASW.Tail(" abc ", 8, ' '))
- /= " abc " or -- blanks, front/back
- TC_Check (ASW.Tail("", 5, 'Z'))
- /= "ZZZZZ" or -- pad characters only
- TC_Check (ASW.Tail("abc", 0))
- /= "" or -- null result
- TC_Check (ASW.Tail(ASW.Tail(" abc ", 6, 'x'),
- 10,
- 'X')) /= "XXXXx abc "
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function "*" - with (Natural, Wide_String) parameters
-
- TC_Set_Name ("""*""");
-
- if TC_Check (ASW."*"(3, Source_String1)) /= "abcdeabcdeabcde" or
- TC_Check (ASW."*"(2, Source_String2)) /= Source_String6 or
- TC_Check (ASW."*"(4, Source_String1(1..2))) /= "abababab" or
- TC_Check (ASW."*"(0, Source_String1)) /= ""
- then
- Report.Failed
- ("Incorrect result from Function ""*"" with wide strings");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4016;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a
deleted file mode 100644
index 8d68868..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a
+++ /dev/null
@@ -1,337 +0,0 @@
--- CXA4017.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 subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Append, Delete, Index, Insert , Length,
--- Overwrite, Replace_Slice, Slice, "&", To_Bounded_Wide_String,
--- To_Wide_String, Translate, and Trim.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of a variety of the Wide_String
--- functions found in the package Ada.Strings.Wide_Bounded, simulating
--- the operations found in a text processing environment.
--- With bounded wide strings, the length of each "line" of text can vary
--- up to the instantiated maximum, allowing one to view a page of text as
--- a series of expandable lines. This provides flexibility in text
--- formatting of individual lines (wide strings).
--- Several subprograms are defined, all of which attempt to take
--- advantage of as many different bounded wide string utilities as
--- possible. Often, an operation that is being performed in a subprogram
--- using a certain bounded wide string utility could more efficiently be
--- performed using a different utility. However, in the interest of
--- including as broad coverage as possible, a mixture of utilities is
--- invoked in this test.
--- A simulated page of text is provided as a parameter to the test
--- defined subprograms, and the appropriate processing performed. The
--- processed page of text is then compared to a predefined "finished"
--- page, and test passage/failure is based on the results of this
--- comparison.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 06 Nov 95 SAIC Corrected initialization error for ACVC 2.0.1.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4017 is
-
-begin
-
- Report.Test ("CXA4017", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Bounded are available, and " &
- "that they produce correct results");
-
- Test_Block:
- declare
-
- Characters_Per_Line : constant Positive := 40;
- Lines_Per_Page : constant Natural := 4;
-
-
- package BS_40 is new
- Ada.Strings.Wide_Bounded.Generic_Bounded_Length(Characters_Per_Line);
-
- use type BS_40.Bounded_Wide_String;
-
- type Page_Type is array (1..Lines_Per_Page) of
- BS_40.Bounded_Wide_String;
-
- -- Note: Misspellings below are intentional.
-
- Line1 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String
- ("ada is a progrraming language designed");
- Line2 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("to support the construction of long-");
- Line3 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("lived, highly reliabel software ");
- Line4 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("systems");
-
- Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4);
-
- Finished_Page : Page_Type :=
- (BS_40.To_Bounded_Wide_String
- ("Ada is a programming language designed"),
- BS_40.To_Bounded_Wide_String("to support the construction of long-"),
- BS_40.To_Bounded_Wide_String
- ("lived, HIGHLY RELIABLE software systems."),
- BS_40.To_Bounded_Wide_String(""));
-
- ---
-
- procedure Compress (Page : in out Page_Type) is
- Clear_Line : Natural := Lines_Per_Page;
- begin
- -- If two consecutive lines on the page are together less than the
- -- maximum line length, then append those two lines, move up all
- -- lower lines on the page, and blank out the last line.
- -- This algorithm works one time through the page, does not perform
- -- repetitive compression, and is designed for use with this test
- -- program only.
- for i in 1..Lines_Per_Page - 1 loop
- if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <=
- BS_40.Max_Length
- then
- Page(i) := BS_40."&"(Page(i),
- Page(i+1)); -- "&" (wd bnd, wd bnd)
-
- for j in i+1..Lines_Per_Page - 1 loop
- Page(j) :=
- BS_40.To_Bounded_Wide_String
- (BS_40.Slice(Page(j+1),
- 1,
- BS_40.Length(Page(j+1))));
- Clear_Line := j + 1;
- end loop;
- Page(Clear_Line) := BS_40.Null_Bounded_Wide_String;
- end if;
- end loop;
- end Compress;
-
- ---
-
- procedure Format (Page : in out Page_Type) is
- Sm_Ada : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("ada");
- Cap_Ada : constant Wide_String := "Ada";
- Char_Pos : Natural := 0;
- Finished : Boolean := False;
- Line : Natural := Page_Type'Last;
- begin
-
- -- Add a period to the end of the last line.
- while Line >= Page_Type'First and not Finished loop
- if Page(Line) /= BS_40.Null_Bounded_Wide_String and
- BS_40.Length(Page(Line)) <= BS_40.Max_Length
- then
- Page(Line) := BS_40.Append(Page(Line), '.');
- Finished := True;
- end if;
- Line := Line - 1;
- end loop;
-
- -- Replace all occurrences of "ada" with "Ada".
- for Line in Page_Type'First .. Page_Type'Last loop
- Finished := False;
- while not Finished loop
- Char_Pos :=
- BS_40.Index (Source => Page(Line),
- Pattern => BS_40.To_Wide_String(Sm_Ada),
- Going => Ada.Strings.Backward);
- -- A zero is returned by function Index if no occurrences of
- -- the pattern wide string are found.
- Finished := (Char_Pos = 0);
- if not Finished then
- BS_40.Replace_Slice
- (Source => Page(Line),
- Low => Char_Pos,
- High => Char_Pos + BS_40.Length(Sm_Ada) - 1,
- By => Cap_Ada);
- end if;
- end loop; -- while loop
- end loop; -- for loop
-
- end Format;
-
- ---
-
- procedure Spell_Check (Page : in out Page_Type) is
- type Spelling_Type is (Incorrect, Correct);
- type Word_Array_Type is array (Spelling_Type)
- of BS_40.Bounded_Wide_String;
- type Dictionary_Type is array (1..2) of Word_Array_Type;
-
- -- Note that the "words" in the dictionary will require various
- -- amounts of Trimming prior to their use in the bounded wide string
- -- functions.
- Dictionary : Dictionary_Type :=
- (1 => (BS_40.To_Bounded_Wide_String(" reliabel "),
- BS_40.To_Bounded_Wide_String(" reliable ")),
- 2 => (BS_40.To_Bounded_Wide_String(" progrraming "),
- BS_40.To_Bounded_Wide_String(" programming ")));
-
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
-
- begin
-
- for Line in Page_Type'Range loop
-
- -- Search for the first incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Overwrite function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(1)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
- Finished := (Pos = 0);
- if not Finished then
- Page(Line) :=
- BS_40.Overwrite(Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(1)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- -- Search for the second incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Delete procedure and Insert function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_Wide_String(
- BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
-
- Finished := (Pos = 0);
-
- if not Finished then
- BS_40.Delete
- (Page(Line),
- Pos,
- Pos + BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both))'Length-1);
- Page(Line) :=
- BS_40.Insert(Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(2)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- end loop;
- end Spell_Check;
-
- ---
-
- procedure Bold (Page : in out Page_Type) is
- Key_Word : constant Wide_String := "highly reliable";
- Bold_Mapping : constant
- Ada.Strings.Wide_Maps.Wide_Character_Mapping :=
- Ada.Strings.Wide_Maps.To_Mapping
- (From => " abcdefghijklmnopqrstuvwxyz",
- To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ");
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
- begin
- -- This procedure is designed to change the case of the phrase
- -- "highly reliable" into upper case (a type of "Bolding").
- -- All instances of the phrase on all lines of the page will be
- -- modified.
-
- for Line in Page_Type'First .. Page_Type'Last loop
- while not Finished loop
- Pos := BS_40.Index(Page(Line), Key_Word);
- Finished := (Pos = 0);
- if not Finished then
-
- BS_40.Overwrite
- (Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Translate
- (BS_40.To_Bounded_Wide_String
- (BS_40.Slice(Page(Line),
- Pos,
- Pos + Key_Word'Length - 1)),
- Bold_Mapping)));
-
- end if;
- end loop;
- Finished := False;
- end loop;
- end Bold;
-
-
- begin
-
- Compress(Page);
- Format(Page);
- Spell_Check(Page);
- Bold(Page);
-
- for i in 1..Lines_Per_Page loop
- if BS_40.To_Wide_String(Page(i)) /=
- BS_40.To_Wide_String(Finished_Page(i)) or
- BS_40.Length(Page(i)) /=
- BS_40.Length(Finished_Page(i))
- then
- Report.Failed("Incorrect modification of Page, Line " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4017;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a
deleted file mode 100644
index 98e0ded..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- CXA4018.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 subprograms defined in package
--- Ada.Strings.Wide_Bounded are available, and that they produce
--- correct results. Specifically, check the subprograms Append,
--- Count, Element, Find_Token, Head, Index_Non_Blank, Replace_Element,
--- Replicate, Tail, To_Bounded_Wide_String, "&", ">", "<", ">=", "<=",
--- and "*".
---
--- TEST DESCRIPTION:
--- This test, when taken in conjunction with test CXA40[17,19,20], will
--- constitute a test of all the functionality contained in package
--- Ada.Strings.Wide_Bounded. This test uses a variety of the
--- subprograms defined in the wide bounded string package in ways typical
--- of common usage. Different combinations of available subprograms
--- are used to accomplish similar wide bounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space.
--- 06 Nov 95 SAIC Corrected evaluation string used in Head/Tail
--- subtests for ACVC 2.0.1.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Bounded;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4018 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice. Blanks are translated to Wide_Character
- -- blanks and all other characters are translated into Wide_Characters with
- -- position values 256 greater than their (narrow) character position
- -- values.
-
- function Translate (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Translate;
-
- function Translate (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Translate(Str(i));
- end loop;
- return WS;
- end Translate;
-
-
-begin
-
- Report.Test ("CXA4018", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Bounded are available, and " &
- "that they produce correct results");
-
- Test_Block:
- declare
-
- package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80);
- use type BS80.Bounded_Wide_String;
-
- Part1 : constant Wide_String := Translate("Rum");
- Part2 : Wide_Character := Translate('p');
- Part3 : BS80.Bounded_Wide_String :=
- BS80.To_Bounded_Wide_String(Translate("el"));
- Part4 : Wide_Character := Translate('s');
- Part5 : BS80.Bounded_Wide_String :=
- BS80.To_Bounded_Wide_String(Translate("tilt"));
- Part6 : Wide_String(1..3) := Translate("ski");
-
- Full_Catenate_String,
- Full_Append_String,
- Constructed_String,
- Drop_String,
- Replicated_String,
- Token_String : BS80.Bounded_Wide_String;
-
- CharA : Wide_Character := Translate('A');
- CharB : Wide_Character := Translate('B');
- CharC : Wide_Character := Translate('C');
- CharD : Wide_Character := Translate('D');
- CharE : Wide_Character := Translate('E');
- CharF : Wide_Character := Translate('F');
-
- ABStr : Wide_String(1..15) := Translate("AAAAABBBBBBBBBB");
- StrB : Wide_String(1..2) := Translate("BB");
- StrE : Wide_String(1..2) := Translate("EE");
-
-
- begin
-
- -- Evaluation of the overloaded forms of the "&" operator.
-
- Full_Catenate_String :=
- BS80."&"(Part2, -- WChar & Bnd WStr
- BS80."&"(Part3, -- Bnd WStr & Bnd WStr
- BS80."&"(Part4, -- WChar & Bnd WStr
- BS80."&"(Part5, -- Bnd WStr & Bnd WStr
- BS80.To_Bounded_Wide_String
- (Part6)))));
-
- Full_Catenate_String :=
- BS80."&"(Part1, Full_Catenate_String); -- WStr & Bnd WStr
- Full_Catenate_String :=
- BS80."&"(Left => Full_Catenate_String,
- Right => Translate('n')); -- Bnd WStr & WChar
-
-
- -- Evaluation of the overloaded forms of function Append.
-
- Full_Append_String :=
- BS80.Append(Part2, -- WChar,Bnd WStr
- BS80.Append(Part3, -- Bnd WStr, Bnd WStr
- BS80.Append(Part4, -- WChar,Bnd WStr
- BS80.Append(BS80.To_Wide_String(Part5), -- WStr,Bnd WStr
- BS80.To_Bounded_Wide_String(Part6)))));
-
- Full_Append_String :=
- BS80.Append(BS80.To_Bounded_Wide_String(Part1), -- Bnd WStr, WStr
- BS80.To_Wide_String(Full_Append_String));
-
- Full_Append_String :=
- BS80.Append(Left => Full_Append_String,
- Right => Translate('n')); -- Bnd WStr, WChar
-
-
- -- Validate the resulting bounded wide strings.
-
- if BS80."<"(Full_Catenate_String, Full_Append_String) or
- BS80.">"(Full_Catenate_String, Full_Append_String) or
- not (Full_Catenate_String = Full_Append_String and
- BS80."<="(Full_Catenate_String, Full_Append_String) and
- BS80.">="(Full_Catenate_String, Full_Append_String))
- then
- Report.Failed
- ("Incorrect results from bounded wide string catenation" &
- " and comparison");
- end if;
-
-
- -- Evaluate the overloaded forms of the Constructor function "*" and
- -- the Replicate function.
-
- Constructed_String :=
- BS80."*"(2,CharA) & -- "AA"
- BS80."*"(2,StrB) & -- "AABBBB"
- BS80."*"(3, BS80."*"(2, CharC)) & -- "AABBBBCCCCCC"
- BS80.Replicate(3,
- BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD"
- BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE"
- BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF"
-
-
- -- Use of Function Replicate that involves dropping wide characters.
- -- The attempt to replicate the 15 character wide string six times will
- -- exceed the 80 wide character bound of the wide string. Therefore,
- -- the result should be the catenation of 5 copies of the 15 character
- -- wide string, followed by 5 'A' wide characters (the first five wide
- -- characters of the 6th replication) with the remaining wide
- -- characters of the 6th replication dropped.
-
- Drop_String :=
- BS80.Replicate(Count => 6,
- Item => ABStr, -- "AAAAABBBBBBBBBB"
- Drop => Ada.Strings.Right);
-
- if BS80.Element(Drop_String, 1) /= Translate('A') or
- BS80.Element(Drop_String, 6) /= Translate('B') or
- BS80.Element(Drop_String, 76) /= Translate('A') or
- BS80.Element(Drop_String, 80) /= Translate('A')
- then
- Report.Failed("Incorrect result from Replicate with Drop");
- end if;
-
-
- -- Use function Index_Non_Blank in the evaluation of the
- -- Constructed_String.
-
- if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /=
- BS80.To_Wide_String(Constructed_String)'First or
- BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /=
- BS80.Length(Constructed_String)
- then
- Report.Failed("Incorrect results from constructor functions");
- end if;
-
-
-
- declare
-
- -- Define wide character set objects for use with the Count function.
- -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above.
-
- A_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 1));
- B_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 3));
- C_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 7));
- D_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 13));
- E_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 19));
- F_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 23));
- Start : Positive;
- Stop : Natural := 0;
-
- begin
-
- -- Evaluate the results from function Count by comparing the number
- -- of A's to the number of F's, B's to E's, and C's to D's in the
- -- Constructed_String.
- -- There should be an equal number of each of the wide characters that
- -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc)
-
- if BS80.Count(Constructed_String, A_Set) /=
- BS80.Count(Constructed_String, F_Set) or
- BS80.Count(Constructed_String, B_Set) /=
- BS80.Count(Constructed_String, E_Set) or
- not (BS80.Count(Constructed_String, C_Set) =
- BS80.Count(Constructed_String, D_Set))
- then
- Report.Failed("Incorrect result from function Count");
- end if;
-
-
- -- Evaluate the functions Head, Tail, and Find_Token.
- -- Create the Token_String from the Constructed_String above.
-
- Token_String :=
- BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" &
- BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" &
- BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF"
-
- if Token_String /=
- BS80.To_Bounded_Wide_String(Translate("ABCDEF")) then
- Report.Failed("Incorrect result from Catenation of Token_String");
- end if;
-
-
- -- Find the starting/ending position of the first A in the
- -- Token_String (both should be 1, only one A appears in string).
- -- The Function Head uses the default pad character to return a
- -- bounded wide string longer than its input parameter bounded
- -- wide string.
-
- BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad.
- A_Set,
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 1 and Stop /= 1 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
-
- -- Find the starting/ending position of the first non-AB slice in
- -- the "head" five wide characters of Token_String (slice CDE at
- -- positions 3-5)
-
- BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE"
- Ada.Strings.Wide_Maps."OR"(A_Set, B_Set), -- Set (AB)
- Ada.Strings.Outside,
- Start,
- Stop);
-
- if Start /= 3 and Stop /= 5 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
-
- -- Find the starting/ending position of the first CD slice in
- -- the "tail" eight wide characters (including two pad wide
- -- characters) of Token_String (slice CD at positions 5-6 of
- -- the tail portion specified)
-
- BS80.Find_Token(BS80.Tail(Token_String, 8,
- Ada.Strings.Wide_Space),
- Ada.Strings.Wide_Maps."OR"(C_Set, D_Set),
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 5 and Stop /= 6 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
-
- -- Evaluate the Replace_Element function.
-
- -- Token_String = "ABCDEF"
-
- BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4));
-
- -- Token_String = "ABDDEF"
-
- BS80.Replace_Element(Source => Token_String,
- Index => 2,
- By => BS80.Element(Token_String, 5));
-
- -- Token_String = "AEDDEF"
-
- BS80.Replace_Element(Token_String,
- 1,
- BS80.Element(BS80.Tail(Token_String, 2), 2));
-
- -- Token_String = "FEDDEF"
- -- Evaluate this result.
-
- if BS80.Element(Token_String,
- BS80.To_Wide_String(Token_String)'First) /=
- BS80.Element(Token_String,
- BS80.To_Wide_String(Token_String)'Last) or
- BS80.Count(Token_String, D_Set) /=
- BS80.Count(Token_String, E_Set) or
- BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /=
- BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or
- BS80.Head(Token_String, 1) /=
- BS80.Tail(Token_String, 1)
- then
- Report.Failed("Incorrect result from operations in combination");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4018;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a
deleted file mode 100644
index 943e3e7..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a
+++ /dev/null
@@ -1,1027 +0,0 @@
--- CXA4019.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 subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results, especially
--- under conditions where truncation of the result is required.
--- Specifically, check the subprograms Append, Count with non-Identity
--- maps, Index with non-Identity maps, Index with Set parameters,
--- Insert (function and procedure), Replace_Slice (function and
--- procedure), To_Bounded_Wide_String, and Translate (function and
--- procedure).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4017, CXA4018, and CXA4020,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Wide_Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 06 Nov 95 SAIC Corrected expected result string in subtest for
--- ACVC 2.0.1.
--- Moved function Dog_to_Cat_Mapping to library
--- level to correct accessibility problem in test.
--- 22 Aug 96 SAIC Corrected three subtests identified in reviewer
--- comments.
--- 17 Feb 97 PWB.CTA Corrected result strings for Translate and Insert
---
---!
-
-package CXA40190 is
-
- -- Wide Character mapping function defined for use with specific
- -- versions of functions Index and Count.
-
- function Dog_to_Cat_Mapping (From : Wide_Character)
- return Wide_Character;
-
-end CXA40190;
-
-package body CXA40190 is
-
- -- Translates "dog" to "cat".
- function Dog_to_Cat_Mapping (From : Wide_Character)
- return Wide_Character is
- begin
- if From = 'd' then
- return 'c';
- elsif From = 'o' then
- return 'a';
- elsif From = 'g' then
- return 't';
- else
- return From;
- end if;
- end Dog_to_Cat_Mapping;
-
-end CXA40190;
-
-
-with CXA40190;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-
-procedure CXA4019 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-begin
-
- Report.Test("CXA4019", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Bounded are " &
- "available, and that they produce correct " &
- "results, especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- use CXA40190;
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Wide_Bounded;
- package ASWC renames Ada.Strings.Wide_Maps.Wide_Constants;
- package Maps renames Ada.Strings.Wide_Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_Wide_String;
-
- Result_String : B10.Bounded_Wide_String;
- Test_String : B10.Bounded_Wide_String;
- AtoE_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("abcde"));
- FtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("fghij"));
- AtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("abcdefghij"));
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd");
- Wide_CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Equiv("cd"));
-
- AB_to_YZ_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "ab", To => "yz");
-
- Wide_AB_to_YZ_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => Equiv("ab"),
- To => Equiv("yz"));
-
- CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- Wide_CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => Equiv("cd"),
- To => Equiv("xy"));
-
-
- -- Access-to-Subprogram object defined for use with specific versions of
- -- functions Index, Count Translate, and procedure Translate.
-
- Map_Ptr : Maps.Wide_Character_Mapping_Function :=
- Dog_to_Cat_Mapping'Access;
-
-
-
- begin
-
- -- Function To_Bounded_Wide_String with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- Test_String :=
- B10.To_Bounded_Wide_String
- (Equiv("Much too long for this bounded wide string"));
- Report.Failed("Length Error not raised by To_Bounded_Wide_String");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by To_Bounded_Wide_String");
- end;
-
- -- Drop = Left
-
- Test_String :=
- B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"),
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("efghijklmn")) then
- Report.Failed
- ("Incorrect result from To_Bounded_Wide_String, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String :=
- B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"),
- Drop => Ada.Strings.Right);
-
- if not(Test_String = AtoJ_Bnd_Str) then
- Report.Failed
- ("Incorrect result from To_Bounded_Wide_String, Drop = Right");
- end if;
-
-
-
-
- -- Function Append with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- -- Append (Bnd Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String(Equiv("abcde")),
- B10.To_Bounded_Wide_String(Equiv("fghijk"))); -- 11 char
- Report.Failed("Length_Error not raised by Append - 1");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 1");
- end;
-
- begin
- -- Append (Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Wide_String(AtoE_Bnd_Str),
- B10.To_Bounded_Wide_String(Equiv("fghijk")),
- AS.Error);
- Report.Failed("Length_Error not raised by Append - 2");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 2");
- end;
-
- begin
- -- Append (Bnd Str, Char);
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), 'k');
- Report.Failed("Length_Error not raised by Append - 3");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 3");
- end;
-
- -- Drop = Left
-
- -- Append (Bnd Str, Bnd Str)
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String(Equiv("abcdefgh")), -- 8 chs
- B10.To_Bounded_Wide_String(Equiv("ijklmn")), -- 6 chs
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("efghijklmn")) -- 10 chars
- then
- Report.Failed("Incorrect truncation performed by Append - 4");
- end if;
-
- -- Append (Bnd Str, Str)
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String("abcdefghij"),
- "xyz",
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_Wide_String("defghijxyz") then
- Report.Failed("Incorrect truncation performed by Append - 5");
- end if;
-
- -- Append (Char, Bnd Str)
-
- Result_String :=
- B10.Append(Equiv('A'),
- B10.To_Bounded_Wide_String(Equiv("abcdefghij")),
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_Wide_String(Equiv("abcdefghij"))
- then
- Report.Failed("Incorrect truncation performed by Append - 6");
- end if;
-
- -- Drop = Right
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(FtoJ_Bnd_Str,
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("fghijabcde"))
- then
- Report.Failed("Incorrect truncation performed by Append - 7");
- end if;
-
- -- Append (Str, Bnd Str)
- Result_String := B10.Append(B10.To_Wide_String(AtoE_Bnd_Str),
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("abcdeabcde"))
- then
- Report.Failed("Incorrect truncation performed by Append - 8");
- end if;
-
- -- Append (Char, Bnd Str)
- Result_String := B10.Append(Equiv('A'), AtoJ_Bnd_Str, Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_Wide_String(Equiv("Aabcdefghi")) then
- Report.Failed("Incorrect truncation performed by Append - 9");
- end if;
-
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location :=
- B10.Index(Source => B10.To_Bounded_Wide_String("foxy fox 2"),
- Pattern => "FOX",
- Going => Ada.Strings.Backward,
- Mapping => ASWC.Upper_Case_Map);
-
- if Location /= 6 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location :=
- B10.Index(B10.To_Bounded_Wide_String("THE QUICK "),
- "quick",
- Ada.Strings.Forward,
- Ada.Strings.Wide_Maps.Wide_Constants.Lower_Case_Map);
-
- if Location /= 5 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- Location := B10.Index(Source => B10.To_Bounded_Wide_String("The the"),
- Pattern => "the",
- Going => Ada.Strings.Forward,
- Mapping => ASWC.Lower_Case_Map);
-
- if Location /= 1 then
- Report.Failed("Incorrect result from Index, non-Identity map - 3");
- end if;
-
-
-
- if B10.Index(B10.To_Bounded_Wide_String("abcd"), -- Pattern = Source
- "abcd") /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("abc"), -- Pattern < Source
- "abcd") /= 0 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- "abc") /= 0
- then
- Report.Failed("Incorrect result from Index with string patterns");
- end if;
-
-
-
- -- Function Index with access-to-subprogram mapping value.
- -- Evaluate the function Index with a wide character mapping function
- -- object that performs the mapping operation.
-
- Location := B10.Index(Source => B10.To_Bounded_Wide_String("My dog"),
- Pattern => "cat",
- Going => Ada.Strings.Forward,
- Mapping => Map_Ptr); -- change "dog" to "cat"
-
- if Location /= 4 then
- Report.Failed("Incorrect result from Index, w/map ptr - 1");
- end if;
-
- Location := B10.Index(B10.To_Bounded_Wide_String("cat or dog"),
- "cat",
- Ada.Strings.Backward,
- Map_Ptr);
-
- if Location /= 8 then
- Report.Failed("Incorrect result from Index, w/map ptr - 2");
- end if;
-
- if B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern = Source
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern < Source
- "cats",
- Ada.Strings.Backward,
- Map_Ptr) /= 0 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String("hot dog"),
- "dog",
- Ada.Strings.Backward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String(" cat dog "),
- " cat",
- Ada.Strings.Backward,
- Map_Ptr) /= 5 or
- B10.Index(B10.To_Bounded_Wide_String("dog CatDog"),
- "cat",
- Ada.Strings.Backward,
- Map_Ptr) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("CatandDog"),
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String("dddd"),
- "ccccc",
- Ada.Strings.Backward,
- Map_Ptr) /= 0
- then
- Report.Failed("Incorrect result from Index w/map ptr - 3");
- end if;
-
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- B10.Index(Source => B10.To_Bounded_Wide_String(Equiv("abcdeabcde")),
- Set => Wide_CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward);
-
- if not (Location = 3) then -- position of first 'c' equivalent in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str),
- Set => Wide_CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward.
- Location := B10.Index(B10.To_Bounded_Wide_String("deddacd"),
- CD_Set,
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward);
-
- if Location /= 2 then -- position of 'e' in source.
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Test = Outside, Going = Backward.
- Location := B10.Index(B10.To_Bounded_Wide_String(Equiv("deddacd")),
- Wide_CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward);
-
- if Location /= 5 then -- position of 'a', correct.
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
- if B10.Index(B10.To_Bounded_Wide_String("cd"), -- Source = Set
- CD_Set) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("c"), -- Source < Set
- CD_Set) /= 1 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- Wide_CD_Set) /= 0 or
- B10.Index(AtoE_Bnd_Str,
- Maps.To_Set('x')) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 5");
- end if;
-
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_Wide_String("THE THE TH"),
- Pattern => "th",
- Mapping => ASWC.Lower_Case_Map);
-
- if Total_Count /= 3 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- -- And a few with identity maps as well.
-
- if B10.Count(B10.To_Bounded_Wide_String(Equiv("ABABABABAB")),
- Equiv("ABA"),
- Maps.Identity) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("ADCBADABCD"),
- "AB",
- Maps.To_Mapping("CD", "AB")) /= 5 or
- B10.Count(B10.To_Bounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv("aaa")) /= 3 or
- B10.Count(B10.To_Bounded_Wide_String(Equiv("XX")),
- Equiv("XXX"),
- Maps.Identity) /= 0 or
- B10.Count(AtoE_Bnd_Str, -- Source = Pattern
- Equiv("abcde")) /= 1 or
- B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null
- " ") /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
-
-
-
- -- Function Count with access-to-subprogram mapping.
- -- Evaluate the version function Count that uses an access-to-subprogram
- -- map parameter.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_Wide_String("dogdogdo"),
- Pattern => "ca",
- Mapping => Map_Ptr);
-
- if Total_Count /= 3 then
- Report.Failed
- ("Incorrect result from function Count, w/map ptr - 1");
- end if;
-
-
- if B10.Count(B10.To_Bounded_Wide_String("DdOoGgod"),
- "c",
- Map_Ptr) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("dododododo"),
- "do",
- Map_Ptr) /= 0 or
- B10.Count(B10.To_Bounded_Wide_String("Dog or dog"),
- "cat",
- Map_Ptr) /= 1 or
- B10.Count(B10.To_Bounded_Wide_String("dddddddddd"),
- "ccccc",
- Map_Ptr) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("do"), -- Source < Pattern
- "cat",
- Map_Ptr) /= 0 or
- B10.Count(B10.To_Bounded_Wide_String(" dog "), -- Source = Pattern
- " cat ",
- Map_Ptr) /= 1 or
- B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null
- " ",
- Map_Ptr) /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w/map ptr - 2");
- end if;
-
-
-
-
- -- Procedure Translate
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("abcdeabcab");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String("yzcdeyzcyz") then
- Report.Failed("Incorrect result from procedure Translate - 1");
- end if;
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("abbaaababb");
-
- B10.Translate(Source => Test_String, Mapping => ASWC.Upper_Case_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String("ABBAAABABB") then
- Report.Failed("Incorrect result from procedure Translate - 2");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String(Equiv("xyzsypcc"));
-
- B10.Translate(Source => Test_String, Mapping => Wide_AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("xyzsypcc")) then
- Report.Failed("Incorrect result from procedure Translate - 3");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := B10.To_Bounded_Wide_String("opabcdelmn");
-
- B10.Translate(Test_String,
- Maps.To_Mapping("abcde", "lmnop"));
-
- if Test_String /= B10.To_Bounded_Wide_String("oplmnoplmn") then
- Report.Failed("Incorrect result from procedure Translate - 4");
- end if;
-
-
-
-
- -- Procedure Translate with access-to-subprogram mapping.
- -- Use the version of Procedure Translate that takes an
- -- access-to-subprogram parameter to perform the Source mapping.
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("dogeatdog");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("cateatcat") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 1");
- end if;
-
- Test_String := B10.To_Bounded_Wide_String("odogcatlmn");
-
- B10.Translate(Test_String, Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("acatcatlmn") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 2");
- end if;
-
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("gggooooddd");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("tttaaaaccc") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr- 3");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String(" DOG cat ");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String(" DOG cat ") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 4");
- end if;
-
- Test_String := B10.Null_Bounded_Wide_String;
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 5");
- end if;
-
-
-
-
- -- Function Translate with access-to-subprogram mapping.
- -- Use the version of Function Translate that takes an
- -- access-to-subprogram parameter to perform the Source mapping.
-
- -- Partial mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String("cateatdog"),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("cateatcat")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 1");
- end if;
-
- if B10.Translate(B10.To_Bounded_Wide_String("cadogtac"),
- Map_Ptr) /=
- B10.To_Bounded_Wide_String("cacattac")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 2");
- end if;
-
- -- Total mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String("dogodggdo"),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("catacttca")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr- 3");
- end if;
-
- -- No mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String(" DOG cat "),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String(" DOG cat ")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 4");
- end if;
-
- if B10.Translate(B10.To_Bounded_Wide_String("d "), Map_Ptr) /=
- B10.To_Bounded_Wide_String("c ") or
- B10.Translate(B10.To_Bounded_Wide_String(" god"), Map_Ptr) /=
- B10.To_Bounded_Wide_String(" tac") or
- B10.Translate(B10.To_Bounded_Wide_String("d o g D og"), Map_Ptr) /=
- B10.To_Bounded_Wide_String("c a t D at") or
- B10.Translate(B10.To_Bounded_Wide_String(" "), Map_Ptr) /=
- B10.To_Bounded_Wide_String(" ") or
- B10.Translate(B10.To_Bounded_Wide_String("dddddddddd"), Map_Ptr) /=
- B10.To_Bounded_Wide_String("cccccccccc")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 5");
- end if;
-
- if B10.Translate(Source => B10.Null_Bounded_Wide_String,
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 6");
- end if;
-
-
-
-
- -- Function Replace_Slice
- -- Evaluate function Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => Equiv("xxxxxx")); -- more than 3.
- Report.Failed("Length_Error not raised by Function Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 7,
- High => 10, -- 7-10, 4 chars.
- By => Equiv("xxxxxx"), -- 6 chars.
- Drop => Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("cdefxxxxxx")) -- drop a,b
- then
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 2,
- High => 5, -- 2-5, 4 chars.
- By => Equiv("xxxxxx"), -- 6 chars.
- Drop => Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("axxxxxxfgh")) -- drop i,j
- then
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Right");
- end if;
-
- -- Low = High = Source'Last, "By" length = 1.
-
- if B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- Equiv("X"),
- Ada.Strings.Error) /=
- B10.To_Bounded_Wide_String(Equiv("abcdX"))
- then
- Report.Failed("Incorrect result from Function Replace_Slice");
- end if;
-
- -- Index_Error raised when High < Source'First - 1.
- begin
- Test_String :=
- B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First,
- B10.To_Wide_String(AtoE_Bnd_Str)'First - 2,
- Equiv("hijklm"));
- Report.Failed("Index_Error not raised by Function Replace_Slice");
- exception
- when AS.Index_Error => null; -- OK, expected exception
- when Constraint_Error => null; -- Also OK, since RM is not clear
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
-
-
- -- Procedure Replace_Slice
- -- Evaluate procedure Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => Equiv("xxxxxx")); -- more than 3.
- Report.Failed("Length_Error not raised by Procedure Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Replace_Slice");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 7,
- High => 9, -- 7-9, 3 chars.
- By => Equiv("xxxxx"), -- 5 chars.
- Drop => Ada.Strings.Left);
-
- if Test_String /=
- B10.To_Bounded_Wide_String(Equiv("cdefxxxxxj")) -- drop a,b
- then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 1,
- High => 3, -- 1-3, 3chars.
- By => Equiv("xxxx"), -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /=
- B10.To_Bounded_Wide_String(Equiv("xxxxdefghi")) -- drop j
- then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Right");
- end if;
-
- -- High = Source'First, Low > High (Insert before Low).
-
- Test_String := AtoE_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => B10.To_Wide_String(Test_String)'Last,
- High => B10.To_Wide_String(Test_String)'First,
- By => Equiv("XXXX"), -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("abcdXXXXe")) then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice");
- end if;
-
-
-
-
- -- Function Insert with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 2,
- New_Item => Equiv("xyz"));
- Report.Failed("Length_Error not raised by Function Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Insert");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 5,
- New_Item => Equiv("xyz"), -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Result_String) /= Equiv("dxyzefghij") then
- Report.Failed("Incorrect result from Function Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Insert(Source => B10.To_Bounded_Wide_String("abcdef"),
- Before => 2,
- New_Item => "vwxyz", -- 5 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_Wide_String(Result_String) /= "avwxyzbcde" then -- drop f.
- Report.Failed("Incorrect result from Function Insert, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Insert(B10.To_Bounded_Wide_String("a"), 1, " B") /=
- B10.To_Bounded_Wide_String(" Ba") or
- B10.Insert(B10.Null_Bounded_Wide_String, 1, Equiv("abcde")) /=
- AtoE_Bnd_Str or
- B10.Insert(B10.To_Bounded_Wide_String("ab"), 2, "") /=
- B10.To_Bounded_Wide_String("ab")
- then
- Report.Failed("Incorrect result from Function Insert");
- end if;
-
-
-
- -- Procedure Insert
-
- -- Drop = Error (Default).
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 9,
- New_Item => Equiv("wxyz"),
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Procedure Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => B10.Length(Test_String), -- before last char
- New_Item => Equiv("xyz"), -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Test_String) /= Equiv("defghixyzj") then
- Report.Failed("Incorrect result from Procedure Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 4,
- New_Item => Equiv("yz"), -- 2 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_Wide_String(Test_String) /= Equiv("abcyzdefgh") then
- Report.Failed
- ("Incorrect result from Procedure Insert, Drop = Right");
- end if;
-
- -- Before = Source'First, New_Item length = 1.
-
- Test_String := B10.To_Bounded_Wide_String(" abc ");
- B10.Insert(Test_String,
- B10.To_Wide_String(Test_String)'First,
- "Z");
-
- if Test_String /= B10.To_Bounded_Wide_String("Z abc ") then
- Report.Failed("Incorrect result from Procedure Insert");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4019;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a
deleted file mode 100644
index 24036f1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a
+++ /dev/null
@@ -1,688 +0,0 @@
--- CXA4020.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 subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Overwrite (function and procedure), Delete,
--- Function Trim (blanks), Trim (Set wide characters, function and
--- procedure), Head, Tail, and Replicate (wide characters and wide
--- strings).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4017, CXA4018, CXA4019,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Wide_Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space.
--- 13 Apr 95 SAIC Corrected certain subtest acceptance conditions.
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4020 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice. Blanks are translated to Wide_Character
- -- blanks and all other characters are translated into Wide_Characters with
- -- position values 256 greater than their (narrow) character position
- -- values.
-
- function Translate (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Translate;
-
-
- function Translate (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Translate(Str(i));
- end loop;
- return WS;
- end Translate;
-
-
-begin
-
- Report.Test("CXA4020", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Bounded are " &
- "available, and that they produce correct " &
- "results, especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASW renames Ada.Strings.Wide_Bounded;
- package Maps renames Ada.Strings.Wide_Maps;
-
- package B10 is new ASW.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_Wide_String;
-
- Result_String : B10.Bounded_Wide_String;
- Test_String : B10.Bounded_Wide_String;
- AtoE_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("abcde"));
- FtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("fghij"));
- AtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("abcdefghij"));
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("cd"));
- XY_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("xy"));
-
-
- begin
-
- -- Function Overwrite with Truncation
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 9,
- New_Item => Translate("xyz"),
- Drop => AS.Error);
- Report.Failed("Exception not raised by Function Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Overwrite");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String), -- 10
- New_Item => Translate("xyz"),
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Result_String) /=
- Translate("cdefghixyz") then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- Translate("xxxyyyzzz"),
- Ada.Strings.Right);
-
- if B10.To_Wide_String(Result_String) /=
- Translate("abxxxyyyzz")
- then
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Right");
- end if;
-
- -- Additional cases of function Overwrite.
-
- if B10.Overwrite(B10.To_Bounded_Wide_String(Translate("a")),
- 1, -- Source length = 1
- Translate(" abc ")) /=
- B10.To_Bounded_Wide_String(Translate(" abc ")) or
- B10.Overwrite(B10.Null_Bounded_Wide_String, -- Null source
- 1,
- Translate("abcdefghij")) /=
- AtoJ_Bnd_Str or
- B10.Overwrite(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First,
- Translate(" ")) /= -- New_Item = 1
- B10.To_Bounded_Wide_String(Translate(" bcde"))
- then
- Report.Failed("Incorrect result from Function Overwrite");
- end if;
-
-
-
- -- Procedure Overwrite
- -- Correct usage, no truncation.
-
- Test_String := AtoE_Bnd_Str; -- "abcde"
- B10.Overwrite(Test_String, 2, Translate("xyz"));
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("axyze")) then
- Report.Failed("Incorrect result from Procedure Overwrite - 1");
- end if;
-
- Test_String := B10.To_Bounded_Wide_String(Translate("abc"));
- B10.Overwrite(Test_String, 2, ""); -- New_Item is null string.
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abc")) then
- Report.Failed("Incorrect result from Procedure Overwrite - 2");
- end if;
-
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 8,
- New_Item => Translate("uvwxyz"));
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Overwrite");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String) - 2, -- 8
- New_Item => Translate("uvwxyz"),
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Test_String) /=
- Translate("defguvwxyz")
- then
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- Translate("xxxyyyzzz"),
- Ada.Strings.Right);
-
- if B10.To_Wide_String(Test_String) /= Translate("abxxxyyyzz") then
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Right");
- end if;
-
-
-
- -- Function Delete
-
- if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- From => 3,
- Through => 8) /=
- B10."&"(B10.Head(AtoJ_Bnd_Str, 2),
- B10.Tail(AtoJ_Bnd_Str, 2)) or
- B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoJ_Bnd_Str, 1, 5) /=
- FtoJ_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
-
- if B10.Delete(B10.To_Bounded_Wide_String(Translate("a")), 1, 1) /=
- B10.Null_Bounded_Wide_String or
- B10.Delete(AtoE_Bnd_Str,
- 5,
- B10.To_Wide_String(AtoE_Bnd_Str)'First) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last) /=
- B10.To_Bounded_Wide_String(Translate("abcd"))
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Function Trim
-
- declare
-
- Text : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("Text"));
- type Bnd_Array_Type is array (1..5) of B10.Bounded_Wide_String;
- Bnd_Array : Bnd_Array_Type :=
- (B10.To_Bounded_Wide_String(Translate(" Text")),
- B10.To_Bounded_Wide_String(Translate("Text ")),
- B10.To_Bounded_Wide_String(Translate(" Text ")),
- B10.To_Bounded_Wide_String(Translate("Text Text")),
- B10.To_Bounded_Wide_String(Translate(" Text Text")));
-
- begin
-
- for i in Bnd_Array_Type'Range loop
- case i is
- when 4 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- Bnd_Array(i) then -- no change
- Report.Failed("Incorrect result from Function Trim - 4");
- end if;
- when 5 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- B10."&"(Text, B10."&"(Translate(' '), Text))
- then
- Report.Failed("Incorrect result from Function Trim - 5");
- end if;
- when others =>
- if B10.Trim(Bnd_Array(i), AS.Both) /= Text then
- Report.Failed("Incorrect result from Function Trim - " &
- Integer'Image(i));
- end if;
- end case;
- end loop;
-
- end;
-
-
-
- -- Function Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded wide string.
- if B10.Trim(Source => B10.To_Bounded_Wide_String(Translate("ddabbaxx")),
- Left => CD_Set,
- Right => XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("abba"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- wide string; likewise for the opposite side. Only "cd" trimmed
- -- from left side, and only "xy" trimmed from right side.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")),
- CD_Set,
- XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("xyabcd"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded wide string, just the appropriate ends.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdabdxabxy")),
- CD_Set,
- XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("abdxab"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from right side only. No change to Left side.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("abxyzddcd")),
- XY_Set,
- CD_Set) /=
- B10.To_Bounded_Wide_String(Translate("abxyz"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Right side");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set);
- if Result_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Fn Trim - Sets, Neither side");
- end if;
-
- if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /=
- AtoE_Bnd_Str or
- B10.Trim(B10.To_Bounded_Wide_String(Translate("dcddcxyyxx")),
- CD_Set,
- XY_Set) /=
- B10.Null_Bounded_Wide_String
- then
- Report.Failed("Incorrect result from Function Trim");
- end if;
-
-
-
- -- Procedure Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded wide string.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("dcabbayx"));
- B10.Trim(Source => Test_String,
- Left => CD_Set,
- Right => XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abba")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- wide string; likewise for the opposite side. Only "cd" trimmed
- -- from left side, and only "xy" trimmed from right side.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cdxyabcdxy"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("xyabcd")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded wide string, just the appropriate ends.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cdabdxabxy"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if not
- (Test_String = B10.To_Bounded_Wide_String(Translate("abdxab"))) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from Left side only. No change to Right side.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cccdabxyz"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abxyz")) then
- Report.Failed
- ("Incorrect result from Proc Trim for Sets, Left side only");
- end if;
-
- -- Trim no characters on either side of the bounded wide string.
-
- Test_String := AtoJ_Bnd_Str;
- B10.Trim(Test_String, CD_Set, CD_Set);
-
- if Test_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Proc Trim-Sets, Neither side");
- end if;
-
-
-
- -- Function Head with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Translate('X'));
- Report.Failed("Length_Error not raised by Function Head");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Head");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the right end of the bounded
- -- wide string (which is initially at its maximum length), then the
- -- first five characters of the intermediate result are dropped to
- -- conform to the maximum size limit of the bounded wide string (10).
-
- Result_String :=
- B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")),
- 15,
- Translate('x'),
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("FGHIJxxxxx"))
- then
- Report.Failed("Incorrect result from Function Head, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (6) are appended to the left end of the bounded
- -- wide string (which is initially at one less than its maximum length),
- -- then the last five characters of the intermediate result are dropped
- -- (which in this case are the pad characters) to conform to the
- -- maximum size limit of the bounded wide string (10).
-
- Result_String :=
- B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHI")),
- 15,
- Translate('x'),
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("ABCDEFGHIx"))
- then
- Report.Failed("Incorrect result from Function Head, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Head(B10.Null_Bounded_Wide_String, 5, Translate('a')) /=
- B10.To_Bounded_Wide_String(Translate("aaaaa")) or
- B10.Head(AtoE_Bnd_Str,
- B10.Length(AtoE_Bnd_Str)) /=
- AtoE_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail with Truncation
- -- Drop = Error (Default Case)
-
- begin
- Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Ada.Strings.Wide_Space,
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Function Tail");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Tail");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the left end of the bounded wide
- -- string (which is initially at two less than its maximum length),
- -- then the first three characters of the intermediate result (in this
- -- case, 3 pad characters) are dropped.
-
- Result_String :=
- B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGH")),
- 13,
- Translate('x'),
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("xxABCDEFGH"))
- then
- Report.Failed("Incorrect result from Function Tail, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (3) are appended to the left end of the bounded wide
- -- string (which is initially at its maximum length), then the last
- -- three characters of the intermediate result are dropped.
-
- Result_String :=
- B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")),
- 13,
- Translate('x'),
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("xxxABCDEFG"))
- then
- Report.Failed("Incorrect result from Function Tail, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Tail(B10.Null_Bounded_Wide_String, 3, Translate(' ')) /=
- B10.To_Bounded_Wide_String(Translate(" ")) or
- B10.Tail(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First) /=
- B10.To_Bounded_Wide_String(Translate("e"))
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function Replicate (#, Char) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => B10.Max_Length + 5,
- Item => Translate('A'),
- Drop => AS.Error);
- Report.Failed
- ("Length_Error not raised by Replicate for characters");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for characters");
- end;
-
- -- Drop = Left, Right
- -- Since this version of Replicate uses wide character parameters, the
- -- result after truncation from left or right will appear the same.
- -- The result will be a 10 character bounded wide string, composed of
- -- 10 "Item" wide characters.
-
- if B10.Replicate(Count => 20,
- Item => Translate('A'),
- Drop => Ada.Strings.Left) /=
- B10.Replicate(15, Translate('A'), Ada.Strings.Right)
- then
- Report.Failed("Incorrect result from Replicate for characters - 1");
- end if;
-
- -- Blank-filled, 10 character bounded wide strings.
-
- if B10.Replicate(B10.Max_Length + 1,
- Translate(' '),
- Drop => Ada.Strings.Left) /=
- B10.Replicate(B10.Max_Length, Ada.Strings.Wide_Space)
- then
- Report.Failed("Incorrect result from Replicate for characters - 2");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(0, Translate('a')) /= B10.Null_Bounded_Wide_String or
- B10.Replicate(1, Translate('a')) /=
- B10.To_Bounded_Wide_String(Translate("a"))
- then
- Report.Failed("Incorrect result from Replicate for characters - 3");
- end if;
-
-
-
- -- Function Replicate (#, String) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => 5, -- result would be 15.
- Item => Translate("abc"));
- Report.Failed
- ("Length_Error not raised by Replicate for wide strings");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for wide strings");
- end;
-
- -- Drop = Left
-
- Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("cdabcdabcd"))
- then
- Report.Failed
- ("Incorrect result from Replicate for wide strings, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("abcdabcdab")) then
- Report.Failed
- ("Incorrect result from Replicate for wide strings, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(5, Translate("X")) /=
- B10.To_Bounded_Wide_String(Translate("XXXXX")) or
- B10.Replicate(10, "") /=
- B10.Null_Bounded_Wide_String or
- B10.Replicate(0, Translate("ab")) /=
- B10.Null_Bounded_Wide_String
- then
- Report.Failed("Incorrect result from Replicate for wide strings");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4020;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a
deleted file mode 100644
index 345a77c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a
+++ /dev/null
@@ -1,311 +0,0 @@
--- CXA4021.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 subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Head, Index,
--- Index_Non_Blank, Insert, Length, Overwrite, Replace_Slice, Slice,
--- Tail, To_Wide_String, To_Unbounded_Wide_String, "*", "&",
--- and "=", "<=", ">=".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings.
--- The test attempts to simulate how unbounded wide strings could be used
--- to simulate paragraphs of text. Modifications could be easily be
--- performed using the provided subprograms (although in this test, the
--- main modification performed was the addition of more text to the
--- string). One would not have to worry about the formatting of the
--- paragraph until it was finished and correct in content. Then, once
--- all required editing is complete, the unbounded strings can be divided
--- up into the appropriate lengths based on particular formatting
--- requirements. The test then compares the formatted text product
--- with a predefined "finished product".
---
--- This test attempts to use a large number of the subprograms provided
--- by package Ada.Strings.Wide_Unbounded. Often, the processing involved
--- could have been performed more efficiently using a minimum number
--- of the subprograms, in conjunction with loops, etc. However, for
--- testing purposes, and in the interest of minimizing the number of
--- tests developed, subprogram variety and feature mixing was stressed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4021 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram character and string parameters to simulate the use of non-
- -- character Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-begin
-
- Report.Test ("CXA4021", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use type ASW.Unbounded_Wide_String;
- use Ada.Strings;
-
- Pamphlet_Paragraph_Count : constant := 2;
- Lines : constant := 4;
- Line_Length : constant := 40;
-
- type Document_Type is array (Positive range <>)
- of ASW.Unbounded_Wide_String;
-
- type Camera_Ready_Copy_Type is array (1..Lines)
- of Wide_String (1..Line_Length);
-
- Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count);
-
- Camera_Ready_Copy : Camera_Ready_Copy_Type :=
- (others => (others => Ada.Strings.Wide_Space));
-
- TC_Finished_Product : Camera_Ready_Copy_Type :=
- ( 1 => Equiv("Ada is a programming language designed "),
- 2 => Equiv("to support long-lived, reliable software"),
- 3 => Equiv(" systems. "),
- 4 => Equiv("Go with Ada! "));
-
- -----
-
-
- procedure Enter_Text_Into_Document (Document : in out Document_Type) is
- begin
-
- -- Fill in both "paragraphs" of the document. Each unbounded wide
- -- string functions as an individual paragraph, containing an
- -- unspecified number of characters.
- -- Use a variety of different unbounded wide string subprograms to
- -- load the data.
-
- Document(1) :=
- ASW.To_Unbounded_Wide_String(Equiv("Ada is a language"));
-
- -- Insert the word "programming" prior to "language".
- Document(1) :=
- ASW.Insert(Document(1),
- ASW.Index(Document(1),
- Equiv("language")),
- ASW.To_Wide_String(Equiv("progra") & -- Wd Str &
- ASW."*"(2,Equiv('m')) & -- Wd Unbd &
- Equiv("ing "))); -- Wd Str
-
-
- -- Overwrite the word "language" with "language" + additional text.
- Document(1) :=
- ASW.Overwrite(Document(1),
- ASW.Index(Document(1),
- ASW.To_Wide_String(
- ASW.Tail(Document(1), 8, Equiv(' '))),
- Ada.Strings.Backward),
- Equiv("language designed to support long-lifed"));
-
-
- -- Replace the word "lifed" with "lived".
- Document(1) :=
- ASW.Replace_Slice(Document(1),
- ASW.Index(Document(1), Equiv("lifed")),
- ASW.Length(Document(1)),
- Equiv("lived"));
-
-
- -- Overwrite the word "lived" with "lived" + additional text.
- Document(1) :=
- ASW.Overwrite(Document(1),
- ASW.Index(Document(1),
- ASW.To_Wide_String
- (ASW.Tail(Document(1), 5, Equiv(' '))),
- Ada.Strings.Backward),
- Equiv("lived, reliable software systems."));
-
-
- -- Use several of the overloaded versions of "&" to form this
- -- unbounded wide string.
-
- Document(2) := Equiv('G') &
- ASW.To_Unbounded_Wide_String(Equiv("o ")) &
- ASW.To_Unbounded_Wide_String(Equiv("with")) &
- Equiv(' ') &
- Equiv("Ada!");
-
- end Enter_Text_Into_Document;
-
-
- -----
-
-
- procedure Create_Camera_Ready_Copy
- (Document : in Document_Type;
- Camera_Copy : out Camera_Ready_Copy_Type) is
- begin
- -- Break the unbounded wide strings into fixed lengths.
-
- -- Search the first unbounded wide string for portions of text that
- -- are less than or equal to the length of a wide string in the
- -- Camera_Ready_Copy_Type object.
-
- Camera_Copy(1) := -- Take characters 1-39,
- ASW.Slice(Document(1), -- and append a blank space.
- 1,
- ASW.Index(ASW.To_Unbounded_Wide_String
- (ASW.Slice(Document(1),
- 1,
- Line_Length)),
- Ada.Strings.Wide_Maps.To_Set(Equiv(' ')),
- Ada.Strings.Inside,
- Ada.Strings.Backward)) & Equiv(' ');
-
- Camera_Copy(2) := -- Take characters 40-79.
- ASW.Slice(Document(1),
- 40,
- (ASW.Index_Non_Blank -- Should return 79
- (ASW.To_Unbounded_Wide_String
- (ASW.Slice(Document(1), -- Slice (40..79)
- 40,
- 79)),
- Ada.Strings.Backward) + 39)); -- Increment since
- -- this slice starts
- -- at 40.
-
- Camera_Copy(3)(1..9) := ASW.Slice(Document(1), -- Characters 80-88
- 80,
- ASW.Length(Document(1)));
-
-
- -- Break the second unbounded wide string into the appropriate
- -- length. It is only twelve characters in length, so the entire
- -- unbounded wide string will be placed on one string of the output
- -- object.
-
- Camera_Copy(4)(1..ASW.Length(Document(2))) :=
- ASW.To_Wide_String(ASW.Head(Document(2),
- ASW.Length(Document(2))));
-
- end Create_Camera_Ready_Copy;
-
-
- -----
-
-
- function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type)
- return Boolean is
- begin
-
- -- Evaluate wide strings for equality, using the operators defined
- -- in package Ada.Strings.Wide_Unbounded. The less than/greater
- -- than or equal comparisons should evaluate to "equals => True".
-
- if ASW.To_Unbounded_Wide_String(Draft(1)) = -- "="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(1)) and
- ASW.To_Unbounded_Wide_String(Draft(2)) <= -- "<="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(2)) and
- ASW.To_Unbounded_Wide_String(Draft(3)) >= -- ">="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(3)) and
- ASW.To_Unbounded_Wide_String(Draft(4)) = -- "="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(4))
- then
- return True;
- else
- return False;
- end if;
-
- end Valid_Proofread;
-
-
- -----
-
-
- begin
-
- -- Enter text into the unbounded wide string paragraphs of the document.
-
- Enter_Text_Into_Document (Pamphlet);
-
-
- -- Reformat the unbounded wide strings into fixed wide string format.
-
- Create_Camera_Ready_Copy (Document => Pamphlet,
- Camera_Copy => Camera_Ready_Copy);
-
-
- -- Verify the conversion process.
-
- if not Valid_Proofread (Draft => Camera_Ready_Copy,
- Master => TC_Finished_Product)
- then
- Report.Failed ("Incorrect unbounded wide string processing result");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4021;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a
deleted file mode 100644
index 3c649a1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a
+++ /dev/null
@@ -1,531 +0,0 @@
--- CXA4022.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 subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Count, Element,
--- Index, Replace_Element, To_Unbounded_Wide_String, and "&", ">", "<".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings. The test simulates how unbounded wide strings
--- will be processed in a user environment, using the subprograms
--- provided in this package.
---
--- Taken in conjunction with tests CXA4021 and CXA4023, this test will
--- constitute a test of the functionality contained in package
--- Ada.Strings.Wide Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded wide string package
--- in ways typical of common usage, with different combinations of
--- available subprograms being used to accomplish similar
--- unbounded wide string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected accessibility level, type visibility,
--- and subtest acceptance criteria problems for
--- ACVC 2.0.1
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings;
-
-package CXA40220 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram character and string parameters to simulate the use of non-
- -- character Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character;
-
- function Equiv (Str : String) return Wide_String;
-
-
- -- Functions and access-to-subprogram value used to supply mapping
- -- capability to the appropriate versions of Count, Index, and
- -- Translate.
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
-end CXA40220;
-
-package body CXA40220 is
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- UnderScore : constant Wide_Character := Equiv('_');
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return UnderScore;
- else
- return From;
- end if;
- end AB_to_US_Mapping_Function;
-
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return Ada.Strings.Wide_Space;
- else
- return From;
- end if;
- end AB_to_Blank_Mapping_Function;
-
-end CXA40220;
-
-
-with CXA40220;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4022 is
-begin
-
- Report.Test ("CXA4022", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use CXA40220;
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type ASW.Unbounded_Wide_String;
-
- Test_String : ASW.Unbounded_Wide_String;
- AtoE_Str : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abcde"));
-
- Complete_String : ASW.Unbounded_Wide_String :=
- ASW."&"(ASW.To_Unbounded_Wide_String(Equiv("Incomplete")),
- ASW."&"(Ada.Strings.Wide_Space,
- ASW.To_Unbounded_Wide_String(Equiv("String"))));
-
- Incomplete_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String
- (Equiv("ncomplete Strin"));
-
- Incorrect_Spelling : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Guob Dai"));
-
- Magic_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abracadabra"));
-
- Incantation : ASW.Unbounded_Wide_String := Magic_String;
-
-
- A_Small_G : Wide_Character := Equiv('g');
- A_Small_D : Wide_Character := Equiv('d');
-
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("abcd"));
- B_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv('b'));
- CD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("cd"));
-
- CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => Equiv("cd"),
- To => Equiv("xy"));
- AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("ab"), Equiv("yz"));
-
-
- Matching_Letters : Natural := 0;
- Location,
- Total_Count : Natural := 0;
-
-
- Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- AB_to_US_Mapping_Function'Access;
-
-
- begin
-
-
- -- Function "&"
-
- -- Prepend an 'I' and append a 'g' to the wide string.
- Incomplete_String := ASW."&"(Equiv('I'),
- Incomplete_String); -- Ch & W Unb
- Incomplete_String := ASW."&"(Incomplete_String,
- A_Small_G); -- W Unb & Ch
-
- if ASW."<"(Incomplete_String, Complete_String) or
- ASW.">"(Incomplete_String, Complete_String) or
- Incomplete_String /= Complete_String
- then
- Report.Failed("Incorrect result from use of ""&"" operator");
- end if;
-
-
-
- -- Function Element
-
- -- Last element of the unbounded wide string should be a 'g'.
- if ASW.Element(Incomplete_String, ASW.Length(Incomplete_String)) /=
- A_Small_G
- then
- Report.Failed("Incorrect result from use of Function Element - 1");
- end if;
-
- if ASW.Element(Incomplete_String, 2) /=
- ASW.Element(ASW.Tail(Incomplete_String, 2), 1) or
- ASW.Element(ASW.Head(Incomplete_String, 4), 2) /=
- ASW.Element(ASW.To_Unbounded_Wide_String(Equiv("wnqz")), 2)
- then
- Report.Failed("Incorrect result from use of Function Element - 2");
- end if;
-
-
-
- -- Procedure Replace_Element
-
- -- The unbounded wide string Incorrect_Spelling starts as "Guob Dai",
- -- and is transformed by the following three procedure calls to
- -- "Good Day".
-
- ASW.Replace_Element(Incorrect_Spelling, 2, Equiv('o'));
-
- ASW.Replace_Element(Incorrect_Spelling,
- ASW.Index(Incorrect_Spelling, B_Set),
- A_Small_D);
-
- ASW.Replace_Element(Source => Incorrect_Spelling,
- Index => ASW.Length(Incorrect_Spelling),
- By => Equiv('y'));
-
- if Incorrect_Spelling /=
- ASW.To_Unbounded_Wide_String(Equiv("Good Day"))
- then
- Report.Failed("Incorrect result from Procedure Replace_Element");
- end if;
-
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String
- (Equiv("abcdefghij")),
- Pattern => Equiv("xy"),
- Going => Ada.Strings.Forward,
- Mapping => CD_to_XY_Map); -- change "cd" to "xy"
-
- if Location /= 3 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location := ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcdabcdab")),
- Equiv("yz"),
- Ada.Strings.Backward,
- AB_to_YZ_Map); -- change all "ab" to "yz"
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- -- A couple with identity maps (default) as well.
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), -- Pat = Src
- Equiv("abcd")) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), -- Pat < Src
- Equiv("abcd")) /= 0 or
- ASW.Index(ASW.Null_Unbounded_Wide_String, -- Src = Null
- Equiv("abc")) /= 0
- then
- Report.Failed
- ("Incorrect result from Index with wide string patterns");
- end if;
-
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- ASW.Index(Source => ASW.To_Unbounded_Wide_String(Equiv("abcdeabcde")),
- Set => CD_Set); -- set containing 'c' and 'd'
-
- if not (Location = 3) then -- position of first 'c' in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- ASW.Index(Source => ASW."&"(AtoE_Str, AtoE_Str),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward, Backward
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- Wide_Maps.To_Set(Equiv("xydcgf")),
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward) /= 2 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- Wide_Maps.To_Set(Equiv("xydcgf")),
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Backward) /= 5 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 5
- then
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Default direction (forward) and mapping (identity).
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("cd")), -- Source = Set
- CD_Set) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("c")), -- Source < Set
- CD_Set) /= 1 or
- ASW.Index(ASW.Null_Unbounded_Wide_String, -- Source = Null
- CD_Set) /= 0 or
- ASW.Index(AtoE_Str,
- Wide_Maps.Null_Set) /= 0 or -- Null set
- ASW.Index(AtoE_Str,
- Wide_Maps.To_Set(Equiv('x'))) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
-
-
- -- Function Index using access-to-subprogram mapping.
- -- Evaluate the function Index with an access value that supplies the
- -- mapping function for this version of Index.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String
- (Equiv("xAxabbxax xaax _cx")),
- Pattern => Equiv("_x"),
- Going => Ada.Strings.Forward,
- Mapping => Map_Ptr); -- change 'a'or 'b' to '_'
-
- if Location /= 6 then -- location of "bx" substring
- Report.Failed("Incorrect result from Index, access value map - 1");
- end if;
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Location := ASW.Index(ASW.To_Unbounded_Wide_String
- (Equiv("ccacdcbbcdacc")),
- Equiv("cd "),
- Ada.Strings.Backward,
- Map_Ptr); -- change 'a' or 'b' to ' '
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, access value map - 2");
- end if;
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")),
- Equiv(" cd"),
- Ada.Strings.Forward,
- Map_Ptr) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")),
- Equiv(" c "), -- No match
- Ada.Strings.Backward,
- Map_Ptr) /= 0
- then
- Report.Failed("Incorrect result from Index, access value map - 3");
- end if;
-
-
-
- -- Function Count
-
- -- Determine the number of characters in the unbounded wide string that
- -- are contained in the set.
-
- Matching_Letters := ASW.Count(Source => Magic_String,
- Set => ABCD_Set);
-
- if Matching_Letters /= 9 then
- Report.Failed
- ("Incorrect result from Function Count with Set parameter");
- end if;
-
- -- Determine the number of occurrences of the following pattern wide
- -- strings in the unbounded wide string Magic_String.
-
- if ASW.Count(Magic_String, Equiv("ab")) /=
- (ASW.Count(Magic_String, Equiv("ac")) +
- ASW.Count(Magic_String, Equiv("ad"))) or
- ASW.Count(Magic_String, Equiv("ab")) /= 2
- then
- Report.Failed
- ("Incorrect result from Function Count, wide string parameter");
- end if;
-
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abbabbabbabba")),
- Pattern => Equiv("yz"),
- Mapping => AB_to_YZ_Map);
-
- if Total_Count /= 4 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ADCBADABCD")),
- Equiv("AB"),
- Wide_Maps.To_Mapping(Equiv("CD"), Equiv("AB"))) /= 5 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("dcccddcdccdddccccd")),
- Equiv("xxy"),
- CD_to_XY_Map) /= 3
- then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 2");
- end if;
-
- -- And a few with identity Wide_Maps as well.
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ABABABABAB")),
- Equiv("ABA"),
- Wide_Maps.Identity) /= 2 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv("aaa")) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat
- Equiv("XXX"),
- Wide_Maps.Identity) /= 0 or
- ASW.Count(AtoE_Str, -- Source = Pattern
- Equiv("abcde")) /= 1 or
- ASW.Count(ASW.Null_Unbounded_Wide_String, -- Source = Null
- Equiv(" ")) /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
-
- -- Function Count using access-to-subprogram mapping.
- -- Evaluate the function Count with an access value specifying the
- -- mapping that is going to occur to Source.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Total_Count :=
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abcbacbadbaAbbB")),
- Pattern => Equiv("__"),
- Mapping => Map_Ptr); -- change 'a' and 'b' to '_'
-
- if Total_Count /= 5 then
- Report.Failed
- ("Incorrect result from function Count, access value map - 1");
- end if;
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("cccaccBcbcaccacAc")),
- Equiv("c c"),
- Map_Ptr) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String
- (Equiv("aBBAAABaBBBBAaBABBABaBBbBB")),
- Equiv(" BB"),
- Map_Ptr) /= 4 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv(" "),
- Map_Ptr) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat
- Equiv("XX "),
- Map_Ptr) /= 0 or
- ASW.Count(AtoE_Str, -- Source'Length = Pattern'Length
- Equiv(" cde"),
- Map_Ptr) /= 1
- then
- Report.Failed
- ("Incorrect result from function Count, access value map - 3");
- end if;
-
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4022;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a
deleted file mode 100644
index d0325fc..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a
+++ /dev/null
@@ -1,585 +0,0 @@
--- CXA4023.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 subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Delete,
--- Find_Token, Translate, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings. The test simulates how unbounded wide strings
--- will be processed in a user environment, using the subprograms
--- provided in this package.
---
--- This test, when taken in conjunction with tests CXA4021-22, will
--- constitute a test of the functionality contained in package
--- Ada.Strings.Wide_Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded wide string package
--- in ways typical of common usage, with different combinations of
--- available subprograms being used to accomplish similar
--- unbounded wide string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected accessibility level and type
--- visibility problems for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings;
-
-package CXA40230 is
-
- -- The following two functions are used to translate character and string
- -- values to non-character "Wide" values. They will be applied to all the
- -- Wide_Bounded subprogram character and string parameters to simulate the
- -- use of Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character;
-
- function Equiv (Str : String) return Wide_String;
-
- -- Functions and access-to-subprogram object used to supply mapping
- -- capability to the appropriate versions of Translate.
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
-end CXA40230;
-
-
-package body CXA40230 is
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- UnderScore : constant Wide_Character := Equiv('_');
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return UnderScore;
- else
- return From;
- end if;
- end AB_to_US_Mapping_Function;
-
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return Ada.Strings.Wide_Space;
- else
- return From;
- end if;
- end AB_to_Blank_Mapping_Function;
-
-end CXA40230;
-
-
-with CXA40230;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4023 is
-begin
-
- Report.Test ("CXA4023", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use CXA40230;
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type ASW.Unbounded_Wide_String;
-
- Test_String : ASW.Unbounded_Wide_String;
- AtoE_Str : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abcde"));
-
- Cad_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("cad"));
-
- Magic_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abracadabra"));
-
- Incantation : ASW.Unbounded_Wide_String := Magic_String;
-
-
- A_Small_G : Wide_Character := Equiv('g');
-
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("abcd"));
- B_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv('b'));
- AB_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps."OR"(Wide_Maps.To_Set(Equiv('a')), B_Set);
-
-
- AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => Equiv("ab"),
- To => Equiv("yz"));
- Code_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("abcd"), Equiv("wxyz"));
- Reverse_Code_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("wxyz"), Equiv("abcd"));
- Non_Existent_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("jkl"), Equiv("mno"));
-
-
- Token_Start : Positive;
- Token_End : Natural := 0;
-
- Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- AB_to_US_Mapping_Function'Access;
-
-
- begin
-
- -- Find_Token
-
- ASW.Find_Token(Magic_String, -- Find location of first "ab" equiv.
- AB_Set, -- Should be (1..2).
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Natural(Token_Start) /= ASW.To_Wide_String(Magic_String)'First or
- Token_End /= ASW.Index(Magic_String, B_Set) or
- Token_End /= 2
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 1");
- end if;
-
-
- ASW.Find_Token(Source => Magic_String, -- Find location of char 'r'equiv
- Set => ABCD_Set, -- in wide str, should be (3..3)
- Test => Ada.Strings.Outside,
- First => Token_Start,
- Last => Token_End);
-
- if Natural(Token_Start) /= 3 or Token_End /= 3 then
- Report.Failed("Incorrect result from Procedure Find_Token - 2");
- end if;
-
-
- ASW.Find_Token(Magic_String, -- No 'g' "equivalent in
- Wide_Maps.To_Set(A_Small_G), -- the wide str, so the
- Ada.Strings.Inside, -- result params should be
- First => Token_Start, -- First = Source'First and
- Last => Token_End); -- Last = 0.
-
-
- if Token_Start /= ASW.To_Wide_String(Magic_String)'First or
- Token_End /= 0
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 3");
- end if;
-
-
- ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")),
- Wide_Maps.To_Set(Equiv("trpq")),
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Token_Start /= 3 or
- Token_End /= 10
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 4");
- end if;
-
- ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")),
- Wide_Maps.To_Set(Equiv("abpq")),
- Ada.Strings.Outside,
- Token_Start,
- Token_End);
-
- if Token_Start /= 7 or
- Token_End /= 11
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 5");
- end if;
-
-
-
- -- Translate
-
- -- Use a mapping ("abcd" -> "wxyz") to transform the contents of
- -- the unbounded wide string.
- -- Magic_String = "abracadabra"
-
- Incantation := ASW.Translate(Magic_String, Code_Map);
-
- if Incantation /=
- ASW.To_Unbounded_Wide_String(Equiv("wxrwywzwxrw"))
- then
- Report.Failed("Incorrect result from Function Translate - 1");
- end if;
-
- -- (Note: See below for additional testing of Function Translate)
-
- -- Use the inverse mapping of the one above to return the "translated"
- -- unbounded wide string to its original form.
-
- ASW.Translate(Incantation, Reverse_Code_Map);
-
- -- The map contained in the following call to Translate contains three
- -- elements, and these elements are not found in the unbounded wide
- -- string, so this call to Translate should have no effect on it.
-
- if Incantation /= ASW.Translate(Magic_String, Non_Existent_Map) then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- -- Partial mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abcdeabcab"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyz")) then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- -- Total mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbaaababb"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzz")) then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- -- No mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("opabcdelmn"));
-
- ASW.Translate(Test_String,
- Wide_Maps.To_Mapping(Equiv("abcde"), Equiv("lmnop")));
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("oplmnoplmn")) then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
-
-
- -- Various degrees of mapping of source (full, partial, none) used
- -- with Function Translate.
-
- if ASW.Translate(
- ASW.To_Unbounded_Wide_String(Equiv("abcdeabcabbbaaacaa")),
- AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyzzzyyycyy")) or
-
- ASW.Translate(
- ASW.To_Unbounded_Wide_String(Equiv("abbaaababbaaaaba")),
- AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzzyyyyzy")) or
-
- ASW.Translate(ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")),
- Mapping => AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")) or
-
- ASW.Translate(ASW.To_Unbounded_Wide_String("opabcdelmnddeaccabec"),
- Wide_Maps.To_Mapping("abcde", "lmnop")) /=
- ASW.To_Unbounded_Wide_String("oplmnoplmnooplnnlmpn")
- then
- Report.Failed("Incorrect result from Function Translate - 2");
- end if;
-
-
-
- -- Procedure Translate using access-to-subprogram mapping.
- -- Partial mapping of source.
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abABaABbaBAbba"));
-
- ASW.Translate(Source => Test_String, -- change equivalent of 'a' and
- Mapping => Map_Ptr); -- 'b' to ' '
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv(" AB AB BA "))
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 1");
- end if;
-
- -- Total mapping of source to blanks.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbbab"));
-
- ASW.Translate(Source => Test_String,
- Mapping => Map_Ptr);
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv(" "))
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 2");
- end if;
-
- -- No mapping of source.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc"));
-
- ASW.Translate(Source => Test_String,
- Mapping => Map_Ptr);
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) -- no change
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 3");
- end if;
-
-
- -- Function Translate using access-to-subprogram mapping value.
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abAbBBAabbacD"));
-
- if ASW.Translate(ASW.Translate(Test_String, Map_Ptr), Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" A BBA cD"))
- then
- Report.Failed
- ("Incorrect result from Function Translate, access value map - 1");
- end if;
-
- if ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" ")) or
- ASW.Translate(ASW.To_Unbounded_Wide_String
- (Equiv(" aa Aa A AAaaa a aA")),
- Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" A A AA A")) or
- ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a ")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" ")) or
- ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("xyz")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv("xyz"))
- then
- Report.Failed
- ("Incorrect result from Function Translate, access value map - 2");
- end if;
-
-
-
- -- Trim
-
- Trim_Block:
- declare
-
- XYZ_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("xyz"));
- PQR_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("pqr"));
-
- Pad : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Pad"));
-
- The_New_Ada : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Ada9X"));
-
- Space_Array : array (1..4) of ASW.Unbounded_Wide_String :=
- (ASW.To_Unbounded_Wide_String(Equiv(" Pad ")),
- ASW.To_Unbounded_Wide_String(Equiv("Pad ")),
- ASW.To_Unbounded_Wide_String(Equiv(" Pad")),
- Pad);
-
- String_Array : array (1..5) of ASW.Unbounded_Wide_String :=
- (ASW.To_Unbounded_Wide_String(Equiv("xyzxAda9Xpqr")),
- ASW.To_Unbounded_Wide_String(Equiv("Ada9Xqqrp")),
- ASW.To_Unbounded_Wide_String(Equiv("zxyxAda9Xqpqr")),
- ASW.To_Unbounded_Wide_String(Equiv("xxxyAda9X")),
- The_New_Ada);
-
- begin
-
- -- Examine the version of Trim that removes blanks from
- -- the left and/or right of a wide string.
-
- for i in 1..4 loop
- if ASW.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then
- Report.Failed("Incorrect result from Trim for spaces - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- Examine the version of Trim that removes set characters from
- -- the left and right of a wide string.
-
- for i in 1..5 loop
- if ASW.Trim(String_Array(i),
- Left => XYZ_Set,
- Right => PQR_Set) /= The_New_Ada then
- Report.Failed
- ("Incorrect result from Trim for set characters - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- No trimming.
-
- if ASW.Trim(
- ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")),
- XYZ_Set,
- PQR_Set) /=
- ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz"))
- then
- Report.Failed
- ("Incorrect result from Trim for set, no trimming");
- end if;
-
- end Trim_Block;
-
-
-
- -- Delete
-
- -- Use the Delete function to remove the first four and last four
- -- characters from the wide string.
-
- if ASW.Delete(Source => ASW.Delete(Magic_String,
- 8,
- ASW.Length(Magic_String)),
- From => ASW.To_Wide_String(Magic_String)'First,
- Through => 4) /=
- Cad_String
- then
- Report.Failed("Incorrect results from Function Delete");
- end if;
-
-
-
- -- Constructors ("*")
-
- Constructor_Block:
- declare
-
- SOS : ASW.Unbounded_Wide_String;
-
- Dot : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Dot_"));
- Dash : constant Wide_String := Equiv("Dash_");
-
- Distress : ASW.Unbounded_Wide_String :=
- ASW."&"(ASW.To_Unbounded_Wide_String
- (Equiv("Dot_Dot_Dot_")),
- ASW."&"(ASW.To_Unbounded_Wide_String
- (Equiv("Dash_Dash_Dash_")),
- ASW.To_Unbounded_Wide_String
- (Equiv("Dot_Dot_Dot"))));
-
- Repeat : constant Natural := 3;
- Separator : constant Wide_Character := Equiv('_');
-
- Separator_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Separator);
-
- begin
-
- -- Use the following constructor forms to construct the wide string
- -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the
- -- trailing underscore in the wide string is removed in the call to
- -- Trim in the If statement condition.
-
- SOS := ASW."*"(Repeat, Dot); -- "*"(#, W Unb Str)
-
- SOS := ASW."&"(SOS,
- ASW."&"(ASW."*"(Repeat, Dash), -- "*"(#, W Str)
- ASW."*"(Repeat, Dot))); -- "*"(#, W Unb Str)
-
- if ASW.Trim(SOS, Wide_Maps.Null_Set, Separator_Set) /= Distress then
- Report.Failed("Incorrect results from Function ""*""");
- end if;
-
- end Constructor_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4023;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a
deleted file mode 100644
index 1b0af9c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a
+++ /dev/null
@@ -1,350 +0,0 @@
--- CXA4024.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 function "-", To_Ranges, To_Domain, and To_Range are
--- available in the package Ada.Strings.Maps, and that they produce
--- correct results based on the Character_Set/Character_Mapping input
--- provided.
---
--- TEST DESCRIPTION:
--- This test examines the operation of four functions from within the
--- Ada.Strings.Maps package. A variety of Character_Sequence,
--- Character_Set, and Character_Mapping objects are created and
--- initialized for use with these functions. In each subtest of
--- function operation, specific inputs are provided to the functions as
--- input parameters, and the results are evaluated against expected
--- values. Wherever appropriate, additional characteristics of the
--- function results are verified against the prescribed result
--- characteristics.
---
---
--- CHANGE HISTORY:
--- 03 Feb 95 SAIC Initial prerelease version
--- 10 Mar 95 SAIC Incorporated reviewer comments.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 05 Oct 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4024 is
-
-begin
-
- Report.Test ("CXA4024", "Check that the function ""-"", To_Ranges, " &
- "To_Domain, and To_Range are available in " &
- "the package Ada.Strings.Maps, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings, Ada.Strings.Maps;
- use type Maps.Character_Set; -- To allow logical set operator
- -- infix notation.
- package ACL1 renames Ada.Characters.Latin_1;
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Maps.Character_Sequence := "aeiou";
- Quasi_Vowel : constant Character := 'y';
-
- Alphabet : Maps.Character_Sequence (1..Last_Letter);
- Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Maps.Character_Set;
-
-
- begin
-
- -- Load the alphabet strings for use in creating sets.
- for i in 0..12 loop
- Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- for i in 0..25 loop
- Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- -- Initialize a series of Character_Set objects.
-
- Alphabet_Set := Maps.To_Set(Alphabet);
- Vowel_Set := Maps.To_Set(Vowels);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
- First_Half_Set := Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
-
- -- Evaluation of Set operator "-".
-
- if Consonant_Set /= "-"(Alphabet_Set, Vowel_Set) or
- Vowel_Set /= (Alphabet_Set - Consonant_Set) or
- Alphabet_Set /= Alphabet_Set - Maps.Null_Set or
- First_Half_Set /= "-"(Alphabet_Set, Second_Half_Set) or
- (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set))
- then
- Report.Failed("Incorrect result from ""-"" operator for sets");
- end if;
-
-
-
- -- Evaluation of Function "To_Ranges".
-
- declare
-
- use type Maps.Character_Range;
- use type Maps.Character_Ranges;
-
- Set_A_to_C : Maps.Character_Set := Maps.To_Set("ABC");
- Set_J : Maps.Character_Set := Maps.To_Set("J");
- Set_M_to_P : Maps.Character_Set := Maps.To_Set("MNOP");
- Set_X_to_Z : Maps.Character_Set := Maps.To_Set("XYZ");
- Set_Of_Five : Maps.Character_Set := Set_A_to_C OR -- Union of the
- Set_M_to_P OR -- five sets.
- Set_X_to_Z OR
- Set_J OR
- Maps.Null_Set;
-
- TC_Range_A_to_C : Maps.Character_Range := (Low => 'A', High => 'C');
- TC_Range_J : Maps.Character_Range := ('J', 'J');
- TC_Range_M_to_P : Maps.Character_Range := ('M', 'P');
- TC_Range_X_to_Z : Maps.Character_Range := (Low => 'X', High => 'Z');
-
- TC_Ranges : Maps.Character_Ranges (1..4) :=
- (1 => TC_Range_A_to_C,
- 2 => TC_Range_J,
- 3 => TC_Range_M_to_P,
- 4 => TC_Range_X_to_Z);
-
- begin
-
- -- Based on input of a set containing four separate "spans" of
- -- character sequences, Function To_Ranges is required to produce
- -- the shortest array of contiguous ranges of Character values in
- -- the input set, in increasing order of Low.
-
- declare
-
- -- This Character_Ranges constant should consist of array
- -- components, each component being a Character_Range from Low
- -- to High containing the appropriate characters.
-
- Ranges_Result : constant Maps.Character_Ranges :=
- Maps.To_Ranges(Set => Set_Of_Five);
- begin
-
- -- Check the structure and components of the Character_Ranges
- -- constant.
-
- if Ranges_Result(1) /= TC_Range_A_to_C or
- Ranges_Result(1).Low /= TC_Ranges(1).Low or
- Ranges_Result(2) /= TC_Range_J or
- Ranges_Result(2).High /= TC_Ranges(2).High or
- Ranges_Result(3) /= TC_Range_M_to_P or
- Ranges_Result(3).Low /= TC_Ranges(3).Low or
- Ranges_Result(3).High /= TC_Ranges(3).High or
- Ranges_Result(4) /= TC_Range_X_To_Z or
- Ranges_Result(4).Low /= TC_Ranges(4).Low or
- Ranges_Result(4).High /= TC_Ranges(4).High
- then
- Report.Failed ("Incorrect structure or components in " &
- "Character_Ranges constant");
- end if;
-
- exception
- when others =>
- Report.Failed("Exception raised using the Function To_Ranges " &
- "to initialize a Character_Ranges constant");
- end;
- end;
-
-
-
- -- Evaluation of Functions To_Domain and To_Range.
-
- declare
-
- Null_Sequence : constant Maps.Character_Sequence := "";
-
- TC_Upper_Case_Sequence : constant Maps.Character_Sequence :=
- "ZYXWVUTSRQPONMABCDEFGHIJKL";
- TC_Lower_Case_Sequence : constant Maps.Character_Sequence :=
- "zyxwvutsrqponmabcdefghijkl";
- TC_Unordered_Sequence : Maps.Character_Sequence(1..6) :=
- "BxACzy";
-
- TC_Upper_to_Lower_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Upper_Case_Sequence,
- TC_Lower_Case_Sequence);
-
- TC_Lower_to_Upper_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Lower_Case_Sequence,
- TC_Upper_Case_Sequence);
-
- TC_Unordered_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Unordered_Sequence,
- "ikglja");
- begin
-
- declare
-
- TC_Domain_1 : constant Maps.Character_Sequence :=
- Maps.To_Domain(TC_Upper_to_Lower_Map);
-
- TC_Domain_2 : constant Maps.Character_Sequence :=
- Maps.To_Domain(TC_Lower_to_Upper_Map);
-
- TC_Domain_3 : Maps.Character_Sequence(1..6);
-
- TC_Range_1 : constant Maps.Character_Sequence :=
- Maps.To_Range(TC_Upper_to_Lower_Map);
-
- TC_Range_2 : constant Maps.Character_Sequence :=
- Maps.To_Range(TC_Lower_to_Upper_Map);
-
- TC_Range_3 : Maps.Character_Sequence(1..6);
-
- begin
-
- -- Function To_Domain returns the shortest Character_Sequence
- -- value such that each character not in the result maps to
- -- itself, and all characters in the result are in ascending
- -- order.
-
- TC_Domain_3 := Maps.To_Domain(TC_Unordered_Map);
-
- -- Check contents of result of To_Domain, must be in ascending
- -- order.
-
- if TC_Domain_1 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- if TC_Domain_2 /= "abcdefghijklmnopqrstuvwxyz" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- if TC_Domain_3 /= "ABCxyz" then
- Report.Failed("Incorrect result from To_Domain with " &
- "an unordered mapping as input");
- end if;
-
-
- -- The lower bound on the returned Character_Sequence value
- -- from To_Domain must be 1.
-
- if TC_Domain_1'First /= 1 or
- TC_Domain_2'First /= 1 or
- TC_Domain_3'First /= 1
- then
- Report.Failed("Incorrect lower bound returned from To_Domain");
- end if;
-
-
- -- Check contents of result of To_Range.
-
- TC_Range_3 := Maps.To_Range(TC_Unordered_Map);
-
- if TC_Range_1 /= "abcdefghijklmnopqrstuvwxyz" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- if TC_Range_2 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- if TC_Range_3 /= "gilkaj" then
- Report.Failed("Incorrect result from To_Range with " &
- "an unordered mapping as input");
- end if;
-
-
- -- The lower bound on the returned Character_Sequence value
- -- must be 1.
-
- if TC_Range_1'First /= 1 or
- TC_Range_2'First /= 1 or
- TC_Range_3'First /= 1
- then
- Report.Failed("Incorrect lower bound returned from To_Range");
- end if;
-
-
- -- The upper bound on the returned Character_Sequence value
- -- must be Map'Length.
-
- if TC_Range_1'Last /= TC_Lower_Case_Sequence'Length or
- TC_Range_2'Last /= TC_Upper_Case_Sequence'Length or
- TC_Range_3'Last /= TC_Unordered_Sequence'Length
- then
- Report.Failed("Incorrect upper bound returned from To_Range");
- end if;
-
- end;
-
- -- Both function To_Domain and To_Range return the null string
- -- when provided the Identity character map as an input parameter.
-
- if Maps.To_Domain(Maps.Identity) /= Null_Sequence then
- Report.Failed("Function To_Domain did not return the null " &
- "string when provided the Identity map as " &
- "input");
- end if;
-
- if Maps.To_Range(Maps.Identity) /= Null_Sequence then
- Report.Failed("Function To_Range did not return the null " &
- "string when provided the Identity map as " &
- "input");
- end if;
-
- exception
- when others =>
- Report.Failed("Exception raised during the evaluation of " &
- "Function To_Domain and To_Range");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4024;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a
deleted file mode 100644
index 1665f7a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXA4025.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 functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Fixed, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test validates the subprograms found in the various Wide_Map
--- and Wide_String packages. It is based on the tests CXA4024 and
--- CXA4026, which are tests for the complementary "non-wide" packages.
---
--- The functions found in CXA4025_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-package CXA4025_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4025_0;
-
-with Ada.Characters.Handling;
-package body CXA4025_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4025_0;
-
-
-with CXA4025_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-
-procedure CXA4025 is
-begin
- Report.Test ("CXA4025",
- "Check that subprograms defined in packages " &
- "Ada.Strings.Wide_Maps and Ada.Strings.Wide_Fixed " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
-
- use Ada.Characters, Ada.Strings;
- use Ada.Exceptions;
- use type Wide_Maps.Wide_Character_Set;
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- Last_Letter : constant := 26;
- Vowels : constant Wide_Maps.Wide_Character_Sequence := "aeiou";
- TC_String : constant Wide_String := "A Standard String";
-
- Alphabet : Wide_Maps.Wide_Character_Sequence (1..Last_Letter);
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set : Wide_Maps.Wide_Character_Set;
-
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..12) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn &
- ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis);
-
- -- Note that there is no upper case version of the last two
- -- characters from above.
-
- TC_New_Character_String : Wide_String(1..12) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn &
- ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4025_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4025_0.Map_To_Upper_Case'Access;
-
- begin
-
- --
- -- Testing of functionality found in Package Ada.Strings.Wide_Maps.
- --
-
- -- Load the alphabet strings for use in creating sets.
- for i in 0..25 loop
- Alphabet(i+1) := Wide_Character'Val(Wide_Character'Pos('a')+i);
- end loop;
-
- -- Initialize a series of Character_Set objects.
- Alphabet_Set := Wide_Maps.To_Set(Alphabet);
- Vowel_Set := Wide_Maps.To_Set(Vowels);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- -- Evaluation of Set operator "-".
- if
- (Alphabet_Set - Consonant_Set) /=
- "AND"(Alphabet_Set, "NOT"(Consonant_Set)) or
- (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set))
- then
- Report.Failed("Incorrect result from ""-"" operator for sets");
- end if;
-
- -- Evaluation of Functions To_Domain and To_Range.
- declare
- Null_Sequence : constant Wide_Maps.Wide_Character_Sequence := "";
- TC_UC_Sequence : constant Wide_Maps.Wide_Character_Sequence :=
- "ZYXWVUTSRQPONMABCDEFGHIJKL";
- TC_LC_Sequence : constant Wide_Maps.Wide_Character_Sequence :=
- "zyxwvutsrqponmabcdefghijkl";
- TC_Upper_to_Lower_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(TC_UC_Sequence,
- TC_LC_Sequence);
- TC_Lower_to_Upper_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(TC_LC_Sequence,
- TC_UC_Sequence);
- begin
- declare
- TC_Domain : constant Wide_Maps.Wide_Character_Sequence :=
- Wide_Maps.To_Domain(TC_Upper_to_Lower_Map);
- TC_Range : constant Wide_Maps.Wide_Character_Sequence :=
- Wide_Maps.To_Range(TC_Lower_to_Upper_Map);
- begin
- -- Function To_Domain returns the shortest Wide_Character_Sequence
- -- value such that each wide character not in the result maps to
- -- itself, and all wide characters in the result are in ascending
- -- order.
- if TC_Domain /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- -- The lower bound on the returned Wide_Character_Sequence value
- -- from To_Domain must be 1.
- if TC_Domain'First /= 1 then
- Report.Failed("Incorrect lower bound returned from To_Domain");
- end if;
-
- -- Check contents of result of To_Range.
- if TC_Range /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- -- The lower bound on the returned Character_Sequence value
- -- must be 1.
- if TC_Range'First /= 1 then
- Report.Failed("Incorrect lower bound returned from To_Range");
- end if;
-
- if TC_Range'Last /= TC_LC_Sequence'Length then
- Report.Failed("Incorrect upper bound returned from To_Range");
- end if;
- end;
-
- -- Both function To_Domain and To_Range return the null string
- -- when provided the Identity character map as an input parameter.
- if Wide_Maps.To_Domain(Wide_Maps.Identity) /= Null_Sequence or
- Wide_Maps.To_Range(Wide_Maps.Identity) /= Null_Sequence
- then
- Report.Failed("Null sequence not returned from To_Domain or " &
- "To_Range when provided the Identity map as input");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during the evaluation of " &
- "Function To_Domain and To_Range");
- end;
-
- -- Testing of functionality found in Package Ada.Strings.Wide_Fixed.
- --
- -- Function Index, Forward direction search.
-
- if Wide_Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg",
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- Wide_Fixed.Index("STRING WITH NO MATCHING PATTERNS",
- "WITH",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Index, Backward direction search.
- if Wide_Fixed.Index("Case of a Mixed Case String",
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
- Wide_Fixed.Index("WOULD MATCH BUT FOR THE CASE",
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Count.
- if Wide_Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or
- Wide_Fixed.Count("", "match", Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
- -- Function Translate.
- if Wide_Fixed.Translate(Source => "A Sample Mixed Case String",
- Mapping => Map_To_Lower_Case_Ptr) /=
- "a sample mixed case string" or
- Wide_Fixed.Translate(New_Character_String,
- Map_To_Upper_Case_Ptr) /=
- TC_New_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Wide_Character Mapping Function parameter");
- end if;
-
- -- Procedure Translate.
- declare
- use Ada.Strings.Wide_Fixed;
- Str : Wide_String(1..19) := "A Mixed Case String";
- begin
- Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr);
- if Str /= "a mixed case string" then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
- end;
-
- -- Procedure Trim.
- declare
- use Ada.Strings.Wide_Fixed;
- Trim_String : Wide_String(1..30) := " A string of characters ";
- begin
- Trim(Trim_String, Ada.Strings.Left, Ada.Strings.Right, 'x');
- if Trim_String /= "xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = left, justify = right, pad = x");
- end if;
-
- Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center);
- if Trim_String /= " xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = right, justify = center, default pad");
- end if;
- end;
-
- -- Procedure Head.
- declare
- Fixed_String : Wide_String(1..20) := "A sample test string";
- begin
- Wide_Fixed.Head(Source => Fixed_String, Count => 14,
- Justify => Ada.Strings.Center, Pad => '$');
- if Fixed_String /= "$$$A sample test $$$" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = center, pad = $");
- end if;
-
- Wide_Fixed.Head(Fixed_String, 11, Ada.Strings.Right);
- if Fixed_String /= " $$$A sample" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = right, default pad");
- end if;
- end;
-
- -- Procedure Tail.
- declare
- use Ada.Strings.Wide_Fixed;
- Tail_String : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- begin
- -- Default left justify.
- Tail(Source => Tail_String, Count => 10, Pad => '-');
- if Tail_String /= "KLMNOPQRST----------" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "default justify, pad = -");
- end if;
-
- Tail(Tail_String, 6, Ada.Strings.Center, 'a');
- if Tail_String /= "aaaaaaa------aaaaaaa" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = center, pad = a");
- end if;
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4025;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a
deleted file mode 100644
index 766979a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a
+++ /dev/null
@@ -1,526 +0,0 @@
--- CXA4026.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 Ada.Strings.Fixed procedures Head, Tail, and Trim, as well
--- as the versions of subprograms Translate (procedure and function),
--- Index, and Count, available in the package which use a
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms contained in
--- the Ada.Strings.Fixed package.
--- This includes procedure versions of Head, Tail, and Trim, as well as
--- four subprograms that use a Character_Mapping_Function as a parameter
--- to provide the mapping capability.
---
--- Two functions are defined to provide the mapping. Access values
--- are defined to refer to these functions. One of the functions will
--- map upper case characters in the range 'A'..'Z' to their lower case
--- counterparts, while the other function will map lower case characters
--- ('a'..'z', or a character whose position is in one of the ranges
--- 223..246 or 248..255, provided the character has an upper case form)
--- to their upper case form.
---
--- Function Index uses the mapping function access value to map the input
--- string prior to searching for the appropriate index value to return.
--- Function Count uses the mapping function access value to map the input
--- string prior to counting the occurrences of the pattern string.
--- Both the Procedure and Function version of Translate use the mapping
--- function access value to perform the translation.
---
--- Results of all subprograms are compared with expected results.
---
---
--- CHANGE HISTORY:
--- 10 Feb 95 SAIC Initial prerelease version
--- 21 Apr 95 SAIC Modified definition of string variable Str_2.
---
---!
-
-
-package CXA4026_0 is
-
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Characters in the range 'A'..'Z' only, and return the input
- -- character otherwise.
-
- function Map_To_Lower_Case (From : Character) return Character;
-
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Character) return Character;
-
-end CXA4026_0;
-
-
-with Ada.Characters.Handling;
-package body CXA4026_0 is
-
- function Map_To_Lower_Case (From : Character) return Character is
- begin
- if From in 'A'..'Z' then
- return Character'Val(Character'Pos(From) -
- (Character'Pos('A') - Character'Pos('a')));
- else
- return From;
- end if;
- end Map_To_Lower_Case;
-
- function Map_To_Upper_Case (From : Character) return Character is
- begin
- return Ada.Characters.Handling.To_Upper(From);
- end Map_To_Upper_Case;
-
-end CXA4026_0;
-
-
-with CXA4026_0;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4026 is
-
-begin
-
- Report.Test ("CXA4026", "Check that procedures Trim, Head, and Tail, " &
- "as well as the versions of subprograms " &
- "Translate, Index, and Count, which use the " &
- "Character_Mapping_Function input parameter," &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings, CXA4026_0;
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
-
- New_Character_String : String(1..10) :=
- Ada.Characters.Latin_1.LC_A_Grave &
- Ada.Characters.Latin_1.LC_A_Ring &
- Ada.Characters.Latin_1.LC_AE_Diphthong &
- Ada.Characters.Latin_1.LC_C_Cedilla &
- Ada.Characters.Latin_1.LC_E_Acute &
- Ada.Characters.Latin_1.LC_I_Circumflex &
- Ada.Characters.Latin_1.LC_Icelandic_Eth &
- Ada.Characters.Latin_1.LC_N_Tilde &
- Ada.Characters.Latin_1.LC_O_Oblique_Stroke &
- Ada.Characters.Latin_1.LC_Icelandic_Thorn;
-
-
- TC_New_Character_String : String(1..10) :=
- Ada.Characters.Latin_1.UC_A_Grave &
- Ada.Characters.Latin_1.UC_A_Ring &
- Ada.Characters.Latin_1.UC_AE_Diphthong &
- Ada.Characters.Latin_1.UC_C_Cedilla &
- Ada.Characters.Latin_1.UC_E_Acute &
- Ada.Characters.Latin_1.UC_I_Circumflex &
- Ada.Characters.Latin_1.UC_Icelandic_Eth &
- Ada.Characters.Latin_1.UC_N_Tilde &
- Ada.Characters.Latin_1.UC_O_Oblique_Stroke &
- Ada.Characters.Latin_1.UC_Icelandic_Thorn;
-
-
- -- Functions used to supply mapping capability.
-
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Lower_Case'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Upper_Case'Access;
-
-
- begin
-
- -- Function Index, Forward direction search.
- -- Note: Several of the following cases use the default value
- -- Forward for the Going parameter.
-
- if Fixed.Index(Source => "The library package Strings.Fixed",
- Pattern => "fix",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 29 or
- Fixed.Index("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN",
- "ain",
- Mapping => Map_To_Lower_Case_Ptr) /= 6 or
- Fixed.Index("maximum number",
- "um",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 6 or
- Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg",
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- Fixed.Index("STRING WITH NO MATCHING PATTERNS",
- "WITH",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Index("THIS STRING IS IN UPPER CASE",
- "IS",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 3 or
- Fixed.Index("", -- Null string.
- "is",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Index("AAABBBaaabbb",
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Backward direction search.
-
- if Fixed.Index("Case of a Mixed Case String",
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
- Fixed.Index("Case of a Mixed Case String",
- "CASE",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 17 or
- Fixed.Index("rain, Rain, and more RAIN",
- "rain",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 22 or
- Fixed.Index("RIGHT place, right time",
- "RIGHT",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 14 or
- Fixed.Index("WOULD MATCH BUT FOR THE CASE",
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Fixed;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index("A Valid String",
- Null_Pattern_String,
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Count.
-
- if Fixed.Count(Source => "ABABABA",
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Fixed.Count("ABABABA", "ABA", Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Count("This IS a MISmatched issue",
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or
- Fixed.Count("This IS a MISmatched issue",
- "is",
- Map_To_Upper_Case_Ptr) /= 0 or
- Fixed.Count("She sells sea shells by the sea shore",
- "s",
- Map_To_Lower_Case_Ptr) /= 8 or
- Fixed.Count("", -- Null string.
- "match",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Fixed;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count("A Valid String",
- Null_Pattern_String,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character Mapping Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Translate.
-
- if Fixed.Translate(Source => "A Sample Mixed Case String",
- Mapping => Map_To_Lower_Case_Ptr) /=
- "a sample mixed case string" or
-
- Fixed.Translate("ALL LOWER CASE",
- Map_To_Lower_Case_Ptr) /=
- "all lower case" or
-
- Fixed.Translate("end with lower case",
- Map_To_Lower_Case_Ptr) /=
- "end with lower case" or
-
- Fixed.Translate("", Map_To_Lower_Case_Ptr) /=
- "" or
-
- Fixed.Translate("start with lower case",
- Map_To_Upper_Case_Ptr) /=
- "START WITH LOWER CASE" or
-
- Fixed.Translate("ALL UPPER CASE STRING",
- Map_To_Upper_Case_Ptr) /=
- "ALL UPPER CASE STRING" or
-
- Fixed.Translate("LoTs Of MiXeD CaSe ChArAcTeRs",
- Map_To_Upper_Case_Ptr) /=
- "LOTS OF MIXED CASE CHARACTERS" or
-
- Fixed.Translate("", Map_To_Upper_Case_Ptr) /=
- "" or
-
- Fixed.Translate(New_Character_String,
- Map_To_Upper_Case_Ptr) /=
- TC_New_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Procedure Translate.
-
- declare
-
- use Ada.Strings.Fixed;
-
- Str_1 : String(1..24) := "AN ALL UPPER CASE STRING";
- Str_2 : String(1..19) := "A Mixed Case String";
- Str_3 : String(1..32) := "a string with lower case letters";
- TC_Str_1 : constant String := Str_1;
- TC_Str_3 : constant String := Str_3;
-
- begin
-
- Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_1 /= "an all upper case string" then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_1 /= TC_Str_1 then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- Translate(Source => Str_2, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_2 /= "a mixed case string" then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- Translate(Source => Str_2, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_2 /= "A MIXED CASE STRING" then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- Translate(Source => Str_3, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_3 /= TC_Str_3 then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
- Translate(Source => Str_3, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_3 /= "A STRING WITH LOWER CASE LETTERS" then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
-
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- end;
-
-
- -- Procedure Trim.
-
- declare
- Use Ada.Strings.Fixed;
- Trim_String : String(1..30) := " A string of characters ";
- begin
-
- Trim(Source => Trim_String,
- Side => Ada.Strings.Left,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = left, justify = right, pad = x");
- end if;
-
- Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center);
-
- if Trim_String /= " xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = right, justify = center, default pad");
- end if;
-
- Trim(Trim_String, Ada.Strings.Both, Pad => '*');
-
- if Trim_String /= "xxxxA string of characters****" then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = both, default justify, pad = *");
- end if;
-
- end;
-
-
- -- Procedure Head.
-
- declare
- Fixed_String : String(1..20) := "A sample test string";
- begin
-
- Fixed.Head(Source => Fixed_String,
- Count => 14,
- Justify => Ada.Strings.Center,
- Pad => '$');
-
- if Fixed_String /= "$$$A sample test $$$" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = center, pad = $");
- end if;
-
- Fixed.Head(Fixed_String, 11, Ada.Strings.Right);
-
- if Fixed_String /= " $$$A sample" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = right, default pad");
- end if;
-
- Fixed.Head(Fixed_String, 9, Pad => '*');
-
- if Fixed_String /= " ***********" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "default justify, pad = *");
- end if;
-
- end;
-
-
- -- Procedure Tail.
-
- declare
- Use Ada.Strings.Fixed;
- Tail_String : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- begin
-
- Tail(Source => Tail_String, Count => 10, Pad => '-');
-
- if Tail_String /= "KLMNOPQRST----------" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "default justify, pad = -");
- end if;
-
- Tail(Tail_String, 6, Justify => Ada.Strings.Center, Pad => 'a');
-
- if Tail_String /= "aaaaaaa------aaaaaaa" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = center, pad = a");
- end if;
-
- Tail(Tail_String, 1, Ada.Strings.Right);
-
- if Tail_String /= " a" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = right, default pad");
- end if;
-
- Tail(Tail_String, 19, Ada.Strings.Right, 'A');
-
- if Tail_String /= "A a" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = right, pad = A");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4026;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a
deleted file mode 100644
index 05c66d4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a
+++ /dev/null
@@ -1,342 +0,0 @@
--- CXA4027.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 versions of Ada.Strings.Bounded subprograms Translate,
--- (procedure and function), Index, and Count, which use the
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms from within
--- the Ada.Strings.Bounded package that use the
--- Character_Mapping_Function mapping parameter to provide a mapping
--- capability.
---
--- Two functions are defined to provide the mapping. Access values
--- are defined to refer to these functions. One of the functions will
--- map upper case characters in the range 'A'..'Z' to their lower case
--- counterparts, while the other function will map lower case characters
--- ('a'..'z', or a character whose position is in one of the ranges
--- 223..246 or 248..255, provided the character has an upper case form)
--- to their upper case form.
---
--- Function Index uses the mapping function access value to map the input
--- string prior to searching for the appropriate index value to return.
--- Function Count uses the mapping function access value to map the input
--- string prior to counting the occurrences of the pattern string.
--- Both the Procedure and Function version of Translate use the mapping
--- function access value to perform the translation.
---
---
--- CHANGE HISTORY:
--- 16 FEB 95 SAIC Initial prerelease version
--- 17 Jul 95 SAIC Incorporated reviewer comments. Replaced two
--- internally declared functions with two library
--- level functions to eliminate accessibility
--- problems.
---
---!
-
-
--- Function CXA4027_0 will return the lower case form of
--- the character input if it is in upper case, and return the input
--- character otherwise.
-
-with Ada.Characters.Handling;
-function CXA4027_0 (From : Character) return Character;
-
-function CXA4027_0 (From : Character) return Character is
-begin
- return Ada.Characters.Handling.To_Lower(From);
-end CXA4027_0;
-
-
-
--- Function CXA4027_1 will return the upper case form of
--- Characters in the range 'a'..'z', or whose position is in one
--- of the ranges 223..246 or 248..255, provided the character has
--- an upper case form.
-
-with Ada.Characters.Handling;
-function CXA4027_1 (From : Character) return Character;
-
-function CXA4027_1 (From : Character) return Character is
-begin
- return Ada.Characters.Handling.To_Upper(From);
-end CXA4027_1;
-
-
-with CXA4027_0, CXA4027_1;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA4027 is
-begin
-
- Report.Test ("CXA4027", "Check that Ada.Strings.Bounded subprograms " &
- "Translate, Index, and Count, which use the " &
- "Character_Mapping_Function input parameter, " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings;
-
- -- Functions used to supply mapping capability.
-
- function Map_To_Lower_Case (From : Character) return Character
- renames CXA4027_0;
-
- function Map_To_Upper_Case (From : Character) return Character
- renames CXA4027_1;
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Lower_Case'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Upper_Case'Access;
-
-
- -- Instantiations of Bounded String generic package.
-
- package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
-
- use type BS1.Bounded_String, BS20.Bounded_String,
- BS40.Bounded_String, BS80.Bounded_String;
-
- String_1 : String(1..1) := "A";
- String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20;
- String_80 : String(1..80) := String_40 & String_40;
-
- BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String;
- BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String;
- BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String;
- BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String;
-
-
- begin
-
- -- Function Index.
-
- if BS40.Index(BS40.To_Bounded_String("Package Strings.Bounded"),
- Pattern => "s.b",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 15 or
- BS80.Index(BS80.To_Bounded_String("STRING TRANSLATIONS SUBPROGRAMS"),
- "tr",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS20.Index(BS20.To_Bounded_String("maximum number"),
- "um",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 10 or
- BS80.Index(BS80.To_Bounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"),
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- BS40.Index(BS40.To_Bounded_String("STRING WITH NO MATCHING PATTERN"),
- "WITH",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0 or
- BS80.Index(BS80.To_Bounded_String("THIS STRING IS IN UPPER CASE"),
- "I",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 16 or
- BS1.Index(BS1.Null_Bounded_String,
- "i",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
- BS40.Index(BS40.To_Bounded_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS80.Index(BS80.To_Bounded_String("WOULD MATCH BUT FOR THE CASE"),
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, using a " &
- "Character Mapping Function parameter");
- end if;
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use BS20;
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index(To_Bounded_String("A Valid String"),
- "",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character_Mapping_Function parameter " &
- "when given a null pattern string");
- end;
-
-
- -- Function Count.
-
- if BS20.Count(BS20.To_Bounded_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS20.Count(BS20.To_Bounded_String("ABABABA"),
- "ABA",
- Map_To_Lower_Case_Ptr) /= 0 or
- BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"),
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- BS80.Count(BS80.To_Bounded_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2 or
- BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"),
- "is",
- Map_To_Upper_Case_Ptr) /= 0 or
- BS80.Count(BS80.To_Bounded_String
- ("Peter Piper and his Pickled Peppers"),
- "p",
- Map_To_Lower_Case_Ptr) /= 7 or
- BS20.Count(BS20.To_Bounded_String("She sells sea shells"),
- "s",
- Map_To_Upper_Case_Ptr) /= 0 or
- BS80.Count(BS80.To_Bounded_String("No matches what-so-ever"),
- "matches",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use BS80;
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count(To_Bounded_String("A Valid String"),
- "",
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character_Mapping_Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character_Mapping_Function parameter " &
- "when given a null pattern string");
- end;
-
-
- -- Function Translate.
-
- if BS40.Translate(BS40.To_Bounded_String("A Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- BS40.To_Bounded_String("a mixed case string") or
-
- BS20."/="(BS20.Translate(BS20.To_Bounded_String("ALL LOWER CASE"),
- Map_To_Lower_Case_Ptr),
- "all lower case") or
-
- BS20."/="("end with lower case",
- BS20.Translate(
- BS20.To_Bounded_String("end with lower case"),
- Map_To_Lower_Case_Ptr)) or
-
- BS1.Translate(BS1.Null_Bounded_String,
- Map_To_Lower_Case_Ptr) /=
- BS1.Null_Bounded_String or
-
- BS80."/="(BS80.Translate(BS80.To_Bounded_String
- ("start with lower case, end with upper case"),
- Map_To_Upper_Case_Ptr),
- "START WITH LOWER CASE, END WITH UPPER CASE") or
-
- BS40.Translate(BS40.To_Bounded_String("ALL UPPER CASE STRING"),
- Map_To_Upper_Case_Ptr) /=
- BS40.To_Bounded_String("ALL UPPER CASE STRING") or
-
- BS80."/="(BS80.Translate(BS80.To_Bounded_String
- ("LoTs Of MiXeD CaSe ChArAcTeRs In ThE StRiNg"),
- Map_To_Upper_Case_Ptr),
- "LOTS OF MIXED CASE CHARACTERS IN THE STRING")
-
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
-
- -- Procedure Translate.
-
- BString_1 := BS1.To_Bounded_String("A");
-
- BS1.Translate(Source => BString_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if not BS1."="(BString_1, "a") then -- "=" for Bounded_String, String
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- BString_20 := BS20.To_Bounded_String(String_20);
- BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr);
-
- if BString_20 /= BS20.To_Bounded_String("abcdefghijklmnopqrst") then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- BString_40 := BS40.To_Bounded_String("String needing highlighting");
- BS40.Translate(BString_40, Map_To_Upper_Case_Ptr);
-
- if not (BString_40 = "STRING NEEDING HIGHLIGHTING") then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- BString_80 := BS80.Null_Bounded_String;
- BS80.Translate(BString_80, Map_To_Upper_Case_Ptr);
-
- if not (BString_80 = BS80.Null_Bounded_String) then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4027;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a
deleted file mode 100644
index bc6cac1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a
+++ /dev/null
@@ -1,331 +0,0 @@
--- CXA4028.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 Ada.Strings.Bounded procedures Append, Head, Tail, and
--- Trim, and relational operator functions "=", ">", ">=", "<", "<="
--- with parameter combinations of type String and Bounded_String,
--- produce correct results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms from within
--- the Ada.Strings.Bounded package. Four different instantiations of
--- Ada.Strings.Bounded.Generic_Bounded_Length provide packages defined
--- to manipulate bounded strings of lengths 1, 20, 40, and 80.
--- Examples of the above mentioned procedures and relational operators
--- from each of these instantiations are tested, with results compared
--- against expected output.
---
--- Testing of the function versions of many of the subprograms tested
--- here is performed in tests CXA4006-CXA4009.
---
---
--- CHANGE HISTORY:
--- 16 Feb 95 SAIC Initial prerelease version
--- 10 Mar 95 SAIC Incorporated reviewer comments.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Report;
-
-procedure CXA4028 is
-
-begin
-
- Report.Test ("CXA4028", "Check that Ada.Strings.Bounded procedures " &
- "Append, Head, Tail, and Trim, and relational " &
- "operator functions =, >, >=, <, <= with " &
- "parameter combinations of type String and " &
- "Bounded_String, produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Strings;
-
- -- Instantiations of Bounded String generic package.
-
- package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
-
- use type BS1.Bounded_String, BS20.Bounded_String,
- BS40.Bounded_String, BS80.Bounded_String;
-
- String_1 : String(1..1) := "A";
- String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20;
- String_80 : String(1..80) := String_40 & String_40;
-
- BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String;
- BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String;
- BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String;
- BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String;
-
- begin
-
- -- Procedure Append.
-
- declare
- use BS1, BS20;
- begin
- Append(Source => BString_1, New_Item => To_Bounded_String("A"));
- Append(BString_1, "B", Ada.Strings.Left);
- Append(BString_1, 'C', Drop => Ada.Strings.Right); -- Drop appended
- -- character.
- if BString_1 /= To_Bounded_String("B") then
- Report.Failed("Incorrect results from BS1 versions of " &
- "procedure Append");
- end if;
-
- Append(BString_20, 'T'); -- Character.
- Append(BString_20, "his string"); -- String.
- Append(BString_20,
- To_Bounded_String(" is complete."), -- Bounded string.
- Drop => Ada.Strings.Right); -- Drop 4 characters.
-
- if BString_20 /= To_Bounded_String("This string is compl") then
- Report.Failed("Incorrect results from BS20 versions of " &
- "procedure Append");
- end if;
- end;
-
-
- -- Operator "=".
-
- BString_40 := BS40.To_Bounded_String(String_40);
- BString_80 := BS80.To_Bounded_String(
- BS40.To_String(BString_40) &
- BS40.To_String(BString_40));
-
- if not (BString_40 = String_40 and -- (Bounded_String, String)
- BS80."="(String_80, BString_80)) -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator "<".
-
- BString_1 := BS1.To_Bounded_String("cat", -- string "c" only.
- Drop => Ada.Strings.Right);
- BString_20 := BS20.To_Bounded_String("Santa Claus");
-
- if BString_1 < "C" or -- (Bounded_String, String)
- BS1."<"(BString_1,"c") or -- (Bounded_String, String)
- "x" < BString_1 or -- (String, Bounded_String)
- BString_20 < "Santa " or -- (Bounded_String, String)
- "Santa and his Elves" < BString_20 -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""<"" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator "<=".
-
- BString_20 := BS20.To_Bounded_String("Sample string");
-
- if BString_20 <= "Sample strin" or -- (Bounded_String, String)
- "sample string" <= BString_20 or -- (String, Bounded_String)
- not("Sample string" <= BString_20) -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""<="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator ">".
-
- BString_40 := BS40.To_Bounded_String("A MUCH LONGER SAMPLE STRING.");
-
- if BString_40 > "A much longer sample string" or -- (Bnd_Str, Str)
- String_20 > BS40.To_Bounded_String(String_40) or -- (Str, Bnd_Str)
- BS40.To_Bounded_String("ABCDEFGH") > "abcdefgh" -- (Str, Bnd_Str)
- then
- Report.Failed("Incorrect results from function "">"" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator ">=".
-
- BString_80 := BS80.To_Bounded_String(String_80);
-
- if not (BString_80 >= String_80 and
- BS80.To_Bounded_String("Programming") >= "PROGRAMMING" and
- "test" >= BS80.To_Bounded_String("tess"))
- then
- Report.Failed("Incorrect results from function "">="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Procedure Trim
-
- BString_20 := BS20.To_Bounded_String(" Left Spaces ");
- BS20.Trim(Source => BString_20,
- Side => Ada.Strings.Left);
-
- if "Left Spaces " /= BString_20 then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Left");
- end if;
-
- BString_40 := BS40.To_Bounded_String(" Right Spaces ");
- BS40.Trim(BString_40, Side => Ada.Strings.Right);
-
- if BString_40 /= " Right Spaces" then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Right");
- end if;
-
- BString_20 := BS20.To_Bounded_String(" Both Sides ");
- BS20.Trim(BString_20, Ada.Strings.Both);
-
- if BString_20 /= BS20.To_Bounded_String("Both Sides") then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Both");
- end if;
-
- BString_80 := BS80.To_Bounded_String("Centered Spaces");
- BS80.Trim(BString_80, Ada.Strings.Both);
-
- if BString_80 /= BS80.To_Bounded_String("Centered Spaces") then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "no blank spaces on the ends of the string");
- end if;
-
-
- -- Procedure Head
-
- BString_40 := BS40.To_Bounded_String("Test String");
- BS40.Head(Source => BString_40,
- Count => 4); -- Count < Source'Length
-
- if BString_40 /= BS40.To_Bounded_String("Test") then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_1 := BS1.To_Bounded_String("X");
- BS1.Head(BString_1, BS1.Length(BString_1)); -- Count = Source'Length
-
- if BString_1 /= "X" then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter equal to Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Sample string");
- BS20.Head(BString_20,
- Count => BS20.Max_Length, -- Count > Source'Length
- Pad => '*');
-
- if BString_20 /= BS20.To_Bounded_String("Sample string*******") then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Twenty Characters 20");
- BS20.Head(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left);
-
- if BString_20 /= "enty Characters 20**" then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Left");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Short String");
- BS20.Head(BString_20, 23, '-', Ada.Strings.Right);
-
- if ("Short String--------") /= BString_20 then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
-
- -- Procedure Tail
-
- BString_40 := BS40.To_Bounded_String("Test String");
- BS40.Tail(Source => BString_40,
- Count => 6); -- Count < Source'Length
-
- if BString_40 /= BS40.To_Bounded_String("String") then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_1 := BS1.To_Bounded_String("X");
- BS1.Tail(BString_1, BS1.Length(BString_1)); -- Count = Source'Length
-
- if BString_1 /= "X" then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter equal to Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Sample string");
- BS20.Tail(BString_20,
- Count => BS20.Max_Length, -- Count > Source'Length
- Pad => '*');
-
- if BString_20 /= BS20.To_Bounded_String("*******Sample string") then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Twenty Characters"); -- Len = 17
- BS20.Tail(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left);
-
- if BString_20 /= "***Twenty Characters" then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Left");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Maximum Length Chars");
- BS20.Tail(BString_20, 23, '-', Ada.Strings.Right);
-
- if ("---Maximum Length Ch") /= BString_20 then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4028;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a
deleted file mode 100644
index 7140674..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a
+++ /dev/null
@@ -1,333 +0,0 @@
--- CXA4029.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 functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Bounded, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test tests the subprograms found in the
--- Ada.Strings.Wide_Bounded package. It is based on the tests
--- CXA4027-28, which are tests for the complementary "non-wide"
--- packages.
---
--- The functions found in CXA4029_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-package CXA4029_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4029_0;
-
-with Ada.Characters.Handling;
-package body CXA4029_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4029_0;
-
-
-with CXA4029_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Bounded;
-
-procedure CXA4029 is
-begin
- Report.Test ("CXA4029",
- "Check that subprograms defined in package " &
- "Ada.Strings.Wide_Bounded produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
- package BS1 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80);
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- use Ada.Characters, Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type BS1.Bounded_Wide_String, BS20.Bounded_Wide_String,
- BS40.Bounded_Wide_String, BS80.Bounded_Wide_String;
-
- TC_String : constant Wide_String := "A Standard String";
-
- BString_1 : BS1.Bounded_Wide_String :=
- BS1.Null_Bounded_Wide_String;
- BString_20 : BS20.Bounded_Wide_String :=
- BS20.Null_Bounded_Wide_String;
- BString_40 : BS40.Bounded_Wide_String :=
- BS40.Null_Bounded_Wide_String;
- BString_80 : BS80.Bounded_Wide_String :=
- BS80.Null_Bounded_Wide_String;
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn);
-
- TC_New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4029_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4029_0.Map_To_Upper_Case'Access;
-
- begin
-
- -- Testing of functionality found in Package Ada.Strings.Wide_Bounded.
- --
- -- Function Index.
-
- if BS80.Index(BS80.To_Bounded_Wide_String("CoMpLeTeLy MiXeD CaSe"),
- "MIXED CASE",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- BS1.Index(BS1.Null_Bounded_Wide_String,
- "i",
- Mapping => Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from BND Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Count.
- if BS40.Count(BS40.To_Bounded_Wide_String("This IS a MISmatched issue"),
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- BS80.Count(BS80.To_Bounded_Wide_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2
- then
- Report.Failed("Incorrect results from BND Function Count, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
- -- Function Translate.
- if BS40.Translate(BS40.To_Bounded_Wide_String("A Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- BS40.To_Bounded_Wide_String("a mixed case string") or
- BS20."/="("end with lower case",
- BS20.Translate(
- BS20.To_Bounded_Wide_String("end with lower case"),
- Map_To_Lower_Case_Ptr))
- then
- Report.Failed("Incorrect results from BND Function Translate, " &
- "using a Character_Mapping_Function parameter");
- end if;
-
- -- Procedure Translate.
- BString_20 := BS20.To_Bounded_Wide_String(String_20);
- BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr);
- if BString_20 /= BS20.To_Bounded_Wide_String("abcdefghijklmnopqrst")
- then
- Report.Failed("Incorrect result from BND Procedure Translate - 1");
- end if;
-
- BString_80 := BS80.Null_Bounded_Wide_String;
- BS80.Translate(BString_80, Map_To_Upper_Case_Ptr);
- if not (BString_80 = BS80.Null_Bounded_Wide_String) then
- Report.Failed("Incorrect result from BND Procedure Translate - 2");
- end if;
-
- -- Procedure Append.
- declare
- use BS20;
- begin
- BString_20 := BS20.Null_Bounded_Wide_String;
- Append(BString_20, 'T');
- Append(BString_20, "his string");
- Append(BString_20,
- To_Bounded_Wide_String(" is complete."),
- Drop => Ada.Strings.Right); -- Drop 4 characters.
- if BString_20 /= To_Bounded_Wide_String("This string is compl") then
- Report.Failed("Incorrect results from BS20 versions of " &
- "procedure Append");
- end if;
- exception
- when others => Report.Failed("Exception raised in block checking " &
- "BND Procedure Append");
- end;
-
- -- Operator "=".
- BString_40 := BS40.To_Bounded_Wide_String(String_40);
- BString_80 := BS80.To_Bounded_Wide_String(
- BS40.To_Wide_String(BString_40) &
- BS40.To_Wide_String(BString_40));
- if not (BString_40 = String_40 and
- BS80."="(String_80, BString_80)) then
- Report.Failed("Incorrect results from BND Function ""="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator "<".
- BString_1 := BS1.To_Bounded_Wide_String("cat",
- Drop => Ada.Strings.Right);
- BString_20 := BS20.To_Bounded_Wide_String("Santa Claus");
- if BString_1 < "C" or
- BS1."<"(BString_1,"c") or
- BS1."<"("x", BString_1) or
- BS20."<"(BString_20,"Santa ") or
- BS20."<"("Santa and his Elves", BString_20)
- then
- Report.Failed("Incorrect results from BND Function ""<"" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator "<=".
- BString_20 := BS20.To_Bounded_Wide_String("Sample string");
- if BS20."<="(BString_20,"Sample strin") or
- not(BS20."<="("Sample string",BString_20))
- then
- Report.Failed("Incorrect results from BND Function ""<="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator ">".
- BString_40 := BS40.To_Bounded_Wide_String(
- "A MUCH LONGER SAMPLE STRING.");
- if BString_40 > "A much longer sample string" or
- BS40.To_Bounded_Wide_String("ABCDEFGH") > "abcdefgh"
- then
- Report.Failed("Incorrect results from BND Function "">"" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator ">=".
- BString_80 := BS80.To_Bounded_Wide_String(String_80);
- if not (BString_80 >= String_80 and
- BS80.To_Bounded_Wide_String("Programming") >= "PROGRAMMING" and
- BS80.">="("test", BS80.To_Bounded_Wide_String("tess")))
- then
- Report.Failed("Incorrect results from BND Function "">="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Procedure Trim
- BString_20 := BS20.To_Bounded_Wide_String(" Both Sides ");
- BS20.Trim(BString_20, Ada.Strings.Both);
- if BString_20 /= BS20.To_Bounded_Wide_String("Both Sides") then
- Report.Failed("Incorrect results from BND Procedure Trim with " &
- "Side = Both");
- end if;
-
- -- Procedure Head
- BString_40 := BS40.To_Bounded_Wide_String("Test String");
- BS40.Head(Source => BString_40,
- Count => 4); -- Count < Source'Length
- if BString_40 /= BS40.To_Bounded_Wide_String("Test") then
- Report.Failed("Incorrect results from BND Procedure Head with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_Wide_String("Short String");
- BS20.Head(BString_20, 23, '-', Ada.Strings.Right);
- if BS20.To_Bounded_Wide_String("Short String--------") /= BString_20 then
- Report.Failed("Incorrect results from BND Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- -- Procedure Tail
- BString_40 := BS40.To_Bounded_Wide_String("Test String");
- BS40.Tail(Source => BString_40,
- Count => 6);
- if BString_40 /= BS40.To_Bounded_Wide_String("String") then
- Report.Failed("Incorrect results from BND Procedure Tail with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_Wide_String("Maximum Length Chars");
- BS20.Tail(BString_20, 23, '-', Ada.Strings.Right);
- if BS20.To_Bounded_Wide_String("---Maximum Length Ch") /= BString_20 then
- Report.Failed("Incorrect results from BND Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4029;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a
deleted file mode 100644
index 475d008..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a
+++ /dev/null
@@ -1,414 +0,0 @@
--- CXA4030.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 Ada.Strings.Unbounded versions of subprograms Translate
--- (procedure and function), Index, and Count, which use a
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of the four subprograms contained
--- in the Ada.Strings.Unbounded package that use a
--- Character_Mapping_Function parameter to provide the mapping
--- capability.
--- Two Character_Mapping_Function objects are defined that reference
--- subprograms contained in the Ada.Characters.Handling package;
--- To_Lower will return the lower-case form of the character provided
--- as the input parameter, To_Upper will return the upper-case form
--- of the character input parameter (provided there is an upper-case
--- form).
--- In several instances in this test, the character handling functions
--- are referenced directly in the parameter list of the subprograms
--- under test, demonstrating another form of expected common usage.
---
--- Results of all subprograms are compared with expected results.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4031, and CXA4032 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 21 Feb 95 SAIC Initial prerelease version
--- 21 Apr 95 SAIC Modified header commentary.
---
---!
-
-with Ada.Strings.Unbounded;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4030 is
-
-begin
-
- Report.Test ("CXA4030", "Check that Ada.Strings.Unbounded versions " &
- "of subprograms Translate (procedure and " &
- "function), Index, and Count, which use a " &
- "Maps.Character_Mapping_Function input " &
- "parameter, produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use type Unb.Unbounded_String;
- use Ada.Strings;
- use Ada.Characters;
-
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
-
- New_Character_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(
- Latin_1.LC_A_Grave &
- Latin_1.LC_A_Ring &
- Latin_1.LC_AE_Diphthong &
- Latin_1.LC_C_Cedilla &
- Latin_1.LC_E_Acute &
- Latin_1.LC_I_Circumflex &
- Latin_1.LC_Icelandic_Eth &
- Latin_1.LC_N_Tilde &
- Latin_1.LC_O_Oblique_Stroke &
- Latin_1.LC_Icelandic_Thorn);
-
-
- TC_New_Character_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(
- Latin_1.UC_A_Grave &
- Latin_1.UC_A_Ring &
- Latin_1.UC_AE_Diphthong &
- Latin_1.UC_C_Cedilla &
- Latin_1.UC_E_Acute &
- Latin_1.UC_I_Circumflex &
- Latin_1.UC_Icelandic_Eth &
- Latin_1.UC_N_Tilde &
- Latin_1.UC_O_Oblique_Stroke &
- Latin_1.UC_Icelandic_Thorn);
-
-
- -- In this test, access objects are defined to refer to two functions
- -- from the Ada.Characters.Handling package. These access objects
- -- will be provided as parameters to the subprograms under test.
- -- Note: There will be several examples in this test of these character
- -- handling functions being referenced directly within the
- -- parameter list of the subprograms under test.
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Handling.To_Lower'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Handling.To_Upper'Access;
-
- begin
-
- -- Function Index, Forward direction search.
- -- Note: Several of the following cases use the default value
- -- Forward for the Going parameter.
-
- if Unb.Index(Source => Unb.To_Unbounded_String(
- "The library package Strings.Unbounded"),
- Pattern => "unb",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 29 or
-
- Unb.Index(Unb.To_Unbounded_String(
- "THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"),
- "ain",
- Mapping => Map_To_Lower_Case_Ptr) /= 6 or
-
- Unb.Index(Unb.To_Unbounded_String("maximum number"),
- "um",
- Ada.Strings.Forward,
- Handling.To_Lower'Access) /= 6 or
-
- Unb.Index(Unb.To_Unbounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"),
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
-
- Unb.Index(Unb.To_Unbounded_String(
- "STRING WITH NO MATCHING PATTERNS"),
- "WITH",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Index(Unb.To_Unbounded_String("THIS STRING IS IN UPPER CASE"),
- "IS",
- Ada.Strings.Forward,
- Handling.To_Upper'Access) /= 3 or
-
- Unb.Index(Unb.Null_Unbounded_String,
- "is",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Index(Unb.To_Unbounded_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Handling.To_Lower'Access) /= 2
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Backward direction search.
-
- if Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"),
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
-
- Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"),
- "CASE",
- Ada.Strings.Backward,
- Mapping => Map_To_Upper_Case_Ptr) /= 17 or
-
- Unb.Index(Unb.To_Unbounded_String("rain, Rain, and more RAIN"),
- "rain",
- Ada.Strings.Backward,
- Handling.To_Lower'Access) /= 22 or
-
- Unb.Index(Unb.To_Unbounded_String("RIGHT place, right time"),
- "RIGHT",
- Ada.Strings.Backward,
- Handling.To_Upper'Access) /= 14 or
-
- Unb.Index(Unb.To_Unbounded_String("WOULD MATCH BUT FOR THE CASE"),
- "WOULD MATCH BUT FOR THE CASE",
- Going => Ada.Strings.Backward,
- Mapping => Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use Unbounded;
- Null_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index(To_Unbounded_String("A Valid Unbounded String"),
- Null_String,
- Going => Ada.Strings.Forward,
- Mapping => Handling.To_Lower'Access);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Count.
-
- if Unb.Count(Source => Unb.To_Unbounded_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
-
- Unb.Count(Unb.To_Unbounded_String("ABABABA"),
- "ABA",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"),
- "is",
- Handling.To_Lower'Access) /= 4 or
-
- Unb.Count(Unb.To_Unbounded_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2 or
-
- Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"),
- "is",
- Mapping => Map_To_Upper_Case_Ptr) /= 0 or
-
- Unb.Count(Unb.To_Unbounded_String(
- "She sells sea shells by the sea shore"),
- "s",
- Handling.To_Lower'Access) /= 8 or
-
- Unb.Count(Unb.Null_Unbounded_String,
- "match",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Unbounded;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count(To_Unbounded_String("A Valid String"),
- Null_Pattern_String,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character Mapping Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Translate.
-
- if Unb.Translate(Source => Unb.To_Unbounded_String(
- "A Sample Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- Unb.To_Unbounded_String("a sample mixed case string") or
-
- Unb.Translate(Unb.To_Unbounded_String("ALL LOWER CASE"),
- Handling.To_Lower'Access) /=
- Unb.To_Unbounded_String("all lower case") or
-
- Unb.Translate(Unb.To_Unbounded_String("end with lower case"),
- Map_To_Lower_Case_Ptr) /=
- Unb.To_Unbounded_String("end with lower case") or
-
- Unb.Translate(Unb.Null_Unbounded_String,
- Handling.To_Lower'Access) /=
- Unb.Null_Unbounded_String or
-
- Unb.Translate(Unb.To_Unbounded_String("start with lower case"),
- Map_To_Upper_Case_Ptr) /=
- Unb.To_Unbounded_String("START WITH LOWER CASE") or
-
- Unb.Translate(Unb.To_Unbounded_String("ALL UPPER CASE STRING"),
- Handling.To_Upper'Access) /=
- Unb.To_Unbounded_String("ALL UPPER CASE STRING") or
-
- Unb.Translate(Unb.To_Unbounded_String(
- "LoTs Of MiXeD CaSe ChArAcTeRs"),
- Map_To_Upper_Case_Ptr) /=
- Unb.To_Unbounded_String("LOTS OF MIXED CASE CHARACTERS") or
-
- Unb.Translate(New_Character_String,
- Handling.To_Upper'Access) /=
- TC_New_Character_String
-
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Procedure Translate.
-
- declare
-
- use Ada.Strings.Unbounded;
- use Ada.Characters.Handling;
-
- Str_1 : Unbounded_String :=
- To_Unbounded_String("AN ALL UPPER CASE STRING");
- Str_2 : Unbounded_String :=
- To_Unbounded_String("A Mixed Case String");
- Str_3 : Unbounded_String :=
- To_Unbounded_String("a string with lower case letters");
- TC_Str_1 : constant Unbounded_String := Str_1;
- TC_Str_3 : constant Unbounded_String := Str_3;
-
- begin
-
- Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_1 /= To_Unbounded_String("an all upper case string") then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_1 /= TC_Str_1 then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- Translate(Str_2, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_2 /= To_Unbounded_String("a mixed case string") then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- Translate(Str_2, Mapping => To_Upper'Access);
-
- if Str_2 /= To_Unbounded_String("A MIXED CASE STRING") then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- Translate(Str_3, To_Lower'Access);
-
- if Str_3 /= TC_Str_3 then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
- Translate(Str_3, To_Upper'Access);
-
- if Str_3 /=
- To_Unbounded_String("A STRING WITH LOWER CASE LETTERS")
- then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
-
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4030;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a
deleted file mode 100644
index 91bc68c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXA4031.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 subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the functions To_Unbounded_String (version with Length
--- parameter), "=", "<", "<=", ">", ">=" (all with String-Unbounded
--- String parameter mix), as well as three versions of Procedure Append.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the subprograms provided in this package.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4030, and CXA4032 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 27 Feb 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4031 is
-begin
-
- Report.Test ("CXA4031", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use Unb;
- use Ada.Exceptions;
-
- subtype LC_Characters is Character range 'a'..'z';
-
- Null_String : constant String := "";
- TC_String : constant String := "A Standard String";
-
- TC_Unb_String,
- TC_New_Unb_String : Unb.Unbounded_String := Unb.Null_Unbounded_String;
-
- begin
-
- -- Function To_Unbounded_String (version with Length parameter)
- -- returns an unbounded string that represents an uninitialized String
- -- whose length is Length.
- -- Note: Unbounded_String length can vary conceptually between 0 and
- -- Natural'Last.
-
- if Unb.Length(Unb.To_Unbounded_String(Length => 10)) /= 10 or
- Unb.Length(Unb.To_Unbounded_String(1)) /= 1 or
- Unb.Length(Unb.To_Unbounded_String(0)) /= 0 or
- Unb.Length(Unb."&"(Unb.To_Unbounded_String(Length => 10),
- Unb."&"(Unb.To_Unbounded_String(1),
- Unb.To_Unbounded_String(0) ))) /= 10+1+0
- then
- Report.Failed
- ("Incorrect results from Function To_Unbounded_String with " &
- "Length parameter");
- end if;
-
-
- -- Procedure Append (Unbounded - Unbounded)
- -- Note: For each of the Append procedures, the resulting string
- -- represented by the Source parameter is given by the
- -- concatenation of the original value of Source and the value
- -- of New_Item.
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L");
- TC_New_Unb_String := Unb.To_Unbounded_String(" and then some");
-
- Unb.Append(Source => TC_Unb_String, New_Item => TC_New_Unb_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Sample string of length L and then some")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 1");
- end if;
-
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L");
- TC_New_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, TC_New_Unb_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Sample string of length L")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 2");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String,
- Unb.To_Unbounded_String("New Unbounded String"));
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("New Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 3");
- end if;
-
-
- -- Procedure Append (Unbounded - String)
-
- TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String and ");
-
- Unb.Append(Source => TC_Unb_String, New_Item => TC_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("An Unbounded String and A Standard String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 1");
- end if;
-
-
- TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String");
-
- Unb.Append(TC_Unb_String, New_Item => Null_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("An Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 2");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, TC_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("A Standard String") then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 3");
- end if;
-
-
- -- Procedure Append (Unbounded - Character)
-
- TC_Unb_String := Unb.To_Unbounded_String("Lower Case = ");
-
- for i in LC_Characters'Range loop
- Unb.Append(Source => TC_Unb_String, New_Item => LC_Characters(i));
- end loop;
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Lower Case = abcdefghijklmnopqrstuvwxyz")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a character " &
- "parameter - 1");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, New_Item => 'a');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("a") then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a character " &
- "parameter - 2");
- end if;
-
-
- -- Function "="
-
- TC_Unb_String := Unb.To_Unbounded_String(TC_String);
-
- if not (TC_Unb_String = TC_String) or -- (Unb_Str, Str)
- not Unb."="("A Standard String", TC_Unb_String) or -- (Str, Unb_Str)
- not ((Unb.Null_Unbounded_String = "") and -- (Unb_Str, Str)
- ("Test String" = -- (Str, Unb_Str)
- Unb.To_Unbounded_String("Test String")))
- then
- Report.Failed("Incorrect results from function ""="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function "<"
-
- if not ("Extra Space" < Unb.To_Unbounded_String("Extra Space ") and
- Unb.To_Unbounded_String("tess") < "test" and
- Unb.To_Unbounded_String("best") < "test") or
- Unb.Null_Unbounded_String < Null_String or
- " leading blank" < Unb.To_Unbounded_String(" leading blank") or
- "ending blank " < Unb.To_Unbounded_String("ending blank ")
- then
- Report.Failed("Incorrect results from function ""<"" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function "<="
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string");
-
- if TC_Unb_String <= "Sample strin" or -- (Unb_Str, Str)
- "sample string" <= TC_Unb_String or -- (Str, Unb_Str)
- not(Unb.Null_Unbounded_String <= "") or -- (Unb_Str, Str)
- not("Sample string" <= TC_Unb_String) -- (Str, Unb_Str)
- then
- Report.Failed("Incorrect results from function ""<="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function ">"
-
- TC_Unb_String := Unb.To_Unbounded_String("A MUCH LONGER STRING");
-
- if not ("A much longer string" > TC_Unb_String and
- Unb.To_Unbounded_String(TC_String) > "A Standard Strin" and
- "abcdefgh" > Unb.To_Unbounded_String("ABCDEFGH")) or
- Unb.Null_Unbounded_String > Null_String
- then
- Report.Failed("Incorrect results from function "">"" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function ">="
-
- TC_Unb_String := Unb.To_Unbounded_String(TC_String);
-
- if not (TC_Unb_String >= TC_String and
- Null_String >= Unb.Null_Unbounded_String and
- "test" >= Unb.To_Unbounded_String("tess") and
- Unb.To_Unbounded_String("Programming") >= "PROGRAMMING")
- then
- Report.Failed("Incorrect results from function "">="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4031;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a
deleted file mode 100644
index 031d01c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a
+++ /dev/null
@@ -1,457 +0,0 @@
--- CXA4032.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 procedures defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the procedures Replace_Slice, Insert, Overwrite, Delete,
--- Trim (2 versions), Head, and Tail.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the procedures defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the procedures provided in this package.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4030, and CXA4031 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the procedures defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 02 Mar 95 SAIC Initial prerelease version.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants;
-with Ada.Strings.Unbounded;
-
-procedure CXA4032 is
-begin
-
- Report.Test ("CXA4032", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use Unb;
- use Ada.Strings;
-
- TC_Null_String : constant String := "";
- TC_String_5 : String(1..5) := "ABCDE";
-
- TC_Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String("Test String");
-
- begin
-
- -- Procedure Replace_Slice
-
- begin -- Low > Source'Last+1
- Unb.Replace_Slice(Source => TC_Unb_String,
- Low => Unb.Length(TC_Unb_String) + 2,
- High => Unb.Length(TC_Unb_String),
- By => TC_String_5);
- Report.Failed("Index_Error not raised by Replace_Slice when Low " &
- "> Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Replace_Slice" &
- "when Low > Source'Last+1");
- end;
-
- -- High >= Low
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Replace_Slice(TC_Unb_String, 5, 5, TC_String_5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("TestABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 1");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String, 1, 4, TC_String_5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 2");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String,
- 11,
- Unb.Length(TC_Unb_String),
- TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 3");
- end if;
-
- -- High < Low
-
- Unb.Replace_Slice(TC_Unb_String, Low => 4, High => 1, By => "xxx");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCxxxDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 4");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String, Low => 1, High => 0, By => "yyy");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 5");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String,
- Unb.Length(TC_Unb_String) + 1,
- Unb.Length(TC_Unb_String),
- By => "zzz");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDEzzz") then
- Report.Failed("Incorrect results from Replace_Slice - 6");
- end if;
-
-
- -- Procedure Insert
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- begin -- Before not in Source'First..Source'Last + 1
- Unb.Insert(Source => TC_Unb_String,
- Before => Unb.Length(TC_Unb_String) + 2,
- New_Item => TC_String_5);
- Report.Failed("Index_Error not raised by Insert when Before " &
- "not in the range Source'First..Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Insert when Before not in " &
- "the range Source'First..Source'Last+1");
- end;
-
- Unb.Insert(TC_Unb_String, 1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test String") then
- Report.Failed("Incorrect results from Insert - 1");
- end if;
-
- Unb.Insert(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test String**") then
- Report.Failed("Incorrect results from Insert - 2");
- end if;
-
- Unb.Insert(TC_Unb_String, 8, "---");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then
- Report.Failed("Incorrect results from Insert - 3");
- end if;
-
- Unb.Insert(TC_Unb_String, 3, TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then
- Report.Failed("Incorrect results from Insert - 4");
- end if;
-
-
- -- Procedure Overwrite
-
- begin -- Position not in Source'First..Source'Last + 1
- Unb.Overwrite(Source => TC_Unb_String,
- Position => Unb.Length(TC_Unb_String) + 2,
- New_Item => TC_String_5);
- Report.Failed("Index_Error not raised by Overwrite when Position " &
- "not in the range Source'First..Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Overwrite when Position not " &
- "in the range Source'First..Source'Last+1");
- end;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Overwrite(Source => TC_Unb_String,
- Position => 1,
- New_Item => "XXXX");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String") then
- Report.Failed("Incorrect results from Overwrite - 1");
- end if;
-
- Unb.Overwrite(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then
- Report.Failed("Incorrect results from Overwrite - 2");
- end if;
-
- Unb.Overwrite(TC_Unb_String, 3, TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then
- Report.Failed("Incorrect results from Overwrite - 3");
- end if;
-
- Unb.Overwrite(TC_Unb_String, 1, "abcdefghijklmn");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("abcdefghijklmn") then
- Report.Failed("Incorrect results from Overwrite - 4");
- end if;
-
-
- -- Procedure Delete
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- -- From > Through (No change to Source)
-
- Unb.Delete(Source => TC_Unb_String,
- From => Unb.Length(TC_Unb_String),
- Through => Unb.Length(TC_Unb_String)-1);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Delete - 1");
- end if;
-
- Unb.Delete(TC_Unb_String, 1, 0);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Delete - 2");
- end if;
-
- -- From <= Through
-
- Unb.Delete(TC_Unb_String, 1, 5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("String") then
- Report.Failed("Incorrect results from Delete - 3");
- end if;
-
- Unb.Delete(TC_Unb_String, 3, 3);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Sting") then
- Report.Failed("Incorrect results from Delete - 4");
- end if;
-
-
- -- Procedure Trim
-
- TC_Unb_String := Unb.To_Unbounded_String("No Spaces");
-
- Unb.Trim(Source => TC_Unb_String, Side => Ada.Strings.Both);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("No Spaces") then
- Report.Failed("Incorrect results from Trim - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String(" Leading Spaces ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Left);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Leading Spaces ") then
- Report.Failed("Incorrect results from Trim - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String(" Ending Spaces ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Right);
-
- if TC_Unb_String /= Unb.To_Unbounded_String(" Ending Spaces") then
- Report.Failed("Incorrect results from Trim - 3");
- end if;
-
- TC_Unb_String :=
- Unb.To_Unbounded_String(" Spaces on both ends ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Both);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Spaces on both ends")
- then
- Report.Failed("Incorrect results from Trim - 4");
- end if;
-
-
- -- Procedure Trim (with Character Set parameters)
-
- TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters");
-
- Unb.Trim(Source => TC_Unb_String,
- Left => Ada.Strings.Maps.Constants.Lower_Set,
- Right => Ada.Strings.Maps.Constants.Lower_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("CASE") then
- Report.Failed("Incorrect results from Trim with Sets - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters");
-
- Unb.Trim(TC_Unb_String,
- Ada.Strings.Maps.Constants.Upper_Set,
- Ada.Strings.Maps.Constants.Upper_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("lowerCASEletters") then
- Report.Failed("Incorrect results from Trim with Sets - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("012abcdefghGFEDCBA789ab");
-
- Unb.Trim(TC_Unb_String,
- Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set,
- Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ghG") then
- Report.Failed("Incorrect results from Trim with Sets - 3");
- end if;
-
-
- -- Procedure Head
-
- -- Count <= Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => 0,
- Pad => '*');
-
- if TC_Unb_String /= Unb.Null_Unbounded_String then
- Report.Failed("Incorrect results from Head - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => 4,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test") then
- Report.Failed("Incorrect results from Head - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String),
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Head - 3");
- end if;
-
- -- Count > Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 4,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String****") then
- Report.Failed("Incorrect results from Head - 4");
- end if;
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 3,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("***") then
- Report.Failed("Incorrect results from Head - 5");
- end if;
-
-
- -- Procedure Tail
-
- -- Count <= Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => 0,
- Pad => '*');
-
- if TC_Unb_String /= Unb.Null_Unbounded_String then
- Report.Failed("Incorrect results from Tail - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => 6,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("String") then
- Report.Failed("Incorrect results from Tail - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String),
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Tail - 3");
- end if;
-
- -- Count > Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 5,
- Pad => 'x');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("xxxxxTest String") then
- Report.Failed("Incorrect results from Tail - 4");
- end if;
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 3,
- Pad => 'X');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXX") then
- Report.Failed("Incorrect results from Tail - 5");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4032;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a
deleted file mode 100644
index 8f39b4c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a
+++ /dev/null
@@ -1,405 +0,0 @@
--- CXA4033.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 functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Unbounded, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test tests the subprograms found in the
--- Ada.Strings.Wide_Unbounded package. It is based on the tests
--- CXA4030-32, which are tests for the complementary "non-wide"
--- packages.
---
--- The functions found in CXA4033_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 24 Feb 97 PWB.CTA Removed attempt to create wide string of length
--- Natural'Last
---!
-
-package CXA4033_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4033_0;
-
-with Ada.Characters.Handling;
-package body CXA4033_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4033_0;
-
-
-with CXA4033_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4033 is
-begin
- Report.Test ("CXA4033",
- "Check that subprograms defined in the package " &
- "Ada.Strings.Wide_Unbounded produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
- package Unb renames Ada.Strings.Wide_Unbounded;
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- use Ada.Characters, Ada.Strings, Unb;
- use type Wide_Maps.Wide_Character_Set;
-
- TC_String : constant Wide_String := "A Standard String";
-
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
- TC_Unb_String : Unbounded_Wide_String := Null_Unbounded_Wide_String;
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn);
-
- TC_New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn);
-
- New_UB_Character_String : Unbounded_Wide_String :=
- To_Unbounded_Wide_String(New_Character_String);
-
- TC_New_UB_Character_String : Unbounded_Wide_String :=
- To_Unbounded_Wide_String(TC_New_Character_String);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4033_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4033_0.Map_To_Upper_Case'Access;
-
- begin
-
- -- Testing functionality found in Package Ada.Strings.Wide_Unbounded.
- --
- -- Function Index.
-
- if Index(To_Unbounded_Wide_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Index(To_Unbounded_Wide_String("Case of a Mixed Case String"),
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17
- then
- Report.Failed("Incorrect results from Function Index, " &
- "using a Wide Character Mapping Function parameter");
- end if;
-
- -- Function Count.
- if Count(Source => To_Unbounded_Wide_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Count(Null_Unbounded_Wide_String, "mat", Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
- -- Function Translate.
- if Translate(To_Unbounded_Wide_String("A Sample Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- To_Unbounded_Wide_String("a sample mixed case string") or
- Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr) /=
- TC_New_UB_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, " &
- "using a Character Mapping Function parameter");
- end if;
-
- -- Procedure Translate.
- declare
- use Ada.Characters.Handling;
- Str : Unbounded_Wide_String :=
- To_Unbounded_Wide_String("AN ALL UPPER CASE STRING");
- begin
- Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr);
- if Str /= To_Unbounded_Wide_String("an all upper case string") then
- Report.Failed("Incorrect result from Procedure Translate 1");
- end if;
-
- Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr);
- if New_UB_Character_String /= TC_New_UB_Character_String then
- Report.Failed("Incorrect result from Procedure Translate 2");
- end if;
- end;
-
- -- Function To_Unbounded_Wide_String (version with Length parameter)
- if Length(To_Unbounded_Wide_String(Length => 10)) /= 10 or
- Length(To_Unbounded_Wide_String(0)) /= 0 or
- Length( To_Unbounded_Wide_String(10) &
- To_Unbounded_Wide_String(1) &
- To_Unbounded_Wide_String(0) ) /= 10 + 1 + 0
- then
- Report.Failed
- ("Incorrect results from Function To_Unbounded_Wide_String " &
- "with Length parameter");
- end if;
-
- -- Procedure Append (Wide_Unbounded - Wide_Unbounded)
- TC_Unb_String := Null_Unbounded_Wide_String;
- Append(TC_Unb_String, To_Unbounded_Wide_String("New Unbounded String"));
- if TC_Unb_String /= To_Unbounded_Wide_String("New Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded wide string parameters");
- end if;
-
-
- -- Procedure Append (Wide_Unbounded - Wide_String)
- TC_Unb_String := To_Unbounded_Wide_String("An Unbounded String and ");
- Append(Source => TC_Unb_String, New_Item => TC_String);
- if TC_Unb_String /=
- To_Unbounded_Wide_String("An Unbounded String and A Standard String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded wide string parameter and a wide " &
- "string parameter");
- end if;
-
- -- Procedure Append (Wide_Unbounded - Wide_Character)
- TC_Unb_String := To_Unbounded_Wide_String("Lower Case = ");
- for i in LC_Characters'Range loop
- Append(Source => TC_Unb_String, New_Item => LC_Characters(i));
- end loop;
- if TC_Unb_String /=
- Unb.To_Unbounded_Wide_String
- ("Lower Case = abcdefghijklmnopqrstuvwxyz")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded wide string parameter and a wide " &
- "character parameter");
- end if;
-
- -- Function "="
- TC_Unb_String := To_Unbounded_Wide_String(TC_String);
- if not (TC_Unb_String = TC_String) or
- not "="("A Standard String", TC_Unb_String) or
- not ((Null_Unbounded_Wide_String = "") and
- ("Test String" = To_Unbounded_Wide_String("Test String")))
- then
- Report.Failed("Incorrect results from Function ""="" with " &
- "wide_string - unbounded wide string parameters");
- end if;
-
- -- Function "<"
- if not ("Extra Space" < To_Unbounded_Wide_String("Extra Space ") and
- To_Unbounded_Wide_String("tess") < "test" and
- To_Unbounded_Wide_String("best") < "test")
- then
- Report.Failed("Incorrect results from Function ""<"" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function "<="
- TC_Unb_String := To_Unbounded_Wide_String("Sample string");
- if TC_Unb_String <= "Sample strin" or
- not("Sample string" <= TC_Unb_String)
- then
- Report.Failed("Incorrect results from Function ""<="" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function ">"
- TC_Unb_String := To_Unbounded_Wide_String("A MUCH LONGER STRING");
- if not ("A much longer string" > TC_Unb_String and
- To_Unbounded_Wide_String(TC_String) > "A Standard Strin" and
- "abcdefgh" > To_Unbounded_Wide_String("ABCDEFGH"))
- then
- Report.Failed("Incorrect results from Function "">"" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function ">="
- TC_Unb_String := To_Unbounded_Wide_String(TC_String);
- if not (TC_Unb_String >= TC_String and
- "test" >= To_Unbounded_Wide_String("tess") and
- To_Unbounded_Wide_String("Programming") >= "PROGRAMMING")
- then
- Report.Failed("Incorrect results from Function "">="" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Procedure Replace_Slice
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Replace_Slice(TC_Unb_String, 5, 5, TC_String_5);
- if TC_Unb_String /= To_Unbounded_Wide_String("TestABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 1");
- end if;
-
- Replace_Slice(TC_Unb_String, 1, 4, TC_String_5);
- if TC_Unb_String /= To_Unbounded_Wide_String("ABCDEABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 2");
- end if;
-
- -- Procedure Insert
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Insert(TC_Unb_String, 1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("**Test String") then
- Report.Failed("Incorrect results from Procedure Insert - 1");
- end if;
-
- Insert(TC_Unb_String, Length(TC_Unb_String)+1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("**Test String**") then
- Report.Failed("Incorrect results from Procedure Insert - 2");
- end if;
-
- -- Procedure Overwrite
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Overwrite(TC_Unb_String, 1, New_Item => "XXXX");
- if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String") then
- Report.Failed("Incorrect results from Procedure Overwrite - 1");
- end if;
-
- Overwrite(TC_Unb_String, Length(TC_Unb_String)+1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String**") then
- Report.Failed("Incorrect results from Procedure Overwrite - 2");
- end if;
-
- -- Procedure Delete
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Delete(TC_Unb_String, 1, 0);
- if TC_Unb_String /= To_Unbounded_Wide_String("Test String") then
- Report.Failed("Incorrect results from Procedure Delete - 1");
- end if;
-
- Delete(TC_Unb_String, 1, 5);
- if TC_Unb_String /= To_Unbounded_Wide_String("String") then
- Report.Failed("Incorrect results from Procedure Delete - 2");
- end if;
-
- -- Procedure Trim
- TC_Unb_String := To_Unbounded_Wide_String(" Leading Spaces ");
- Trim(TC_Unb_String, Ada.Strings.Left);
- if TC_Unb_String /= To_Unbounded_Wide_String("Leading Spaces ") then
- Report.Failed("Incorrect results from Procedure Trim - 1");
- end if;
-
- TC_Unb_String :=
- To_Unbounded_Wide_String(" Spaces on both ends ");
- Trim(TC_Unb_String, Ada.Strings.Both);
- if TC_Unb_String /=
- To_Unbounded_Wide_String("Spaces on both ends")
- then
- Report.Failed("Incorrect results from Procedure Trim - 2");
- end if;
-
- -- Procedure Trim (with Wide_Character_Set parameters)
- TC_Unb_String := To_Unbounded_Wide_String("012abcdefghGFEDCBA789ab");
- Trim(TC_Unb_String,
- Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set,
- Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set);
- if TC_Unb_String /= To_Unbounded_Wide_String("ghG") then
- Report.Failed("Incorrect results from Procedure Trim with Sets");
- end if;
-
- -- Procedure Head
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Head(Source => TC_Unb_String, Count => 0, Pad => '*');
- if TC_Unb_String /= Null_Unbounded_Wide_String then
- Report.Failed("Incorrect results from Procedure Head - 1");
- end if;
-
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Head(Source => TC_Unb_String, Count => 4, Pad => '*');
- if TC_Unb_String /= To_Unbounded_Wide_String("Test") then
- Report.Failed("Incorrect results from Procedure Head - 2");
- end if;
-
- -- Procedure Tail
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Tail(Source => TC_Unb_String, Count => 0, Pad => '*');
- if TC_Unb_String /= Null_Unbounded_Wide_String then
- Report.Failed("Incorrect results from Procedure Tail - 1");
- end if;
-
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Tail(TC_Unb_String, Length(TC_Unb_String) + 5, 'x');
- if TC_Unb_String /= To_Unbounded_Wide_String("xxxxxTest String") then
- Report.Failed("Incorrect results from Procedure Tail - 2");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4033;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a
deleted file mode 100644
index a1ed53d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- CXA4034.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Ada.Strings.Bounded.Slice raises Index_Error if
--- High > Length (Source) or Low > Length (Source) + 1.
--- (Defect Report 8652/0049).
---
--- Check that Ada.Strings.Wide_Bounded.Slice raises Index_Error if
--- High > Length (Source) or Low > Length (Source) + 1.
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 14 MAR 2001 RLB Added Wide_Bounded subtest.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Wide_Bounded;
-use Ada.Strings;
-with Report;
-use Report;
-procedure CXA4034 is
-
- package Bs is new Ada.Strings.Bounded.Generic_Bounded_Length (40);
-
- package WBs is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (32);
-
- Source : String (Ident_Int (1) .. Ident_Int (30));
-
- Wide_Source : Wide_String (Ident_Int (1) .. Ident_Int (24));
-
- X : Bs.Bounded_String;
-
- WX : WBs.Bounded_Wide_String;
-
-begin
- Test ("CXA4034",
- "Check that Slice raises Index_Error if either Low or High is " &
- "greater than the Length(Source) for Ada.Strings.Bounded and " &
- "Ada.Strings.Wide_Bounded");
-
- -- Fill Source with "ABC..."
- for I in Source'Range loop
- Source (I) := Ident_Char (Character'Val (I +
- Character'Pos ('A') - Source'First));
- end loop;
- -- and W with "ABC..."
- for I in Wide_Source'Range loop
- Wide_Source (I) := Ident_Wide_Char (Wide_Character'Val (I +
- Wide_Character'Pos ('A') - Wide_Source'First));
- end loop;
-
- X := Bs.To_Bounded_String (Source);
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (28), High => Ident_Int (41));
- begin
- Failed ("No exception raised by Slice - 1");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 1");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (8), High => Ident_Int (31));
- begin
- Failed ("No exception raised by Slice - 2");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 2");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (15), High => Ident_Int (30));
- begin
- if S /= Source(15..30) then
- Failed ("Wrong result - 3");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 3");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (42), High => Ident_Int (28));
- begin
- Failed ("No exception raised by Slice - 4");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 4");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (31), High => Ident_Int (28));
- begin
- if S /= "" then
- Failed ("Wrong result - 5");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 5");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (30), High => Ident_Int (30));
- begin
- if S /= Source(30..30) then
- Failed ("Wrong result - 6");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 6");
- end;
-
- WX := WBs.To_Bounded_Wide_String (Wide_Source);
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (21), High => Ident_Int (33));
- begin
- Failed ("No exception raised by Slice - 7");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 7");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (8), High => Ident_Int (25));
- begin
- Failed ("No exception raised by Slice - 8");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 8");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (15), High => Ident_Int (24));
- begin
- if W /= Wide_Source(15..24) then
- Failed ("Wrong result - 8");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 9");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (36), High => Ident_Int (20));
- begin
- Failed ("No exception raised by Slice - 10");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 10");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (25), High => Ident_Int (21));
- begin
- if W /= "" then
- Failed ("Wrong result - 11");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 11");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (24), High => Ident_Int (24));
- begin
- if W /= Wide_Source(24..24) then
- Failed ("Wrong result - 12");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 12");
- end;
-
- Result;
-end CXA4034;
-
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a
deleted file mode 100644
index c9a007e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a
+++ /dev/null
@@ -1,471 +0,0 @@
--- CXA5011.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, for both Float_Random and Discrete_Random packages,
--- the following are true:
--- 1) two objects of type Generator are initialized to the same state.
--- 2) when the Function Reset is used to reset two generators
--- to different time-dependent states, the resulting random values
--- from each generator are different.
--- 3) when the Function Reset uses the same integer initiator
--- to reset two generators to the same state, the resulting random
--- values from each generator are identical.
--- 4) when the Function Reset uses different integer initiator
--- values to reset two generators, the resulting random numbers are
--- different.
---
--- TEST DESCRIPTION:
--- This test evaluates components of the Ada.Numerics.Float_Random and
--- Ada.Numerics.Discrete_Random packages.
--- This test checks to see that objects of type Generator are initialized
--- to the same state. In addition, the functionality of Function Reset is
--- validated.
--- For each of the objectives above, evaluation of the various generators
--- is performed using each of the following techniques. When the states of
--- two generators are to be compared, each state is saved, then
--- transformed to a bounded-string variable. The bounded-strings can
--- then be compared for equality. In this case, matching bounded-strings
--- are evidence that the states of two generators are the same.
--- In addition, two generators are compared by evaluating a series of
--- random numbers they produce. A matching series of random numbers
--- implies that the generators were in the same state prior to producing
--- the numbers.
---
---
--- CHANGE HISTORY:
--- 20 Apr 95 SAIC Initial prerelease version.
--- 07 Jul 95 SAIC Incorporated reviewer comments/suggestions.
--- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 17 Aug 96 SAIC Deleted Subtest #2.
--- 09 Feb 01 RLB Repaired to work on implementations with a 16-bit
--- Integer.
-
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Float_Random;
-with Ada.Numerics.Discrete_Random;
-with Ada.Strings.Bounded;
-with ImpDef;
-with Report;
-
-procedure CXA5011 is
-begin
-
- Report.Test ("CXA5011", "Check the effect of Function Reset on the " &
- "state of random number generators");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use Ada.Strings.Bounded;
-
- -- Declare an modular subtype, and use it to instantiate the discrete
- -- random number generator generic package.
-
- type Discrete_Range is mod 2**(Integer'Size-1);
- package Discrete_Package is new Discrete_Random(Discrete_Range);
-
- -- Declaration of random number generator objects.
-
- Discrete_Generator_1,
- Discrete_Generator_2 : Discrete_Package.Generator;
- Float_Generator_1,
- Float_Generator_2 : Float_Random.Generator;
-
- -- Declaration of bounded string packages instantiated with the
- -- value of Max_Image_Width constant from each random number generator
- -- package, and bounded string variables used to hold the image of
- -- random number generator states.
-
- package Discrete_String_Pack is
- new Generic_Bounded_Length(Discrete_Package.Max_Image_Width);
-
- package Float_String_Pack is
- new Generic_Bounded_Length(Float_Random.Max_Image_Width);
-
- use Discrete_String_Pack, Float_String_Pack;
-
- TC_Seed : Integer;
- TC_Max_Loop_Count : constant Natural := 1000;
- Allowed_Matches : constant Natural := 2;
- --
- -- In a sequence of TC_Max_Loop_Count random numbers that should
- -- not match, some may match by chance. Up to Allowed_Matches
- -- numbers may match before the test is considered to fail.
- --
-
-
- procedure Check_Float_State (Gen_1, Gen_2 : Float_Random.Generator;
- Sub_Test : Integer;
- States_Should_Match : Boolean) is
-
- use type Float_Random.State;
-
- State_1,
- State_2 : Float_Random.State;
-
- State_String_1,
- State_String_2 : Float_String_Pack.Bounded_String :=
- Float_String_Pack.Null_Bounded_String;
- begin
-
- Float_Random.Save(Gen => Gen_1, To_State => State_1);
- Float_Random.Save(Gen_2, State_2);
-
- State_String_1 :=
- Float_String_Pack.To_Bounded_String(Source =>
- Float_Random.Image(Of_State => State_1));
-
- State_String_2 :=
- Float_String_Pack.To_Bounded_String(Float_Random.Image(State_2));
-
- case States_Should_Match is
- when True =>
- if State_1 /= State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Float generators " &
- "are not the same");
- end if;
- if State_String_1 /= State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Float generators " &
- "are not the same");
- end if;
- when False =>
- if State_1 = State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Float generators " &
- "are the same");
- end if;
- if State_String_1 = State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Float generators " &
- "are the same");
- end if;
- end case;
- end Check_Float_State;
-
-
-
- procedure Check_Discrete_State (Gen_1,
- Gen_2 : Discrete_Package.Generator;
- Sub_Test : Integer;
- States_Should_Match : Boolean) is
-
- use type Discrete_Package.State;
-
- State_1, State_2 : Discrete_Package.State;
-
- State_String_1,
- State_String_2 : Discrete_String_Pack.Bounded_String :=
- Discrete_String_Pack.Null_Bounded_String;
- begin
-
- Discrete_Package.Save(Gen => Gen_1,
- To_State => State_1);
- Discrete_Package.Save(Gen_2, To_State => State_2);
-
- State_String_1 :=
- Discrete_String_Pack.To_Bounded_String(Source =>
- Discrete_Package.Image(Of_State => State_1));
-
- State_String_2 :=
- Discrete_String_Pack.To_Bounded_String(Source =>
- Discrete_Package.Image(Of_State => State_2));
-
- case States_Should_Match is
- when True =>
- if State_1 /= State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Discrete " &
- "generators are not the same");
- end if;
- if State_String_1 /= State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Discrete " &
- "generators are not the same");
- end if;
- when False =>
- if State_1 = State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Discrete " &
- "generators are the same");
- end if;
- if State_String_1 = State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Discrete " &
- "generators are the same");
- end if;
- end case;
- end Check_Discrete_State;
-
-
-
- procedure Check_Float_Values (Gen_1, Gen_2 : Float_Random.Generator;
- Sub_Test : Integer;
- Values_Should_Match : Boolean) is
- Matches : Natural := 0;
- Check_Failed : Boolean := False;
- begin
- case Values_Should_Match is
- when True =>
- for i in 1..TC_Max_Loop_Count loop
- if Float_Random.Random(Gen_1) /= Float_Random.Random(Gen_2)
- then
- Check_Failed := True;
- exit;
- end if;
- end loop;
- if Check_Failed then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Float generators " &
- "Failed check");
- end if;
- when False =>
- for i in 1..TC_Max_Loop_Count loop
- if Float_Random.Random(Gen_1) = Float_Random.Random(Gen_2)
- then
- Matches := Matches + 1;
- end if;
- end loop;
- end case;
-
- if (Values_Should_Match and Check_Failed) or
- (not Values_Should_Match and Matches > Allowed_Matches)
- then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Float generators " &
- "Failed check");
- end if;
-
- end Check_Float_Values;
-
-
-
- procedure Check_Discrete_Values (Gen_1,
- Gen_2 : Discrete_Package.Generator;
- Sub_Test : Integer;
- Values_Should_Match : Boolean) is
- Matches : Natural := 0;
- Check_Failed : Boolean := False;
- begin
- case Values_Should_Match is
- when True =>
- for i in 1..TC_Max_Loop_Count loop
- if Discrete_Package.Random(Gen_1) /=
- Discrete_Package.Random(Gen_2)
- then
- Check_Failed := True;
- exit;
- end if;
- end loop;
- when False =>
- for i in 1..TC_Max_Loop_Count loop
- if Discrete_Package.Random(Gen_1) =
- Discrete_Package.Random(Gen_2)
- then
- Matches := Matches + 1;
- end if;
- end loop;
- end case;
-
- if (Values_Should_Match and Check_Failed) or
- (not Values_Should_Match and Matches > Allowed_Matches)
- then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Discrete generators " &
- "Failed check");
- end if;
-
- end Check_Discrete_Values;
-
-
-
- begin
-
- Sub_Test_1:
- -- Check that two objects of type Generator are initialized to the
- -- same state.
- begin
-
- -- Since the discrete and float random generators are in the initial
- -- state, using Procedure Save to save the states of the generator
- -- objects, and transforming these states into strings using
- -- Function Image, should yield identical strings.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 1,
- States_Should_Match => True);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 1,
- States_Should_Match => True);
-
- -- Since the two random generator objects are in their initial
- -- state, the values produced from each (upon calls to Random)
- -- should be identical.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 1,
- Values_Should_Match => True);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 1,
- Values_Should_Match => True);
-
- end Sub_Test_1;
-
-
-
- Sub_Test_3:
- -- Check that when the Function Reset uses the same integer
- -- initiator to reset two generators to the same state, the
- -- resulting random values and the state from each generator
- -- are identical.
- declare
- use Discrete_Package, Float_Random;
- begin
-
- -- Reset the generators to the same states, using the version of
- -- Function Reset with both generator parameter and initiator
- -- specified.
-
- TC_Seed := Integer(Random(Discrete_Generator_1));
- Reset(Gen => Discrete_Generator_1, Initiator => TC_Seed);
- Reset(Discrete_Generator_2, Initiator => TC_Seed);
- Reset(Float_Generator_1, TC_Seed);
- Reset(Float_Generator_2, TC_Seed);
-
- -- Since the random generators have been reset to identical states,
- -- bounded string images of these states should yield identical
- -- strings.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 3,
- States_Should_Match => True);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 3,
- States_Should_Match => True);
-
- -- Since the random generators have been reset to identical states,
- -- the values produced from each (upon calls to Random) should
- -- be identical.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 3,
- Values_Should_Match => True);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 3,
- Values_Should_Match => True);
-
- end Sub_Test_3;
-
-
-
- Sub_Test_4:
- -- Check that when the Function Reset uses different integer
- -- initiator values to reset two generators, the resulting random
- -- numbers and states are different.
- begin
-
- -- Reset the generators to different states.
-
- TC_Seed :=
- Integer(Discrete_Package.Random(Discrete_Generator_1));
-
- Discrete_Package.Reset(Gen => Discrete_Generator_1,
- Initiator => TC_Seed);
-
- -- Set the seed value to a different value for the second call
- -- to Reset.
- -- Note: A second call to Random could be made, as above, but that
- -- would not ensure that the resulting seed value was
- -- different from the first.
-
- if TC_Seed /= Integer'Last then
- TC_Seed := TC_Seed + 1;
- else
- TC_Seed := TC_Seed - 1;
- end if;
-
- Discrete_Package.Reset(Gen => Discrete_Generator_2,
- Initiator => TC_Seed);
-
- Float_Random.Reset(Float_Generator_1, 16#FF#); -- 255
- Float_Random.Reset(Float_Generator_2, 2#1110_0000#); -- 224
-
- -- Since the two float random generators are in different
- -- states, the bounded string images depicting their states should
- -- differ.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 4,
- States_Should_Match => False);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 4,
- States_Should_Match => False);
-
- -- Since the two discrete random generator objects were reset
- -- to different states, the values produced from each (upon calls
- -- to Random) should differ.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 4,
- Values_Should_Match => False);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 4,
- Values_Should_Match => False);
-
- end Sub_Test_4;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a
deleted file mode 100644
index a286fa7..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a
+++ /dev/null
@@ -1,536 +0,0 @@
--- CXA5012.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, for both Float_Random and Discrete_Random packages,
--- the following are true:
--- 1) the procedures Save and Reset can be used to save the
--- specific state of a random number generator, and then restore
--- the specific state to the generator following some intermediate
--- generator activity.
--- 2) the Function Image can be used to obtain a string
--- representation of the state of a generator; and that the
--- Function Value will transform a string representation of the
--- state of a random number generator into the actual state object.
--- 3) a call to Function Value, with a string value that is
--- not the image of any generator state, is a bounded error. This
--- error either raises Constraint_Error or Program_Error, or is
--- accepted. (See Technical Corrigendum 1).
---
--- TEST DESCRIPTION:
--- This test evaluates components of the Ada.Numerics.Float_Random and
--- Ada.Numerics.Discrete_Random packages.
--- The first objective block of this test uses Procedure Save to
--- save the particular state of a random number generator. The random
--- number generator then generates a series of random numbers. The
--- saved state variable is then used to reset (using Procedure Reset)
--- the generator back to the state it was in at the point of the call
--- to Save. Random values are then generated from this restored
--- generator, and compared with expected values.
--- The second objective block of this test uses Function Image to
--- provide a string representation of a state code. This string is
--- then transformed back to a state code value, and used to reset a
--- random number generator to the saved state. Random values are
--- likewise generated from this restored generator, and compared with
--- expected values.
---
---
--- CHANGE HISTORY:
--- 25 Apr 95 SAIC Initial prerelease version.
--- 17 Jul 95 SAIC Incorporated reviewer comments.
--- 17 Dec 97 EDS Change subtype upper limit from 100_000 to 10_000.
--- 16 Sep 99 RLB Updated objective 3 for Technical Corrigendum 1
--- changes.
-
---!
-
-with Ada.Numerics.Float_Random;
-with Ada.Numerics.Discrete_Random;
-with Ada.Strings.Bounded;
-with ImpDef;
-with Report;
-
-procedure CXA5012 is
-
-begin
-
- Report.Test ("CXA5012", "Check the effect of Procedures Save and " &
- "Reset, and Functions Image and Value " &
- "from the Ada.Numerics.Discrete_Random " &
- "and Float_Random packages");
-
- Test_Block:
- declare
-
- use Ada.Numerics, Ada.Strings.Bounded;
-
- -- Declare an integer subtype and an enumeration subtype, and use them
- -- to instantiate the discrete random number generator generic package.
-
- subtype Discrete_Range is Integer range 1..10_000;
- type Suit_Of_Cards is (Ace, One, Two, Three, Four, Five, Six,
- Seven, Eight, Nine, Ten, Jack, Queen, King);
- package Discrete_Pack is new Discrete_Random(Discrete_Range);
- package Card_Pack is new Discrete_Random(Suit_Of_Cards);
-
- -- Declaration of random number generator objects.
-
- DGen_1, DGen_2 : Discrete_Pack.Generator;
- EGen_1, EGen_2 : Card_Pack.Generator;
- FGen_1, FGen_2 : Float_Random.Generator;
-
- -- Variables declared to hold random numbers over the inclusive range
- -- of their corresponding type.
-
- DVal_1, DVal_2 : Discrete_Range;
- EVal_1, EVal_2 : Suit_Of_Cards;
- FVal_1, FVal_2 : Float_Random.Uniformly_Distributed;
-
- -- Declaration of State variables used to hold the state of the
- -- random number generators.
-
- DState_1, DState_2 : Discrete_Pack.State;
- EState_1, EState_2 : Card_Pack.State;
- FState_1, FState_2 : Float_Random.State;
-
- -- Declaration of bounded string packages instantiated with the
- -- value of Max_Image_Width constant, and bounded string variables
- -- used to hold the image of random number generator states.
-
- package DString_Pack is
- new Generic_Bounded_Length(Discrete_Pack.Max_Image_Width);
- package EString_Pack is
- new Generic_Bounded_Length(Card_Pack.Max_Image_Width);
- package FString_Pack is
- new Generic_Bounded_Length(Float_Random.Max_Image_Width);
-
- use DString_Pack, EString_Pack, FString_Pack;
-
- DString_1, DString_2 : DString_Pack.Bounded_String :=
- DString_Pack.Null_Bounded_String;
- EString_1, EString_2 : EString_Pack.Bounded_String :=
- EString_Pack.Null_Bounded_String;
- FString_1, FString_2 : FString_Pack.Bounded_String :=
- FString_Pack.Null_Bounded_String;
-
- -- Test variables.
-
- TC_Count : Natural;
- TC_Discrete_Check_Failed,
- TC_Enum_Check_Failed,
- TC_Float_Check_Failed : Boolean := False;
- TC_Seed : Integer;
-
- begin
-
- Objective_1:
- -- Check that the procedures Save and Reset can be used to save the
- -- specific state of a random number generator, and then restore the
- -- specific state to the generator following some intermediate
- -- generator activity.
- declare
-
- First_Row : constant := 1;
- Second_Row : constant := 2;
- TC_Max_Values : constant := 100;
-
- TC_Discrete_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Discrete_Range;
- TC_Enum_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Suit_Of_Cards;
- TC_Float_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Float_Random.Uniformly_Distributed;
- begin
-
- -- The state of the random number generators are saved to state
- -- variables using the procedure Save.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Card_Pack.Save (Gen => EGen_1, To_State => EState_1);
- Float_Random.Save (Gen => FGen_1, To_State => FState_1);
-
- -- Random number generators are used to fill the first half of the
- -- first row of the arrays with randomly generated values.
-
- for i in 1..TC_Max_Values/2 loop
- TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- The random number generators are reset to the states saved in the
- -- state variables, using the procedure Reset.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset (Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- The same random number generators are used to fill the first half
- -- of the second row of the arrays with randomly generated values.
-
- for i in 1..TC_Max_Values/2 loop
- TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- Run the random number generators many times (not using results).
-
- for i in Discrete_Range'Range loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- EVal_1 := Card_Pack.Random(EGen_1);
- FVal_1 := Float_Random.Random(FGen_1);
- end loop;
-
- -- The states of the random number generators are saved to state
- -- variables using the procedure Save.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Card_Pack.Save(Gen => EGen_1, To_State => EState_1);
- Float_Random.Save (Gen => FGen_1, To_State => FState_1);
-
- -- The last half of the first row of the arrays are filled with
- -- values generated from the same random number generators.
-
- for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop
- TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- The random number generators are reset to the states saved in the
- -- state variables, using the procedure Reset.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset(Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- The last half of the second row of the arrays are filled with
- -- values generated from the same random number generator.
- -- These values should exactly mirror the values in the last half
- -- of the first row of the arrays that had been previously generated.
-
- for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop
- TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- Check that the values in the two rows of the arrays are identical.
-
- for i in 1..TC_Max_Values loop
- if TC_Discrete_Array(First_Row,i) /=
- TC_Discrete_Array(Second_Row,i)
- then
- TC_Discrete_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..TC_Max_Values loop
- if TC_Enum_Array(First_Row,i) /= TC_Enum_Array(Second_Row,i) then
- TC_Enum_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..TC_Max_Values loop
- if TC_Float_Array(First_Row,i) /= TC_Float_Array(Second_Row,i)
- then
- TC_Float_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- if TC_Discrete_Check_Failed then
- Report.Failed("Discrete random values generated following use " &
- "of procedures Save and Reset were not the same");
- TC_Discrete_Check_Failed := False;
- end if;
-
- if TC_Enum_Check_Failed then
- Report.Failed("Enumeration random values generated following " &
- "use of procedures Save and Reset were not the " &
- "same");
- TC_Enum_Check_Failed := False;
- end if;
-
- if TC_Float_Check_Failed then
- Report.Failed("Float random values generated following use " &
- "of procedures Save and Reset were not the same");
- TC_Float_Check_Failed := False;
- end if;
-
- end Objective_1;
-
-
-
- Objective_2:
- -- Check that the Function Image can be used to obtain a string
- -- representation of the state of a generator.
- -- Check that the Function Value will transform a string
- -- representation of the state of a random number generator
- -- into the actual state object.
- begin
-
- -- Use two discrete and float random number generators to generate
- -- a series of values (so that the generators are no longer in their
- -- initial states, and they have generated the same number of
- -- random values).
-
- TC_Seed := Integer(Discrete_Pack.Random(DGen_1));
- Discrete_Pack.Reset(DGen_1, TC_Seed);
- Discrete_Pack.Reset(DGen_2, TC_Seed);
- Card_Pack.Reset (EGen_1, TC_Seed);
- Card_Pack.Reset (EGen_2, TC_Seed);
- Float_Random.Reset (FGen_1, TC_Seed);
- Float_Random.Reset (FGen_2, TC_Seed);
-
- for i in 1..1000 loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- DVal_2 := Discrete_Pack.Random(DGen_2);
- EVal_1 := Card_Pack.Random(EGen_1);
- EVal_2 := Card_Pack.Random(EGen_2);
- FVal_1 := Float_Random.Random(FGen_1);
- FVal_2 := Float_Random.Random(FGen_2);
- end loop;
-
- -- Use the Procedure Save to save the states of the generators
- -- to state variables.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Discrete_Pack.Save(DGen_2, To_State => DState_2);
- Card_Pack.Save (Gen => EGen_1, To_State => EState_1);
- Card_Pack.Save (EGen_2, To_State => EState_2);
- Float_Random.Save (FGen_1, To_State => FState_1);
- Float_Random.Save (FGen_2, FState_2);
-
- -- Use the Function Image to produce a representation of the state
- -- codes as (bounded) string objects.
-
- DString_1 := DString_Pack.To_Bounded_String(
- Discrete_Pack.Image(Of_State => DState_1));
- DString_2 := DString_Pack.To_Bounded_String(
- Discrete_Pack.Image(DState_2));
- EString_1 := EString_Pack.To_Bounded_String(
- Card_Pack.Image(Of_State => EState_1));
- EString_2 := EString_Pack.To_Bounded_String(
- Card_Pack.Image(EState_2));
- FString_1 := FString_Pack.To_Bounded_String(
- Float_Random.Image(Of_State => FState_1));
- FString_2 := FString_Pack.To_Bounded_String(
- Float_Random.Image(FState_2));
-
- -- Compare the bounded string objects for equality.
-
- if DString_1 /= DString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Discrete generators");
- end if;
- if EString_1 /= EString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Enumeration " &
- "generators");
- end if;
- if FString_1 /= FString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Float generators");
- end if;
-
- -- The string representation of a state code is transformed back
- -- to a state code variable using the Function Value.
-
- DState_1 := Discrete_Pack.Value(Coded_State =>
- DString_Pack.To_String(DString_1));
- EState_1 := Card_Pack.Value(EString_Pack.To_String(EString_1));
- FState_1 := Float_Random.Value(FString_Pack.To_String(FString_1));
-
- -- One of the (pair of each type of ) generators is used to generate
- -- a series of random values, getting them "out of synch" with the
- -- specific generation sequence of the other generators.
-
- for i in 1..100 loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- EVal_1 := Card_Pack.Random(EGen_1);
- FVal_1 := Float_Random.Random (FGen_1);
- end loop;
-
- -- The "out of synch" generators are reset to the previous state they
- -- had when their states were saved, and they should now have the same
- -- states as the generators that did not generate the values above.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset (Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- All generators should now be in the same state, so the
- -- random values they produce should be the same.
-
- for i in 1..1000 loop
- if Discrete_Pack.Random(DGen_1) /= Discrete_Pack.Random(DGen_2)
- then
- TC_Discrete_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..1000 loop
- if Card_Pack.Random(EGen_1) /= Card_Pack.Random(EGen_2) then
- TC_Enum_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..1000 loop
- if Float_Random.Random(FGen_1) /= Float_Random.Random(FGen_2)
- then
- TC_Float_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- if TC_Discrete_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Discrete generator");
- end if;
- if TC_Enum_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Enumeration generator");
- end if;
- if TC_Float_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Float generator");
- end if;
-
- end Objective_2;
-
-
-
- Objective_3:
- -- Check that a call to Function Value, with a string value that is
- -- not the image of any generator state, is a bounded error. This
- -- error either raises Constraint_Error or Program_Error, or is
- -- accepted. (See Technical Corrigendum 1).
- declare
- Not_A_State : constant String := ImpDef.Non_State_String;
- begin
-
- begin
- DState_1 := Discrete_Pack.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Discrete_Random.Value");
- end if;
- Discrete_Pack.Reset(DGen_1, DState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- Report.Comment("Constraint_Error raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- when Program_Error => -- OK, expected exception.
- Report.Comment("Program_Error raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- when others =>
- Report.Failed("Unexpected exception raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- end;
-
- begin
- EState_1 := Card_Pack.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of an enumeration " &
- "random number generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Discrete_Random.Value");
- end if;
- Card_Pack.Reset(EGen_1, EState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when Program_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of an enumeration " &
- "random number generator");
- end;
-
- begin
- FState_1 := Float_Random.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by an " &
- "instantiated version of " &
- "Ada.Numerics.Float_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Float_Random.Value");
- end if;
- Float_Random.Reset(FGen_1, FState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when Program_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by an " &
- "instantiated version of " &
- "Ada.Numerics.Float_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- end;
-
- end Objective_3;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a
deleted file mode 100644
index fe5b6e2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5013.a
+++ /dev/null
@@ -1,326 +0,0 @@
--- CXA5013.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 discrete random number generator will yield each value
--- in its result subtype in a finite number of calls, provided that
--- the number of such values does not exceed 2**15.
---
--- TEST DESCRIPTION:
--- This test demonstrates certain capabilities of the random number
--- generator packages in Ada.Numerics. A generic subprogram is
--- defined that will be instantiated to produce a total of two test
--- subprograms.
--- The area examined by this test is the production of random values
--- over a discrete range. A generic procedure is instantiated with
--- an instance of the Discrete_Random package, once for an integer type,
--- and once for an enumeration type. The test procedure performs a
--- test run, generating a specific number of random numbers over the
--- range of the type. If this run did not generate each of the values
--- in the type range, an asynchronous select statement is invoked. This
--- select statement has a trigger statement delay for a specific
--- (implementation defined) amount of time during which additional test
--- runs will be performed.
--- At the end of each run in this test, an evaluation is made to
--- determine if each value in the range of possible values have been
--- generated. At the conclusion of the runs, or if the specified test
--- delay time expires, the test is concluded with a status value
--- returned from the test procedure. An implementation is given three
--- completely separate opportunities to run the test successfully, and
--- if at the conclusion of all of these tests no successful result has
--- been returned, the test is considered failed.
---
---
--- CHANGE HISTORY:
--- 27 Apr 95 SAIC Initial prerelease version.
---
---!
-
-with Ada.Numerics.Discrete_Random;
-with ImpDef;
-with Report;
-
-procedure CXA5013 is
-
-begin
-
- Report.Test ("CXA5013", "Check that a discrete random number generator " &
- "will yield each value in its result subtype " &
- "in a finite number of calls");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
-
- -- The following constant designed into the test creates a high
- -- probability that a random series of numbers will satisfy the
- -- requirements. Occasionally, even a random series of numbers
- -- will fail. In such a case, the test will reset the random
- -- number generator and rerun the test conditions. This constant
- -- determines how many times the random number generator will be
- -- reset before any individual test run is failed.
-
- TC_Max_Random_Test_Runs : constant := 3;
-
- -- The following constant will ensure that multiple attempts of the
- -- complete set of tests are performed in the event of a failure of
- -- a set of test runs.
-
- TC_Finite_Number_Of_Tests : constant := 3;
-
-
- TC_Test_Run : Integer := 0;
- TC_Success : Boolean := False;
- TC_Trials_Per_Test : Integer := 1500;
-
- type Enum_Type is (One, Two, Three, Four, Five, Six, Seven);
- type Discrete_Type is range 1..100;
-
-
- package Enum_Pack is new Discrete_Random(Enum_Type);
- package Discrete_Pack is
- new Discrete_Random(Result_Subtype => Discrete_Type);
-
-
-
- --
- -- Definition of generic Random_Test procedure, which will be
- -- instantiated for both an integer type and an enumeration type.
- --
-
- generic
- with package Gen_Pack is new Ada.Numerics.Discrete_Random (<>);
- procedure Random_Test (Trials_Per_Test : in Integer;
- Success : out Boolean);
-
-
- procedure Random_Test (Trials_Per_Test : in Integer;
- Success : out Boolean) is
- Total_Runs : Integer := 0;
- Total_Trials : Integer := 0;
- Total_Attempts_This_Test : Integer := 0;
- Random_Array : array (Gen_Pack.Result_Subtype)
- of Boolean := (others => False);
- Gen : Gen_Pack.Generator;
-
- function All_Values_Present return Boolean is
- Result : Boolean := True;
- begin
- for i in Gen_Pack.Result_Subtype'Range loop
- if not Random_Array(i) then
- Result := False;
- exit;
- end if;
- end loop;
- return Result;
- end All_Values_Present;
-
- begin
-
- Success := False; -- Initialized to failure prior to test.
- Gen_Pack.Reset(Gen); -- Perform a time-dependent reset.
-
- -- Guarantee that a specific minimum number of trials are performed
- -- prior to the timer being set.
-
- for i in 1..Trials_Per_Test loop
- -- Set array element to True when a particular array
- -- index is generated by the random number generator.
- Random_Array(Gen_Pack.Random(Gen)) := True;
- end loop;
-
- if All_Values_Present then
-
- Success := True; -- Test was successful, exit procedure with no
- -- further testing performed.
- else
-
- -- Initial test above was unsuccessful, so set a timer and perform
- -- additional trials to determine if all values in the discrete
- -- range will be produced.
-
- select
-
- -- This asynchronous select has a triggering statement which
- -- is a delay statement, set to an implementation defined
- -- number of seconds for any particular test to execute.
- -- The point here is to allow the implementation to decide
- -- how long to run this test in order to generate an
- -- appropriate (i.e., correct) sample from the Random Number
- -- Generator.
-
- delay ImpDef.Delay_Per_Random_Test; -- Delay per test.
-
- -- If, after expiration of delay, the random number generator
- -- has generated all values within the range at least once,
- -- then the result is success; otherwise, a comment is output
- -- to indicate that the random number generator was
- -- unsuccessful in this series of test runs.
-
- if All_Values_Present then
- Success := True;
- else
- Total_Attempts_This_Test :=
- Total_Runs * Trials_Per_Test + Total_Trials;
- Report.Comment
- ("Not all numbers within the Range were produced in " &
- Integer'Image(
- Integer(ImpDef.Delay_Per_Random_Test*1000.0)) &
- " milliseconds or in " &
- Integer'Image(Total_Attempts_This_Test) &
- " trials during this test");
- end if;
-
- then abort
-
- -- After setting the triggering statement above, the execution
- -- of this abortable part is begun.
- -- This loop continues until either a) every value has been
- -- produced or b) the triggering statement times out.
-
- Total_Runs := 1;
-
- Test_Loop: -- This loop continues until a test run is
- loop -- successful, the test run limit has been reached,
- -- or the triggering statement times-out above.
-
- Total_Trials := 0;
-
- for i in 1..Trials_Per_Test loop
- Total_Trials := i; -- Used above if triggering statement
- -- completes prior to test completion.
-
- -- Set array element to True when a particular array
- -- index is generated by the random number generator.
-
- Random_Array(Gen_Pack.Random(Gen)) := True;
-
- end loop;
-
- -- At the conclusion of a complete series of trials, the
- -- following evaluation is performed to determine whether
- -- the test run was successful, or whether an additional
- -- test run should be re-attempted.
-
- if All_Values_Present then
- Success := True;
- exit Test_Loop;
- elsif Total_Runs = TC_Max_Random_Test_Runs then
- Report.Comment
- ("Not all numbers in the Range were produced in " &
- Integer'Image(Total_Runs*Trials_Per_Test) &
- " individual trials during this test");
- exit Test_Loop;
- else
- Total_Runs := Total_Runs + 1;
- end if;
-
- end loop Test_Loop;
- end select;
- end if;
- end Random_Test;
-
-
-
- -- Instantiation of test procedures.
-
- procedure Discrete_Random_Test is new Random_Test(Discrete_Pack);
- procedure Enumeration_Random_Test is new Random_Test(Enum_Pack);
-
-
- begin
-
- -- Make a series of test runs, checking to ensure that discrete
- -- random number generators produce each value in their result subtype
- -- within a finite number of calls. In each case, if the first test
- -- is not successful, another attempt is made, after a time-dependent
- -- reset, up to a total of 3 runs. This allows an implementation
- -- multiple opportunities to pass the test successfully.
- -- Note: The odds of getting all 100 integer values in 1500 trials are
- -- greater than 99.997 percent, confirmed by Monte Carlo
- -- simulation.
-
-
-
- -- Run the Random_Test for an integer discrete random number generator.
-
- TC_Test_Run := 0;
- TC_Success := False;
- while TC_Test_Run < TC_Finite_Number_Of_Tests and
- not TC_Success
- loop
- TC_Test_Run := TC_Test_Run + 1; -- Increment test counter.
- Discrete_Random_Test (TC_Trials_Per_Test, -- Perform test.
- TC_Success);
- -- Increment the number of trials that will be performed
- -- in the next test by 50%.
- TC_Trials_Per_Test := TC_Trials_Per_Test + TC_Trials_Per_Test/2 ;
- end loop;
-
- if not TC_Success then
- Report.Failed("Random_Test was run " & Integer'Image(TC_Test_Run) &
- " times, but a successful result was not recorded " &
- "from any run using the integer discrete random " &
- "number generator");
- end if;
-
-
-
- -- Run the Random_Test for an enumeration type random number generator.
-
- -- Note: The odds of getting all seven enumeration values in 100
- -- trials are greater than 99.997 percent, confirmed by Monte
- -- Carlo simulation.
-
- TC_Test_Run := 0;
- TC_Trials_Per_Test := 100;
- TC_Success := False;
- while TC_Test_Run < TC_Finite_Number_Of_Tests and
- not TC_Success
- loop
- TC_Test_Run := TC_Test_Run + 1;
- Enumeration_Random_Test (TC_Trials_Per_Test,
- TC_Success);
- -- Increment the number of trials that will be performed
- -- in the next test by 50%.
- TC_Trials_Per_Test := TC_Trials_Per_Test + TC_Trials_Per_Test/2 ;
- end loop;
-
- if not TC_Success then
- Report.Failed("Random_Test was run " & Integer'Image(TC_Test_Run) &
- " times, but a successful result was not recorded " &
- "from any run using the enumeration random number " &
- "generator");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5013;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a
deleted file mode 100644
index e1035db..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a
+++ /dev/null
@@ -1,342 +0,0 @@
--- CXA5015.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 following representation-oriented attributes are
--- available and that the produce correct results:
--- 'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling,
--- 'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation,
--- 'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and
--- 'Model_Small.
---
--- TEST DESCRIPTION:
--- This test checks whether certain attributes of floating point types
--- are available from an implementation. Where attribute correctness
--- can be verified in a straight forward manner, the appropriate checks
--- are included here. However, this test is not intended to ensure the
--- correctness of the results returned from all of the attributes
--- examined in this test; that process will occur in the tests of the
--- Numerics_Annex.
---
---
--- CHANGE HISTORY:
--- 26 Jun 95 SAIC Initial prerelease version.
--- 29 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Fix value for checking the S'Adjacent attribute
---!
-
-with Report;
-
-procedure CXA5015 is
-
- subtype Float_Subtype is Float range -10.0..10.0;
- type Derived_Float_1 is digits 8;
- type Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10;
-
- use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2;
-
- TC_Boolean : Boolean;
- TC_Float : Float;
- TC_SFloat : Float_Subtype;
- TC_DFloat_1 : Derived_Float_1;
- TC_DFloat_2 : Derived_Float_2;
- TC_Tolerance : Float := 0.001;
-
- function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float)
- return Boolean is
- begin
- return abs(Actual_Result - Expected_Result) > Tolerance;
- end Not_Equal;
-
-
-begin
-
- Report.Test ("CXA5015", "Check that certain representation-oriented " &
- "attributes are available and that they " &
- "produce correct results");
-
- -- New Representation-Oriented Attributes.
- --
- -- Check the S'Denorm attribute.
-
- TC_Boolean := Float'Denorm;
- TC_Boolean := Float_Subtype'Denorm;
- TC_Boolean := Derived_Float_1'Denorm;
- TC_Boolean := Derived_Float_2'Denorm;
-
-
- -- Check the S'Signed_Zeroes attribute.
-
- TC_Boolean := Float'Signed_Zeros;
- TC_Boolean := Float_Subtype'Signed_Zeros;
- TC_Boolean := Derived_Float_1'Signed_Zeros;
- TC_Boolean := Derived_Float_2'Signed_Zeros;
-
-
- -- New Primitive Function Attributes.
- --
- -- Check the S'Exponent attribute.
-
- TC_Float := 0.5;
- TC_SFloat := 0.99;
- TC_DFloat_1 := 2.45;
- TC_DFloat_2 := 2.65;
-
- if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or
- Float'Exponent(TC_Float) > 2
- then
- Report.Failed("Incorrect result from the 'Exponent attribute");
- end if;
-
-
- -- Check the S'Fraction attribute.
-
- if Not_Equal
- (Float'Fraction(TC_Float),
- TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Fraction attribute - 1");
- end if;
-
- if Float'Fraction(TC_Float) <
- (1.0/Float(Float'Machine_Radix)) - TC_Tolerance or
- Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance
- then
- Report.Failed("Incorrect result from the 'Fraction attribute - 2");
- end if;
-
-
- -- Check the S'Compose attribute.
-
- if Not_Equal
- (Float'Compose(TC_Float, 3),
- TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Compose attribute");
- end if;
-
-
- -- Check the S'Scaling attribute.
-
- if Not_Equal
- (Float'Scaling(TC_Float, 2),
- TC_Float * Float(Float'Machine_Radix)**2,
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Scaling attribute");
- end if;
-
-
- -- Check the S'Floor attribute.
-
- TC_Float := 0.99;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Floor(TC_Float) /= 0.0 or
- Float_Subtype'Floor(TC_SFloat) /= 1.0 or
- Derived_Float_1'Floor(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Floor(TC_DFloat_2) /= -3.0
- then
- Report.Failed("Incorrect result from the 'Floor attribute");
- end if;
-
-
- -- Check the S'Ceiling attribute.
-
- TC_Float := 0.99;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.99;
-
- if Float'Ceiling(TC_Float) /= 1.0 or
- Float_Subtype'Ceiling(TC_SFloat) /= 1.0 or
- Derived_Float_1'Ceiling(TC_DFloat_1) /= 3.0 or
- Derived_Float_2'Ceiling(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Ceiling attribute");
- end if;
-
-
- -- Check the S'Rounding attribute.
-
- TC_Float := 0.49;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Rounding(TC_Float) /= 0.0 or
- Float_Subtype'Rounding(TC_SFloat) /= 1.0 or
- Derived_Float_1'Rounding(TC_DFloat_1) /= 3.0 or
- Derived_Float_2'Rounding(TC_DFloat_2) /= -3.0
- then
- Report.Failed("Incorrect result from the 'Rounding attribute");
- end if;
-
-
- -- Check the S'Unbiased_Rounding attribute.
-
- TC_Float := 0.50;
- TC_SFloat := 1.50;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Unbiased_Rounding(TC_Float) /= 0.0 or
- Float_Subtype'Unbiased_Rounding(TC_SFloat) /= 2.0 or
- Derived_Float_1'Unbiased_Rounding(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Unbiased_Rounding(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Unbiased_Rounding " &
- "attribute");
- end if;
-
-
- -- Check the S'Truncation attribute.
-
- TC_Float := -0.99;
- TC_SFloat := 1.50;
- TC_DFloat_1 := 2.99;
- TC_DFloat_2 := -2.50;
-
- if Float'Truncation(TC_Float) /= 0.0 or
- Float_Subtype'Truncation(TC_SFloat) /= 1.0 or
- Derived_Float_1'Truncation(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Truncation(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Truncation attribute");
- end if;
-
-
- -- Check the S'Remainder attribute.
-
- TC_Float := 9.0;
- TC_SFloat := 7.5;
- TC_DFloat_1 := 5.0;
- TC_DFloat_2 := 8.0;
-
- if Float'Remainder(TC_Float, 2.0) /= 1.0 or
- Float_Subtype'Remainder(TC_SFloat, 3.0) /= 1.5 or
- Derived_Float_1'Remainder(TC_DFloat_1, 2.0) /= 1.0 or
- Derived_Float_2'Remainder(TC_DFloat_2, 4.0) /= 0.0
- then
- Report.Failed("Incorrect result from the 'Remainder attribute");
- end if;
-
-
- -- Check the S'Adjacent attribute.
-
- TC_Float := 4.0;
- TC_SFloat := -1.0;
-
- if Float'Adjacent(TC_Float, TC_Float) /= TC_Float or
- Float_Subtype'Adjacent(TC_SFloat, -1.0) /= TC_SFloat
- then
- Report.Failed("Incorrect result from the 'Adjacent attribute");
- end if;
-
-
- -- Check the S'Copy_Sign attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.0;
- TC_DFloat_2 := -2.5;
-
- if Float'Copy_Sign(TC_Float, -2.0) /= 0.0 or
- Float_Subtype'Copy_Sign(TC_SFloat, 4.0) /= 1.0 or
- Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0) /= -5.0 or
- Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0) /= -2.5
- then
- Report.Failed("Incorrect result from the 'Copy_Sign attribute");
- end if;
-
-
- -- Check the S'Leading_Part attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.88;
- TC_DFloat_2 := -2.52;
-
- -- Leading part obtained in the variables.
- TC_Float := Float'Leading_Part(TC_Float, 2);
- TC_SFloat := Float_Subtype'Leading_Part(TC_SFloat, 2);
- TC_DFloat_1 := Derived_Float_1'Leading_Part(TC_DFloat_1, 2);
- TC_DFloat_2 := Derived_Float_2'Leading_Part(TC_DFloat_2, 2);
-
- -- Checking for the leading part of the variables at this point should
- -- produce the same values.
- if Float'Leading_Part(TC_Float, 2) /= TC_Float or
- Float_Subtype'Leading_Part(TC_SFloat, 2) /= TC_SFloat or
- Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or
- Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2
- then
- Report.Failed("Incorrect result from the 'Leading_Part attribute");
- end if;
-
-
- -- Check the S'Machine attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.88;
- TC_DFloat_2 := -2.52;
-
- -- Closest machine number obtained in the variables.
- TC_Float := Float'Machine(TC_Float);
- TC_SFloat := Float_Subtype'Machine(TC_SFloat);
- TC_DFloat_1 := Derived_Float_1'Machine(TC_DFloat_1);
- TC_DFloat_2 := Derived_Float_2'Machine(TC_DFloat_2);
-
- -- Checking for the closest machine number to each of the variables at
- -- this point should produce the same values.
- if Float'Machine(TC_Float) /= TC_Float or
- Float_Subtype'Machine(TC_SFloat) /= TC_SFloat or
- Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or
- Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2
- then
- Report.Failed("Incorrect result from the 'Machine attribute");
- end if;
-
-
- -- New Model-Oriented Attributes.
- --
- -- Check the S'Model_Small attribute.
-
- if Not_Equal
- (Float'Model_Small,
- Float(Float'Machine_Radix)**(Float'Model_Emin-1),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Model_Small attribute");
- end if;
-
-
- Report.Result;
-
-end CXA5015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a
deleted file mode 100644
index 12db5e7..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXA5A01.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 functions Sin and Sinh provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Sin and Sinh resulting from
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, as well as instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A01.A
---
---
--- CHANGE HISTORY:
--- 06 Mar 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 26 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A01 is
-begin
-
- Report.Test ("CXA5A01", "Check that the functions Sin and Sinh provide " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Sin Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Sin with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Sin (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "negative value");
- end;
-
-
- -- Test of Sin for prescribed result at zero.
-
- if GEF.Sin (0.0) /= 0.0 or
- EF.Sin (0.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sin(0.0)");
- end if;
-
-
- -- Test of Sin with expected result value between 0.0 and 1.0.
-
- if not (GEF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or
- not ( EF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or
- not FXA5A00.Result_Within_Range(GEF.Sin(0.35), 0.343, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sin(1.18), 0.924, 0.001)
- then
- Report.Failed("Incorrect value returned from Sin function when " &
- "the expected result is between 0.0 and 1.0");
- end if;
-
-
- -- Test of Sin with expected result value between -1.0 and 0.0.
-
- if not (GEF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or
- not ( EF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or
- not FXA5A00.Result_Within_Range(GEF.Sin(-0.24), -0.238, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sin(-1.00), -0.841, 0.001)
- then
- Report.Failed("Incorrect value returned from Sin function when " &
- "the expected result is between -1.0 and 0.0");
- end if;
-
-
- -- Testing of the Sin function with Cycle parameter.
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is zero.
-
- begin
- New_Float_Result := GEF.Sin (X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Sin function " &
- "when the Cycle parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Sin function " &
- "when the Cycle parameter is zero");
- end;
-
- begin
- The_Result := EF.Sin (X => 0.34, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by EF.Sin function when " &
- "the Cycle parameter is zero");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Sin function " &
- "when the Cycle parameter is zero");
- end;
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is negative.
-
- begin
- New_Float_Result := GEF.Sin (X => 0.45, Cycle => -1.0);
- Report.Failed("Argument_Error not raised by GEF.Sin function " &
- "when the Cycle parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Sin function " &
- "when the Cycle parameter is negative");
- end;
-
- begin
- The_Result := EF.Sin (X => 0.10, Cycle => -4.0);
- Report.Failed("Argument_Error not raised by EF.Sin function when " &
- "the Cycle parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Sin function " &
- "when the Cycle parameter is negative");
- end;
-
-
- -- Check that no exception occurs on computing the Sin with very
- -- large (positive and negative) input values and Cycle parameter.
-
- begin
- New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large), 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "positive value and Cycle parameter");
- end;
-
- begin
- The_Result := EF.Sin (FXA5A00.Minus_Large, 720.0);
- Dont_Optimize_Float(The_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Sin with large " &
- "negative value and Cycle parameter");
- end;
-
-
- -- Test of Sin with Cycle parameter for prescribed result at zero.
-
- if GEF.Sin (0.0, 360.0) /= 0.0 or
- EF.Sin (0.0, 180.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sin function with " &
- "cycle parameter for a zero input parameter value");
- end if;
-
-
- -- Tests of Sin function with Cycle parameter for prescribed results.
-
- if GEF.Sin(0.0, 360.0) /= 0.0 or
- EF.Sin(180.0, 360.0) /= 0.0 or
- GEF.Sin(90.0, 360.0) /= 1.0 or
- EF.Sin(450.0, 360.0) /= 1.0 or
- GEF.Sin(270.0, 360.0) /= -1.0 or
- EF.Sin(630.0, 360.0) /= -1.0
- then
- Report.Failed("Incorrect result from the Sin function with " &
- "various cycle values for prescribed results");
- end if;
-
-
- -- Testing of Sinh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Test for Constraint_Error on parameter with large positive magnitude.
-
- begin
-
- if New_Float'Machine_Overflows then
- New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Large));
- Report.Failed("Constraint_Error not raised when the GEF.Sinh " &
- "function is provided a parameter with a large " &
- "positive value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the GEF.Sinh " &
- "function is provided a parameter with a large " &
- "positive value");
- end;
-
- -- Test for Constraint_Error on parameter with large negative magnitude.
-
- begin
-
- if Float'Machine_Overflows then
- The_Result := EF.Sinh (FXA5A00.Minus_Large);
- Report.Failed("Constraint_Error not raised when the EF.Sinh " &
- "function is provided a parameter with a " &
- "large negative value");
- Dont_Optimize_Float(The_Result, 10);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the EF.Sinh " &
- "function is provided a parameter with a " &
- "large negative value");
- end;
-
-
- -- Test that no exception occurs when the Sinh function is provided a
- -- very small positive or negative value.
-
- begin
- New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sinh with a very" &
- "small positive value");
- end;
-
- begin
- The_Result := EF.Sinh (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 12);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Sinh with a very" &
- "small negative value");
- end;
-
-
- -- Test for prescribed 0.0 result of Function Sinh with 0.0 parameter.
-
- if GEF.Sinh (0.0) /= 0.0 or
- EF.Sinh (0.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sinh(0.0)");
- end if;
-
-
- -- Test of Sinh function with various input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Sinh(0.01), 0.010, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sinh(0.61), 0.649, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Sinh(1.70), 2.65, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sinh(3.15), 11.65, 0.01)
- then
- Report.Failed("Incorrect result returned from Sinh function " &
- "with various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a
deleted file mode 100644
index 9e6c575..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a
+++ /dev/null
@@ -1,328 +0,0 @@
--- CXA5A02.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 functions Cos and Cosh provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Cos and Cosh resulting from
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with type derived from type Float, as well as the pre-instantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A02.A
---
---
--- CHANGE HISTORY:
--- 09 Mar 95 SAIC Initial prerelease version.
--- 03 Apr 95 SAIC Removed reference to derived type.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks specifying Cycle => 2.0 * Pi
--- 26 Jun 98 EDS Protected exception checks by first testing
--- for 'Machine_Overflows. Removed code deleted
--- by comment.
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks have been deleted.
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A02 is
-begin
-
- Report.Test ("CXA5A02", "Check that the functions Cos and Cosh provide " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Cos Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Cos with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Cos (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cos with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Cos (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cos with large " &
- "negative value");
- end;
-
-
- -- Test of Cos for prescribed result at zero.
-
- if GEF.Cos (0.0) /= 1.0 or
- EF.Cos (0.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cos(0.0)");
- end if;
-
-
- -- Test of Cos with expected result value between 1.0 and -1.0.
-
- if not (Result_Within_Range( EF.Cos(Ada.Numerics.Pi/3.0),
- 0.500,
- 0.001) and
- Result_Within_Range(GEF.Cos(0.6166), 0.816, 0.001) and
- Result_Within_Range(GEF.Cos(0.1949), 0.981, 0.001) and
- Result_Within_Range( EF.Cos(Ada.Numerics.Pi/2.0),
- 0.00,
- 0.001) and
- Result_Within_Range( EF.Cos(2.0*Ada.Numerics.Pi/3.0),
- -0.500,
- 0.001) and
- Result_Within_Range(GEF.Cos(New_Float(Ada.Numerics.Pi)),
- -1.00,
- 0.001))
- then
- Report.Failed("Incorrect value returned from Cos function when " &
- "the expected result is between 1.0 and -1.0");
- end if;
-
-
- -- Testing of the Cos function with Cycle parameter.
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is zero.
-
- begin
- New_Float_Result := GEF.Cos (X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Cos function " &
- "when the Cycle parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.cos function " &
- "when the Cycle parameter is zero");
- end;
-
- begin
- The_Result := EF.Cos (X => 0.55, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by EF.Cos function when " &
- "the Cycle parameter is zero");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Cos function " &
- "when the Cycle parameter is zero");
- end;
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is negative.
-
- begin
- New_Float_Result := GEF.Cos (X => 0.45, Cycle => -2.0*Pi);
- Report.Failed("Argument_Error not raised by GEF.Cos function " &
- "when the Cycle parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Cos function " &
- "when the Cycle parameter is negative");
- end;
-
- begin
- The_Result := EF.Cos (X => 0.10, Cycle => -Pi/2.0);
- Report.Failed("Argument_Error not raised by EF.Cos function when " &
- "the Cycle parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Cos function " &
- "when the Cycle parameter is negative");
- end;
-
- -- Test of Cos with Cycle parameter for prescribed result at zero.
-
- if GEF.Cos (0.0, 360.0) /= 1.0 or
- EF.Cos (0.0, 360.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cos function with " &
- "cycle parameter for a zero input parameter value");
- end if;
-
-
- -- Tests of Cos function with specified Cycle, using various input
- -- parameter values for prescribed results.
-
- if GEF.Cos(0.0, 360.0) /= 1.0 or
- EF.Cos(360.0, 360.0) /= 1.0 or
- GEF.Cos(90.0, 360.0) /= 0.0 or
- EF.Cos(270.0, 360.0) /= 0.0 or
- GEF.Cos(180.0, 360.0) /= -1.0 or
- EF.Cos(540.0, 360.0) /= -1.0
- then
- Report.Failed("Incorrect result from the Cos function with " &
- "specified cycle for prescribed results");
- end if;
-
-
-
- -- Testing of Cosh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Test for Constraint_Error on parameter with large positive magnitude.
-
- begin
-
- if New_Float'Machine_Overflows then
-
- New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Large));
- Report.Failed("Constraint_Error not raised when the GEF.Cosh " &
- "function is provided a parameter with a large " &
- "positive value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the GEF.Cosh " &
- "function is provided a parameter with a large " &
- "positive value");
- end;
-
- -- Test for Constraint_Error on parameter with large negative magnitude.
-
- begin
-
- if Float'Machine_Overflows then
- The_Result := EF.Cosh (FXA5A00.Minus_Large);
- Report.Failed("Constraint_Error not raised when the EF.Cosh " &
- "function is provided a parameter with a " &
- "large negative value");
- Dont_Optimize_Float(The_Result, 10);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the EF.Cosh " &
- "function is provided a parameter with a " &
- "large negative value");
- end;
-
-
- -- Test that no exception occurs when the Cosh function is provided a
- -- very small positive or negative value.
-
- begin
- New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cosh with a very" &
- "small positive value");
- end;
-
- begin
- The_Result := EF.Cosh (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 12);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Cosh with a very" &
- "small negative value");
- end;
-
-
- -- Test for prescribed 1.0 result of Function Cosh with 0.0 parameter.
-
- if GEF.Cosh (0.0) /= 1.0 or
- EF.Cosh (0.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cosh(0.0)");
- end if;
-
-
- -- Test of Cosh function with various input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Cosh(0.24), 1.029, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(0.59), 1.179, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Cosh(1.06), 1.616, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(1.50), 2.352, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Cosh(1.84), 3.228, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(3.40), 14.99, 0.01)
- then
- Report.Failed("Incorrect result from Cosh function with " &
- "various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a
deleted file mode 100644
index d99ba9b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a
+++ /dev/null
@@ -1,426 +0,0 @@
--- CXA5A03.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 functions Tan, Tanh, and Arctanh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Tan, Tanh, and Arctanh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A03.A
---
---
--- CHANGE HISTORY:
--- 14 Mar 95 SAIC Initial prerelease version.
--- 06 Apr 95 SAIC Corrected errors in context clause references
--- and usage of Cycle parameter.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A03 is
-begin
-
- Report.Test ("CXA5A03", "Check that the functions Tan, Tanh, and " &
- "Arctanh provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Tan Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with large " &
- "negative value");
- end;
-
-
- -- Check that no exception occurs on computing the Tan with very
- -- small (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with small " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 4);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with small " &
- "negative value");
- end;
-
-
- -- Check prescribed result from Tan function. When the parameter X
- -- has the value zero, the Tan function yields a result of zero.
-
- if GEF.Tan(0.0) /= 0.0 or
- EF.Tan(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tan function with zero " &
- "value input parameter");
- end if;
-
-
- -- Check the results of the Tan function with various input parameters.
-
- if not (Result_Within_Range(GEF.Tan(0.7854), 1.0, 0.001) and
- Result_Within_Range(GEF.Tan(0.8436), 1.124, 0.001) and
- Result_Within_Range( EF.Tan(Pi), 0.0, 0.001) and
- Result_Within_Range( EF.Tan(-Pi), 0.0, 0.001) and
- Result_Within_Range(GEF.Tan(0.5381), 0.597, 0.001) and
- Result_Within_Range( EF.Tan(0.1978), 0.200, 0.001))
- then
- Report.Failed("Incorrect result from Tan function with various " &
- "input parameters");
- end if;
-
-
- -- Testing of Tan function with cycle parameter.
-
- -- Check that Constraint_Error is raised by the Tan function with
- -- specified cycle, when the value of the parameter X is an odd
- -- multiple of the quarter cycle.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Tan(270.0, 360.0);
- Report.Failed("Constraint_Error not raised by GEF.Tan on odd " &
- "multiple of the quarter cycle");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Tan on odd " &
- "multiple of the quarter cycle");
- end;
- end if;
-
- -- Check that the exception Numerics.Argument_Error is raised, when
- -- the value of the parameter Cycle is zero or negative.
-
- begin
- New_Float_Result := GEF.Tan(X => 1.0, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " &
- "parameter has negative value");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Tan when Cycle " &
- "parameter has negative value");
- end;
-
- begin
- The_Result := EF.Tan(1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " &
- "parameter has a zero value");
- Dont_Optimize_Float(The_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Tan when Cycle " &
- "parameter has a zero value");
- end;
-
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large), 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (FXA5A00.Minus_Large, Cycle => 360.0);
- Dont_Optimize_Float(The_Result, 9);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with large " &
- "negative value");
- end;
-
-
- -- Check prescribed result from Tan function with Cycle parameter.
-
- if GEF.Tan(0.0, 360.0) /= 0.0 or
- EF.Tan(0.0, Cycle => 360.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tan function with cycle " &
- "parameter, using a zero value input parameter");
- end if;
-
-
- -- Check the Tan function, with specified Cycle parameter, with a
- -- variety of input parameters.
-
- if not Result_Within_Range(GEF.Tan(30.0, 360.0), 0.577, 0.001) or
- not Result_Within_Range( EF.Tan(57.0, 360.0), 1.540, 0.001) or
- not Result_Within_Range(GEF.Tan(115.0, 360.0), -2.145, 0.001) or
- not Result_Within_Range( EF.Tan(299.0, 360.0), -1.804, 0.001) or
- not Result_Within_Range(GEF.Tan(390.0, 360.0), 0.577, 0.001) or
- not Result_Within_Range( EF.Tan(520.0, 360.0), -0.364, 0.001)
- then
- Report.Failed("Incorrect result from the Tan function with " &
- "cycle parameter, with various input parameter " &
- "values");
- end if;
-
-
-
- -- Testing of Tanh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tanh (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 10);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tanh with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tanh (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tanh with large " &
- "negative value");
- end;
-
-
- -- Check for prescribed result of Tanh with zero value input parameter.
-
- if GEF.Tanh (0.0) /= 0.0 or
- EF.Tanh (0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tanh with zero parameter");
- end if;
-
-
- -- Check the results of the Tanh function with various input
- -- parameters.
-
- if not (FXA5A00.Result_Within_Range(GEF.Tanh(2.99), 0.995, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(0.130), 0.129, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(Pi), 0.996, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(-Pi), -0.996, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(0.60), 0.537, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(1.04), 0.778, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(1.55), 0.914, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(-2.14), -0.973, 0.001))
- then
- Report.Failed("Incorrect result from Tanh function with various " &
- "input parameters");
- end if;
-
-
-
- -- Testing of Arctanh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised by the Arctanh function
- -- when the absolute value of the parameter X is one.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Arctanh(X => 1.0);
- Report.Failed("Constraint_Error not raised by Function Arctanh " &
- "when provided a parameter value of 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 12);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh "
- & "when provided a parameter value of 1.0");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Arctanh(-1.0);
- Report.Failed("Constraint_Error not raised by Function Arctanh " &
- "when provided a parameter value of -1.0");
- Dont_Optimize_Float(The_Result, 13);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh "
- & "when provided a parameter value of -1.0");
- end;
- end if;
-
- -- Check that Function Arctanh raises Argument_Error when the absolute
- -- value of the parameter X exceeds one.
-
- begin
- New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a parameter value greater than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 14);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a parameter value greater than 1.0");
- end;
-
-
- begin
- The_Result := EF.Arctanh(FXA5A00.Minus_One_Minus_Delta);
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a parameter value less than -1.0");
- Dont_Optimize_Float(The_Result, 15);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a parameter value less than -1.0");
- end;
-
-
- begin
- New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.Large));
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a large positive parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 16);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a large positive parameter value");
- end;
-
-
- begin
- The_Result := EF.Arctanh(FXA5A00.Minus_Large);
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a large negative parameter value");
- Dont_Optimize_Float(The_Result, 17);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a large negative parameter value");
- end;
-
-
- -- Prescribed results for Function Arctanh with zero input value.
-
- if GEF.Arctanh(0.0) /= 0.0 or
- EF.Arctanh(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arctanh with a " &
- "parameter value of zero");
- end if;
-
-
- -- Check the results of the Arctanh function with various input
- -- parameters.
-
- if not (Result_Within_Range(GEF.Arctanh(0.15), 0.151, 0.001) and
- Result_Within_Range( EF.Arctanh(0.44), 0.472, 0.001) and
- Result_Within_Range(GEF.Arctanh(0.81), 1.127, 0.001) and
- Result_Within_Range( EF.Arctanh(0.99), 2.647, 0.001))
- then
- Report.Failed("Incorrect result from Arctanh function with " &
- "various input parameters");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A03;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a
deleted file mode 100644
index 9b590a2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a
+++ /dev/null
@@ -1,434 +0,0 @@
--- CXA5A04.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 functions Cot, Coth, and Arccoth provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Cot, Coth, and Arccoth
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A04.A
---
---
--- CHANGE HISTORY:
--- 15 Mar 95 SAIC Initial prerelease version.
--- 07 Apr 95 SAIC Corrected errors in context clause reference,
--- added trigonometric relationship checks.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A04 is
-begin
-
- Report.Test ("CXA5A04", "Check that the functions Cot, Coth, and " &
- "Arccoth provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Cot Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised with the Cot function is
- -- given a parameter input value of 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (0.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "when provided a zero input parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "when provided a zero input parameter value");
- end;
- end if;
-
- -- Check that no exception occurs on computing the Cot with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cot with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Cot (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 3);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Cot with large " &
- "negative value");
- end;
-
-
- -- Check the results of the Cot function with various input parameters.
-
- if not (FXA5A00.Result_Within_Range(GEF.Cot(Pi/4.0), 1.0, 0.001) and
- FXA5A00.Result_Within_Range( EF.Cot(Pi/2.0), 0.0, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Cot(3.0*Pi/4.0),-1.0, 0.001) and
- FXA5A00.Result_Within_Range( EF.Cot(3.0*Pi/2.0), 0.0, 0.001))
- then
- Report.Failed("Incorrect result from Cot function with various " &
- "input parameters");
- end if;
-
-
- -- Check the results of the Cot function against the results of
- -- various trigonometric relationships.
-
- if not FXA5A00.Result_Within_Range(GEF.Cot(New_Float(Pi/4.0)),
- 1.0/EF.Tan(Pi/4.0),
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Cot(Pi/4.0),
- EF.Cos(Pi/4.0)/EF.Sin(Pi/4.0),
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(Pi/4.0)),
- Pi/4.0,
- 0.001)
- then
- Report.Failed("Incorrect result from Cot function with respect " &
- "to various trigonometric relationship expected " &
- "results");
- end if;
-
-
- -- Testing of Cot with Cycle parameter.
-
- -- Check that Argument_Error is raised by the Cot function when the
- -- value of the Cycle parameter is zero or negative.
-
- begin
- New_Float_Result := GEF.Cot (1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Cot Function " &
- "with a specified cycle value of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by the Cot Function with " &
- "a specified cycle value of 0.0");
- end;
-
- begin
- The_Result := EF.Cot (X => 1.0, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Cot Function " &
- "with a specified cycle value of -360.0");
- Dont_Optimize_Float(The_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by the Cot Function with " &
- "a specified cycle value of -360.0");
- end;
-
-
- -- Check that Constraint_Error is raised by the Cot Function with
- -- specified cycle, when the value of the parameter X is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (0.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is 0.0");
- end;
- end if;
-
- -- Check that Constraint_Error is raised by the Cot Function with
- -- specified cycle, when the value of the parameter X is a multiple
- -- of the half cycle.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (180.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (180.0, 360.0)");
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle" &
- " (180.0, 360.0)");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Cot (540.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (540.0, 360.0)");
- Dont_Optimize_Float(The_Result, 8);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (540.0, 360.0)");
- end;
- end if;
-
---pwb-math -- Check that no exception occurs on computing the Cot with very
---pwb-math -- large (positive and negative) input values.
---pwb-math
---pwb-math begin
---pwb-math New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large), 2.0*Pi);
---pwb-math Dont_Optimize_New_Float(New_Float_Result, 9);
---pwb-math exception
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception on GEF.Cot with large " &
---pwb-math "positive value");
---pwb-math end;
---pwb-math
---pwb-math begin
---pwb-math The_Result := EF.Cot (FXA5A00.Minus_Large, Cycle => 2.0*Pi);
---pwb-math Dont_Optimize_Float(The_Result, 10);
---pwb-math exception
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception on EF.Cot with large " &
---pwb-math "negative value");
---pwb-math end;
---pwb-math
---pwb-math
---pwb-math -- Check prescribed result from Cot function with Cycle parameter.
---pwb-math
---pwb-math if not FXA5A00.Result_Within_Range
---pwb-math (GEF.Cot(New_Float(FXA5A00.Half_Pi), 2.0*Pi), 0.0, 0.001) or
---pwb-math not FXA5A00.Result_Within_Range
---pwb-math (EF.Cot(3.0*Pi/2.0, Cycle => 2.0*Pi), 0.0, 0.001)
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Cot function with cycle " &
---pwb-math "parameter, using a multiple of Pi/2 as the " &
---pwb-math "input parameter");
---pwb-math end if;
-
-
- -- Testing of Coth Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Coth with very
- -- large (positive and negative) input values.
-
- begin
- The_Result := EF.Coth (FXA5A00.Large);
- if The_Result > 1.0 then
- Report.Failed("Result of Coth function with large positive " &
- "value greater than 1.0");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Coth with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Coth (FXA5A00.Minus_Large);
- if The_Result < -1.0 then
- Report.Failed("Result of Coth function with large negative " &
- "value less than -1.0");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Coth with large " &
- "negative value");
- end;
-
-
- -- Check that Constraint_Error is raised by the Coth function, when
- -- the value of the parameter X is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Coth (X => 0.0);
- Report.Failed("Constraint_Error not raised by the Coth function " &
- "when the value of parameter X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Coth " &
- "function when the value of parameter X is 0.0");
- end;
- end if;
-
-
- -- Testing of Arccoth Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised by the Arccoth function
- -- when the absolute value of the parameter X is 1.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Arccoth (X => 1.0);
- Report.Failed("Constraint_Error not raised by the Arccoth " &
- "function when the value of parameter X is 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 12);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function when the value of parameter X is 1.0");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Arccoth (-1.0);
- Report.Failed("Constraint_Error not raised by the Arccoth " &
- "function when the value of parameter X is -1.0");
- Dont_Optimize_Float(The_Result, 13);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function when the value of parameter X is -1.0");
- end;
- end if;
-
- -- Check that Argument_Error is raised by the Arccoth function when
- -- the absolute value of the parameter X is less than 1.0.
-
- begin
- New_Float_Result := GEF.Arccoth (X => New_Float(One_Minus_Delta));
- Report.Failed("Argument_Error not raised by the Arccoth " &
- "function with parameter value less than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 14);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function with parameter value less than 1.0");
- end;
-
- begin
- The_Result := EF.Arccoth (X => FXA5A00.Minus_One_Plus_Delta);
- Report.Failed("Argument_Error not raised by the Arccoth function " &
- "with parameter value between 0.0 and -1.0");
- Dont_Optimize_Float(The_Result, 15);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function with parameter value between 0.0 " &
- "and -1.0");
- end;
-
-
- -- Check the results of the Arccoth function with various input
- -- parameters.
-
- if not (Result_Within_Range(GEF.Arccoth(1.01), 2.652, 0.01) and
- Result_Within_Range( EF.Arccoth(1.25), 1.099, 0.01) and
- Result_Within_Range(GEF.Arccoth(1.56), 0.760, 0.001) and
- Result_Within_Range( EF.Arccoth(1.97), 0.560, 0.001) and
- Result_Within_Range(GEF.Arccoth(2.40), 0.444, 0.001) and
- Result_Within_Range( EF.Arccoth(4.30), 0.237, 0.001) and
- Result_Within_Range(GEF.Arccoth(5.80), 0.174, 0.001) and
- Result_Within_Range( EF.Arccoth(7.00), 0.144, 0.001))
- then
- Report.Failed("Incorrect result from Arccoth function with various " &
- "input parameters");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A04;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a
deleted file mode 100644
index b50da3a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXA5A05.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 functions Arcsin and Arcsinh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arcsin and Arcsinh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A05.A
---
---
--- CHANGE HISTORY:
--- 20 Mar 95 SAIC Initial prerelease version.
--- 06 Apr 95 SAIC Corrected errors in context clause reference and
--- use of Cycle parameter.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explict Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A05 is
-begin
-
- Report.Test ("CXA5A05", "Check that the functions Arcsin and Arcsinh " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Function Arcsin, both instantiated and pre-instantiated
- -- versions.
-
- -- Check that Argument_Error is raised by the Arcsin function when
- -- the absolute value of the parameter X is greater than 1.0.
-
- begin
- New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by Arcsin function " &
- "when provided a parameter value larger than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Arcsin function " &
- "when provided a parameter value larger than 1.0");
- end;
-
- begin
- The_Result := EF.Arcsin(FXA5A00.Minus_Large);
- Report.Failed("Argument_Error not raised by Arcsin function " &
- "when provided a large negative parameter value");
- Dont_Optimize_Float(The_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Arcsin function " &
- "when provided a large negative parameter value");
- end;
-
-
- -- Check the prescribed result of function Arcsin with parameter 0.0.
-
- if GEF.Arcsin(X => 0.0) /= 0.0 or
- EF.Arcsin(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arcsin when the " &
- "value of the parameter X is 0.0");
- end if;
-
-
- -- Check the results of the Arcsin function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arcsin(1.0), 1.571, 0.001) or
- not Result_Within_Range( EF.Arcsin(0.62), 0.669, 0.001) or
- not Result_Within_Range(GEF.Arcsin(0.01), 0.010, 0.001) or
- not Result_Within_Range( EF.Arcsin(-0.29), -0.294, 0.001) or
- not Result_Within_Range(GEF.Arcsin(-0.50), -0.524, 0.001) or
- not Result_Within_Range( EF.Arcsin(-1.0), -1.571, 0.001)
- then
- Report.Failed("Incorrect result from Function Arcsin with " &
- "various input parameters");
- end if;
-
-
- -- Testing of Function Arcsin with specified Cycle parameter.
-
---pwb-math -- Check that Argument_Error is raised by the Arcsin function with
---pwb-math -- specified cycle, whenever the absolute value of the parameter X
---pwb-math -- is greater than 1.0.
---pwb-math
---pwb-math begin
---pwb-math New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.Large), 2.0*Pi);
---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided a large " &
---pwb-math "positive input parameter");
---pwb-math Dont_Optimize_New_Float(New_Float_Result, 3);
---pwb-math exception
---pwb-math when Argument_Error => null; -- OK, expected exception.
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided a large " &
---pwb-math "positive input parameter");
---pwb-math end;
---pwb-math
---pwb-math begin
---pwb-math The_Result := EF.Arcsin(FXA5A00.Minus_One_Minus_Delta, 2.0*Pi);
---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided an input " &
---pwb-math "parameter less than -1.0");
---pwb-math Dont_Optimize_Float(The_Result, 4);
---pwb-math exception
---pwb-math when Argument_Error => null; -- OK, expected exception.
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided an input " &
---pwb-math "parameter less than -1.0");
---pwb-math end;
---pwb-math
- -- Check that Argument_Error is raised by the Arcsin function with
- -- specified cycle, whenever the Cycle parameter is zero or negative.
-
- begin
- New_Float_Result := GEF.Arcsin(2.0, 0.0);
- Report.Failed("Argument_Error not raised by Function Arcsin " &
- "with specified cycle of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arcsin " &
- "with specified cycle of 0.0");
- end;
-
- begin
- The_Result := EF.Arcsin(2.0, -2.0*Pi);
- Report.Failed("Argument_Error not raised by Function Arcsin " &
- "with specified negative cycle parameter");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arcsin " &
- "with specified negative cycle parameter");
- end;
-
-
---pwb-math -- Check the prescribed result of function Arcsin with specified Cycle
---pwb-math -- parameter, when the value of parameter X is 0.0.
---pwb-math
---pwb-math if GEF.Arcsin(X => 0.0, Cycle => 2.0*Pi) /= 0.0 or
---pwb-math EF.Arcsin(0.0, 2.0*Pi) /= 0.0
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Function Arcsin with " &
---pwb-math "specified Cycle parameter, when the value " &
---pwb-math "of parameter X is 0.0");
---pwb-math end if;
---pwb-math
---pwb-math
---pwb-math -- Test of the Arcsin function with specified Cycle parameter with
---pwb-math -- various input parameters.
---pwb-math
---pwb-math if not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.01, 2.0*Pi),
---pwb-math 0.010,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.14, 2.0*Pi),
---pwb-math 0.141,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.37, 2.0*Pi),
---pwb-math 0.379,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.55, 2.0*Pi),
---pwb-math 0.582,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin(-0.22, 2.0*Pi),
---pwb-math -0.222,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(-0.99, 2.0*Pi),
---pwb-math -1.43,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 360.0),
---pwb-math 90.0,
---pwb-math 0.1) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 100.0),
---pwb-math 25.0,
---pwb-math 0.1)
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Arcsin with specified " &
---pwb-math "cycle parameter with various input parameters");
---pwb-math end if;
-
- -- Testing of Arcsinh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Arcsinh with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Arcsinh(FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with large " &
- "negative value");
- end;
-
-
- -- Check that no exception occurs on computing the Arcsinh with very
- -- small (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with small " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Arcsinh(-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 10);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with small " &
- "negative value");
- end;
-
-
- -- Check function Arcsinh for prescribed result with parameter 0.0.
-
- if GEF.Arcsinh(X => 0.0) /= 0.0 or
- EF.Arcsinh(X => 0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arcsinh when " &
- "provided a 0.0 input parameter");
- end if;
-
-
- -- Check the results of the Arcsinh function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arcsinh(0.15), 0.149, 0.001) or
- not Result_Within_Range( EF.Arcsinh(0.82), 0.748, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(1.44), 1.161, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(6.70), 2.601, 0.001) or
- not Result_Within_Range( EF.Arcsinh(Pi), 1.862, 0.001) or
- not Result_Within_Range( EF.Arcsinh(-Pi), -1.862, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(-1.0), -0.881, 0.001) or
- not Result_Within_Range( EF.Arcsinh(-5.5), -2.406, 0.001)
- then
- Report.Failed("Incorrect result from Function Arcsin with " &
- "various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A05;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a
deleted file mode 100644
index 191a96d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXA5A06.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 functions Arccos and Arccosh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arccos and Arccosh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A06.A
---
---
--- CHANGE HISTORY:
--- 27 Mar 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A06 is
-begin
-
- Report.Test ("CXA5A06", "Check that the functions Arccos and Arccosh " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arccos Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccos function when the
- -- absolute value of the input parameter is greater than 1.0.
-
- begin
- New_Float_Result := GEF.Arccos(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "when the input parameter is greater than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function when the input parameter is greater " &
- "than 1.0");
- end;
-
- begin
- The_Result := EF.Arccos(-FXA5A00.Large);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "when the input parameter is a large negative value");
- Dont_Optimize_Float(The_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function when the input parameter is a " &
- "large negative value");
- end;
-
-
- -- Check the prescribed results of the Arccos function.
-
- if GEF.Arccos(X => 1.0) /= 0.0 or
- EF.Arccos(1.0) /= 0.0
- then
- Report.Failed("Incorrect result returned by the Arccos function " &
- "when provided a parameter value of 0.0");
- end if;
-
-
- -- Check the results of the Arccos function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arccos(0.77), 0.692, 0.001) or
- not Result_Within_Range( EF.Arccos(0.37), 1.19, 0.01) or
- not Result_Within_Range(GEF.Arccos(0.0), Pi/2.0, 0.01) or
- not Result_Within_Range( EF.Arccos(-0.11), 1.68, 0.01) or
- not Result_Within_Range(GEF.Arccos(-0.67), 2.31, 0.01) or
- not Result_Within_Range( EF.Arccos(-0.94), 2.79, 0.01) or
- not Result_Within_Range(GEF.Arccos(-1.0), Pi, 0.01)
- then
- Report.Failed("Incorrect result returned from the Arccos " &
- "function when provided a variety of input " &
- "parameters");
- end if;
-
-
- -- Testing of the Arccos function with specified Cycle parameter.
-
- -- Check that Argument_Error is raised by the Arccos function, with
- -- specified Cycle parameter, when the absolute value of the input
- -- parameter is greater than 1.0.
-
- begin
---pwb-math: Next line: Changed 2.0*Pi to 360.0
- New_Float_Result := GEF.Arccos(New_Float(Large), Cycle => 360.0);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the input " &
- "parameter is a large positive value");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the input parameter is a large positive value");
- end;
-
- begin
---pwb-math: Next line: Changed 2.0*Pi to 360.0
- The_Result := EF.Arccos(FXA5A00.Minus_One_Minus_Delta, 360.0);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the input " &
- "parameter is less than -1.0");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, " &
- "when the input parameter is less than -1.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Arccos function with
- -- specified cycle when the value of the Cycle parameter is zero or
- -- negative.
-
- begin
- New_Float_Result := GEF.Arccos(X => 1.0, Cycle => 0.0 );
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the Cycle parameter is 0.0");
- end;
-
- begin
- The_Result := EF.Arccos(1.0, Cycle => -2.0*Pi);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the Cycle " &
- "parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the Cycle parameter is negative");
- end;
-
-
- -- Check the prescribed result of the Arccos function with specified
- -- Cycle parameter.
-
---pwb-math: Next two lines: Changed 2.0*Pi to 360.0
- if GEF.Arccos(X => 1.0, Cycle => 360.0) /= 0.0 or
- EF.Arccos(1.0, 360.0) /= 0.0
- then
- Report.Failed("Incorrect result from the Arccos function with " &
- "specified Cycle parameter, when the input " &
- "parameter value is 1.0");
- end if;
-
-
- -- Check the results of the Arccos function, with specified Cycle
- -- parameter, with various input parameters.
-
- if --pwb-math not Result_Within_Range(GEF.Arccos( 0.04, 2.0*Pi), 1.53, 0.01) or
---pwb-math not Result_Within_Range( EF.Arccos( 0.14, 2.0*Pi), 1.43, 0.01) or
---pwb-math not Result_Within_Range(GEF.Arccos( 0.57, 2.0*Pi), 0.96, 0.01) or
---pwb-math not Result_Within_Range( EF.Arccos( 0.99, 2.0*Pi), 0.14, 0.01) or
- not Result_Within_Range(GEF.Arccos(-1.0, 360.0), 180.0, 0.1) or
- not Result_Within_Range(GEF.Arccos(-1.0, 100.0), 50.0, 0.1) or
- not Result_Within_Range(GEF.Arccos( 0.0, 360.0), 90.0, 0.1) or
- not Result_Within_Range(GEF.Arccos( 0.0, 100.0), 25.0, 0.1)
- then
- Report.Failed("Incorrect result returned from the Arccos " &
- "function with specified Cycle parameter, " &
- "when provided a variety of input parameters");
- end if;
-
-
-
- -- Testing of Arccosh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccosh function when
- -- the value of the parameter X is less than 1.0.
-
- begin
- New_Float_Result := GEF.Arccosh(New_Float(FXA5A00.One_Minus_Delta));
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the parameter value is less than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a parameter value less " &
- "than 1.0");
- end;
-
- begin
- The_Result := EF.Arccosh(0.0);
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the parameter value is 0.0");
- Dont_Optimize_Float(The_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a parameter value of 0.0");
- end;
-
- begin
- New_Float_Result := GEF.Arccosh(New_Float(-FXA5A00.Large));
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the large negative parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a large negative parameter " &
- "value");
- end;
-
-
- -- Check the prescribed results of the Arccosh function.
-
- if GEF.Arccosh(X => 1.0) /= 0.0 or
- EF.Arccosh(1.0) /= 0.0
- then
- Report.Failed("Incorrect result returned by the Arccosh " &
- "function when provided a parameter value of 0.0");
- end if;
-
-
- -- Check the results of the Arccosh function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arccosh(1.03), 0.244, 0.001) or
- not Result_Within_Range( EF.Arccosh(1.28), 0.732, 0.001) or
- not Result_Within_Range(GEF.Arccosh(1.50), 0.962, 0.001) or
- not Result_Within_Range( EF.Arccosh(1.77), 1.17, 0.01) or
- not Result_Within_Range(GEF.Arccosh(2.00), 1.32, 0.01) or
- not Result_Within_Range( EF.Arccosh(4.30), 2.14, 0.01) or
- not Result_Within_Range(GEF.Arccosh(6.90), 2.62, 0.01)
- then
- Report.Failed("Incorrect result returned from the Arccosh " &
- "function when provided a variety of input " &
- "parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A06;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a
deleted file mode 100644
index 179d54c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a
+++ /dev/null
@@ -1,413 +0,0 @@
--- CXA5A07.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 function Arctan provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arctan resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions with
--- a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A07.A
---
---
--- CHANGE HISTORY:
--- 04 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A07 is
-begin
-
- Report.Test ("CXA5A07", "Check that the Arctan function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Float_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arctan Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arctan function when
- -- provided parameter values of 0.0, 0.0.
-
- begin
- New_Float_Result := GEF.Arctan(Y => 0.0, X => 0.0);
- Report.Failed("Argument_Error not raised when the Arctan " &
- "function is provided input of 0.0, 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided 0.0, 0.0 input parameters");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided a large positive or negative Y parameter value, when
- -- using the default value for parameter X.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large negative Y parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided a small positive or negative Y parameter value, when
- -- using the default value for parameter X.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Small);
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small negative Y parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided combinations of large and small positive or negative
- -- parameter values for both Y and X input parameters.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Large, X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided large positive X and Y parameter values");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Large),
- X => New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large negative Y parameter value " &
- "and a small positive X parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Small, X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 8);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small positive Y parameter value " &
- "and a large positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Small),
- New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small negative Y parameter value " &
- "and a large negative parameter value");
- end;
-
-
- -- Check that when the Arctan function is provided a Y parameter value
- -- of 0.0 and a positive X parameter input value, the prescribed result
- -- of zero is returned.
-
- if GEF.Arctan(Y => 0.0) /= 0.0 or -- Default X value
- EF.Arctan(Y => 0.0, X => FXA5A00.Large) /= 0.0 or
---pwb-math: Next line: changed 2.0*Pi to 360.0
- GEF.Arctan(0.0, 360.0) /= 0.0 or
- EF.Arctan(0.0, FXA5A00.Small) /= 0.0
- then
- Report.Failed("Incorrect results from the Arctan function when " &
- "provided a Y parameter value of 0.0 and various " &
- "positive X parameter values");
- end if;
-
-
- -- Check that the Arctan function provides correct results when provided
- -- a variety of Y parameter values.
-
- if not FXA5A00.Result_Within_Range(EF.Arctan(Pi), 1.26, 0.01) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-Pi), -1.26, 0.01) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(1.0), 0.785, 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-1.0), -0.785, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(0.25), 0.245, 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(0.92), 0.744, 0.001)
- then
- Report.Failed("Incorrect results from the Arctan function when " &
- "provided a variety of Y parameter values");
- end if;
-
-
-
- -- Check the results of the Arctan function with specified cycle
- -- parameter.
-
- -- Check that the Arctan function with specified Cycle parameter
- -- raises Argument_Error when the value of the Cycle parameter is zero
- -- or negative.
-
- begin
- Float_Result := EF.Arctan(Y => Pi, Cycle => 0.0); -- Default X value
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "with default X parameter value, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_Float(Float_Result, 10);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function with default X parameter value, when " &
- "provided a 0.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "when the Cycle parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided a 0.0 cycle parameter " &
- "value");
- end;
-
- begin
- Float_Result := EF.Arctan(Y => Pi, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "with a default X parameter value, when the Cycle " &
- "parameter is -360.0");
- Dont_Optimize_Float(Float_Result, 12);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function with a default X parameter value, when " &
- "provided a -360.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => -Pi);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "when the Cycle parameter is -Pi");
- Dont_Optimize_New_Float(New_Float_Result, 13);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided a -Pi cycle parameter " &
- "value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function with
- -- specified Cycle parameter, when provided large and small positive
- -- or negative parameter values for both Y and X input parameters.
-
- begin
- Float_Result := EF.Arctan(Y => -FXA5A00.Large,
- X => -FXA5A00.Large,
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 14);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "negative X and Y parameter values");
- end;
-
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Large),
- X => New_Float(-FXA5A00.Small),
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 15);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "positive Y parameter value and a small negative " &
- "X parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arctan(Y => -FXA5A00.Small,
- X => -FXA5A00.Large,
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 16);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "negative Y parameter value and a large negative " &
- "X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Small),
- New_Float(FXA5A00.Large),
---pwb-math: Next line: changed 2.0*Pi to 360.0
- 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 17);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided a " &
- "small negative Y parameter value and a large " &
- "positive X parameter value");
- end;
-
-
- -- Check that the Arctan function with specified Cycle parameter
- -- provides correct results when provided a variety of Y parameter
- -- input values.
-
---pwb-math if not FXA5A00.Result_Within_Range(EF.Arctan(Pi, Cycle => 2.0*Pi),
---pwb-math 1.26,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-Pi, Cycle => 2.0*Pi),
---pwb-math -1.26,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*Pi),
---pwb-math 0.785,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*Pi),
---pwb-math -0.785,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(0.16, Cycle => 2.0*Pi),
---pwb-math 0.159,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0),
---pwb-math 45.0,
---pwb-math 0.1) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0),
---pwb-math 12.5,
---pwb-math 0.1)
-
---pwb-math Next 12 lines are replacements for 21 commented lines above
- if not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*180.0),
- 45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*180.0),
- -45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0),
- 45.0,
- 0.1) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0),
- 12.5,
- 0.1)
- then
- Report.Failed("Incorrect results from the Arctan function with " &
- "specified Cycle parameter when provided a variety " &
- "of Y parameter values");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A07;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a
deleted file mode 100644
index ae2b85a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a
+++ /dev/null
@@ -1,474 +0,0 @@
--- CXA5A08.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 function Arccot provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arccot resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A08.A
---
---
--- CHANGE HISTORY:
--- 06 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 28 Feb 97 CTA.PWB Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A08 is
-begin
-
- Report.Test ("CXA5A08", "Check that the Arccot function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Float_Result : Float;
- Angle : Float;
- New_Float_Result : New_Float;
- New_Float_Angle : New_Float;
- Incorrect_Inverse : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arccot Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccot function when
- -- provided parameter values of 0.0, 0.0.
-
- begin
- New_Float_Result := GEF.Arccot(X => 0.0, Y => 0.0);
- Report.Failed("Argument_Error not raised when the Arccot " &
- "function is provided input of 0.0, 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided 0.0, 0.0 input parameters");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided a large positive or negative X parameter value, when
- -- using the default value for parameter Y.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large negative X parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided a small positive or negative X parameter value, when
- -- using the default value for parameter Y.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Small);
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small negative X parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided combinations of large and small positive or negative
- -- parameter values for both X and Y input parameters.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Large, Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided large positive X and Y parameter values");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Large),
- Y => New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large negative X parameter value " &
- "and a small positive Y parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Small, Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 8);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small positive X parameter value " &
- "and a large positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Small),
- New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small negative X parameter value " &
- "and a large negative Y parameter value");
- end;
-
-
- -- Check that when the Arccot function is provided a Y parameter value
- -- of 0.0 and a positive X parameter input value, the prescribed result
- -- of zero is returned.
-
- if EF.Arccot(X => FXA5A00.Large, Y => 0.0) /= 0.0 or
- GEF.Arccot(2.0*Pi, Y => 0.0) /= 0.0 or
- EF.Arccot(FXA5A00.Small, 0.0) /= 0.0 or
- EF.Arccot(X => FXA5A00.Large, Y => 0.0, Cycle => 360.0) /= 0.0 or
- GEF.Arccot(2.0*Pi, Y => 0.0, Cycle => 360.0) /= 0.0 or
- EF.Arccot(FXA5A00.Small, 0.0, Cycle => 360.0) /= 0.0
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "provided a Y parameter value of 0.0 and various " &
- "positive X parameter values");
- end if;
-
-
- -- Check that the Arccot function provides correct results when
- -- provided a variety of X parameter values.
-
- if not Result_Within_Range( EF.Arccot( 1.0), Pi/4.0, 0.001) or
- not Result_Within_Range(GEF.Arccot( 0.0), Pi/2.0, 0.001) or
- not Result_Within_Range( EF.Arccot(-1.0), 3.0*Pi/4.0, 0.001)
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "provided a variety of Y parameter values");
- end if;
-
-
- -- Check the results of the Arccot function with specified cycle
- -- parameter.
-
- -- Check that the Arccot function with specified Cycle parameter
- -- raises Argument_Error when the value of the Cycle parameter is zero
- -- or negative.
-
- begin
- Float_Result := EF.Arccot(X => Pi, Cycle => 0.0); -- Default Y value
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "with default Y parameter value, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_Float(Float_Result, 10);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function with default Y parameter value, when " &
- "provided a 0.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "when the Cycle parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided a 0.0 cycle parameter " &
- "value");
- end;
-
- begin
- Float_Result := EF.Arccot(X => Pi, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "with a default Y parameter value, when the Cycle " &
- "parameter is -360.0");
- Dont_Optimize_Float(Float_Result, 12);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function with a default Y parameter value, when " &
- "provided a -360.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => -Pi);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "when the Cycle parameter is -Pi");
- Dont_Optimize_New_Float(New_Float_Result, 13);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided a -Pi cycle parameter " &
- "value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function with
- -- specified Cycle parameter, when provided large and small positive
- -- or negative parameter values for both X and Y input parameters.
-
- begin
- Float_Result := EF.Arccot(X => -FXA5A00.Large,
- Y => -FXA5A00.Large,
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 14);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided large " &
- "negative X and Y parameter values");
- end;
-
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Large),
- Y => New_Float(-FXA5A00.Small),
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 15);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided large " &
- "positive X parameter value and a small negative " &
- "Y parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arccot(X => -FXA5A00.Small,
- Y => -FXA5A00.Large,
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 16);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided small " &
- "negative X parameter value and a large negative " &
- "Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Small),
- New_Float(FXA5A00.Large),
---pwb-math Next line: changed 2.0*Pi to 360.0
- 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 17);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided a " &
- "small positive X parameter value and a large " &
- "positive Y parameter value");
- end;
-
-
- -- Check that the Arccot function with specified Cycle parameter
- -- provides correct results when provided a variety of X parameter
- -- input values.
-
- if not FXA5A00.Result_Within_Range(GEF.Arccot( 0.0, Cycle => 360.0),
- 90.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot( 0.0, Cycle => 100.0),
- 25.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arccot( 1.0, Cycle => 360.0),
- 45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot( 1.0, Cycle => 100.0),
- 12.5,
- 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arccot(-1.0, Cycle => 360.0),
- 135.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot(-1.0, Cycle => 100.0),
- 37.5,
- 0.001)
- then
- Report.Failed("Incorrect results from the Arccot function with " &
- "specified Cycle parameter when provided a variety " &
- "of X parameter values");
- end if;
-
-
- if not FXA5A00.Result_Within_Range(EF.Arccot(0.2425355, 0.9701420),
- EF.Arccot(0.25),
- 0.01) or
- not FXA5A00.Result_Within_Range(EF.Arccot(0.3162277, 0.9486831),
- Ef.Arccot(0.33),
- 0.01)
- then
- Report.Failed("Incorrect results from the Arccot function with " &
- "comparison to other Arccot function results");
- end if;
-
-
- if not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.4472135,
- 0.8944270)),
- 0.5,
- 0.01) or
- not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.9987380,
- 0.0499369)),
- 20.0,
- 0.1)
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "used as argument to Cot function");
- end if;
-
-
- -- Check that inverse function results are correct.
- -- Default Cycle test.
-
- Angle := 0.001;
- while Angle < Pi and not Incorrect_Inverse loop
- if not Result_Within_Range(EF.Arccot(EF.Cot(Angle)), Angle, 0.001)
- then
- Incorrect_Inverse := True;
- end if;
- Angle := Angle + 0.001;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect results returned from the Inverse " &
- "comparison of Cot and Arccot using the default " &
- "cycle value");
- Incorrect_Inverse := False;
- end if;
-
- -- Non-Default Cycle test.
-
- New_Float_Angle := 0.01;
- while New_Float_Angle < 180.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF.Arccot(EF.Cot(Float(New_Float_Angle),
- Cycle => 360.0),
- Cycle => 360.0),
- Float(New_Float_Angle),
- 0.01) or
- not Result_Within_Range(GEF.Arccot(
- New_Float(GEF.Cot(New_Float_Angle,
- Cycle => 360.0)),
- Cycle => 360.0),
- Float(New_Float_Angle),
- 0.01)
- then
- Incorrect_Inverse := True;
- end if;
- New_Float_Angle := New_Float_Angle + 0.01;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect results returned from the Inverse " &
- "comparison of Cot and Arccot using non-default " &
- "cycle value");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A08;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a
deleted file mode 100644
index 22bd2f8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a
+++ /dev/null
@@ -1,400 +0,0 @@
--- CXA5A09.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 function Log provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Log resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions with
--- with a type derived from type Float,as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A09.A
---
---
--- CHANGE HISTORY:
--- 11 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A09 is
-begin
-
- Report.Test ("CXA5A09", "Check that the Log function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Arg,
- Float_Result : Float := 0.0;
- New_Float_Result : New_Float := 0.0;
-
- Incorrect_Inverse,
- Incorrect_Inverse_Base_2,
- Incorrect_Inverse_Base_8,
- Incorrect_Inverse_Base_10,
- Incorrect_Inverse_Base_16 : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Log Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised when the parameter X is negative.
-
- begin
- New_Float_Result := GEF.Log(X => -1.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "when the input parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "when the input parameter is negative");
- end;
-
- begin
- Float_Result := EF.Log(X => -FXA5A00.Large);
- Report.Failed("Argument_Error not raised by the Log function " &
- "when the input parameter is negative");
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "when the input parameter is negative");
- end;
-
-
- -- Check that Constraint_Error is raised when the Log function is
- -- provided an input parameter of zero.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Log(X => 0.0);
- Report.Failed("Constraint_Error not raised by the Log function " &
- "when the input parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function "
- & "when the input parameter is zero");
- end;
- end if;
-
-
- -- Check for the reference manual prescribed results of the Log function.
-
- if GEF.Log(X => 1.0) /= 0.0 or
- EF.Log(X => 1.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Log when provided " &
- "an input parameter value of 1.0");
- end if;
-
-
- -- Check that the Log function provides correct results when provided
- -- a variety of input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Log(0.015), -4.20, 0.01) or
- not FXA5A00.Result_Within_Range(GEF.Log(0.592), -0.524, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Log(0.997), -0.003, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Log(1.341), 0.293, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Log(2.826), 1.04, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Log(10.052), 2.31, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Log(2569.143), 7.85, 0.01)
- then
- Report.Failed("Incorrect results from Function Log when provided " &
- "a variety of input parameter values");
- end if;
-
- Arg := 0.001;
- while Arg < 1.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.001) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 0.001;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 0.001..1.0");
- Incorrect_Inverse := False;
- end if;
-
- Arg := 1.0;
- while Arg < 10.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.01) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 0.01;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 1.0..10.0");
- Incorrect_Inverse := False;
- end if;
-
- Arg := 1.0;
- while Arg < 1000.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.1) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 1.0..1000.0");
- end if;
-
-
- -- Testing of Log Function, with specified Base parameter, both
- -- instantiated and pre-instantiated versions.
-
- -- Check that Argument_Error is raised by the Log function with
- -- specified Base parameter, when the X parameter value is negative.
-
- begin
- New_Float_Result := GEF.Log(X => -1.0, Base => 16.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter, when the input parameter " &
- "value is -1.0");
- Dont_Optimize_New_Float(New_Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter, when the X parameter value " &
- "is -1.0");
- end;
-
- begin
- Float_Result := EF.Log(X => -FXA5A00.Large, Base => 8.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter, when the X parameter " &
- "value is a large negative value");
- Dont_Optimize_Float(Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter, when the X parameter " &
- "value is a large negative value");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is zero.
-
- begin
- New_Float_Result := GEF.Log(X => 10.0, Base => 0.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter of 0.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is one.
-
- begin
- Float_Result := EF.Log(X => 12.3, Base => 1.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter of 1.0");
- Dont_Optimize_Float(Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter of 1.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is negative.
-
- begin
- New_Float_Result := GEF.Log(X => 12.3, Base => -10.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with negative Base parameter");
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with negative Base parameter");
- end;
-
-
- -- Check that Constraint_Error is raised by the Log function when the
- -- input X parameter value is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Log(X => 0.0, Base => 16.0);
- Report.Failed("Constraint_Error not raised by the Log function " &
- "with specified Base parameter, when the value of " &
- "the parameter X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Log" &
- "with specified Base parameter, when the value " &
- "of the parameter X is 0.0");
- end;
- end if;
-
- -- Check for the prescribed results of the Log function with specified
- -- Base parameter.
-
- if GEF.Log(X => 1.0, Base => 16.0) /= 0.0 or
- EF.Log(X => 1.0, Base => 10.0) /= 0.0 or
- GEF.Log(1.0, Base => 8.0) /= 0.0 or
- EF.Log(1.0, 2.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Log with specified " &
- "Base parameter when provided an parameter X input " &
- "value of 1.0");
- end if;
-
-
- -- Check that the Log function with specified Base parameter provides
- -- correct results when provided a variety of input parameters.
-
- if not Result_Within_Range(GEF.Log( 10.0, e), 2.30, 0.01) or
- not Result_Within_Range( EF.Log( 8.0, 2.0), 3.0, 0.01) or
- not Result_Within_Range(GEF.Log(256.0, 2.0), 8.0, 0.01) or
- not Result_Within_Range( EF.Log(512.0, 8.0), 3.0, 0.01) or
- not Result_Within_Range(GEF.Log(0.5649, e), -0.57, 0.01) or
- not Result_Within_Range( EF.Log(1.7714, e), 0.57, 0.01) or
- not Result_Within_Range(GEF.Log(0.5718, 10.0), -0.243, 0.001) or
- not Result_Within_Range( EF.Log(466.25, 10.0), 2.67, 0.01)
- then
- Report.Failed("Incorrect results from Function Log with specified " &
- "Base parameter, when provided a variety of input " &
- "parameter values");
- end if;
-
-
- Arg := 1.0;
- while Arg < 1000.0 and
- not (Incorrect_Inverse_Base_2 and Incorrect_Inverse_Base_8 and
- Incorrect_Inverse_Base_10 and Incorrect_Inverse_Base_16)
- loop
- if not FXA5A00.Result_Within_Range(EF."**"(2.0,EF.Log(Arg,2.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_2 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(8.0,EF.Log(Arg,8.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_8 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(10.0,EF.Log(Arg,10.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_10 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(16.0,EF.Log(Arg,16.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_16 := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
- if Incorrect_Inverse_Base_2 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 2");
- end if;
-
- if Incorrect_Inverse_Base_8 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 8");
- end if;
-
- if Incorrect_Inverse_Base_10 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 10");
- end if;
-
- if Incorrect_Inverse_Base_16 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 16");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A09;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a
deleted file mode 100644
index 4804d67..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a
+++ /dev/null
@@ -1,551 +0,0 @@
--- CXA5A10.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 functions Exp and Sqrt, and the exponentiation
--- operator "**" provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the versions of Exp, Sqrt, and "**"
--- resulting from the instantiation of the
--- Ada.Numerics.Generic_Elementary_Functions with a type derived from
--- type Float, as well as the preinstantiated version of this package
--- for type Float.
--- Prescribed results (stated as such in the reference manual),
--- including instances prescribed to raise exceptions, are examined
--- in the test cases. In addition, certain evaluations are performed
--- for the preinstantiated package where the actual function result is
--- compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A10.A
---
---
--- CHANGE HISTORY:
--- 17 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 Oct 01 RLB Protected Constraint_Error exception tests by
--- first testing for 'Machine_Overflows.
---
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A10 is
-begin
-
- Report.Test ("CXA5A10", "Check that Exp, Sqrt, and the ""**"" operator " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use FXA5A00, Ada.Numerics;
- use Ada.Exceptions;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- use GEF, EF;
-
- Arg,
- Float_Result : Float;
- New_Float_Result : New_Float;
-
- Flag_1, Flag_2, Flag_3, Flag_4,
- Incorrect_Inverse_Base_e,
- Incorrect_Inverse_Base_2,
- Incorrect_Inverse_Base_8,
- Incorrect_Inverse_Base_10,
- Incorrect_Inverse_Base_16 : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of the "**" operator, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the exponentiation operator
- -- when the value of the Left parameter (operand) is negative.
-
- begin
- New_Float_Result := GEF."**"(Left => -10.0,
- Right => 2.0);
- Report.Failed("Argument_Error not raised by the instantiated " &
- "version of the exponentiation operator when the " &
- "value of the Left parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when the value of the Left parameter " &
- "is negative");
- end;
-
- begin
- Float_Result := (-FXA5A00.Small) ** 4.0;
- Report.Failed("Argument_Error not raised by the preinstantiated " &
- "version of the exponentiation operator when the " &
- "value of the Left parameter is negative");
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the value of the Left parameter " &
- "is negative");
- end;
-
-
- -- Check that Argument_Error is raised by the exponentiation operator
- -- when both parameters (operands) have the value 0.0.
-
- begin
- New_Float_Result := GEF."**"(0.0, Right => 0.0);
- Report.Failed("Argument_Error not raised by the instantiated " &
- "version of the exponentiation operator when " &
- "both operands are zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when both operands are zero");
- end;
-
- begin
- Float_Result := 0.0**0.0;
- Report.Failed("Argument_Error not raised by the preinstantiated " &
- "version of the exponentiation operator when both " &
- "operands are zero");
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when both operands are zero");
- end;
-
-
- -- Check that Constraint_Error is raised by the exponentiation
- -- operator when the value of the left parameter (operand) is zero,
- -- and the value of the right parameter (exponent) is negative.
- -- This check applies only if Machine_Overflows is true [A.5.1(28, 30)].
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF."**"(0.0, Right => -2.0);
- Report.Failed("Constraint_Error not raised by the instantiated " &
- "version of the exponentiation operator when " &
- "the left parameter is 0.0, and the right " &
- "parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, " &
- "and the right parameter is negative");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- Float_Result := 0.0 ** (-FXA5A00.Small);
- Report.Failed("Constraint_Error not raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, and the " &
- "right parameter is negative");
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, and " &
- "the right parameter is negative");
- end;
- end if;
-
- -- Prescribed results.
- -- Check that exponentiation by a 0.0 exponent yields the value one.
-
- if GEF."**"(Left => 10.0, Right => 0.0) /= 1.0 or
- EF."**"(FXA5A00.Large, Right => 0.0) /= 1.0 or
- GEF."**"(3.0, 0.0) /= 1.0 or
- FXA5A00.Small ** 0.0 /= 1.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the exponent is 0.0");
- end if;
-
-
- -- Check that exponentiation by a unit exponent yields the value
- -- of the left operand.
-
- if GEF."**"(Left => 50.0, Right => 1.0) /= 50.0 or
- EF."**"(FXA5A00.Large, Right => 1.0) /= FXA5A00.Large or
- GEF."**"(6.0, 1.0) /= 6.0 or
- FXA5A00.Small ** 1.0 /= FXA5A00.Small
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the exponent is 1.0");
- end if;
-
-
- -- Check that exponentiation of the value 1.0 yields the value 1.0.
-
- if GEF."**"(Left => 1.0, Right => 16.0) /= 1.0 or
- EF."**"(1.0, Right => FXA5A00.Large) /= 1.0 or
- GEF."**"(1.0, 3.0) /= 1.0 or
- 1.0 ** FXA5A00.Small /= 1.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the operand is 1.0");
- end if;
-
-
- -- Check that exponentiation of the value 0.0 yields the value 0.0.
-
- if GEF."**"(Left => 0.0, Right => 10.0) /= 0.0 or
- EF."**"(0.0, Right => FXA5A00.Large) /= 0.0 or
- GEF."**"(0.0, 4.0) /= 0.0 or
- 0.0 ** FXA5A00.Small /= 0.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the operand is 0.0");
- end if;
-
-
- -- Check that exponentiation of various operands with a variety of
- -- of exponent values yield correct results.
-
- if not Result_Within_Range(GEF."**"(5.0, 2.0), 25.0, 0.01) or
- not Result_Within_Range(GEF."**"(1.225, 1.5), 1.36, 0.01) or
- not Result_Within_Range(GEF."**"(0.26, 2.0), 0.068, 0.001) or
- not Result_Within_Range( EF."**"(e, 5.0), 148.4, 0.1) or
- not Result_Within_Range( EF."**"(10.0, e), 522.7, 0.1) or
- not Result_Within_Range( EF."**"(e, (-3.0)), 0.050, 0.001) or
- not Result_Within_Range(GEF."**"(10.0,(-2.0)), 0.010, 0.001)
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator with a variety of operand and exponent " &
- "values");
- end if;
-
-
- -- Use the following loops to check for internal consistency between
- -- inverse functions.
-
- declare
- -- Use the relative error value to account for non-exact
- -- computations.
- TC_Relative_Error: Float := 0.005;
- begin
- for i in 1..5 loop
- for j in 0..5 loop
- if not Incorrect_Inverse_Base_e and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- e**(Float(j)*EF.Log(Float(i))),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_e := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base e " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_2 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 2.0**(Float(j)*EF.Log(Float(i),2.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_2 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 2 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_8 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 8.0**(Float(j)*EF.Log(Float(i),8.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_8 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 8 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_10 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 10.0**(Float(j)*EF.Log(Float(i),10.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_10 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 10 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_16 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 16.0**(Float(j)*EF.Log(Float(i),16.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_16 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 16 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- end loop;
- end loop;
- end;
-
- -- Reset Flags.
- Incorrect_Inverse_Base_e := False;
- Incorrect_Inverse_Base_2 := False;
- Incorrect_Inverse_Base_8 := False;
- Incorrect_Inverse_Base_10 := False;
- Incorrect_Inverse_Base_16 := False;
-
-
- -- Testing of Exp Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that the result of the Exp Function, when provided an X
- -- parameter value of 0.0, is 1.0.
-
- if GEF.Exp(X => 0.0) /= 1.0 or
- EF.Exp(0.0) /= 1.0
- then
- Report.Failed("Incorrect result returned by Function Exp when " &
- "given a parameter value of 0.0");
- end if;
-
-
- -- Check that the Exp Function provides correct results when provided
- -- a variety of input parameter values.
-
- if not Result_Within_Range(GEF.Exp(0.001), 1.01, 0.01) or
- not Result_Within_Range( EF.Exp(0.1), 1.11, 0.01) or
- not Result_Within_Range(GEF.Exp(1.2697), 3.56, 0.01) or
- not Result_Within_Range( EF.Exp(3.2525), 25.9, 0.1) or
- not Result_Within_Range(GEF.Exp(-0.2198), 0.803, 0.001) or
- not Result_Within_Range( EF.Exp(-1.6621), 0.190, 0.001) or
- not Result_Within_Range(GEF.Exp(-2.3888), 0.092, 0.001) or
- not Result_Within_Range( EF.Exp(-5.4415), 0.004, 0.001)
- then
- Report.Failed("Incorrect result from Function Exp when provided " &
- "a variety of input parameter values");
- end if;
-
- -- Use the following loops to check for internal consistency between
- -- inverse functions.
-
- Arg := 0.01;
- while Arg < 10.0 loop
- if not Incorrect_Inverse_Base_e and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- e**(Arg*EF.Log(Arg)),
- 0.001)
- then
- Incorrect_Inverse_Base_e := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base e");
- end if;
- if not Incorrect_Inverse_Base_2 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 2.0**(Arg*EF.Log(Arg,2.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_2 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 2");
- end if;
- if not Incorrect_Inverse_Base_8 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 8.0**(Arg*EF.Log(Arg,8.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_8 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 8");
- end if;
- if not Incorrect_Inverse_Base_10 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 10.0**(Arg*EF.Log(Arg,10.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_10 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 10");
- end if;
- if not Incorrect_Inverse_Base_16 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 16.0**(Arg*EF.Log(Arg,16.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_16 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 16");
- end if;
- Arg := Arg + 0.01;
- end loop;
-
-
- -- Testing of Sqrt Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Sqrt Function when
- -- the value of the input parameter X is negative.
-
- begin
- Float_Result := EF.Sqrt(X => -FXA5A00.Small);
- Report.Failed("Argument_Error not raised by Function Sqrt " &
- "when provided a small negative input parameter " &
- "value");
- Dont_Optimize_Float(Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Sqrt " &
- "when provided a small negative input parameter " &
- "value");
- end;
-
- begin
- New_Float_Result := GEF.Sqrt(X => -64.0);
- Report.Failed("Argument_Error not raised by Function Sqrt " &
- "when provided a large negative input parameter " &
- "value");
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Sqrt " &
- "when provided a large negative input parameter " &
- "value");
- end;
-
-
- -- Check that the Sqrt Function, when given an X parameter value of 0.0,
- -- returns a result of 0.0.
-
- if GEF.Sqrt(X => 0.0) /= 0.0 or
- EF.Sqrt(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "an input parameter value of 0.0");
- end if;
-
-
- -- Check that the Sqrt Function, when given an X parameter input value
- -- of 1.0, returns a result of 1.0.
-
- if GEF.Sqrt(X => 1.0) /= 1.0 or
- EF.Sqrt(1.0) /= 1.0
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "an input parameter value of 1.0");
- end if;
-
-
- -- Check that the Sqrt Function provides correct results when provided
- -- a variety of input parameter values.
-
- if not FXA5A00.Result_Within_Range(GEF.Sqrt(0.0327), 0.181, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(0.1808), 0.425, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Sqrt(1.0556), 1.03, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(32.8208), 5.73, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(27851.0), 166.9, 0.1) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(61203.4), 247.4, 0.1) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(655891.0), 809.9, 0.1)
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "a variety of input parameter values");
- end if;
-
- -- Check internal consistency between functions.
-
- Arg := 0.01;
- while Arg < 10.0 loop
- if not Flag_1 and
- not FXA5A00.Result_Within_Range(Arg,
- EF.Sqrt(Arg)*EF.Sqrt(Arg),
- 0.01)
- then
- Report.Failed("Inconsistency found in Case 1");
- Flag_1 := True;
- end if;
- if not Flag_2 and
- not FXA5A00.Result_Within_Range(Arg, EF.Sqrt(Arg)**2.0, 0.01)
- then
- Report.Failed("Inconsistency found in Case 2");
- Flag_2 := True;
- end if;
- if not Flag_3 and
- not FXA5A00.Result_Within_Range(EF.Log(Arg),
- EF.Log(Sqrt(Arg)**2.0), 0.01)
- then
- Report.Failed("Inconsistency found in Case 3");
- Flag_3 := True;
- end if;
- if not Flag_4 and
- not FXA5A00.Result_Within_Range(EF.Log(Arg),
- 2.00*EF.Log(EF.Sqrt(Arg)),
- 0.01)
- then
- Report.Failed("Inconsistency found in Case 4");
- Flag_4 := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A10;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a
deleted file mode 100644
index 16f3075..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXA8001.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 all elements to be transferred to a sequential file of
--- mode Append_File will be placed following the last element currently
--- in the file.
--- Check that it is possible to append data to a file that has been
--- previously appended to.
--- Check that the predefined procedure Write will place an element after
--- the last element in the file in mode Append_File.
---
--- TEST DESCRIPTION:
--- This test implements a sequential file system that has the capability
--- to store data records at the end of a file. Initially, the file is
--- opened with mode Out_File, and data is written to the file. The file
--- is closed, then reopened with mode Append_File. An additional record
--- is written, and again the file is closed. The file is then reopened,
--- again with mode Append_File, and another record is written to the
--- file.
--- The file is closed again, the reopened with mode In_File, and the data
--- in the file is read and checked for proper ordering within the file.
---
--- An expected common usage of Append_File mode would be in the opening
--- of a file that currently contains data. Likewise, the reopening of
--- files in Append_Mode that have been previously appended to for the
--- addition of more data would be frequently encountered. This test
--- attempts to simulate both situations. (Of course, in an actual user
--- environment, the open/write/close processing would be performed using
--- looping structures, rather than the straight-line processing displayed
--- here.)
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Sequential_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Sequential_IO;
-with Report;
-
-procedure CXA8001 is
-
- -- Declare data types and objects to be stored in the file.
- subtype Name_Type is String (1 .. 10);
- type Tickets is range 0 .. 1000;
-
- type Order_Type is record
- Name : Name_Type;
- No_of_Tickets : Tickets;
- end record;
-
- package Order_IO is new Sequential_IO (Order_Type); -- Declare Seq_IO
- -- package,
- Order_File : Order_IO.File_Type; -- and file object.
- Order_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXA8001" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXA8001", "Check that all elements to be transferred to a " &
- "sequential file of mode Append_File will be " &
- "placed following the last element currently " &
- "in the file");
-
- Test_for_Sequential_IO_Support:
- begin
-
- -- An implementation that does not support Sequential_IO in a particular
- -- environment will raise Use_Error or Name_Error on calls to various
- -- Sequential_IO operations. This block statement encloses a call to
- -- Create, which should produce an exception in a non-supportive
- -- environment. These exceptions will be handled to produce a
- -- Not_Applicable result.
-
- Order_IO.Create (File => Order_File, -- Create Sequential_IO file
- Mode => Order_IO.Out_File, -- with mode Out_File.
- Name => Order_Filename);
-
- exception
-
- when Order_IO.Use_Error | Order_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Sequential_IO" );
- raise Incomplete;
-
- end Test_for_Sequential_IO_Support;
-
- Operational_Test_Block:
- declare
- -- Assign values into the component fields of the data objects.
- Buyer_1 : constant Order_Type := ("John Smith", 3);
- Buyer_2 : constant Order_Type :=
- (Name => "Jane Jones", No_of_Tickets => 2);
- Buyer_3 : Order_Type := ("Mike Brown", 5);
-
- begin
- Order_IO.Write (File => Order_File, -- Write initial data item
- Item => Buyer_1); -- to file.
-
- Order_IO.Close (File => Order_File); -- Close file.
-
- --
- -- Enter additional data records into the file. (Append to a file of
- -- previous mode Out_File).
- --
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.Append_File, -- with mode Append_File.
- Order_Filename);
-
- Order_IO.Write (Order_File, Buyer_2); -- Write second data item
- -- to file.
- Order_IO.Close (File => Order_File); -- Close file.
-
- -- Check to determine whether file is actually closed.
- begin
- Order_IO.Write (Order_File, Buyer_2);
- Report.Failed("Exception not raised on Write to Closed file");
- exception
- when Order_IO.Status_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception on Write to Closed file");
- end;
-
- --
- -- The following code segment demonstrates appending data to a file
- -- that has been previously appended to.
- --
-
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.Append_File, -- with mode Append_File.
- Order_Filename );
-
- Order_IO.Write (Order_File, Buyer_3); -- Write third data item
- -- to file.
- Order_IO.Close (File => Order_File); -- Close file.
-
-
- Test_Verification_Block:
- declare
- TC_Order1, TC_Order2, TC_Order3 : Order_Type;
- begin
-
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.In_File, -- with mode In_File.
- Order_Filename );
-
- Order_IO.Read (File => Order_File, -- Read records from file.
- Item => TC_Order1);
- Order_IO.Read (Order_File, TC_Order2);
- Order_IO.Read (Order_File, TC_Order3);
-
- -- Compare the contents of each with the individual data items.
- -- If items read from file do not match the items placed into
- -- the file, in the appropriate order, then fail.
-
- if ((TC_Order1 /= Buyer_1) or
- (TC_Order2.Name /= Buyer_2.Name) or
- (TC_Order2.No_of_Tickets /= Buyer_2.No_of_Tickets) or
- not ((TC_Order3.Name = "Mike Brown") and
- (TC_Order3.No_of_Tickets = 5))) then
- Report.Failed ("Incorrect appending of record data in file");
- end if;
-
- -- Check to determine that no more than three data records were
- -- actually written to the file.
- if not Order_IO.End_Of_File (Order_File) then
- Report.Failed("File not empty after three reads");
- end if;
-
- exception
-
- when Order_IO.End_Error => -- If three items not in
- -- file (data overwritten),
- -- then fail.
- Report.Failed ("Incorrect number of record elements in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed("Exception raised during Sequential_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Check that file is open prior to deleting it.
- if Order_IO.Is_Open(Order_File) then
- Order_IO.Delete (Order_File);
- else
- Order_IO.Open(Order_File, Order_IO.In_File, Order_Filename);
- Order_IO.Delete (Order_File);
- end if;
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Sequential_IO" );
-
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA8001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a
deleted file mode 100644
index 8670e98..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a
+++ /dev/null
@@ -1,285 +0,0 @@
--- CXA8002.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 resetting a file using mode Append_File allows for the
--- writing of elements to the file starting after the last element in
--- the file.
--- Check that the result of function Name can be used on a subsequent
--- reopen of the file.
--- Check that a mode change occurs on reset of a file to/from mode
--- Append_File.
---
--- TEST DESCRIPTION:
--- This test simulates the read/write of data from/to an individual
--- sequential file. New data can be appended to the end of the existing
--- file, and the same file can be reset to allow reading of data from
--- the file. This process can occur multiple times.
--- When the mode of the file is changed with a Reset, the current mode
--- value assigned to the file is checked using the result of function
--- Mode. This, in conjunction with the read/write operations, verifies
--- that a mode change has taken place on Reset.
---
--- An expected common usage of the scenarios found in this test would
--- be a case where a single data file is kept open continuously, being
--- reset for read/append of data. For systems that do not support a
--- direct form of I/O, this would allow for efficient use of a sequential
--- I/O file.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Sequential_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Feb 97 PWB.CTA Fixed handling for file non-support and Reset
--- non-support.
---!
-
-with Sequential_IO;
-with Report;
-
-procedure CXA8002 is
- subtype Employee_Data is String (1 .. 11);
- package Data_IO is new Sequential_IO (Employee_Data);
-
- Employee_Data_File : Data_IO.File_Type;
- Employee_Filename : constant String :=
- Report.Legal_File_Name (Nam => "CXA8002");
-
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXA8002", "Check that resetting a file using mode " &
- "Append_File allows for the writing of " &
- "elements to the file starting after the " &
- "last element in the file");
-
- Test_for_Sequential_IO_Support:
- begin
-
- -- An implementation that does not support Sequential_IO in a particular
- -- environment will raise Use_Error or Name_Error on calls to various
- -- Sequential_IO operations. This block statement encloses a call to
- -- Create, which should produce an exception in a non-supportive
- -- environment. These exceptions will be handled to produce a
- -- Not_Applicable result.
-
- Data_IO.Create (File => Employee_Data_File, -- Create file in
- Mode => Data_IO.Append_File, -- mode Append_File.
- Name => Employee_Filename);
-
- --
- -- The following portion of code demonstrates the fact that a sequential
- -- file can be created in Append_File mode, and that data can be written
- -- to the file.
- --
-
- exception
- when Data_IO.Use_Error | Data_IO.Name_Error =>
- Report.Not_Applicable
- ( "Sequential files not supported - Create as Append_File");
- raise Incomplete;
- end Test_for_Sequential_IO_Support;
- Operational_Test_Block:
- declare
- Blank_Data : constant Employee_Data := " ";
- Employee_1 : constant Employee_Data := "123-45-6789";
- Employee_2 : Employee_Data := "987-65-4321";
-
- -- Note: Artificial numerical data chosen above to prevent any
- -- unintended similarity with persons alive or dead.
-
- TC_Employee_Data : Employee_Data := Blank_Data;
-
-
- function TC_Mode_Selection (Selector : Integer)
- return Data_IO.File_Mode is
- begin
- case Report.Ident_Int(Selector) is
- when 1 => return Data_IO.In_File;
- when 2 => return Data_IO.Out_File;
- when others => return Data_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- Employee_Filename : constant String := -- Use function Name to
- Data_IO.Name (File => Employee_Data_File); -- store filename in
- -- string variable.
- begin
-
- Data_IO.Write (File => Employee_Data_File, -- Write initial data
- Item => Employee_1); -- entry to file.
-
- --
- -- The following portion of code demonstrates that a sequential file
- -- can be reset to various file modes, including Append_File mode,
- -- allowing data to be added to the end of the file.
- --
- begin
- Data_IO.Reset (File => Employee_Data_File, -- Reset file with
- Mode => Data_IO.In_File); -- mode In_File.
- exception
- when Data_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to In_File not supported for Sequential_IO");
- raise Incomplete;
- when others =>
- Report.Failed
- ("Unexpected exception on Reset to In_File (Sequential_IO)");
- raise Incomplete;
- end;
- if Data_IO."="(Data_IO.Mode (Employee_Data_File),
- TC_Mode_Selection (1)) then -- Compare In_File mode
- -- Reset successful,
- Data_IO.Read (File => Employee_Data_File, -- now verify file data.
- Item => TC_Employee_Data);
-
- if ((TC_Employee_Data (1 .. 7) /= "123-45-") or
- (TC_Employee_Data (5 .. 11) /= "45-6789")) then
- Report.Failed ("Data read error");
- end if;
-
- else
- Report.Failed ("File mode not changed by Reset");
- end if;
-
- --
- -- Simulate appending data to a file that has previously been written
- -- to and read from.
- --
- begin
- Data_IO.Reset (File => Employee_Data_File, -- Reset file with
- Mode => Data_IO.Append_File); -- mode Append_File.
- exception
- when Data_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to Append_File not supported for Sequential_IO");
- raise Incomplete;
- when others =>
- Report.Failed
- ("Unexpected exception on Reset to Append_File (Sequential_IO)");
- raise Incomplete;
- end;
-
- if Data_IO.Is_Open (Employee_Data_File) then -- File remains open
- -- following Reset to
- -- Append_File mode?
-
- if Data_IO."=" (Data_IO.Mode (Employee_Data_File),
- TC_Mode_Selection (3)) then -- Compare to
- -- Append_File mode.
- Data_IO.Write (File => Employee_Data_File, -- Write additional
- Item => Employee_2); -- data to file.
- else
- Report.Failed ("File mode not changed by Reset");
- end if;
-
- else
- Report.Failed
- ("File status not Open following Reset to Append mode");
- end if;
-
- Data_IO.Close (Employee_Data_File);
-
-
- Test_Verification_Block:
- begin
-
- Data_IO.Open (File => Employee_Data_File, -- Reopen file, using
- Mode => Data_IO.In_File, -- previous result of
- Name => Employee_Filename); -- function Name.
-
- TC_Employee_Data := Blank_Data; -- Clear record field.
- Data_IO.Read (Employee_Data_File, -- Read first record,
- TC_Employee_Data); -- check ordering of
- -- records.
-
- if not ((TC_Employee_Data (1 .. 3) = "123") and then
- (TC_Employee_Data (4 .. 11) = "-45-6789")) then
- Report.Failed ("Data read error - first record");
- end if;
-
- TC_Employee_Data := Blank_Data; -- Clear record field.
- Data_IO.Read (Employee_Data_File, -- Read second record,
- TC_Employee_Data); -- check for ordering of
- -- records.
-
- if ((TC_Employee_Data (1 .. 6) /= "987-65") or else
- not (TC_Employee_Data (3 .. 11) = "7-65-4321")) then
- Report.Failed ("Data read error - second record");
- end if;
-
- -- Check that only two items were written to the file.
- if not Data_IO.End_Of_File(Employee_Data_File) then
- Report.Failed("Incorrect number of records in file");
- end if;
-
- exception
-
- when Data_IO.End_Error => -- If two items not in
- -- file (data overwritten),
- -- then fail.
- Report.Failed ("Incorrect number of record elements in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed("Exception raised during Sequential_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Check that file is open prior to deleting it.
- if Data_IO.Is_Open(Employee_Data_File) then
- Data_IO.Delete (Employee_Data_File);
- else
- Data_IO.Open(Employee_Data_File,
- Data_IO.In_File,
- Employee_Filename);
- Data_IO.Delete (Employee_Data_File);
- end if;
- exception
- when others =>
- Report.Failed ("Sequential_IO Delete not properly supported");
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ("Unexpected exception");
- Report.Result;
-end CXA8002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a
deleted file mode 100644
index cf9b5e0..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a
+++ /dev/null
@@ -1,214 +0,0 @@
--- CXA8003.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 Append_File mode has not been added to package Direct_IO.
---
--- TEST DESCRIPTION:
--- This test uses a procedure to change the mode of an existing Direct_IO
--- file. The file descriptor is passed as a parameter, along with a
--- numeric indicator for the new mode. Based on the numeric parameter,
--- a Direct_IO.Reset is performed using a File_Mode'Value transformation
--- of a string constant into a File_Mode value. An attempt to reset a
--- Direct_IO file to mode Append_File should cause an Constraint_Error
--- to be raised, as Append_File mode has not been added to Direct_IO in
--- Ada 9X.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations supporting Direct_IO
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Feb 97 PWB.CTA Allowed for non-support of Reset for certain
--- modes.
---!
-
-with Direct_IO;
-with Report;
-
-procedure CXA8003 is
- Incomplete : exception;
- begin
-
- Report.Test ("CXA8003", "Check that Append_File mode has not " &
- "been added to package Direct_IO");
-
- Test_for_Direct_IO_Support:
- declare
-
- subtype String_Data_Type is String (1 .. 20);
- type Numeric_Data_Type is range 1 .. 512;
- type Composite_Data_Type is array (1 .. 3) of String_Data_Type;
-
- type File_Data_Type is record
- Data_Field_1 : String_Data_Type;
- Data_Field_2 : Numeric_Data_Type;
- Data_Field_3 : Composite_Data_Type;
- end record;
-
- package Dir_IO is new Direct_IO (File_Data_Type);
-
- Data_File : Dir_IO.File_Type;
- Dir_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- An application creates a text file with mode Out_File.
- -- Use_Error will be raised if Direct_IO operations or external
- -- files are not supported.
-
- Dir_IO.Create (Data_File,
- Dir_IO.Out_File,
- Dir_Filename);
-
- Change_File_Mode:
- declare
-
- TC_Append_Test_Executed : Boolean := False;
-
- type Mode_Selection_Type is ( A, I, IO, O );
-
-
- procedure Change_Mode (File : in out Dir_IO.File_Type;
- To : in Mode_Selection_Type) is
- begin
- case To is
- when A =>
- TC_Append_Test_Executed := True;
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Append_File"));
- when I =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("In_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to In_File not supported: Direct_IO");
- raise Incomplete;
- end;
- when IO =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Inout_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to InOut_File not supported: Direct_IO");
- raise Incomplete;
- end;
- when O =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Out_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to Out_File not supported: Direct_IO");
- raise Incomplete;
- end;
- end case;
- end Change_Mode;
-
-
- begin
-
- -- At some point in the processing, the application may call a
- -- procedure to change the mode of the file (perhaps for
- -- additional data entry, data verification, etc.). It is at
- -- this point that a use of Append_File mode for a Direct_IO
- -- file would cause an exception.
-
- for I in reverse Mode_Selection_Type loop
- Change_Mode (Data_File, I);
- Report.Comment
- ("Mode changed to " &
- Dir_IO.File_Mode'Image (Dir_IO.Mode (Data_File)));
- end loop;
-
- Report.Failed("No error raised on change to Append_File mode");
-
- exception
-
- -- A handler has been provided in the application, which
- -- handles the constraint error, allowing processing to
- -- continue.
-
- when Constraint_Error =>
-
- if TC_Append_Test_Executed then
- Report.Comment ("Constraint_Error correctly raised on " &
- "attempted Append_File mode selection " &
- "for a Direct_IO file");
- else
- Report.Failed ("Append test was not executed");
- end if;
-
- when Incomplete => raise;
-
- when others => Report.Failed ("Unexpected exception raised");
-
- end Change_File_Mode;
-
- Final_Block:
- begin
- if Dir_IO.Is_Open (Data_File) then
- Dir_IO.Delete (Data_File);
- else
- Dir_IO.Open (Data_File, Dir_IO.In_File, Dir_Filename);
- Dir_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ("Delete not properly supported: Direct_IO");
- end Final_Block;
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the
- -- specified mode, the environment does not support Direct_IO
- -- operations, the following handlers are included:
-
- when Dir_IO.Name_Error =>
- Report.Not_Applicable("Name_Error raised on Direct IO Create");
-
- when Dir_IO.Use_Error =>
- Report.Not_Applicable("Use_Error raised on Direct IO Create");
-
- when others =>
- Report.Failed
- ("Unexpected exception raised on Direct IO Create");
-
- end Test_for_Direct_IO_Support;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
-
-end CXA8003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a
deleted file mode 100644
index 4fe9c35..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a
+++ /dev/null
@@ -1,287 +0,0 @@
--- CXA9001.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 operations defined in the generic package
--- Ada.Storage_IO provide the ability to store and retrieve objects
--- which may include implicit levels of indirection in their
--- implementation, from an in-memory buffer.
---
--- TEST DESCRIPTION:
--- The following scenario demonstrates how an object of a type with
--- (potential) levels of indirection (based on the implementation)
--- can be "flattened" and written/read to/from a Direct_IO file.
--- In this small example, we have attempted to simulate the situation
--- where two independent programs are using a particular Direct_IO file,
--- one writing data to the file, and the second program reading that file.
--- The Storage_IO Read and Write procedures are used to "flatten"
--- and reconstruct objects of the record type.
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations capable of supporting external
--- Direct_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Jun 95 SAIC Modified to constrain type used with Storage_IO.
--- 20 Nov 95 SAIC Corrected and enhanced for ACVC 2.0.1.
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Report;
-with Ada.Storage_IO;
-with Ada.Direct_IO;
-
-procedure CXA9001 is
- package Dir_IO is new Ada.Direct_IO (Integer);
- Test_File : Dir_IO.File_Type;
- Incomplete : exception;
-begin
-
- Report.Test ("CXA9001", "Check that the operations defined in the " &
- "generic package Ada.Storage_IO provide the " &
- "ability to store and retrieve objects which " &
- "may include implicit levels of indirection in " &
- "their implementation, from an in-memory buffer");
-
-
- Test_For_Direct_IO_Support:
- begin
-
- -- The following Create does not have any bearing on the test scenario,
- -- but is included to check that the implementation supports Direct_IO
- -- files. An exception on this Create statement will raise a Name_Error
- -- or Use_Error, which will be handled to produce a Not_Applicable
- -- result. If created, the file is immediately deleted, as it is not
- -- needed for the program scenario.
-
- Dir_IO.Create (Test_File, Dir_IO.Out_File, Report.Legal_File_Name(1));
-
- exception
-
- when Dir_IO.Use_Error | Dir_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Direct_IO" );
- raise Incomplete;
-
- end Test_for_Direct_IO_Support;
-
- Deletion1:
- begin
- Dir_IO.Delete (Test_File);
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Direct_IO - 1" );
- end Deletion1;
-
-
- Test_Block:
- declare
-
- The_Filename : constant String := Report.Legal_File_Name(2);
-
- -- The following type is the basic unit used in this test. It is
- -- incorporated into the definition of the Unit_Array_Type.
-
- type Unit_Type is
- record
- Position : Natural := 19;
- String_Value : String (1..9) := (others => 'X');
- end record;
-
- TC_Size : Natural := Natural'First;
-
- procedure Data_Storage (Number_Of_Units : in Natural;
- Result : out Natural) is
-
- -- Type based on input parameter. Uses type Unit_Type
- -- as the array element.
- type Unit_Array_Type is array (1..Number_Of_Units)
- of Unit_Type;
-
- -- This type definition is the ultimate storage type used
- -- in this test; uses type Unit_Array_Type as a record
- -- component field.
- -- This record type contains a component that is an array of
- -- records, with each of these records containing a Natural
- -- and a String value (i.e., a record containing an array of
- -- records).
-
- type Data_Storage_Type is
- record
- Data_Value : Natural := Number_Of_Units;
- Unit_Array : Unit_Array_Type;
- end record;
-
- -- The instantiation of the following generic package is a
- -- central point in this test. Storage_IO is instantiated for
- -- a specific data type, and will be used to "flatten" objects
- -- of that type into buffers. Direct_IO is instantiated for
- -- these Storage_IO buffers.
-
- package Flat_Storage_IO is
- new Ada.Storage_IO (Data_Storage_Type);
- package Buffer_IO is
- new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type);
-
- Buffer_File : Buffer_IO.File_Type;
- Outbound_Buffer : Flat_Storage_IO.Buffer_Type;
- Storage_Item : Data_Storage_Type;
-
- begin -- procedure Data_Storage
-
- Buffer_IO.Create (Buffer_File,
- Buffer_IO.Out_File,
- The_Filename);
-
- Flat_Storage_IO.Write (Buffer => Outbound_Buffer,
- Item => Storage_Item);
-
- -- At this point, any levels of indirection have been removed
- -- by the Storage_IO procedure, and the buffered data can be
- -- written to a file.
-
- Buffer_IO.Write (Buffer_File, Outbound_Buffer);
- Buffer_IO.Close (Buffer_File);
- Result := Storage_Item.Unit_Array'Last + -- 5 +
- Storage_Item.Unit_Array -- 9
- (Storage_Item.Unit_Array'First).String_Value'Length;
-
- exception
- when others =>
- Report.Failed ("Data storage error");
- if Buffer_IO.Is_Open (Buffer_File) then
- Buffer_IO.Close (Buffer_File);
- end if;
- end Data_Storage;
-
- procedure Data_Retrieval (Number_Of_Units : in Natural;
- Result : out Natural) is
- type Unit_Array_Type is array (1..Number_Of_Units)
- of Unit_Type;
-
- type Data_Storage_Type is
- record
- Data_Value : Natural := Number_Of_Units;
- Unit_Array : Unit_Array_Type;
- end record;
-
- package Flat_Storage_IO is
- new Ada.Storage_IO (Data_Storage_Type);
- package Reader_IO is
- new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type);
-
- Reader_File : Reader_IO.File_Type;
- Inbound_Buffer : Flat_Storage_IO.Buffer_Type;
- Storage_Item : Data_Storage_Type;
- TC_Item : Data_Storage_Type;
-
- begin -- procedure Data_Retrieval
-
- Reader_IO.Open (Reader_File, Reader_IO.In_File, The_Filename);
- Reader_IO.Read (Reader_File, Inbound_Buffer);
-
- Flat_Storage_IO.Read (Inbound_Buffer, Storage_Item);
-
- -- Validate the reconstructed value against an "unflattened"
- -- value.
-
- if Storage_Item.Data_Value /= TC_Item.Data_Value
- then
- Report.Failed ("Data_Retrieval Error - 1");
- end if;
-
- for i in 1..Number_Of_Units loop
- if Storage_Item.Unit_Array(i).String_Value'Length /=
- TC_Item.Unit_Array(i).String_Value'Length or
- Storage_Item.Unit_Array(i).Position /=
- TC_Item.Unit_Array(i).Position or
- Storage_Item.Unit_Array(i).String_Value /=
- TC_Item.Unit_Array(i).String_Value
- then
- Report.Failed ("Data_Retrieval Error - 2");
- end if;
- end loop;
-
- Result := Storage_Item.Unit_Array'Last + -- 5 +
- Storage_Item.Unit_Array -- 9
- (Storage_Item.Unit_Array'First).String_Value'Length;
-
- if Reader_IO.Is_Open (Reader_File) then
- Reader_IO.Delete (Reader_File);
- else
- Reader_IO.Open (Reader_File,
- Reader_IO.In_File,
- The_Filename);
- Reader_IO.Delete (Reader_File);
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception raised in Data_Retrieval");
- if Reader_IO.Is_Open (Reader_File) then
- Reader_IO.Delete (Reader_File);
- else
- Reader_IO.Open (Reader_File,
- Reader_IO.In_File,
- The_Filename);
- Reader_IO.Delete (Reader_File);
- end if;
- end Data_Retrieval;
-
-
- begin -- Test_Block
-
- -- The number of Units is provided in this call to Data_Storage.
- Data_Storage (Number_Of_Units => Natural(Report.Ident_Int(5)),
- Result => TC_Size);
-
- if TC_Size /= 14 then
- Report.Failed ("Data_Storage error in Data_Storage");
- end if;
-
- Data_Retrieval (Number_Of_Units => Natural(Report.Ident_Int(5)),
- Result => TC_Size);
-
- if TC_Size /= 14 then
- Report.Failed ("Data retrieval error in Data_Retrieval");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA9001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a
deleted file mode 100644
index 415a566..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a
+++ /dev/null
@@ -1,482 +0,0 @@
--- CXA9002.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 operations defined in the generic package
--- Ada.Storage_IO provide the ability to store and retrieve objects
--- of tagged types from in-memory buffers.
---
--- TEST DESCRIPTION:
--- The following scenario demonstrates how objects of a tagged type,
--- extended types, and twice extended types can be written/read
--- to/from Direct_IO files. The Storage_IO subprograms, Read and Write,
--- demonstrated in this scenario, perform tag "fixing" prior to/following
--- transfer to the Direct_IO files.
--- This method is especially important for those implementations that
--- represent tags as pointers, or for cases where the tagged objects
--- are read in by a program other than the one that wrote them.
---
--- In this small example, we have attempted to simulate the situation
--- where two independent programs are using a series of Direct_IO files,
--- one writing data to the files, and the second program reading the
--- data from those files. Two procedures are defined, the first
--- simulating the program responsible for writing, the second simulating
--- a separate program opening and reading the data from the files.
---
--- The hierarchy of types used in this test can be displayed as follows:
---
--- Account_Type
--- / \
--- / \
--- / \
--- Cash_Account_Type Investment_Account_Type
--- / \
--- / \
--- / \
--- Checking_Account_Type Savings_Account_Type
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations capable of supporting external
--- Direct_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected incorrect prefix of 'Tag for ACVC 2.0.1,
--- and mode of files in Procedure Read_Data.
--- Added verification of objects reconstructed from
--- files.
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-package CXA9002_0 is
-
- type Investment_Type is (Stocks, Bonds, Mutual_Funds);
- type Savings_Type is (Standard, Business, Impound);
-
- type Account_Type is tagged
- record
- Num : String (1..3);
- end record;
-
- type Cash_Account_Type is new Account_Type with
- record
- Years_As_Customer : Natural := 1;
- end record;
-
- type Investment_Account_Type is new Account_Type with
- record
- Investment_Vehicle : Investment_Type := Stocks;
- end record;
-
- type Checking_Account_Type is new Cash_Account_Type with
- record
- Checks_Per_Year : Positive := 200;
- Interest_Bearing : Boolean := False;
- end record;
-
- type Savings_Account_Type is new Cash_Account_Type with
- record
- Kind : Savings_Type := Standard;
- end record;
-
-end CXA9002_0;
-
----
-
-with Report;
-with Ada.Storage_IO;
-with Ada.Direct_IO;
-with Ada.Tags;
-with CXA9002_0;
-
-procedure CXA9002 is
- package Dir_IO is new Ada.Direct_IO (Integer);
- Test_File : Dir_IO.File_Type;
- Incomplete : exception;
-begin
-
- Report.Test ("CXA9002", "Check that the operations defined in the " &
- "generic package Ada.Storage_IO provide the " &
- "ability to store and retrieve objects of " &
- "tagged types from in-memory buffers");
-
-
- Test_For_Direct_IO_Support:
- begin
-
- -- The following Create does not have any bearing on the test scenario,
- -- but is included to check that the implementation supports Direct_IO
- -- files. An exception on this Create statement will raise a Name_Error
- -- or Use_Error, which will be handled to produce a Not_Applicable
- -- result. If created, the file is immediately deleted, as it is not
- -- needed for the program scenario.
-
- Dir_IO.Create (Test_File,
- Dir_IO.Out_File,
- Report.Legal_File_Name(1));
- exception
-
- when Dir_IO.Use_Error | Dir_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Direct_IO" );
- raise Incomplete;
-
- end Test_for_Direct_IO_Support;
-
- Deletion:
- begin
- Dir_IO.Delete (Test_File);
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Direct_IO" );
- end Deletion;
-
- Test_Block:
- declare
-
- use CXA9002_0;
-
- Acct_Filename : constant String := Report.Legal_File_Name(1);
- Cash_Filename : constant String := Report.Legal_File_Name(2);
- Inv_Filename : constant String := Report.Legal_File_Name(3);
- Chk_Filename : constant String := Report.Legal_File_Name(4);
- Sav_Filename : constant String := Report.Legal_File_Name(5);
-
- type Tag_Pointer_Type is access String;
-
- TC_Account_Type_Tag,
- TC_Cash_Account_Type_Tag,
- TC_Investment_Account_Type_Tag,
- TC_Checking_Account_Type_Tag,
- TC_Savings_Account_Type_Tag : Tag_Pointer_Type;
-
- TC_Account : Account_Type :=
- (Num => "123");
-
- TC_Cash_Account : Cash_Account_Type :=
- (Num => "234",
- Years_As_Customer => 3);
-
- TC_Investment_Account : Investment_Account_Type :=
- (Num => "456",
- Investment_Vehicle => Bonds);
-
- TC_Checking_Account : Checking_Account_Type :=
- (Num => "567",
- Years_As_Customer => 2,
- Checks_Per_Year => 300,
- Interest_Bearing => True);
-
- TC_Savings_Account : Savings_Account_Type :=
- (Num => "789",
- Years_As_Customer => 14,
- Kind => Business);
-
- procedure Buffer_Data is
-
- Account : Account_Type :=
- TC_Account;
- Cash_Account : Cash_Account_Type :=
- TC_Cash_Account;
- Investment_Account : Investment_Account_Type :=
- TC_Investment_Account;
- Checking_Account : Checking_Account_Type :=
- TC_Checking_Account;
- Savings_Account : Savings_Account_Type :=
- TC_Savings_Account;
-
- -- The instantiations below are a central point in this test.
- -- Storage_IO is instantiated for each of the specific tagged
- -- type. These instantiated packages will be used to compress
- -- tagged objects of these various types into buffers that will
- -- be written to the Direct_IO files declared below.
-
- package Acct_SIO is new Ada.Storage_IO (Account_Type);
- package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type);
- package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type);
- package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type);
- package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type);
-
- -- Direct_IO is instantiated for the buffer types defined in the
- -- instantiated Storage_IO packages.
-
- package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type);
- package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type);
- package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type);
- package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type);
- package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type);
-
- Acct_Buffer : Acct_SIO.Buffer_Type;
- Cash_Buffer : Cash_SIO.Buffer_Type;
- Inv_Buffer : Inv_SIO.Buffer_Type;
- Chk_Buffer : Chk_SIO.Buffer_Type;
- Sav_Buffer : Sav_SIO.Buffer_Type;
-
- Acct_File : Acct_DIO.File_Type;
- Cash_File : Cash_DIO.File_Type;
- Inv_File : Inv_DIO.File_Type;
- Chk_File : Chk_DIO.File_Type;
- Sav_File : Sav_DIO.File_Type;
-
- begin
-
- Acct_DIO.Create (Acct_File, Acct_DIO.Out_File, Acct_Filename);
- Cash_DIO.Create (Cash_File, Cash_DIO.Out_File, Cash_Filename);
- Inv_DIO.Create (Inv_File, Inv_DIO.Out_File, Inv_Filename);
- Chk_DIO.Create (Chk_File, Chk_DIO.Out_File, Chk_Filename);
- Sav_DIO.Create (Sav_File, Sav_DIO.Out_File, Sav_Filename);
-
- -- Store the tag values of the objects declared above for
- -- comparison with tag values of objects following processing.
-
- TC_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Account_Type'Tag));
-
- TC_Cash_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Cash_Account_Type'Tag));
-
- TC_Investment_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Investment_Account_Type'Tag));
-
- TC_Checking_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Checking_Account_Type'Tag));
-
- TC_Savings_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Savings_Account_Type'Tag));
-
- -- Prepare tagged data for writing to the Direct_IO files using
- -- Storage_IO procedure to place data in buffers.
-
- Acct_SIO.Write (Buffer => Acct_Buffer, Item => Account);
- Cash_SIO.Write (Cash_Buffer, Cash_Account);
- Inv_SIO.Write (Inv_Buffer, Item => Investment_Account);
- Chk_SIO.Write (Buffer => Chk_Buffer, Item => Checking_Account);
- Sav_SIO.Write (Sav_Buffer, Savings_Account);
-
- -- At this point, the data and associated tag values have been
- -- buffered by the Storage_IO procedure, and the buffered data
- -- can be written to the appropriate Direct_IO file.
-
- Acct_DIO.Write (File => Acct_File, Item => Acct_Buffer);
- Cash_DIO.Write (Cash_File, Cash_Buffer);
- Inv_DIO.Write (Inv_File, Item => Inv_Buffer);
- Chk_DIO.Write (File => Chk_File, Item =>Chk_Buffer);
- Sav_DIO.Write (Sav_File, Sav_Buffer);
-
- -- Close all Direct_IO files.
-
- Acct_DIO.Close (Acct_File);
- Cash_DIO.Close (Cash_File);
- Inv_DIO.Close (Inv_File);
- Chk_DIO.Close (Chk_File);
- Sav_DIO.Close (Sav_File);
-
- exception
- when others => Report.Failed("Exception raised in Buffer_Data");
- end Buffer_Data;
-
- procedure Read_Data is
-
- Account : Account_Type;
- Cash_Account : Cash_Account_Type;
- Investment_Account : Investment_Account_Type;
- Checking_Account : Checking_Account_Type;
- Savings_Account : Savings_Account_Type;
-
- -- Storage_IO is instantiated for each of the specific tagged
- -- type.
-
- package Acct_SIO is new Ada.Storage_IO (Account_Type);
- package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type);
- package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type);
- package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type);
- package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type);
-
- -- Direct_IO is instantiated for the buffer types defined in the
- -- instantiated Storage_IO packages.
-
- package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type);
- package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type);
- package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type);
- package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type);
- package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type);
-
- Acct_Buffer : Acct_SIO.Buffer_Type;
- Cash_Buffer : Cash_SIO.Buffer_Type;
- Inv_Buffer : Inv_SIO.Buffer_Type;
- Chk_Buffer : Chk_SIO.Buffer_Type;
- Sav_Buffer : Sav_SIO.Buffer_Type;
-
- Acct_File : Acct_DIO.File_Type;
- Cash_File : Cash_DIO.File_Type;
- Inv_File : Inv_DIO.File_Type;
- Chk_File : Chk_DIO.File_Type;
- Sav_File : Sav_DIO.File_Type;
-
- begin
-
- -- Open the Direct_IO files.
-
- Acct_DIO.Open (Acct_File, Acct_DIO.In_File, Acct_Filename);
- Cash_DIO.Open (Cash_File, Cash_DIO.In_File, Cash_Filename);
- Inv_DIO.Open (Inv_File, Inv_DIO.In_File, Inv_Filename);
- Chk_DIO.Open (Chk_File, Chk_DIO.In_File, Chk_Filename);
- Sav_DIO.Open (Sav_File, Sav_DIO.In_File, Sav_Filename);
-
- -- Read the buffer data from the files using Direct_IO.
-
- Acct_DIO.Read (File => Acct_File, Item => Acct_Buffer);
- Cash_DIO.Read (Cash_File, Cash_Buffer);
- Inv_DIO.Read (Inv_File, Item => Inv_Buffer);
- Chk_DIO.Read (File => Chk_File, Item =>Chk_Buffer);
- Sav_DIO.Read (Sav_File, Sav_Buffer);
-
- -- At this point, the data and associated tag values are stored
- -- in buffers. Use the Storage_IO procedure Read to recreate the
- -- tagged objects from the buffers.
-
- Acct_SIO.Read (Buffer => Acct_Buffer, Item => Account);
- Cash_SIO.Read (Cash_Buffer, Cash_Account);
- Inv_SIO.Read (Inv_Buffer, Item => Investment_Account);
- Chk_SIO.Read (Buffer => Chk_Buffer, Item => Checking_Account);
- Sav_SIO.Read (Sav_Buffer, Savings_Account);
-
- -- Delete all Direct_IO files.
-
- Acct_DIO.Delete (Acct_File);
- Cash_DIO.Delete (Cash_File);
- Inv_DIO.Delete (Inv_File);
- Chk_DIO.Delete (Chk_File);
- Sav_DIO.Delete (Sav_File);
-
- Data_Verification_Block:
- begin
-
- if Account /= TC_Account then
- Report.Failed("Incorrect Account object reconstructed");
- end if;
-
- if Cash_Account /= TC_Cash_Account then
- Report.Failed
- ("Incorrect Cash_Account object reconstructed");
- end if;
-
- if Investment_Account /= TC_Investment_Account then
- Report.Failed
- ("Incorrect Investment_Account object reconstructed");
- end if;
-
- if Checking_Account /= TC_Checking_Account then
- Report.Failed
- ("Incorrect Checking_Account object reconstructed");
- end if;
-
- if Savings_Account /= TC_Savings_Account then
- Report.Failed
- ("Incorrect Savings_Account object reconstructed");
- end if;
-
- exception
- when others =>
- Report.Failed
- ("Exception raised during Data_Verification Block");
- end Data_Verification_Block;
-
-
- -- To ensure that the tags of the values reconstructed by
- -- Storage_IO were properly preserved, object tag values following
- -- object reconstruction are compared with tag values of objects
- -- stored prior to processing.
-
- Tag_Verification_Block:
- begin
-
- if TC_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(Account_Type'Class(Account)'Tag)
- then
- Report.Failed("Incorrect Account tag");
- end if;
-
- if TC_Cash_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Cash_Account_Type'Class(Cash_Account)'Tag)
- then
- Report.Failed("Incorrect Cash_Account tag");
- end if;
-
- if TC_Investment_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Investment_Account_Type'Class(Investment_Account)'Tag)
- then
- Report.Failed("Incorrect Investment_Account tag");
- end if;
-
- if TC_Checking_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Checking_Account_Type'Class(Checking_Account)'Tag)
- then
- Report.Failed("Incorrect Checking_Account tag");
- end if;
-
- if TC_Savings_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Savings_Account_Type'Class(Savings_Account)'Tag)
- then
- Report.Failed("Incorrect Savings_Account tag");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception raised during tag evaluation");
- end Tag_Verification_Block;
-
- exception
- when others => Report.Failed ("Exception in Read_Data");
- end Read_Data;
-
- begin -- Test_Block
-
- -- Enter the data into the appropriate files.
- Buffer_Data;
-
- -- Reconstruct the data from files, and verify the results.
- Read_Data;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA9002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a
deleted file mode 100644
index 6c2af98..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a
+++ /dev/null
@@ -1,279 +0,0 @@
--- CXAA001.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 Line_Length and Page_Length maximums for a Text_IO
--- file of mode Append_File are initially zero (unbounded) after a
--- Create, Open, or Reset, and that these values can be modified using
--- the procedures Set_Line_Length and Set_Page_Length.
--- Check that setting the Line_Length and Page_Length attributes to zero
--- results in an unbounded Text_IO file.
--- Check that setting the line length when in Append_Mode doesn't
--- change the length of lines previously written to the Text_IO file.
---
--- TEST DESCRIPTION:
--- This test attempts to simulate a possible text processing environment.
--- String values, from a number of different string types, are written to
--- a Text_IO file. Prior to the writing of each, the line length is set
--- to the particular length of the data being written. In addition, the
--- default line and page lengths are checked, to determine whether they
--- are unbounded (length = 0) following a create, reset, or open of a
--- Text_IO file with mode Append_File.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA001 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA001" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA001","Check that the Line_Length and Page_Length " &
- "maximums for a Text_IO file of mode Append_File " &
- "are initially zero (unbounded) after a Create, " &
- "Open, or Reset, and that these values can be " &
- "modified using the procedures Set_Line_Length " &
- "and Set_Page_Length");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise an exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Append_File,
- Name => Data_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- subtype Confidential_Data_Type is string (1 .. 10);
- subtype Secret_Data_Type is string (1 .. 20);
- subtype Top_Secret_Data_Type is string (1 .. 30);
-
- Zero : constant Text_IO.Count := 0;
- Confidential_Data_Size : constant Text_IO.Count := 10;
- Secret_Data_Size : constant Text_IO.Count := 20;
- Top_Secret_Data_Size : constant Text_IO.Count := 30;
-
- -- The following generic procedure is designed to simulate a text
- -- processing environment where line and page sizes are set and
- -- verified prior to the writing of data to a file.
-
- generic
- Data_Size : Text_IO.Count;
- procedure Write_Data_To_File (Data_Item : in String);
-
- procedure Write_Data_To_File (Data_Item : in String) is
- use Text_IO; -- Used to provide visibility to the "/=" operator.
- begin
- if (Text_IO.Line_Length (Data_File) /= Zero) then -- Check default
- Report.Failed("Line not of unbounded length"); -- line length,
- elsif (Text_IO.Page_Length (Data_File) /= Zero) then -- default
- Report.Failed ("Page not of unbounded length"); -- page length.
- end if;
-
- Text_IO.Set_Line_Length (File => Data_File, -- Set the line
- To => Data_Size); -- length.
- Text_IO.Set_Page_Length (File => Data_File, -- Set the page
- To => Data_Size); -- length.
- -- Verify the lengths set.
- if (Integer(Text_IO.Line_Length (Data_File)) /=
- Report.Ident_Int(Integer(Data_Size))) then
- Report.Failed ("Line length not set to appropriate length");
- elsif (Integer(Text_IO.Page_Length (Data_File)) /=
- Report.Ident_Int(Integer(Data_Size))) then
- Report.Failed ("Page length not set to appropriate length");
- end if;
-
- Text_IO.Put_Line (File => Data_File, -- Write data to
- Item => Data_Item); -- file.
-
- end Write_Data_To_File;
-
- -- Instantiation for the three data types/sizes.
-
- procedure Write_Confidential_Data is
- new Write_Data_To_File (Data_Size => Confidential_Data_Size);
-
- procedure Write_Secret_Data is
- new Write_Data_To_File (Data_Size => Secret_Data_Size);
-
- procedure Write_Top_Secret_Data is
- new Write_Data_To_File (Data_Size => Top_Secret_Data_Size);
-
- Confidential_Item : Confidential_Data_Type := "Confidenti";
- Secret_Item : Secret_Data_Type := "Secret Data Values ";
- Top_Secret_Item : Top_Secret_Data_Type :=
- "Extremely Top Secret Data ";
-
- begin
-
- -- The following call simulates processing occurring after the create
- -- of a Text_IO file with mode Append_File.
-
- Write_Confidential_Data (Confidential_Item);
-
- -- The following call simulates processing occurring after the reset
- -- of a Text_IO file with mode Append_File.
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.Append_File); -- Reset to
- -- Append_File mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Write_Secret_Data (Data_Item => Secret_Item);
-
- Text_IO.Close (Data_File); -- Close file.
-
- -- The following processing simulates processing occurring after the
- -- opening of an existing file with mode Append_File.
-
- Text_IO.Open (Data_File, -- Open file in
- Text_IO.Append_File, -- Append_File mode.
- Data_Filename);
-
- Write_Top_Secret_Data (Top_Secret_Item);
-
- Test_Verification_Block:
- declare
- TC_String1,
- TC_String2,
- TC_String3 : String (1..80) := (others => ' ');
- TC_Length1,
- TC_Length2,
- TC_Length3 : Natural := 0;
- begin
-
- Reset2:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File); -- Reset for reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Text_IO.Get_Line (Data_File, TC_String1, TC_Length1);
- Text_IO.Get_Line (Data_File, TC_String2, TC_Length2);
- Text_IO.Get_Line (Data_File, TC_String3, TC_Length3);
-
- -- Verify that the line lengths of each line were accurate.
- -- Note: Each data line was written to the file after the
- -- particular line length had been set (to the data length).
-
- if not ((TC_Length1 = Natural(Confidential_Data_Size)) and
- (TC_Length2 = Natural(Secret_Data_Size)) and
- (TC_Length3 = Natural(Top_Secret_Data_Size))) then
- Report.Failed ("Inaccurate line lengths read from file");
- end if;
-
- -- Verify that the data read from the file are accurate.
-
- if (TC_String1(1..TC_Length1) /= Confidential_Item) or else
- (TC_String2(1..TC_Length2) /= Secret_Item) or else
- (TC_String3(1..TC_Length3) /= Top_Secret_Item) then
- Report.Failed ("Corrupted data items read from file");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Check that the file is open prior to deleting it.
- if Text_IO.Is_Open(Data_File) then
- Text_IO.Delete(Data_File);
- else
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete(Data_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a
deleted file mode 100644
index 953d33f..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CXAA002.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 procedures New_Page, Set_Line, Set_Col, and New_Line
--- subprograms perform properly on a text file created with mode
--- Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the creation of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file created with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files created with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files created with
--- mode Append_File.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files created with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Append_File mode. Various
--- calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
-
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA002 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA002" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA002", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "created with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Append_File,
- Name => Data_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Default_Position : constant Text_IO.Positive_Count := 1;
- Section_Header : constant String := "VII. ";
- Appendix_Title : constant String := "Appendix A";
- Appendix_Content : constant String := "TBD";
-
- -- The following procedure simulates the addition of an Appendix page
- -- to an existing text file.
- procedure Position_Appendix_Text is
- use Text_IO; -- To provide visibility to the "/=" operator.
- begin
-
- -- Test control code.
- -- Verify initial page, line, column number.
- if "/="(Text_IO.Page (Data_File), Default_Position) then
- Report.Failed ("Incorrect default page number");
- end if;
- if Text_IO.Line (Data_File) /= Default_Position then
- Report.Failed ("Incorrect default line number");
- end if;
- if "/="(Text_IO.Col (Data_File), Default_Position) then
- Report.Failed ("Incorrect default column number");
- end if;
-
- -- Simulated usage code.
- -- Set new page/line positions.
- Text_IO.Put_Line
- (Data_File, "Add some optional data to the file here");
- Text_IO.New_Page (Data_File);
- Text_IO.New_Line (File => Data_File, Spacing => 2);
-
- -- Test control code.
- if Integer(Text_IO.Page (Data_File)) /= Report.Ident_Int(2) or else
- Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(3) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code.
- Text_IO.Put (Data_File, Section_Header); -- Position title
- Text_IO.Put_Line (Data_File, Appendix_Title); -- of Appendix.
-
- Text_IO.Set_Line (File => Data_File, To => 5); -- Set new
- Text_IO.Set_Col (File => Data_File, To => 8); -- position.
-
- -- Test control code.
- if (Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(5)) or
- (Integer(Text_IO.Col (Data_File)) /= Report.Ident_Int(8)) then
- Report.Failed ("Incorrect results from line/column positioning");
- end if;
-
- -- Simulated usage code. -- Position
- Text_IO.Put_Line (Data_File, Appendix_Content); -- content of
- -- Appendix.
- end Position_Appendix_Text;
-
- begin
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment:
- -- A document is created/modified/edited Then...
- -- Text is to be appended to the document.
- -- A procedure is called to perform that operation.
- -- The position on the appended page is set, verified, and text is
- -- appended to the existing file.
- --
- -- Note: The text file has been originally created in Append_File
- -- mode, and has not been closed prior to this processing.
-
- Position_Appendix_Text;
-
- Test_Verification_Block:
- declare
- TC_Page,
- TC_Line,
- TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- Blanks : constant String := " ";
- TC_String : String (1 .. 17) := Blanks;
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Text_IO.Skip_Page (Data_File);
- -- Loop to the third line
- for I in 1 .. 3 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 16) or else -- Verify the title line.
- (TC_String (1..4) /= "VII.") or else
- (TC_String (3..16) /= ("I. " & Appendix_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
-
- TC_String := Blanks; -- Clear string.
- -- Loop to the fifth line
- for I in 4 .. 5 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 10) or -- Verify the contents.
- (TC_String (8..10) /= Appendix_Content) then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Data_File) then
- Text_IO.Delete(Data_File);
- else
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete(Data_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a
deleted file mode 100644
index c9580df..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXAA003.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 procedures New_Page, Set_Line, Set_Col, and New_Line
--- subprograms perform properly on a text file reset (from Out_File)
--- with mode Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the reset of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file reset with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files reset with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File. Check that Set_Line has no effect if the specified
--- line equals the current line.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Out_File mode,
--- and then reset to Append_File mode.
--- Various calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA003 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA003" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA003", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "reset with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Out_File,
- Name => Data_Filename);
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Text files not supported - Create as Out_File" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Default_Position : constant Text_IO.Positive_Count := 1;
-
- Section_Header : constant String := "IX. ";
- Glossary_Title : constant String := "GLOSSARY";
- Glossary_Content : constant String := "TBD";
-
- -- The following procedure simulates the addition of a Glossary page
- -- to an existing text file that has been reset with mode
- -- Append_File.
-
- procedure Position_Glossary_Text
- (The_File : in out Text_IO.File_Type) is
- use Text_IO; -- To provide visibility to the "/=" operator.
- begin
-
- -- Test control code.
- -- Verify initial page value.
- if (Text_IO.Page (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default page number");
- end if;
- -- Verify initial line number.
- if (Text_IO.Line (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default line number");
- end if;
- -- Verify initial column number.
- if (Text_IO.Col (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default column number");
- end if;
- -- Simulated usage code. Set new page/line positions.
- Text_IO.New_Page (The_File);
- Text_IO.New_Page (The_File);
- Text_IO.New_Line (File => The_File, Spacing => 1);
-
- -- Test control code.
- if (Integer(Text_IO.Page(The_File)) /=
- Report.Ident_Int(3)) or else
- (Integer(Text_IO.Line (The_File)) /=
- Report.Ident_Int(2)) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code. Position title of Glossary.
- Text_IO.Put (The_File, Section_Header);
- Text_IO.Put_Line (The_File, Glossary_Title);
- -- Set line to the current line.
- Text_IO.Set_Line (File => The_File, To => 3);
-
- -- Test control code.
- if (Integer(Text_IO.Page (The_File)) /= Report.Ident_Int(3)) or
- (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(3)) or
- (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(1)) then
- Report.Failed ("Set_Line failed for current line");
- end if;
-
- -- Simulated usage code.
- Text_IO.Set_Line (File => The_File, To => 4); -- Set new
- Text_IO.Set_Col (File => The_File, To => 10); -- position.
-
- -- Test control code.
- if (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(4)) or
- (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(10)) then
- Report.Failed
- ("Incorrect results from line/column positioning");
- end if;
-
- -- Simulated usage code. -- Position
- Text_IO.Put_Line (The_File, Glossary_Content); -- content of
- -- Glossary.
- end Position_Glossary_Text;
-
-
- begin
-
- -- In the scenario, data is added to the file here.
- Text_IO.Put_Line (File => Data_File, Item => "Some optional data");
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment. Text is to be appended to an
- -- existing document:
- -- The file is reset to append mode.
- -- A procedure is called to perform the positioning and placement
- -- of text.
- -- The position on the appended page is set, verified, and text is
- -- placed in the file.
- --
- -- Note: The text file has been originally created in Out_File
- -- mode, and has subsequently been reset to Append_File mode.
-
- Reset1:
- begin
- -- Reset has effect of calling New_Page.
- Text_IO.Reset (Data_File, Text_IO.Append_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Position_Glossary_Text (The_File => Data_File);
-
- Test_Verification_Block:
- declare
- TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- Blanks : constant String :=
- " ";
- TC_String : String (1 .. 15) := Blanks;
- begin
- Reset2:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Text_IO.Skip_Page (Data_File);
- Text_IO.Skip_Page (Data_File);
-
- -- If the Reset to Append_File mode actually put a page terminator
- -- on the file, as allowed (but not required) by RM A.10.2(4), then
- -- we are now on page 3, an empty page. We'll need to skip one more.
-
- if Text_IO.End_Of_Page (Data_File) then
- Text_IO.Skip_Page (Data_File);
- end if;
-
- -- Now we're on the Glossary page.
-
- -- Loop to the second line
- for I in 1 .. 2 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
- if (TC_Position /= 13) or else -- Verify the title line.
- (TC_String (1..2) /= "IX") or else
- (TC_String (3..13) /= (". " & Glossary_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
-
- TC_String := Blanks; -- Clear string.
- -- Loop to the fourth line
- for I in 3 .. 4 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 12) or -- Verify the contents.
- (TC_String (8..12) /= " " & Glossary_Content) then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Data_File) then
- Text_IO.Delete (Data_File);
- else
- Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
- end Final_Block;
-
- Report.Result;
-
- exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a
deleted file mode 100644
index f3ea17e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a
+++ /dev/null
@@ -1,260 +0,0 @@
--- CXAA004.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 procedures New_Page, Set_Line, Set_Col, and New_Line
--- perform properly on a text file opened with mode Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the opening of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file opened with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files opened with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files opened with
--- mode Append_File.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Out_File mode,
--- and then reset to Append_File mode.
--- Various calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA004 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA004" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA004", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "opened with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Out_File,
- Name => Data_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- use Text_IO; -- To provide visibility to the "/=" operator.
-
- Default_Position : constant Text_IO.Positive_Count := 1;
-
- Section_Header : constant String := "X. ";
- Reference_Title : constant String := "REFERENCES";
- Reference_Content : constant String := "Available Upon Request";
-
- begin
-
- -- Some amount of text processing would occur here in the scenario
- -- following file creation, prior to file closure.
- Text_IO.Put_Line (File => Data_File, Item => "Some optional data");
-
- -- Close has the effect of a call to New_Page (adding a page
- -- terminator).
- Text_IO.Close (Data_File);
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment:
- -- Certain text is to be appended to a document.
- -- The file is opened in Append_File mode.
- -- The position on the appended page is set, verified, and text
- -- is placed in the file.
- --
- -- Note: The text file has been originally created in Out_File
- -- mode, has been subsequently closed and is now being reopened in
- -- Append_File mode for further processing.
-
- Text_IO.Open (Data_File, Text_IO.Append_File, Data_Filename);
-
- -- Test control code.
- if (Text_IO.Page(Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default page number"); -- page value.
- end if;
- if (Text_IO.Line(Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default line number"); -- line number.
- end if;
- if (Text_IO.Col (Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default column number"); -- column no.
- end if;
-
- -- Simulated usage code.
- Text_IO.New_Page (Data_File); -- Set new page/
- Text_IO.New_Line (File => Data_File, Spacing => 2); -- line pos.
- Text_IO.Put (Data_File, Section_Header); -- Position
- Text_IO.Put_Line (Data_File, Reference_Title); -- title.
-
- -- Test control code. -- Verify new
- if (Integer(Text_IO.Page (Data_File)) /= -- page and
- Report.Ident_Int(2)) or else -- line.
- (Integer(Text_IO.Line (Data_File)) /=
- Report.Ident_Int(4)) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code.
- Text_IO.Set_Line (File => Data_File, To => 8); -- Set new
- Text_IO.Set_Col (File => Data_File, To => 30); -- position.
- Text_IO.Put_Line (Data_File, Reference_Content);
-
- -- Test control code.
- if (Integer(Text_IO.Line (Data_File)) /=
- Report.Ident_Int(9)) or -- Verify new
- (Integer(Text_IO.Col (Data_File)) /= -- position.
- Report.Ident_Int(1)) then
- Report.Failed ("Incorrect results from line/column positioning");
- end if;
-
- Test_Verification_Block:
- declare
- TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- TC_String : String (1 .. 55) := (others => ' ');
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Text_IO.Skip_Page (Data_File);
-
- -- If the Reset to Append_File mode actually put a page terminator
- -- in the file, as allowed (but not required) by RM A.10.2(4), then
- -- we are now on page 2, an empty page. Therefore, we need to skip
- -- one more page.
-
- if Text_IO.End_Of_Page (Data_File) then
- Text_IO.Skip_Page (Data_File);
- end if;
-
- -- Now we're on the reference page.
-
- -- Loop to the third line
- for I in 1 .. 3 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 14) or else -- Verify the title line.
- (TC_String (1..6) /= "X. RE") or else
- (TC_String (2..14) /= (". " & Reference_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
- -- Loop to the eighth line
- for I in 4 .. 8 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 51) or -- Verify the contents.
- (TC_String (30..51) /= "Available Upon Request") then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Data_File) then
- Text_IO.Delete (Data_File);
- else
- Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Delete not properly implemented - Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ("Unexpected exception");
- Report.Result;
-
-end CXAA004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a
deleted file mode 100644
index 7b2a0bc..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXAA005.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 procedure Put, when called with string parameters, does
--- not update the line number of a text file of mode Append_File, when
--- the line length is unbounded (i.e., only the column number is
--- updated).
--- Check that a call to the procedure Put with a null string argument
--- has no measurable effect on a text file of mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to ensure that when a string is appended to an
--- unbounded text file, it is placed following the last element currently
--- in the file. For an unbounded text file written with Put procedures
--- only (not Put_Line), the line number should not be incremented by
--- subsequent calls to Put in Append_File mode. Only the column number
--- should be incremented based on the length of the string parameter
--- placed in the file. If a call to Put with a null string argument is
--- made, no change to the line or column number should occur, and no
--- element(s) should be added to the file, so that there would be no
--- measurable change to the file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA005 is
- An_Unbounded_File : Ada.Text_IO.File_Type;
- Unbounded_File_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA005" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA005", "Check that the procedure Put does not " &
- "increment line numbers when used with " &
- "unbounded text files of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An application creates a text file in mode Out_File, with the intention
- -- of entering string data packets into the file as appropriate. In the
- -- event that the particular environment where the application is running
- -- does not support Text_IO, Use_Error will be raised on calls to Text_IO
- -- operations.
- -- This exception will be handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (File => An_Unbounded_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Unbounded_File_Name);
- exception
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- subtype String_Sequence_Type is string (1 .. 20);
- type String_Pointer_Type is access String_Sequence_Type;
-
--- During the course of processing, the application creates a variety of data
--- pointers that refer to particular data items. The possibility of having
--- null data values in this environment exists.
-
- Data_Packet_1 : String_Pointer_Type :=
- new String_Sequence_Type'("One Data Sequence 01");
-
- Data_Packet_2 : String_Pointer_Type :=
- new String_Sequence_Type'("New Data Sequence 02");
-
- Blank_Data_Packet : String_Pointer_Type :=
- new String_Sequence_Type'(" ");
-
- Null_Data_Packet : constant String := "";
-
- TC_Line, TC_Col : Natural := 0;
-
- function TC_Mode_Selection (Selector : Integer)
- return Ada.Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Ada.Text_IO.In_File;
- when 2 => return Ada.Text_IO.Out_File;
- when others => return Ada.Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- begin
-
--- The application places some data into the file, using the Put subroutine.
--- This operation can occur one-to-many times.
-
- Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_1.all);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Col (An_Unbounded_File)) /=
- Report.Ident_Int(21)) or
- (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /=
- Report.Ident_Int(1)) then
- Report.Failed ("Incorrect Col position after 1st Put");
- end if;
-
--- The application may close the file at some point following its initial
--- entry of data.
-
- Ada.Text_IO.Close (An_Unbounded_File);
-
--- At some later point in the processing, more data needs to be added to the
--- file, so the application opens the file in Append_File mode.
-
- Ada.Text_IO.Open (File => An_Unbounded_File,
- Mode => Ada.Text_IO.Append_File,
- Name => Unbounded_File_Name);
-
- -- Test control code.
- -- Store line/column number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File));
- TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File));
-
--- Additional data items can then be appended to the file.
-
- Ada.Text_IO.Put (An_Unbounded_File, Blank_Data_Packet.all);
-
- -- Test control code.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- (TC_Col + 20)) or
- (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 2nd Put");
- end if;
-
--- In order to accommodate various scenarios, the application may have changed
--- the mode of the data file to In_File in order to retrieve/verify some of
--- the data contained there. However, with the need to place more data into
--- the file, the file can be reset to Append_File mode.
-
- Reset1:
- begin
- Ada.Text_IO.Reset (An_Unbounded_File,
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Test control code.
- -- Store line/column number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File));
- TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File));
-
--- Additional data can then be appended to the file. On some occasions, an
--- attempt to enter a null string value into the file may occur. This should
--- have no effect on the file, leaving it unchanged.
-
- -- No measurable effect from Put with null string.
- Ada.Text_IO.Put (An_Unbounded_File, Null_Data_Packet);
-
- -- Test control code.
- -- There should be no change following the Put above.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- TC_Col) or
- (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 3rd Put");
- end if;
-
--- Additional data can be appended to the file.
-
- Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_2.all);
-
- -- Test control code.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- (TC_Col + 20)) or
- (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 4th Put");
- end if;
-
- Test_Verification_Block:
- declare
- File_Data : String (1 .. 80);
- TC_Width : Natural;
- begin
-
--- The application has the capability to reset the file to In_File mode to
--- verify some of the data that is contained there.
-
- Reset2:
- begin
- Ada.Text_IO.Reset (An_Unbounded_File, Ada.Text_IO.In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported - Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Text_IO.Get_Line (An_Unbounded_File,
- File_Data,
- TC_Width);
-
- -- Test control code.
- -- Since it is implementation defined whether a page
- -- terminator separates preexisting text from new text
- -- following an open in append mode (as occurred above),
- -- verify only that the first data item written to the
- -- file was not overwritten by any subsequent call to Put.
-
- if (File_Data (File_Data'First) /= 'O') or
- (File_Data (20) /= '1') then
- Report.Failed ("Data placed incorrectly in file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(An_Unbounded_File) then
- Ada.Text_IO.Delete (An_Unbounded_File);
- else
- Ada.Text_IO.Open(An_Unbounded_File,
- Ada.Text_IO.In_File,
- Unbounded_File_Name);
- Ada.Text_IO.Delete (An_Unbounded_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented -- Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA005;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a
deleted file mode 100644
index 518d43b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a
+++ /dev/null
@@ -1,285 +0,0 @@
--- CXAA006.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 for a bounded line length text file of mode Append_File,
--- when the number of characters to be output exceeds the number of
--- columns remaining on the current line, a call to Put will output
--- characters of the string sufficient to fill the remaining columns of
--- the line (up to line length), then output a line terminator, reset the
--- column number, increment the line number, then output the balance of
--- the item.
---
--- Check that the procedure Put does not raise Layout_Error when the
--- number of characters to be output exceeds the line length of a bounded
--- text file of mode Append_File.
---
--- TEST DESCRIPTION:
--- This test demonstrates the situation where an application intends to
--- output variable length string elements to a text file in the most
--- efficient manner possible. This is the case in a typesetting
--- environment where text is compressed and split between lines of a
--- bounded length.
---
--- The procedure Put will break string parameters placed in the file at
--- the point of the line length. Two examples are demonstrated in this
--- test, one being the case where only one column remains on a line, and
--- the other being the case where a larger portion of the line remains
--- unfilled, but still not sufficient to contain the entire output
--- string.
---
--- During the course of the test, the file is reset to Append_File mode,
--- and the bounded line length is modified for different lines of the
--- file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA006 is
-
- A_Bounded_File : Ada.Text_IO.File_Type;
- Bounded_File_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA006" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA006", "Check that procedure Put will correctly " &
- "output string items to a bounded line " &
- "length text file of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file in mode Append_File, with the intention
--- of using the procedure Put to compress variable length string data into the
--- file in the most efficient manner possible.
-
- Ada.Text_IO.Create (File => A_Bounded_File,
- Mode => Ada.Text_IO.Append_File,
- Name => Bounded_File_Name);
- exception
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Twelve_Characters : constant String := "12Characters";
- Nineteen_Characters : constant String := "Nineteen_Characters";
- TC_Line : Natural := 0;
-
- function TC_Mode_Selection (Selector : Integer)
- return Ada.Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Ada.Text_IO.In_File;
- when 2 => return Ada.Text_IO.Out_File;
- when others => return Ada.Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- begin
-
--- The application sets the line length of the file to be bound at 20. All
--- lines in this file will be limited to that length.
-
- Ada.Text_IO.Set_Line_Length (A_Bounded_File, 20);
-
- Ada.Text_IO.Put (A_Bounded_File, Nineteen_Characters);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /=
- Report.Ident_Int(1)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(20)) then
- Report.Failed ("Incorrect position after 1st Put");
- end if;
-
--- The application finds that there is only one column available on the
--- current line, so the next string item to be output must be broken at
--- the appropriate place (following the first character).
-
- Ada.Text_IO.Put (File => A_Bounded_File,
- Item => Twelve_Characters);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /=
- Report.Ident_Int(2)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(12)) then
- Report.Failed ("Incorrect position after 2nd Put");
- end if;
-
--- The application subsequently modifies the processing, resetting the file
--- at this point to In_File mode in order to verify data that has been written
--- to the file. Following this, the application resets the file to Append_File
--- mode in order to continue the placement of data into the file, but modifies
--- the original bounded line length for subsequent lines to be appended.
-
- -- Reset to Append mode; call outputs page terminator and
- -- resets line length to Unbounded.
- Reset1:
- begin
- Ada.Text_IO.Reset (A_Bounded_File,
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Ada.Text_IO.Set_Line_Length (A_Bounded_File, 15);
-
- -- Store line number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(A_Bounded_File));
-
--- The application finds that fifteen columns are available on the current
--- line but that the string item to be output exceeds this available space.
--- It must be split at the end of the line, and the balance placed on the
--- next file line.
-
- Ada.Text_IO.Put (File => A_Bounded_File,
- Item => Nineteen_Characters);
-
- -- Test control code.
- -- Positioned on new line at col 5.
- if (Natural(Ada.Text_IO.Line (A_Bounded_File)) /=
- (TC_Line + 1)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(5)) then
- Report.Failed ("Incorrect position after 3rd Put");
- end if;
-
-
- Test_Verification_Block:
- declare
- First_String : String (1 .. 80);
- Second_String : String (1 .. 80);
- Third_String : String (1 .. 80);
- Fourth_String : String (1 .. 80);
- TC_Width1 : Natural;
- TC_Width2 : Natural;
- TC_Width3 : Natural;
- TC_Width4 : Natural;
- begin
-
--- The application has the capability to reset the file to In_File mode to
--- verify some or all of the data that is contained there.
-
- Reset2:
- begin
- Ada.Text_IO.Reset (A_Bounded_File, Ada.Text_IO.In_File);
- exception
- when others =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Text_IO.Get_Line
- (A_Bounded_File, First_String, TC_Width1);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Second_String, TC_Width2);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Third_String, TC_Width3);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Fourth_String, TC_Width4);
-
- -- Test control code.
- if (First_String (1..TC_Width1) /= Nineteen_Characters & "1") or
- (Second_String (1..TC_Width2) /= "2Characters") or
- (Third_String (1..TC_Width3) /=
- Nineteen_Characters(1..15)) or
- (Fourth_String (1..TC_Width4) /= "ters")
- then
- Report.Failed ("Data placed incorrectly in file");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when Ada.Text_IO.End_Error =>
- Report.Failed ("Incorrect number of lines in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Ada.Text_IO.Layout_Error =>
- Report.Failed ("Layout Error raised when positioning text");
-
- when others =>
- Report.Failed ("Exception in Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(A_Bounded_File) then
- Ada.Text_IO.Delete (A_Bounded_File);
- else
- Ada.Text_IO.Open (A_Bounded_File,
- Ada.Text_IO.In_File,
- Bounded_File_Name);
- Ada.Text_IO.Delete (A_Bounded_File);
- end if;
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA006;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a
deleted file mode 100644
index fe79c2d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a
+++ /dev/null
@@ -1,263 +0,0 @@
--- CXAA007.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 capabilities of Text_IO.Integer_IO perform correctly
--- on files of Append_File mode, for instantiations with integer and
--- user-defined subtypes.
--- Check that the formatting parameters available in the package can
--- be used and modified successfully in the storage and retrieval of
--- data.
---
--- TEST DESCRIPTION:
--- This test simulates a receiving department inventory system. Data on
--- items received is entered into an inventory database. This information
--- consists of integer entry number, item number, and bar code.
--- One item is placed into the inventory file immediately following file
--- creation, subsequent items are entered following file opening in
--- Append_File mode. Data items are validated by reading all data from
--- the file and comparing against known values (those used to enter the
--- data originally).
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, opening in Append_File mode, resetting
--- from Append_File mode to In_File mode, as well as a variety of Text_IO
--- and Integer_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA007 is
- use Ada;
-
- Inventory_File : Text_IO.File_Type;
- Inventory_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA007" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA007", "Check that the capabilities of " &
- "Text_IO.Integer_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Inventory_File,
- Mode => Text_IO.Append_File,
- Name => Inventory_Filename);
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Max_Entries_Per_Order : constant Natural := 4;
-
- type Bar_Code_Type is range 0 .. 127; -- Values to be stored as base
- -- two numbers in file.
- type Item_Type is record
- Entry_Number : Natural := 0;
- Item_Number : Integer := 0;
- Bar_Code : Bar_Code_Type := 0;
- end record;
-
- type Inventory_Type is
- array (1 .. Max_Entries_Per_Order) of Item_Type;
-
- Inventory_List : Inventory_Type := ((1, 119, 87), -- Items received
- (2, 206, 44), -- this order.
- (3, -25, 126),
- (4, -18, 31));
-
- Daily_Order : constant := 1;
- Entry_Field_Width : constant Natural := 1;
- Item_Base : constant Natural := 16;
- Items_Inventoried : Natural := 1;
- Items_To_Inventory : Natural := 4;
-
- package Entry_IO is new Text_IO.Integer_IO (Natural);
- package Item_IO is new Text_IO.Integer_IO (Integer);
- package Bar_Code_IO is new Text_IO.Integer_IO (Bar_Code_Type);
-
-
- -- The following procedure simulates the addition of inventory item
- -- information into a data file.
-
- procedure Update_Inventory (The_Item : in Item_Type) is
- Spacer : constant String := " ";
- begin
- -- Enter all the incoming data into the inventory file.
- Entry_IO.Put (Inventory_File, The_Item.Entry_Number);
- Text_IO.Put (Inventory_File, Spacer);
- Item_IO.Put (Inventory_File, The_Item.Item_Number);
- Text_IO.Put (Inventory_File, Spacer);
- Bar_Code_IO.Put(File => Inventory_File,
- Item => The_Item.Bar_Code,
- Width => 13,
- Base => 2);
- Text_IO.New_Line(Inventory_File);
- end Update_Inventory;
-
-
- begin
-
- -- This code section simulates a receiving department maintaining a
- -- data file containing information on items that have been ordered
- -- and received.
- --
- -- As new orders are received, the file is opened in Append_File
- -- mode.
- -- Data is taken from the inventory list and entered into the file,
- -- in specific format.
- -- Enter the order into the inventory file. This is item 1 in
- -- the inventory list.
- -- The data entry process can be repeated numerous times as required.
-
- Entry_IO.Put (Inventory_File,
- Inventory_List(Daily_Order).Entry_Number);
- Item_IO.Put (Inventory_File,
- Inventory_List(Daily_Order).Item_Number);
- Bar_Code_IO.Put (File => Inventory_File,
- Item => Inventory_List(Daily_Order).Bar_Code);
- Text_IO.New_Line (Inventory_File);
-
- Text_IO.Close (Inventory_File);
-
-
- Entry_IO.Default_Width := Entry_Field_Width; -- Modify the default
- -- width of Entry_IO.
- Item_IO.Default_Base := Item_Base; -- Modify the default
- -- number base of
- -- Item_IO
- Text_IO.Open (Inventory_File,
- Text_IO.Append_File, -- Open in Append mode.
- Inventory_Filename);
- -- Enter items
- while (Items_Inventoried < Items_To_Inventory) loop -- 2-4 into the
- Items_Inventoried := Items_Inventoried + 1; -- inventory file.
- Update_Inventory (The_Item => Inventory_List (Items_Inventoried));
- end loop;
-
- Test_Verification_Block: -- Read and check
- declare -- all the data
- TC_Entry : Natural; -- values that
- TC_Item : Integer; -- have been
- TC_Bar_Code : Bar_Code_Type; -- entered in the
- TC_Item_Count : Natural := 0; -- data file.
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to mode In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- while not Text_IO.End_Of_File (Inventory_File) loop
- Entry_IO.Get (Inventory_File, TC_Entry);
- Item_IO.Get (Inventory_File, TC_Item);
- Bar_Code_IO.Get (Inventory_File, TC_Bar_Code);
- Text_IO.Skip_Line (Inventory_File);
- TC_Item_Count := TC_Item_Count + 1;
-
- if (TC_Item /= Inventory_List(TC_Entry).Item_Number) or
- (TC_Bar_Code /= Inventory_List(TC_Entry).Bar_Code) then
- Report.Failed ("Error in integer data read from file");
- end if;
- end loop;
-
- if (TC_Item_Count /= Max_Entries_Per_Order) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Integer_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Inventory_File) then
- Text_IO.Delete (Inventory_File);
- else
- Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename);
- Text_IO.Delete (Inventory_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA007;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a
deleted file mode 100644
index c21d07e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CXAA008.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 capabilities provided in instantiations of the
--- Ada.Text_IO.Fixed_IO package operate correctly when the mode of
--- the file is Append_File. Check that Fixed_IO procedures Put and Get
--- properly transfer fixed point data to/from data files that are in
--- Append_File mode. Check that the formatting parameters available in
--- the package can be used and modified successfully in the appending and
--- retrieval of data.
---
--- TEST DESCRIPTION:
--- This test simulates order processing, with data values being written
--- to a file, in a specific format, using Fixed_IO. Validation is done
--- on this process by reading the data values from the file, and
--- comparing them for equality with the values originally written to
--- the file.
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, resetting to Append_File mode,
--- resetting from Append_File mode to In_File mode, as well as a
--- variety of Text_IO and Fixed_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA008 is
- use Ada;
-
- Inventory_File : Text_IO.File_Type;
- Inventory_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA008" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA008", "Check that the capabilities of " &
- "Text_IO.Fixed_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Inventory_File,
- Mode => Text_IO.Append_File,
- Name => Inventory_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Daily_Orders_Received : constant Natural := 4;
-
- type Item_Type is delta 0.1 range 0.0 .. 5000.0;
- type Cost_Type is delta 0.01 range 0.0 .. 10_000.0;
- type Profit_Type is delta 0.01 range -100.0 .. 1000.0;
-
- type Product_Type is record
- Item_Number : Item_Type := 0.0;
- Unit_Cost : Cost_Type := 0.00;
- Percent_Markup : Profit_Type := 0.00;
- end record;
-
- type Inventory_Type is
- array (1 .. Daily_Orders_Received) of Product_Type;
-
- Daily_Inventory : Inventory_Type := (( 1.0, 1.75, 50.00),
- ( 155.0, 20.00, -5.50),
- (3343.5, 2.50, 126.50),
- (4986.0, 180.00, 31.75));
-
- package Item_IO is new Text_IO.Fixed_IO (Item_Type);
- package Cost_IO is new Text_IO.Fixed_IO (Cost_Type);
- package Markup_IO is new Text_IO.Fixed_IO (Profit_Type);
-
-
- function TC_Mode_Selection (Selector : Integer)
- return Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Text_IO.In_File;
- when 2 => return Text_IO.Out_File;
- when others => return Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
-
- -- The following function simulates the addition of inventory item
- -- information into a data file. Boolean status of True is returned
- -- if all of the data entry was successful, False otherwise.
-
- function Update_Inventory (The_List : Inventory_Type)
- return Boolean is
- begin
- for I in 1 .. Daily_Orders_Received loop
- Item_IO.Put (Inventory_File, The_List(I).Item_Number);
- Cost_IO.Put (Inventory_File, The_List(I).Unit_Cost, 10, 4, 0);
- Markup_IO.Put(File => Inventory_File,
- Item => The_List(I).Percent_Markup,
- Fore => 6,
- Aft => 3,
- Exp => 2);
- Text_IO.New_Line (Inventory_File);
- end loop;
- return (True); -- Return a Status value.
- exception
- when others => return False;
- end Update_Inventory;
-
-
- begin
-
- -- This code section simulates a receiving department maintaining a
- -- data file containing information on items that have been ordered
- -- and received.
-
- -- Whenever items are received, the file is reset to Append_File
- -- mode. Data is taken from an inventory list and entered into the
- -- file, in specific format.
-
- Reset1:
- begin -- Reset to
- Text_IO.Reset (Inventory_File, -- Append mode.
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- end Reset1;
-
- -- Enter data.
- if not Update_Inventory (The_List => Daily_Inventory) then
- Report.Failed ("Exception occurred during inventory update");
- raise Incomplete;
- end if;
-
- Test_Verification_Block:
- declare
- TC_Item : Item_Type;
- TC_Cost : Cost_Type;
- TC_Markup : Profit_Type;
- TC_Item_Count : Natural := 0;
- begin
-
- Reset2:
- begin
- Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- while not Text_IO.End_Of_File (Inventory_File) loop
- Item_IO.Get (Inventory_File, TC_Item);
- Cost_IO.Get (Inventory_File, TC_Cost);
- Markup_IO.Get (File => Inventory_File,
- Item => TC_Markup,
- Width => 0);
- Text_IO.Skip_Line (Inventory_File);
- TC_Item_Count := TC_Item_Count + 1;
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Item /= Daily_Inventory(TC_Item_Count).Item_Number) then
- Report.Failed ("Error in Item_Number read from file");
- end if;
- if (TC_Cost /= Daily_Inventory(TC_Item_Count).Unit_Cost) then
- Report.Failed ("Error in Unit_Cost read from file");
- end if;
- if not (TC_Markup =
- Daily_Inventory(TC_Item_Count).Percent_Markup) then
- Report.Failed ("Error in Percent_Markup read from file");
- end if;
-
- end loop;
-
- if (TC_Item_Count /= Daily_Orders_Received) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Fixed_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Inventory_File) then
- Text_IO.Delete (Inventory_File);
- else
- Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename);
- Text_IO.Delete (Inventory_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA008;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a
deleted file mode 100644
index d478060..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a
+++ /dev/null
@@ -1,290 +0,0 @@
--- CXAA009.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 capabilities provided in instantiations of the
--- Ada.Text_IO.Float_IO package operate correctly when the mode of
--- the file is Append_File. Check that Float_IO procedures Put and Get
--- properly transfer floating point data to/from data files that are in
--- Append_File mode. Check that the formatting parameters available in
--- the package can be used and modified successfully in the appending and
--- retrieval of data.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate an environment where a data file
--- that holds floating point information is created, written to, and
--- closed. In the future, the file can be reopened in Append_File mode,
--- additional data can be appended to it, and then closed. This process
--- of Open/Append/Close can be repeated as necessary. All data written
--- to the file is verified for accuracy when retrieved from the file.
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, opening in Append_File mode, resetting
--- from Append_File mode to In_File mode, as well as a variety of Text_IO
--- and Float_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA009 is
-
- use Ada;
- Loan_File : Text_IO.File_Type;
- Loan_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA009" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA009", "Check that the capabilities of " &
- "Text_IO.Float_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Loan_File, -- Create in
- Mode => Text_IO.Out_File, -- Out_File mode.
- Name => Loan_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Total_Loans_Outstanding : constant Natural := 3;
- Transaction_Status : Boolean := False;
-
- type Account_Balance_Type is digits 6 range 0.0 .. 1.0E6;
- type Loan_Balance_Type is digits 6;
- type Interest_Rate_Type is digits 4 range 0.0 .. 30.00;
-
- type Loan_Info_Type is record
- Account_Balance : Account_Balance_Type := 0.00;
- Loan_Balance : Loan_Balance_Type := 0.00;
- Loan_Interest_Rate : Interest_Rate_Type := 0.00;
- end record;
-
- Home_Refinance_Loan : Loan_Info_Type :=
- (14_500.00, 135_000.00, 6.875);
- Line_Of_Credit_Loan : Loan_Info_Type :=
- ( 5490.00, -3000.00, 13.75);
- Small_Business_Loan : Loan_Info_Type :=
- (Account_Balance => 45_000.00,
- Loan_Balance => 10_500.00,
- Loan_Interest_Rate => 5.875);
-
- package Acct_IO is new Text_IO.Float_IO (Account_Balance_Type);
- package Loan_IO is new Text_IO.Float_IO (Loan_Balance_Type);
- package Rate_IO is new Text_IO.Float_IO (Interest_Rate_Type);
-
-
- -- The following procedure performs the addition of loan information
- -- into a data file. Boolean status of True is returned if all of
- -- the data entry was successful, False otherwise.
- -- This demonstrates use of Float_IO using a variety of data formats.
-
- procedure Update_Loan_Info (The_File : in out Text_IO.File_Type;
- The_Loan : in Loan_Info_Type;
- Status : out Boolean ) is
- begin
- Acct_IO.Put (The_File, The_Loan.Account_Balance);
- Loan_IO.Put (The_File, The_Loan.Loan_Balance, 15, 2, 0);
- Rate_IO.Put (File => The_File,
- Item => The_Loan.Loan_Interest_Rate,
- Fore => 6,
- Aft => 3,
- Exp => 0);
- Text_IO.New_Line (The_File);
- Status := True;
- exception
- when others => Status := False;
- end Update_Loan_Info;
-
-
- begin
-
- -- This code section simulates a bank maintaining a data file
- -- containing information on loans that have been made.
- -- The scenario:
- -- The loan file was created in Out_File mode.
- -- Some number of data records are added.
- -- The file is closed.
- -- The file is subsequently reopened in Append_File mode.
- -- Data is appended to the file.
- -- The file is closed.
- -- Repeat the Open/Append/Close process as required.
- -- Verify data in the file.
- -- etc.
-
- Update_Loan_Info(Loan_File, Home_Refinance_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed ("Failure in update of first loan data");
- end if;
-
- Text_IO.Close (Loan_File);
-
- -- When subsequent data items are to be added to the file, the file
- -- is opened in Append_File mode.
-
- Text_IO.Open (Loan_File, -- Open with
- Text_IO.Append_File, -- Append mode.
- Loan_Filename);
-
- Update_Loan_Info(Loan_File, Line_Of_Credit_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed("Failure in update of first loan data");
- end if;
-
- Text_IO.Close(Loan_File);
-
- -- To add additional data to the file, the file
- -- is again opened in Append_File mode (appending to a file
- -- previously appended to).
-
- Text_IO.Open (Loan_File, -- Open with
- Text_IO.Append_File, -- Append mode.
- Loan_Filename);
-
- Update_Loan_Info(Loan_File, Small_Business_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed("Failure in update of first loan data");
- end if;
-
- Test_Verification_Block:
- declare
- type Ledger_Type is
- array (1 .. Total_Loans_Outstanding) of Loan_Info_Type;
- TC_Bank_Ledger : Ledger_Type;
- TC_Item_Count : Natural := 0;
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Loan_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- while not Text_IO.End_Of_File (Loan_File) loop
- TC_Item_Count := TC_Item_Count + 1;
- Acct_IO.Get (Loan_File,
- TC_Bank_Ledger(TC_Item_Count).Account_Balance);
- Loan_IO.Get (Loan_File,
- TC_Bank_Ledger(TC_Item_Count).Loan_Balance,
- 0);
- Rate_IO.Get(File => Loan_File,
- Item =>
- TC_Bank_Ledger(TC_Item_Count).Loan_Interest_Rate,
- Width => 0);
- Text_IO.Skip_Line(Loan_File);
-
- end loop;
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Bank_Ledger(1) /= Home_Refinance_Loan) or
- (TC_Bank_Ledger(2) /= Line_Of_Credit_Loan) or
- (TC_Bank_Ledger(3) /= Small_Business_Loan) then
- Report.Failed("Error in data read from file");
- end if;
-
- if (TC_Item_Count /= Total_Loans_Outstanding) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Float_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Loan_File) then
- Text_IO.Delete(Loan_File);
- else
- Text_IO.Open(Loan_File, Text_IO.In_File, Loan_Filename);
- Text_IO.Delete(Loan_File);
- end if;
-
- exception
-
- when Text_IO.Use_Error =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA009;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a
deleted file mode 100644
index 5678aee..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a
+++ /dev/null
@@ -1,335 +0,0 @@
--- CXAA010.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 operations defined in package Ada.Text_IO.Decimal_IO
--- are available, and that they function correctly when used for the
--- input/output of Decimal types.
---
--- TEST DESCRIPTION:
--- This test demonstrates the Put and Get procedures found in the
--- generic package Ada.Text_IO.Decimal_IO. Both Put and Get are
--- overloaded to allow placement or extraction of decimal values
--- to/from a text file or a string. This test demonstrates both forms
--- of each subprogram.
--- The test defines an array of records containing decimal value
--- and string component fields. All component values are placed in a
--- Text_IO file, with the decimal values being placed there using the
--- version of Put defined for files, and using user-specified formatting
--- parameters. The data is later extracted from the file, with the
--- decimal values being removed using the version of Get defined for
--- files. Decimal values are then written to strings, using the
--- appropriate Put procedure. Finally, extraction of the decimal data
--- from the strings completes the evaluation of the Decimal_IO package
--- subprograms.
--- The reconstructed data is verified at the end of the test against the
--- data originally written to the file.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations capable of supporting external
--- Text_IO files and Decimal Fixed Point Types
---
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Information Systems Annex (F):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex F:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-F RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Feb 95 SAIC Modified test to allow for Use_Error/Name_Error
--- generation by an implementation not supporting
--- Text_IO operations.
--- 14 Nov 95 SAIC Corrected string indexing for ACVC 2.0.1.
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
--- 16 FEB 98 EDS Modified documentation.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA010 is
- use Ada.Text_IO;
- Tax_Roll : Ada.Text_IO.File_Type;
- Tax_Roll_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA010" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA010", "Check that the operations defined in package " &
- "Ada.Text_IO.Decimal_IO are available, and " &
- "that they function correctly when used for " &
- "the input/output of Decimal types");
-
- Test_for_Decimal_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO creation or naming
- -- of external files in a particular environment will raise Use_Error
- -- or Name_Error on a call to Text_IO Create. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. Either of these exceptions will be
- -- handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name);
-
- exception
-
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Decimal_IO_Support;
-
- Taxation:
- declare
-
- ID_Length : constant := 5;
- Price_String_Length : constant := 5;
- Value_String_Length : constant := 6;
- Total_String_Length : constant := 20;
- Spacer : constant String := " "; -- Two blanks.
-
- type Price_Type is delta 0.1 digits 4; -- ANX-F RQMT
- type Value_Type is delta 0.01 digits 5; -- ANX-F RQMT
-
- type Property_Type is
- record
- Parcel_ID : String (1..ID_Length);
- Purchase_Price : Price_Type;
- Assessed_Value : Value_Type;
- end record;
-
- type City_Block_Type is array (1..4) of Property_Type;
-
- subtype Tax_Bill_Type is string (1..Total_String_Length);
- type Tax_Bill_Array_Type is array (1..4) of Tax_Bill_Type;
-
- Neighborhood : City_Block_Type :=
- (("X9254", 123.0, 135.00), ("X3569", 345.0, 140.50),
- ("X3434", 234.0, 179.50), ("X8838", 456.0, 158.00));
-
- Neighborhood_Taxes : Tax_Bill_Array_Type;
-
- package Price_IO is new Ada.Text_IO.Decimal_IO (Price_Type);
- package Value_IO is new Ada.Text_IO.Decimal_IO (Value_Type);
-
- begin -- Taxation
-
- Assessors_Office:
- begin
-
- for Parcel in City_Block_Type'Range loop
- -- Note: All data in the file will be separated with a
- -- two-character blank spacer.
- Ada.Text_IO.Put(Tax_Roll, Neighborhood(Parcel).Parcel_ID);
- Ada.Text_IO.Put(Tax_Roll, Spacer);
-
- -- Use Decimal_IO.Put with non-default format parameters to
- -- place decimal data into file.
- Price_IO.Put (Tax_Roll, Neighborhood(Parcel).Purchase_Price,
- Fore => 3, Aft =>1, Exp => 0);
- Ada.Text_IO.Put(Tax_Roll, Spacer);
-
- Value_IO.Put (Tax_Roll, Neighborhood(Parcel).Assessed_Value,
- Fore => 3, Aft =>2, Exp => 0);
- Ada.Text_IO.New_Line(Tax_Roll);
- end loop;
-
- Ada.Text_IO.Close (Tax_Roll);
-
- exception
- when others =>
- Report.Failed ("Exception raised in Assessor's Office");
- end Assessors_Office;
-
-
- Twice_A_Year:
- declare
-
- procedure Collect_Tax(Index : in Integer;
- Tax_Array : in out Tax_Bill_Array_Type) is
- ID : String (1..ID_Length);
- Price : Price_Type := 0.0;
- Value : Value_Type := 0.00;
- Price_String : String (1..Price_String_Length);
- Value_String : String (1..Value_String_Length);
- begin
-
- -- Extract information from the Text_IO file; one string, two
- -- decimal values.
- -- Note that the Spacers that were put in the file above are
- -- not individually read here, due to the fact that each call
- -- to Decimal_IO.Get below uses a zero in the Width field,
- -- which allows each Get procedure to skip these leading blanks
- -- prior to extracting the numeric value.
-
- Ada.Text_IO.Get (Tax_Roll, ID);
-
- -- A zero value of Width is provided, so the following
- -- two calls to Decimal_IO.Get will skip the leading blanks,
- -- (from the Spacer variable above), then read the numeric
- -- literals.
-
- Price_IO.Get (Tax_Roll, Price, 0);
- Value_IO.Get (Tax_Roll, Value, 0);
- Ada.Text_IO.Skip_Line (Tax_Roll);
-
- -- Convert the values read from the file into string format,
- -- using user-specified format parameters.
- -- Format of the Price_String should be "nnn.n"
- -- Format of the Value_String should be "nnn.nn"
-
- Price_IO.Put (To => Price_String,
- Item => Price,
- Aft => 1);
- Value_IO.Put (Value_String, Value, 2);
-
- -- Construct a string of length 20 that contains the Parcel_ID,
- -- the Purchase_Price, and the Assessed_Value, separated by
- -- two-character blank data spacers. Store this string
- -- into the string array out parameter.
- -- Format of each Tax_Array element should be
- -- "Xnnnn nnn.n nnn.nn" (with an 'n' signifying a digit).
-
- Tax_Array(Index) := ID & Spacer &
- Price_String & Spacer &
- Value_String;
- exception
- when Data_Error =>
- Report.Failed("Data Error raised during the extraction " &
- "of decimal data from the file");
- when others =>
- Report.Failed("Exception in Collect_Tax procedure");
- end Collect_Tax;
-
-
- begin -- Twice_A_Year
-
- Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.In_File, Tax_Roll_Name);
-
- -- Determine property tax bills for the entire neighborhood from
- -- the information that is stored in the file. Store information
- -- in the Neighborhood_Taxes string array.
-
- for Parcel in City_Block_Type'Range loop
- Collect_Tax (Parcel, Neighborhood_Taxes);
- end loop;
-
- exception
- when others =>
- Report.Failed ("Exception in Twice_A_Year Block");
- end Twice_A_Year;
-
- -- Use Decimal_IO Get procedure to extract information from a string.
- -- Verify data against original values.
- Validation_Block:
- declare
- TC_ID : String (1..ID_Length); -- 1..5
- TC_Price : Price_Type;
- TC_Value : Value_Type;
- Length : Positive;
- Front,
- Rear : Integer := 0;
- begin
-
- for Parcel in City_Block_Type'Range loop
- -- Extract values from the strings of the string array.
- -- Each element of the string array is 20 characters long; the
- -- first five characters are the Parcel_ID, two blank characters
- -- separate data, the next five characters contain the Price
- -- decimal value, two blank characters separate data, the last
- -- six characters contain the Value decimal value.
- -- Extract each of these components in turn.
-
- Front := 1; -- 1
- Rear := ID_Length; -- 5
- TC_ID := Neighborhood_Taxes(Parcel)(Front..Rear);
-
- -- Extract the decimal value from the next slice of the string.
- Front := Rear + 3; -- 8
- Rear := Front + Price_String_Length - 1; -- 12
- Price_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear),
- Item => TC_Price,
- Last => Length);
-
- -- Extract next decimal value from slice of string, based on
- -- length of preceding strings read from string array element.
- Front := Rear + 3; -- 15
- Rear := Total_String_Length; -- 20
- Value_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear),
- Item => TC_Value,
- Last => Length);
-
- if TC_ID /= Neighborhood(Parcel).Parcel_ID or
- TC_Price /= Neighborhood(Parcel).Purchase_Price or
- TC_Value /= Neighborhood(Parcel).Assessed_Value
- then
- Report.Failed ("Incorrect data validation");
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed ("Exception in Validation Block");
- end Validation_Block;
-
- -- Check that the Text_IO file is open, then delete.
-
- if not Ada.Text_IO.Is_Open (Tax_Roll) then
- Report.Failed ("File not left open after processing");
- Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name);
- end if;
-
- Ada.Text_IO.Delete (Tax_Roll);
-
- exception
- when others =>
- Report.Failed ("Exception in Taxation block");
- -- Check that the Text_IO file is open, then delete.
- if not Ada.Text_IO.Is_Open (Tax_Roll) then
- Ada.Text_IO.Open (Tax_Roll,
- Ada.Text_IO.Out_File,
- Tax_Roll_Name);
- end if;
- Ada.Text_IO.Delete (Tax_Roll);
- end Taxation;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA010;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a
deleted file mode 100644
index 8cc136d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a
+++ /dev/null
@@ -1,266 +0,0 @@
--- CXAA011.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 operations of Text_IO.Enumeration_IO perform correctly
--- on files of Append_File mode, for instantiations using
--- enumeration types. Check that Enumeration_IO procedures Put and Get
--- properly transfer enumeration data to/from data files.
--- Check that the formatting parameters available in the package can
--- be used and modified successfully in the storage and retrieval of data.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate an environment where a data file
--- that holds enumeration type information is reset from it current mode
--- to allow the appending of data to the end of the This process
--- of Reset/Write can be repeated as necessary. All data written
--- to the file is verified for accuracy when retrieved from the file.
---
--- This test verifies issues of resetting a file created in Out_File mode
--- to Append_File mode, resetting from Append_File mode to In_File mode,
--- as well as a variety of Text_IO and Enumeration_IO predefined
--- subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA011 is
- use Ada;
-
- Status_Log : Text_IO.File_Type;
- Status_Log_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA011" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA011", "Check that the operations of " &
- "Text_IO.Enumeration_IO operate correctly for " &
- "files with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Status_Log,
- Mode => Text_IO.Out_File,
- Name => Status_Log_Filename);
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
- Operational_Test_Block:
- declare
-
- type Days_In_Week is (Monday, Tuesday, Wednesday, Thursday, Friday,
- Saturday, Sunday);
- type Hours_In_Day is (A0000, A0600, P1200, P0600); -- Six hour
- -- blocks.
- type Status_Type is (Operational, Off_Line);
-
- type Status_Record_Type is record
- Day : Days_In_Week;
- Hour : Hours_In_Day;
- Status : Status_Type;
- end record;
-
- Morning_Reading : Status_Record_Type :=
- (Wednesday, A0600, Operational);
- Evening_Reading : Status_Record_Type :=
- (Saturday, P0600, Off_Line);
-
- package Day_IO is new Text_IO.Enumeration_IO (Days_In_Week);
- package Hours_IO is new Text_IO.Enumeration_IO (Hours_In_Day);
- package Status_IO is new Text_IO.Enumeration_IO (Status_Type);
-
-
- -- The following function simulates the hourly recording of equipment
- -- status.
-
- function Record_Status (Reading : Status_Record_Type)
- return Boolean is
- use Text_IO; -- To provide visibility to type Type_Set and
- -- enumeration literal Upper_Case.
- begin
- Day_IO.Put (File => Status_Log,
- Item => Reading.Day,
- Set => Type_Set'(Upper_Case));
- Hours_IO.Put (Status_Log, Reading.Hour, 7);
- Status_IO.Put (Status_Log, Reading.Status,
- Width => 8, Set => Lower_Case);
- Text_IO.New_Line (Status_Log);
- return (True);
- exception
- when others => return False;
- end Record_Status;
-
- begin
-
- -- The usage scenario intended is as follows:
- -- File is created.
- -- Unrelated/unknown file processing occurs.
- -- On six hour intervals, file is reset to Append_File mode.
- -- Data is appended to file.
- -- Unrelated/unknown file processing resumes.
- -- Reset/Append process is repeated.
-
- Reset1:
- begin
- Text_IO.Reset (Status_Log, -- Reset to
- Text_IO.Append_File); -- Append mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Day_IO.Default_Width := Days_In_Week'Width + 5; -- Default values
- -- are modifiable.
-
- if not Record_Status (Morning_Reading) then -- Enter data.
- Report.Failed ("Exception occurred during data file update");
- end if;
-
- Reset2:
- begin
- Text_IO.Reset (Status_Log, -- Reset to
- Text_IO.Append_File); -- Append mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- if not Record_Status (Evening_Reading) then -- Enter data.
- Report.Failed ("Exception occurred during data file update");
- end if;
-
- Test_Verification_Block:
- declare
- TC_Reading1 : Status_Record_Type;
- TC_Reading2 : Status_Record_Type;
- begin
-
- Reset3:
- begin
- Text_IO.Reset (Status_Log, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset3;
-
- Day_IO.Get (Status_Log, TC_Reading1.Day); -- Read data from
- Hours_IO.Get (Status_Log, TC_Reading1.Hour); -- first record.
- Status_IO.Get (Status_Log, TC_Reading1.Status);
- Text_IO.Skip_Line (Status_Log);
-
- -- Verify the data read from the file. Compare with the
- -- record that was originally entered into the file.
-
- if (TC_Reading1 /= Morning_Reading) then
- Report.Failed ("Data error on reading first record");
- end if;
-
- Day_IO.Get (Status_Log, TC_Reading2.Day); -- Read data from
- Hours_IO.Get (Status_Log, TC_Reading2.Hour); -- second record.
- Status_IO.Get (Status_Log, TC_Reading2.Status);
- Text_IO.Skip_Line (Status_Log);
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Reading2.Day /= Evening_Reading.Day) or
- (TC_Reading2.Hour /= Evening_Reading.Hour) or
- (TC_Reading2.Status /= Evening_Reading.Status) then
- Report.Failed ("Data error on reading second record");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Enumeration_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Status_Log) then
- Text_IO.Delete (Status_Log);
- else
- Text_IO.Open (Status_Log, Text_IO.Out_File, Status_Log_Filename);
- Text_IO.Delete (Status_Log);
- end if;
- exception
- when Text_IO.Use_Error =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a
deleted file mode 100644
index 07523b4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXAA012.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 exception Mode_Error is raised when an attempt is made
--- to read from (perform a Get_Line) or use the predefined End_Of_File
--- function on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, resulting
--- from their use with files of the wrong Mode. This results in the
--- raising of Mode_Error exceptions, which is handled within blocks
--- embedded in the test.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA012 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA012" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA012", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to read " &
- "from (perform a Get_Line) or use the " &
- "predefined End_Of_File function on a " &
- "text file with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- Use_Error or Name_Error will be raised if Text_IO operations
- -- or external files are not supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- -- The application writes some amount of data to the file.
-
- Text_IO.Put_Line (Text_File, "Data entered into the file");
-
- Text_IO.Close (Text_File);
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
-
- Test_for_Reading:
- declare
- TC_Data : String (1..80);
- TC_Length : Natural := 0;
- begin
-
--- During the course of its processing, the application may become confused
--- and erroneously attempt to read data from the file that is currently in
--- Append_File mode (instead of the anticipated In_File mode).
--- This would result in the raising of Mode_Error.
-
- Text_IO.Get_Line (Text_File, TC_Data, TC_Length);
- Report.Failed ("Exception not raised by Get_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed ("Exception in Get_Line processing");
- end Test_for_Reading;
-
-
- Test_for_End_Of_File:
- declare
- TC_End_Of_File : Boolean;
- begin
-
--- Again, during the course of its processing, the application attempts to
--- call the End_Of_File function for the file that is currently in
--- Append_File mode (instead of the anticipated In_File mode).
-
- TC_End_Of_File := Text_IO.End_Of_File (Text_File);
- Report.Failed ("Exception not raised by End_Of_File");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_File processing");
- end Test_for_End_Of_File;
-
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a
deleted file mode 100644
index be658ca..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXAA013.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 exception Mode_Error is raised when an attempt is made
--- to skip a line or page using the predefined Skip_Line and Skip_Page
--- procedures on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, which
--- results in the raising of a Mode_Error exception.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA013 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA013" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA013", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to skip " &
- "a line or page using the predefined " &
- "Skip_Line and Skip_Page procedures on " &
- "a text file with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file with mode Append_File.
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
--- The application writes some amount of data to the file.
-
- Text_IO.Put_Line (Text_File, "Data entered into the file");
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Test_for_Skip_Line:
- declare
- TC_Spacing : constant Text_IO.Count := 3;
- begin
-
--- During the course of its processing, the application may attempt to
--- invoke the Skip_Line procedure on a file that is currently in Append_File
--- mode (instead of the anticipated In_File mode). This results in the
--- raising of Mode_Error.
-
- Text_IO.Skip_Line (Text_File, TC_Spacing);
- Report.Failed ("Exception not raised by Skip_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in Skip_Line processing");
- end Test_for_Skip_Line;
-
- Test_for_Skip_Page:
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- assumes that the file mode is In_File, this time attempting to call the
--- Skip_Page procedure for the file (that is currently in Append_File mode).
-
- Text_IO.Skip_Page (Text_File);
- Report.Failed ("Exception not raised by Skip_Page");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in Skip_Page processing");
- end Test_for_Skip_Page;
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA013;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a
deleted file mode 100644
index 0b74c61..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a
+++ /dev/null
@@ -1,178 +0,0 @@
--- CXAA014.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 exception Mode_Error is raised when an attempt is made
--- to check for the end of a line or page using the predefined functions
--- End_Of_Line or End_Of_Page on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, which
--- results in the raising of a Mode_Error exception.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA014 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA014" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA014", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to check " &
- "for the end of a line or page using the " &
- "predefined functions End_Of_Line or " &
- "End_Of_Page on a text file with mode " &
- "Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
--- The application writes some amount of data to the file.
-
- for I in 1 .. 10 loop
- Text_IO.Put_Line (Text_File, "Data entered into the file");
- end loop;
-
- Text_IO.Close (Text_File);
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
-
- Test_for_End_Of_Line:
- declare
- TC_End_Of_Line : Boolean;
- begin
-
--- During the course of its processing, the application may attempt to
--- invoke the End_Of_Line function on a file that is currently in Append_File
--- mode (instead of the anticipated In_File mode). This results in the
--- raising of Mode_Error.
-
- TC_End_Of_Line := Text_IO.End_Of_Line (Text_File);
- Report.Failed ("Exception not raised by End_Of_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_Line processing");
- end Test_for_End_Of_Line;
-
-
- Test_for_End_Of_Page:
- declare
- TC_End_Of_Page : Boolean;
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- assumes that the file mode is In_File, this time attempting to call the
--- End_Of_Page function for the file (that is currently in Append_File mode).
-
- TC_End_Of_Page := Text_IO.End_Of_Page (Text_File);
- Report.Failed ("Exception not raised by End_Of_Page");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_Page processing");
- end Test_for_End_Of_Page;
-
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA014;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a
deleted file mode 100644
index 919ef05..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CXAA015.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 exception Status_Error is raised when an attempt is
--- made to create or open a file in Append_File mode when the file is
--- already open.
--- Check that the exception Name_Error is raised by procedure Open when
--- attempting to open a file in Append_File mode when the name supplied
--- as the filename does not correspond to an existing external file.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- inappropriate usage of text processing subprograms Create and Open,
--- resulting in the raising of Status_Error and Name_Error exceptions.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA015 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA015" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA015", "Check that the appropriate exceptions " &
- "are raised when procedures Create and " &
- "Open are used to inappropriately operate " &
- "on files of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file with mode Append_File.
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename);
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
--- The application writes some amount of data to the file.
-
- for I in 1 .. 5 loop
- Text_IO.Put_Line (Text_File, "Data entered into the file");
- end loop;
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Errors : constant Natural := 3;
- TC_Errors : Natural := 0;
- begin
-
-
- Test_for_Create:
- begin
-
--- During the course of its processing, the application may (erroneously)
--- attempt to create the same file already in existence in Append_File mode.
--- This results in the raising of Status_Error.
-
- Text_IO.Create (Text_File,
- Text_IO.Append_File,
- Text_Filename);
- Report.Failed ("Exception not raised by Create");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Status_Error =>
- TC_Errors := TC_Errors + 1;
- when others =>
- Report.Failed("Exception in Create processing");
- end Test_for_Create;
-
-
- First_Test_For_Open:
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- attempts to Open a file (in Append_File mode) that is already open.
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
- Report.Failed ("Exception not raised by improper Open - 1");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Status_Error =>
- TC_Errors := TC_Errors + 1;
-
--- At some point in its processing, the application closes the file that is
--- currently open.
-
- Text_IO.Close (Text_File);
- when others =>
- Report.Failed("Exception in Open processing - 1");
- end First_Test_For_Open;
-
-
- Open_With_Wrong_Filename:
- declare
- TC_Wrong_Filename : constant String :=
- Report.Legal_File_Name(2);
- begin
-
--- At this point, the application attempts to Open (in Append_File mode) the
--- file used in previous processing, but it attempts this Open using a name
--- string that does not correspond to any existing external file.
--- First make sure the file doesn't exist. (If it did, then the check
--- for open in append mode wouldn't work.)
-
- Verify_No_File:
- begin
- Text_IO.Open (Text_File,
- Text_IO.In_File,
- TC_Wrong_Filename);
- exception
- when Text_IO.Name_Error =>
- null;
- when others =>
- Report.Failed ( "Unexpected exception on Open check" );
- end Verify_No_File;
-
- Delete_No_File:
- begin
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Unexpected exception - Delete check" );
- end Delete_No_File;
-
- Text_IO.Open (Text_File,
- Text_IO.Append_File,
- TC_Wrong_Filename);
- Report.Failed ("Exception not raised by improper Open - 2");
-
--- An exception handler for the Name_Error, present within the application,
--- catches the exception and processing continues.
-
- exception
- when Text_IO.Name_Error =>
- TC_Errors := TC_Errors + 1;
- when others =>
- Report.Failed("Exception in Open processing - 2");
- end Open_With_Wrong_Filename;
-
-
- if (TC_Errors /= TC_Number_Of_Forced_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a
deleted file mode 100644
index 8ae69a1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a
+++ /dev/null
@@ -1,462 +0,0 @@
--- CXAA016.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 type File_Access is available in Ada.Text_IO, and that
--- objects of this type designate File_Type objects.
--- Check that function Set_Error will set the current default error file.
--- Check that versions of Ada.Text_IO functions Standard_Input,
--- Standard_Output, Standard_Error return File_Access values designating
--- the standard system input, output, and error files.
--- Check that versions of Ada.Text_IO functions Current_Input,
--- Current_Output, Current_Error return File_Access values designating
--- the current system input, output, and error files.
---
--- TEST DESCRIPTION:
--- This test tests the use of File_Access objects in referring
--- to File_Type objects, as well as several new functions that return
--- File_Access objects as results.
--- Four user-defined files are created. These files will be set to
--- function as current system input, output, and error files.
--- Data will be read from and written to these files during the
--- time at which they function as the current system files.
--- An array of File_Access objects will be defined. It will be
--- initialized using functions that return File_Access objects
--- referencing the Standard and Current Input, Output, and Error files.
--- This "saves" the initial system environment, which will be modified
--- to use the user-defined files as the current default Input, Output,
--- and Error files. At the end of the test, the data in this array
--- will be used to restore the initial system environment.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations capable of supporting
--- external Text_IO files.
---
---
--- CHANGE HISTORY:
--- 25 May 95 SAIC Initial prerelease version.
--- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
--- 18 Jan 99 RLB Repaired to allow Not_Applicable systems to
--- fail delete.
---!
-
-with Ada.Text_IO;
-package CXAA016_0 is
- New_Input_File,
- New_Output_File,
- New_Error_File_1,
- New_Error_File_2 : aliased Ada.Text_IO.File_Type;
-end CXAA016_0;
-
-
-with Report;
-with Ada.Exceptions;
-with Ada.Text_IO; use Ada.Text_IO;
-with CXAA016_0; use CXAA016_0;
-
-procedure CXAA016 is
-
- Non_Applicable_System : exception;
- No_Reset : exception;
- Not_Applicable_System : Boolean := False;
-
- procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type;
- ID_Num : in Integer ) is
- begin
- if not Ada.Text_IO.Is_Open ( A_File ) then
- Ada.Text_IO.Open ( A_File,
- Ada.Text_IO.In_File,
- Report.Legal_File_Name ( ID_Num ) );
- end if;
- Ada.Text_IO.Delete ( A_File );
- exception
- when Ada.Text_IO.Name_Error =>
- if Not_Applicable_System then
- null; -- File probably wasn't created.
- else
- Report.Failed ( "Can't open file for Text_IO" );
- end if;
- when Ada.Text_IO.Use_Error =>
- if Not_Applicable_System then
- null; -- File probably wasn't created.
- else
- Report.Failed ( "Delete not properly implemented for Text_IO" );
- end if;
- when others =>
- Report.Failed ( "Unexpected exception in Delete_File" );
- end Delete_File;
-
-begin
-
- Report.Test ("CXAA016", "Check that the type File_Access is available " &
- "in Ada.Text_IO, and that objects of this " &
- "type designate File_Type objects");
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- type System_File_Array_Type is
- array (Integer range <>) of File_Access;
-
- -- Fill the following array with the File_Access results of six
- -- functions.
-
- Initial_Environment : System_File_Array_Type(1..6) :=
- ( Standard_Input,
- Standard_Output,
- Standard_Error,
- Current_Input,
- Current_Output,
- Current_Error );
-
- New_Input_Ptr : File_Access := New_Input_File'Access;
- New_Output_Ptr : File_Access := New_Output_File'Access;
- New_Error_Ptr : File_Access := New_Error_File_1'Access;
-
- Line : String(1..80);
- Length : Natural := 0;
-
- Line_1 : constant String := "This is the first line in the Output file";
- Line_2 : constant String := "This is the next line in the Output file";
- Line_3 : constant String := "This is the first line in Error file 1";
- Line_4 : constant String := "This is the next line in Error file 1";
- Line_5 : constant String := "This is the first line in Error file 2";
- Line_6 : constant String := "This is the next line in Error file 2";
-
-
-
- procedure New_File (The_File : in out File_Type;
- Mode : in File_Mode;
- Next : in Integer) is
- begin
- Create (The_File, Mode, Report.Legal_File_Name(Next));
- exception
- -- The following two exceptions may be raised if a system is not
- -- capable of supporting external Text_IO files. The handler will
- -- raise a user-defined exception which will result in a
- -- Not_Applicable result for the test.
- when Use_Error | Name_Error => raise Non_Applicable_System;
- end New_File;
-
-
-
- procedure Check_Initial_Environment (Env : System_File_Array_Type) is
- begin
- -- Check that the system has defined the following sources/
- -- destinations for input/output/error, and that the six functions
- -- returning File_Access values are available.
- if not (Env(1) = Standard_Input and
- Env(2) = Standard_Output and
- Env(3) = Standard_Error and
- Env(4) = Current_Input and
- Env(5) = Current_Output and
- Env(6) = Current_Error)
- then
- Report.Failed("At the start of the test, the Standard and " &
- "Current File_Access values associated with " &
- "system Input, Output, and Error files do " &
- "not correspond");
- end if;
- end Check_Initial_Environment;
-
-
-
- procedure Load_Input_File (Input_Ptr : in File_Access) is
- begin
- -- Load data into the file that will function as the user-defined
- -- system input file.
- Put_Line(Input_Ptr.all, Line_1);
- Put_Line(Input_Ptr.all, Line_2);
- Put_Line(Input_Ptr.all, Line_3);
- Put_Line(Input_Ptr.all, Line_4);
- Put_Line(Input_Ptr.all, Line_5);
- Put_Line(Input_Ptr.all, Line_6);
- end Load_Input_File;
-
-
-
- procedure Restore_Initial_Environment
- (Initial_Env : System_File_Array_Type) is
- begin
- -- Restore the Current Input, Output, and Error files to their
- -- original states.
-
- Set_Input (Initial_Env(4).all);
- Set_Output(Initial_Env(5).all);
- Set_Error (Initial_Env(6).all);
-
- -- At this point, the user-defined files that were functioning as
- -- the Current Input, Output, and Error files have been replaced in
- -- that capacity by the state of the original environment.
-
- declare
-
- -- Capture the state of the current environment.
-
- Current_Env : System_File_Array_Type (1..6) :=
- (Standard_Input, Standard_Output, Standard_Error,
- Current_Input, Current_Output, Current_Error);
- begin
-
- -- Compare the current environment with that of the saved
- -- initial environment.
-
- if Current_Env /= Initial_Env then
- Report.Failed("Restored file environment was not the same " &
- "as the initial file environment");
- end if;
- end;
- end Restore_Initial_Environment;
-
-
-
- procedure Verify_Files (O_File, E_File_1, E_File_2 : in File_Type) is
- Str_1, Str_2, Str_3, Str_4, Str_5, Str_6 : String (1..80);
- Len_1, Len_2, Len_3, Len_4, Len_5, Len_6 : Natural;
- begin
-
- -- Get the lines that are contained in all the files, and verify
- -- them against the expected results.
-
- Get_Line(O_File, Str_1, Len_1); -- The user defined output file
- Get_Line(O_File, Str_2, Len_2); -- should contain two lines of data.
-
- if Str_1(1..Len_1) /= Line_1 or
- Str_2(1..Len_2) /= Line_2
- then
- Report.Failed("Incorrect results from Current_Output file");
- end if;
-
- Get_Line(E_File_1, Str_3, Len_3); -- The first error file received
- Get_Line(E_File_1, Str_4, Len_4); -- two lines of data originally,
- Get_Line(E_File_1, Str_5, Len_5); -- then had two additional lines
- Get_Line(E_File_1, Str_6, Len_6); -- appended from the second error
- -- file.
- if Str_3(1..Len_3) /= Line_3 or
- Str_4(1..Len_4) /= Line_4 or
- Str_5(1..Len_5) /= Line_5 or
- Str_6(1..Len_6) /= Line_6
- then
- Report.Failed("Incorrect results from first Error file");
- end if;
-
- Get_Line(E_File_2, Str_5, Len_5); -- The second error file
- Get_Line(E_File_2, Str_6, Len_6); -- received two lines of data.
-
- if Str_5(1..Len_5) /= Line_5 or
- Str_6(1..Len_6) /= Line_6
- then
- Report.Failed("Incorrect results from second Error file");
- end if;
-
- end Verify_Files;
-
-
-
- begin
-
- Check_Initial_Environment (Initial_Environment);
-
- -- Create user-defined text files that will be set to serve as current
- -- system input, output, and error files.
-
- New_File (New_Input_File, Out_File, 1); -- Will be reset prior to use.
- New_File (New_Output_File, Out_File, 2);
- New_File (New_Error_File_1, Out_File, 3);
- New_File (New_Error_File_2, Out_File, 4);
-
- -- Enter several lines of text into the new input file. This file will
- -- be reset to mode In_File to function as the current system input file.
- -- Note: File_Access value used as parameter to this procedure.
-
- Load_Input_File (New_Input_Ptr);
-
- -- Reset the New_Input_File to mode In_File, to allow it to act as the
- -- current system input file.
-
- Reset1:
- begin
- Reset (New_Input_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 1" );
- raise No_Reset;
- end Reset1;
-
- -- Establish new files that will function as the current system Input,
- -- Output, and Error files.
-
- Set_Input (New_Input_File);
- Set_Output(New_Output_Ptr.all);
- Set_Error (New_Error_Ptr.all);
-
- -- Perform various file processing tasks, exercising specific new
- -- Text_IO functionality.
- --
- -- Read two lines from Current_Input and write them to Current_Output.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Output, Line(1..Length));
- end loop;
-
- -- Read two lines from Current_Input and write them to Current_Error.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- Reset the Current system error file.
-
- Set_Error (New_Error_File_2);
-
- -- Read two lines from Current_Input and write them to Current_Error.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- At this point in the processing, the new Output file, and each of
- -- the two Error files, contain two lines of data.
- -- Note that New_Error_File_1 has been replaced by New_Error_File_2
- -- as the current system error file, allowing New_Error_File_1 to be
- -- reset (Mode_Error raised otherwise).
- --
- -- Reset the first Error file to Append_File mode, and then set it to
- -- function as the current system error file.
-
- Reset2:
- begin
- Reset (New_Error_File_1, Append_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO - 2" );
- raise No_Reset;
- end Reset2;
-
- Set_Error (New_Error_File_1);
-
- -- Reset the second Error file to In_File mode, then set it to become
- -- the current system input file.
-
- Reset3:
- begin
- Reset (New_Error_File_2, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 3" );
- raise No_Reset;
- end Reset3;
-
- New_Error_Ptr := New_Error_File_2'Access;
- Set_Input (New_Error_Ptr.all);
-
- -- Append all of the text lines (2) in the new current system input
- -- file onto the current system error file.
-
- while not End_Of_File(Current_Input) loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- Restore the original system file environment, based upon the values
- -- stored at the start of this test.
- -- Check that the original environment has been restored.
-
- Restore_Initial_Environment (Initial_Environment);
-
- -- Reset all three files to In_File_Mode prior to verification.
- -- Note: If these three files had still been the designated Current
- -- Input, Output, or Error files for the system, a Reset
- -- operation at this point would raise Mode_Error.
- -- However, at this point, the environment has been restored to
- -- its original state, and these user-defined files are no longer
- -- designated as current system files, allowing a Reset.
-
- Reset4:
- begin
- Reset(New_Error_File_1, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 4" );
- raise No_Reset;
- end Reset4;
-
- Reset5:
- begin
- Reset(New_Error_File_2, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 5" );
- raise No_Reset;
- end Reset5;
-
- Reset6:
- begin
- Reset(New_Output_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 6" );
- raise No_Reset;
- end Reset6;
-
- -- Check that all the files contain the appropriate data.
-
- Verify_Files (New_Output_File, New_Error_File_1, New_Error_File_2);
-
- exception
- when No_Reset =>
- null;
- when Non_Applicable_System =>
- Report.Not_Applicable("System not capable of supporting external " &
- "text files -- Name_Error/Use_Error raised " &
- "during text file creation");
- Not_Applicable_System := True;
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Delete_Block:
- begin
- Delete_File ( New_Input_File, 1 );
- Delete_File ( New_Output_File, 2 );
- Delete_File ( New_Error_File_1, 3 );
- Delete_File ( New_Error_File_2, 4 );
- end Delete_Block;
-
- Report.Result;
-
-end CXAA016;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a
deleted file mode 100644
index 17d0922..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a
+++ /dev/null
@@ -1,400 +0,0 @@
--- CXAA017.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 Ada.Text_IO function Look_Ahead sets parameter End_Of_Line
--- to True if at the end of a line; otherwise check that it returns the
--- next character from a file (without consuming it), while setting
--- End_Of_Line to False.
---
--- Check that Ada.Text_IO function Get_Immediate will return the next
--- control or graphic character in parameter Item from the specified
--- file. Check that the version of Ada.Text_IO function Get_Immediate
--- with the Available parameter will, if a character is available in the
--- specified file, return the character in parameter Item, and set
--- parameter Available to True.
---
--- TEST DESCRIPTION:
--- This test exercises specific capabilities of two Text_IO subprograms,
--- Look_Ahead and Get_Immediate. A file is prepared that contains a
--- variety of graphic and control characters on several lines.
--- In processing this file, a call to Look_Ahead is performed to ensure
--- that characters are available, then individual characters are
--- extracted from the current line using Get_Immediate. The characters
--- returned from both subprogram calls are compared with the expected
--- character result. Processing on each file line continues until
--- Look_Ahead indicates that the end of the line is next. Separate
--- verification is performed to ensure that all characters of each line
--- are processed, and that the Available and End_Of_Line parameters
--- of the subprograms are properly set in the appropriate instances.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations capable of supporting
--- external Text_IO files.
---
---
--- CHANGE HISTORY:
--- 30 May 95 SAIC Initial prerelease version.
--- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-package CXAA017_0 is
-
- User_Defined_Input_File : aliased Ada.Text_IO.File_Type;
-
-end CXAA017_0;
-
-
-with CXAA017_0; use CXAA017_0;
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA017 is
-
- use Ada.Characters.Latin_1;
- use Ada.Exceptions;
- use Ada.Text_IO;
-
- Non_Applicable_System : exception;
- No_Reset : exception;
-
-begin
-
- Report.Test ("CXAA017", "Check that Ada.Text_IO subprograms " &
- "Look_Ahead and Get_Immediate are available " &
- "and produce correct results");
-
- Test_Block:
- declare
-
- User_Input_Ptr : File_Access := User_Defined_Input_File'Access;
-
- UDLA_Char, -- Acronym UDLA => "User Defined Look Ahead"
- UDGI_Char, -- Acronym UDGI => "User Defined Get Immediate"
- TC_Char : Character := Ada.Characters.Latin_1.NUL;
-
- UDLA_End_Of_Line,
- UDGI_Available : Boolean := False;
-
- Char_Pos : Natural;
-
- -- This string contains five ISO 646 Control characters and six ISO 646
- -- Graphic characters:
- TC_String_1 : constant String := STX &
- SI &
- DC2 &
- CAN &
- US &
- Space &
- Ampersand &
- Solidus &
- 'A' &
- LC_X &
- DEL;
-
- -- This string contains two ISO 6429 Control and six ISO 6429 Graphic
- -- characters:
- TC_String_2 : constant String := IS4 &
- SCI &
- Yen_Sign &
- Masculine_Ordinal_Indicator &
- UC_I_Grave &
- Multiplication_Sign &
- LC_C_Cedilla &
- LC_Icelandic_Thorn;
-
- TC_Number_Of_Strings : constant := 2;
-
- type String_Access_Type is access constant String;
- type String_Ptr_Array_Type is
- array (1..TC_Number_Of_Strings) of String_Access_Type;
-
- TC_String_Ptr_Array : String_Ptr_Array_Type :=
- (new String'(TC_String_1),
- new String'(TC_String_2));
-
-
-
- procedure Create_New_File (The_File : in out File_Type;
- Mode : in File_Mode;
- Next : in Integer) is
- begin
- Create (The_File, Mode, Report.Legal_File_Name(Next));
- exception
- -- The following two exceptions can be raised if a system is not
- -- capable of supporting external Text_IO files. The handler will
- -- raise a user-defined exception which will result in a
- -- Not_Applicable result for the test.
- when Use_Error | Name_Error => raise Non_Applicable_System;
- end Create_New_File;
-
-
-
- procedure Load_File (The_File : in out File_Type) is
- -- This procedure will load several strings into the file denoted
- -- by the input parameter. A call to New_Line will add line/page
- -- termination characters, which will be available for processing
- -- along with the text in the file.
- begin
- Put_Line (The_File, TC_String_Ptr_Array(1).all);
- New_Line (The_File, Spacing => 1);
- Put_Line (The_File, TC_String_Ptr_Array(2).all);
- end Load_File;
-
-
- begin
-
- -- Create user-defined text file that will serve as the appropriate
- -- sources of input to the procedures under test.
-
- Create_New_File (User_Defined_Input_File, Out_File, 1);
-
- -- Enter several lines of text into the new input file.
- -- The characters that make up these text strings will be processed
- -- using the procedures being exercised in this test.
-
- Load_File (User_Defined_Input_File);
-
- -- Check that Mode_Error is raised by Look_Ahead and Get_Immedidate
- -- if the mode of the file object is not In_File.
- -- Currently, the file mode is Out_File.
-
- begin
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
- Report.Failed("Mode_Error not raised by Look_Ahead");
- Report.Comment("This char should never be printed: " & UDLA_Char);
- exception
- when Mode_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed ("The following exception was raised during the " &
- "check that Look_Ahead raised Mode_Error when " &
- "provided a file object that is not in In_File " &
- "mode: " & Exception_Name(The_Error));
- end;
-
- begin
- Get_Immediate(User_Defined_Input_File, UDGI_Char);
- Report.Failed("Mode_Error not raised by Get_Immediate");
- Report.Comment("This char should never be printed: " & UDGI_Char);
- exception
- when Mode_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed ("The following exception was raised during the " &
- "check that Get_Immediate raised Mode_Error " &
- "when provided a file object that is not in " &
- "In_File mode: " & Exception_Name(The_Error));
- end;
-
-
- -- The file will then be reset to In_File mode to properly function as
- -- a source of input.
-
- Reset1:
- begin
- Reset (User_Defined_Input_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise No_Reset;
- end Reset1;
-
- -- Process the input file, exercising various Text_IO
- -- functionality, and validating the results at each step.
- -- Note: The designated File_Access object is used in processing
- -- the New_Default_Input_File in the second loop below.
-
- -- Process characters in first line of text of each file.
-
- Char_Pos := 1;
-
- -- Check that the first line is not blank.
-
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
-
- while not UDLA_End_Of_Line loop
-
- -- Use the Get_Immediate procedure on the file to get the next
- -- available character on the current line.
-
- Get_Immediate(User_Defined_Input_File, UDGI_Char);
-
- -- Check that the characters returned by both procedures are the
- -- same, and that they match the expected character from the file.
-
- if UDLA_Char /= TC_String_Ptr_Array(1).all(Char_Pos) or
- UDGI_Char /= TC_String_Ptr_Array(1).all(Char_Pos)
- then
- Report.Failed("Incorrect retrieval of character " &
- Integer'Image(Char_Pos) & " of first string");
- end if;
-
- -- Increment the character position counter.
- Char_Pos := Char_Pos + 1;
-
- -- Check the next character on the line. If at the end of line,
- -- the processing flow will exit the While loop.
-
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
-
- end loop;
-
- -- Check to ensure that the "end of line" results returned from the
- -- Look_Ahead procedure (used to exit the above While loop) corresponds
- -- with the result of Function End_Of_Line.
-
- if not End_Of_Line(User_Defined_Input_File)
- then
- Report.Failed("Result of procedure Look_Ahead that indicated " &
- "being at the end of the line does not correspond " &
- "with the result of function End_Of_Line");
- end if;
-
- -- Check that all characters in the string were processed.
-
- if Char_Pos-1 /= TC_String_1'Length then
- Report.Failed("Not all of the characters on the first line " &
- "were processed");
- end if;
-
-
- -- Call procedure Skip_Line to advance beyond the end of the first line.
-
- Skip_Line(User_Defined_Input_File);
-
-
- -- Process the second line in the file (a blank line).
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- if not UDLA_End_Of_Line then
- Report.Failed("Incorrect end of line determination from procedure " &
- "Look_Ahead when processing a blank line");
- end if;
-
- -- Call procedure Skip_Line to advance beyond the end of the second line.
-
- Skip_Line(User_Input_Ptr.all);
-
-
- -- Process characters in the third line of the file (second line
- -- of text)
- -- Note: The version of Get_Immediate used in processing this line has
- -- the Boolean parameter Available.
-
- Char_Pos := 1;
-
- -- Check whether the line is blank (i.e., at end of line, page, or file).
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- while not UDLA_End_Of_Line loop
-
- -- Use the Get_Immediate procedure on the file to get access to the
- -- next character on the current line.
-
- Get_Immediate(User_Input_Ptr.all, UDGI_Char, UDGI_Available);
-
- -- Check that the Available parameter of Get_Immediate was set
- -- to indicate that a character was available in the file.
- -- Check that the characters returned by both procedures are the
- -- same, and they all match the expected character from the file.
-
- if not UDGI_Available or
- UDLA_Char /= TC_String_Ptr_Array(2).all(Char_Pos) or
- UDGI_Char /= TC_String_Ptr_Array(2).all(Char_Pos)
- then
- Report.Failed("Incorrect retrieval of character " &
- Integer'Image(Char_Pos) & " of second string");
- end if;
-
- -- Increment the character position counter.
-
- Char_Pos := Char_Pos + 1;
-
- -- Check the next character on the line. If at the end of line,
- -- the processing flow will exit the While loop.
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- end loop;
-
- -- Check to ensure that the "end of line" results returned from the
- -- Look_Ahead procedure (used to exit the above While loop) corresponds
- -- with the result of Function End_Of_Line.
-
- if not End_Of_Line(User_Defined_Input_File)
- then
- Report.Failed("Result of procedure Look_Ahead that indicated " &
- "being at the end of the line does not correspond " &
- "with the result of function End_Of_Line");
- end if;
-
- -- Check that all characters in the second string were processed.
-
- if Char_Pos-1 /= TC_String_2'Length then
- Report.Failed("Not all of the characters on the second line " &
- "were processed");
- end if;
-
-
- Deletion:
- begin
- -- Delete the user defined file.
-
- if Is_Open(User_Defined_Input_File) then
- Delete(User_Defined_Input_File);
- else
- Open(User_Defined_Input_File, Out_File, Report.Legal_File_Name(1));
- Delete(User_Defined_Input_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
-
- exception
-
- when No_Reset =>
- null;
-
- when Non_Applicable_System =>
- Report.Not_Applicable("System not capable of supporting external " &
- "text files -- Name_Error/Use_Error raised " &
- "during text file creation");
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXAA017;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a
deleted file mode 100644
index 53b16fe..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a
+++ /dev/null
@@ -1,277 +0,0 @@
--- CXAA018.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 subprograms defined in the package Text_IO.Modular_IO
--- provide correct results.
---
--- TEST DESCRIPTION:
--- This test checks that the subprograms defined in the
--- Ada.Text_IO.Modular_IO package provide correct results.
--- A modular type is defined and used to instantiate the generic
--- package Ada.Text_IO.Modular_IO. Values of the modular type are
--- written to a Text_IO file, and to a series of string variables, using
--- different versions of the procedure Put from the instantiated IO
--- package. These modular data items are retrieved from the file and
--- string variables using the appropriate instantiated version of
--- procedure Get. A variety of Base and Width parameter values are
--- used in the procedure calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 03 Jul 95 SAIC Initial prerelease version.
--- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Text_IO;
-with System;
-with Report;
-
-procedure CXAA018 is
-begin
-
- Report.Test ("CXAA018", "Check that the subprograms defined in " &
- "the package Text_IO.Modular_IO provide " &
- "correct results");
-
- Test_for_Text_IO_Support:
- declare
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String := Report.Legal_File_Name;
- begin
-
- -- An application creates a text file in mode Out_File, with the
- -- intention of entering modular data into the file as appropriate.
- -- In the event that the particular environment where the application
- -- is running does not support Text_IO, Use_Error or Name_Error will be
- -- raised on calls to Text_IO operations. Either of these exceptions
- -- will be handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (File => Data_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Data_Filename);
-
- Test_Block:
- declare
-
- type Mod_Type is mod System.Max_Binary_Modulus;
- -- Max_Binary_Modulus must be at least 2**16, which would result
- -- in a base range of 0..65535 (zero to one less than the given
- -- modulus) for this modular type.
-
- package Mod_IO is new Ada.Text_IO.Modular_IO(Mod_Type);
- use Ada.Text_IO, Mod_IO;
- use type Mod_Type;
-
- Number_Of_Modular_Items : constant := 6;
- Number_Of_Error_Items : constant := 1;
-
- TC_Modular : Mod_Type;
- TC_Last_Character_Read : Positive;
-
- Modular_Array : array (1..Number_Of_Modular_Items) of Mod_Type :=
- ( 0, 97, 255, 1025, 12097, 65535 );
-
-
- procedure Load_File (The_File : in out Ada.Text_IO.File_Type) is
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- This procedure is designed to load Modular_Type data into a
- -- data file.
- --
- -- Use the Modular_IO procedure Put to enter modular data items
- -- into the data file.
-
- for i in 1..Number_Of_Modular_Items loop
- -- Use default Base parameter of 10.
- Mod_IO.Put(File => Data_File,
- Item => Modular_Array(i),
- Width => 6,
- Base => Mod_IO.Default_Base);
- end loop;
-
- -- Enter data into the file such that on the corresponding "Get"
- -- of this data, Data_Error must be raised. This value is outside
- -- the base range of Modular_Type.
- -- Text_IO is used to enter the value in the file.
-
- for i in 1..Number_Of_Error_Items loop
- Ada.Text_IO.Put(The_File, "-10");
- end loop;
-
- end Load_File;
-
-
-
- procedure Process_File(The_File : in out Ada.Text_IO.File_Type) is
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- Use procedure Get (for Files) to extract the modular data from
- -- the Text_IO file.
-
- for i in 1..Number_Of_Modular_Items loop
- Mod_IO.Get(The_File, TC_Modular, Width => 6);
-
- if TC_Modular /= Modular_Array(i) then
- Report.Failed("Incorrect modular data read from file " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- -- The final item in the Data_File is a modular value that is
- -- outside the base range 0..Num'Last. This value should raise
- -- Data_Error on an attempt to "Get" it from the file.
-
- for i in 1..Number_Of_Error_Items loop
- begin
- Mod_IO.Get(The_File, TC_Modular, Mod_IO.Default_Width);
- Report.Failed
- ("Exception Data_Error not raised when Get " &
- "was used to read modular data outside base " &
- "range of type, item # " &
- Integer'Image(i));
- exception
- when Ada.Text_IO.Data_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised when Get " &
- "was used to read modular data outside " &
- "base range of type from Data_File, " &
- "data item #" & Integer'Image(i));
- end;
- end loop;
-
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised in Process_File");
- end Process_File;
-
-
-
- begin -- Test_Block.
-
- -- Place modular values into data file.
-
- Load_File(Data_File);
- Ada.Text_IO.Close(Data_File);
-
- -- Read modular values from data file.
-
- Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename);
- Process_File(Data_File);
-
- -- Verify versions of Modular_IO procedures Put and Get for Strings.
-
- Modular_IO_in_Strings:
- declare
- TC_String_Array : array (1..Number_Of_Modular_Items)
- of String(1..30) := (others =>(others => ' '));
- begin
-
- -- Place modular values into strings using the Procedure Put,
- -- Use a variety of different "Base" parameter values.
- -- Note: This version of Put uses the length of the given
- -- string as the value of the "Width" parameter.
-
- for i in 1..2 loop
- Mod_IO.Put(To => TC_String_Array(i),
- Item => Modular_Array(i),
- Base => Mod_IO.Default_Base);
- end loop;
- for i in 3..4 loop
- Mod_IO.Put(TC_String_Array(i),
- Modular_Array(i),
- Base => 2);
- end loop;
- for i in 5..6 loop
- Mod_IO.Put(TC_String_Array(i), Modular_Array(i), 16);
- end loop;
-
- -- Get modular values from strings using the Procedure Get.
- -- Compare with expected modular values.
-
- for i in 1..Number_Of_Modular_Items loop
-
- Mod_IO.Get(From => TC_String_Array(i),
- Item => TC_Modular,
- Last => TC_Last_Character_Read);
-
- if TC_Modular /= Modular_Array(i) then
- Report.Failed("Incorrect modular data value obtained " &
- "from String following use of Procedures " &
- "Put and Get from Strings, Modular_Array " &
- "item #" & Integer'Image(i));
- end if;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Put and Get for Strings");
- end Modular_IO_in_Strings;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Delete(Data_File);
- else
- Ada.Text_IO.Open(Data_File,
- Ada.Text_IO.In_File,
- Data_Filename);
- Ada.Text_IO.Delete(Data_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Ada.Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on text file Create");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXAA018;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a
deleted file mode 100644
index 04c257e9..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- CXAA019.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 Standard_Output can be flushed. Check that 'in' parameters of
--- types Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type can be
--- flushed. (Defect Report 8652/0051).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 16 MAR 2001 RLB Readied for release; fixed Not_Applicable check
--- to terminate test gracefully.
---
---!
-with Ada.Streams.Stream_Io;
-use Ada.Streams;
-with Ada.Text_Io;
-with Ada.Wide_Text_Io;
-with Report;
-use Report;
-procedure CXAA019 is
-
- procedure Check (File : in Ada.Text_Io.File_Type) is
- begin
- Ada.Text_Io.Put_Line
- (File, " - CXAA019 About to flush a Text_IO file passed " &
- "as 'in' parameter");
- Ada.Text_Io.Flush (File);
- end Check;
-
- procedure Check (File : in Ada.Wide_Text_Io.File_Type) is
- begin
- Ada.Wide_Text_Io.Put_Line
- (File, " - CXAA019 About to flush a Wide_Text_IO file passed " &
- "as 'in' parameter");
- Ada.Wide_Text_Io.Flush (File);
- end Check;
-
- procedure Check (File : in Stream_Io.File_Type) is
- S : Stream_Element_Array (1 .. 10);
- begin
- for I in S'Range loop
- S (I) := Stream_Element (Character'Pos ('A') + I);
- end loop;
- Stream_Io.Write (File, S);
- Comment ("About to flush a Stream_IO file passed as 'in' parameter");
- Stream_Io.Flush (File);
- end Check;
-
-
-begin
- Test ("CXAA019",
- "Check that Standard_Output can be flushed; check that " &
- "'in' Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type" &
- "parameters can be flushed");
-
- Ada.Text_Io.Put_Line (Ada.Text_Io.Standard_Output,
- " - CXAA019 About to flush Standard_Output");
- Ada.Text_Io.Flush (Ada.Text_Io.Standard_Output);
-
- Check (Ada.Text_Io.Current_Output);
-
- declare
- TC_OK : Boolean := False;
- F : Ada.Text_Io.File_Type;
- begin
- begin
- Ada.Text_Io.Create (F, Name => Legal_File_Name (X => 1));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Text_IO file");
- end;
- if TC_OK then
- Check (F);
- Ada.Text_Io.Delete (F);
- end if;
- end;
-
- declare
- TC_OK : Boolean := False;
- F : Ada.Wide_Text_Io.File_Type;
- begin
- begin
- Ada.Wide_Text_Io.Create (F, Name => Legal_File_Name (X => 2));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Wide_Text_IO file");
- end;
- if TC_OK then
- Check (F);
- Ada.Wide_Text_Io.Delete (F);
- end if;
- end;
-
- declare
- TC_OK : Boolean := False;
- F : Stream_Io.File_Type;
- begin
- begin
- Stream_Io.Create (F, Name => Legal_File_Name (X => 3));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Stream_IO file");
- end;
- if TC_OK then
- Check (F);
- Stream_Io.Delete (F);
- end if;
- end;
-
- Result;
-end CXAA019;
-
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a
deleted file mode 100644
index 483acd1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a
+++ /dev/null
@@ -1,272 +0,0 @@
--- CXAB001.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 operations defined in package Wide_Text_IO allow for
--- the input/output of Wide_Character and Wide_String data.
---
--- TEST DESCRIPTION:
--- This test is designed to exercise the components of the Wide_Text_IO
--- package, including the Put/Get utilities for Wide_Characters and
--- Wide_String objects.
--- The test utilizes the Put and Get procedures defined for
--- Wide_Characters, as well as the Put, Get, Put_Line, and Get_Line
--- procedures defined for Wide_Strings. In addition, many of the
--- additional subprograms found in package Wide_Text_IO are used in this
--- test.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Wide_Text_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with Ada.Wide_Text_IO;
-with Report;
-
-procedure CXAB001 is
-
- Filter_File : Ada.Wide_Text_IO.File_Type;
- Filter_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAB001" );
- Incomplete : exception;
-
-
-begin
-
- Report.Test ("CXAB001", "Check that the operations defined in package " &
- "Wide_Text_IO allow for the input/output of " &
- "Wide_Character and Wide_String data");
-
-
- Test_for_Wide_Text_IO_Support:
- begin
-
- -- An implementation that does not support Wide_Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Wide_Text_IO operations. This block statement encloses a call to
- -- Create, which should raise an exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Ada.Wide_Text_IO.Create (File => Filter_File, -- Create.
- Mode => Ada.Wide_Text_IO.Out_File,
- Name => Filter_Filename);
-
- exception
-
- when Ada.Wide_Text_IO.Use_Error | Ada.Wide_Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Wide_Text_IO" );
- raise Incomplete;
-
- end Test_for_Wide_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- First_String : constant Wide_String := "Somewhere ";
- Second_String : constant Wide_String := "Over The ";
- Third_String : constant Wide_String := "Rainbow";
- Current_Char : Wide_Character := ' ';
-
- begin
-
- Enter_Data_In_File:
- declare
- Pos : Natural := 1;
- Bad_Character_Found : Boolean := False;
- begin
- -- Use the Put procedure defined for Wide_Character data to
- -- write all of the wide characters of the First_String into
- -- the file individually, followed by a call to New_Line.
-
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Put (Filter_File, First_String (Pos)); -- Put.
- Pos := Pos + 1;
- end loop;
- Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line.
-
- -- Reset to In_File mode and read file contents, using the Get
- -- procedure defined for Wide_Character data.
- Reset1:
- begin
- Ada.Wide_Text_IO.Reset (Filter_File, -- Reset.
- Ada.Wide_Text_IO.In_File);
- exception
- when Ada.Wide_Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Wide_Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Pos := 1;
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get.
- -- Verify the wide character against the original string.
- if Current_Char /= First_String(Pos) then
- Bad_Character_Found := True;
- end if;
- Pos := Pos + 1;
- end loop;
-
- if Bad_Character_Found then
- Report.Failed ("Incorrect Wide_Character read from file - 1");
- end if;
-
- -- Following user file/string processing, the Wide_String data
- -- of the Second_String and Third_String Wide_String objects are
- -- appended to the file.
- -- The Put procedure defined for Wide_String data is used to
- -- transfer the Second_String, followed by a call to New_Line.
- -- The Put_Line procedure defined for Wide_String data is used
- -- to transfer the Third_String.
- Reset2:
- begin
- Ada.Wide_Text_IO.Reset (Filter_File, -- Reset.
- Ada.Wide_Text_IO.Append_File);
-
- exception
- when Ada.Wide_Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Wide_Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Wide_Text_IO.Put (Filter_File, Second_String); -- Put.
- Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line.
-
- Ada.Wide_Text_IO.Put_Line (Filter_File, Third_String); -- Put_Line.
- Ada.Wide_Text_IO.Close (Filter_File); -- Close.
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception in Enter_Data_In_File block");
- raise;
-
- end Enter_Data_In_File;
-
- ---
-
- Filter_Block:
- declare
-
- Pos : Positive := 1;
- TC_String2 : Wide_String (1..Second_String'Length);
- TC_String3 : Wide_String (1..Third_String'Length);
- Last : Natural := Natural'First;
-
- begin
-
- Ada.Wide_Text_IO.Open (Filter_File, -- Open.
- Ada.Wide_Text_IO.In_File,
- Filter_Filename);
-
-
- -- Read the data of the First_String from the file, using the
- -- Get procedure defined for Wide_Character data.
- -- Verify that the character corresponds to the data originally
- -- written to the file.
-
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get.
- if Current_Char /= First_String(Pos) then
- Report.Failed
- ("Incorrect Wide_Character read from file - 2");
- end if;
- Pos := Pos + 1;
- end loop;
-
- -- The first line of the file has been read, move to the second.
- Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line.
-
- -- Read the Wide_String data from the second and third lines of
- -- the file.
- Ada.Wide_Text_IO.Get (Filter_File, TC_String2); -- Get.
- Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line.
- Ada.Wide_Text_IO.Get_Line (Filter_File, -- Get_Line.
- TC_String3, Last);
-
- -- Verify data of second and third strings.
- if TC_String2 /= Second_String then
- Report.Failed ("Incorrect Wide_String read from file - 1");
- end if;
- if TC_String3 /= Third_String then
- Report.Failed ("Incorrect Wide_String read from file - 2");
- end if;
-
- -- The file should now be at EOF.
- if not Ada.Wide_Text_IO.End_Of_File (Filter_File) then -- EOF.
- Report.Failed ("File not empty following filtering");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception in Filter_Block");
- raise;
- end Filter_Block;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Wide_Text_IO.Is_Open (Filter_File) then -- Is_Open.
- Ada.Wide_Text_IO.Delete (Filter_File); -- Delete.
- else
- Ada.Wide_Text_IO.Open (Filter_File, -- Open.
- Ada.Wide_Text_IO.Out_File,
- Filter_Filename);
- Ada.Wide_Text_IO.Delete (Filter_File); -- Delete.
- end if;
- exception
- when others =>
- Report.Failed ("Delete not properly implemented for Wide_Text_IO");
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAB001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a
deleted file mode 100644
index a77d561..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXAC001.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 attribute T'Write will, for any specific non-limited
--- type T, write an item of the subtype to the stream.
---
--- Check that the attribute T'Read will, for a specific non-limited
--- type T, read a value of the subtype from the stream.
---
--- TEST DESCRIPTION:
--- The scenario depicted in this test is that of an environment where
--- product data is stored in stream form, then reconstructed into the
--- appropriate data structures. Several records of product information
--- are stored in an array; the array is passed as a parameter to a
--- procedure for storage in the stream. A header is created based on the
--- number of data records stored in the array. The header is then written
--- to the stream, followed by each record maintained in the array.
--- In order to retrieve data from the stream, the header information is
--- read from the stream, and the data stored in the header is used to
--- perform the appropriate number of read operations of record data from
--- the stream. All data read from the stream is validated against the
---- values that were written to the stream.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected call to Read in Procedure Retrieve_Data
--- for ACVC 2.0.1.
--- 27 Feb 08 PWB.CTA Allowed for non-support of certain IO operations.
---!
-
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXAC001 is
-
- package Strm_Pack renames Ada.Streams.Stream_IO;
- The_File : Strm_Pack.File_Type;
- The_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC001" );
- Incomplete : exception;
-
-
-begin
-
- Report.Test ("CXAC001", "Check that the 'Read and 'Write attributes " &
- "will transfer an object of a specific, " &
- "non-limited type to/from a stream");
-
- Test_for_Stream_IO_Support:
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Strm_Pack.Create (The_File, Strm_Pack.Out_File, The_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error |
- Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- The_Stream : Strm_Pack.Stream_Access;
- Todays_Date : String (1 .. 6) := "271193";
-
- type ID_Type is range 1 .. 100;
- type Size_Type is (Small, Medium, Large, XLarge);
-
- type Header_Type is record
- Number_of_Elements : Natural := 0;
- Origination_Date : String (1 .. 6);
- end record;
-
- type Data_Type is record
- ID : ID_Type;
- Size : Size_Type;
- end record;
-
- type Data_Array_Type is array (Positive range <>) of Data_Type;
-
- Product_Information_1 : Data_Array_Type (1 .. 3) := ((20, Large),
- (55, Small),
- (89, XLarge));
-
- Product_Information_2 : Data_Array_Type (1 .. 4) := (( 5, XLarge),
- (27, Small),
- (79, Medium),
- (93, XLarge));
-
- procedure Store_Data ( The_Stream : in Strm_Pack.Stream_Access;
- The_Array : in Data_Array_Type ) is
- Header : Header_Type;
- begin
-
- -- Fill in header info.
- Header.Number_of_Elements := The_Array'Length;
- Header.Origination_Date := Todays_Date;
-
- -- Write header to stream.
- Header_Type'Write (The_Stream, Header);
-
- -- Write each record in the array to the stream.
- for I in 1 .. Header.Number_of_Elements loop
- Data_Type'Write (The_Stream, The_Array (I));
- end loop;
-
- end Store_Data;
-
- procedure Retrieve_Data (The_Stream : in Strm_Pack.Stream_Access;
- The_Header : out Header_Type;
- The_Array : out Data_Array_Type ) is
- begin
-
- -- Read header from the stream.
- Header_Type'Read (The_Stream, The_Header);
-
- -- Read the records from the stream into the array.
- for I in 1 .. The_Header.Number_of_Elements loop
- Data_Type'Read (The_Stream, The_Array (I));
- end loop;
-
- end Retrieve_Data;
-
- begin
-
- -- Assign access value.
- The_Stream := Strm_Pack.Stream (The_File);
-
- -- Product information is to be stored in the stream file. These
- -- data arrays are of different sizes (actually, the records
- -- are stored individually, not as a single array). Prior to the
- -- record data being written, a header record is initialized with
- -- information about the data to be written, then itself is written
- -- to the stream.
-
- Store_Data (The_Stream, Product_Information_1);
- Store_Data (The_Stream, Product_Information_2);
-
- Test_Verification_Block:
- declare
- Product_Header_1 : Header_Type;
- Product_Header_2 : Header_Type;
- Product_Array_1 : Data_Array_Type (1 .. 3);
- Product_Array_2 : Data_Array_Type (1 .. 4);
- begin
-
- Reset1:
- begin
- Strm_Pack.Reset (The_File, Strm_Pack.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Data is read from the stream, first the appropriate header,
- -- then the associated data records, which are then reconstructed
- -- into a data array of product information.
-
- Retrieve_Data (The_Stream, Product_Header_1, Product_Array_1);
-
- -- Validate a field in the header.
- if (Product_Header_1.Origination_Date /= Todays_Date) or
- (Product_Header_1.Number_of_Elements /= 3)
- then
- Report.Failed ("Incorrect Header_1 info read from stream");
- end if;
-
- -- Validate the data records read from the file.
- for I in 1 .. Product_Header_1.Number_of_Elements loop
- if (Product_Array_1(I) /= Product_Information_1(I)) then
- Report.Failed ("Incorrect Product 1 info read from" &
- " record: " & Integer'Image (I));
- end if;
- end loop;
-
- -- Repeat this read and verify operation for the next parcel of
- -- data. Again, header and data record information are read from
- -- the same stream file.
- Retrieve_Data (The_Stream, Product_Header_2, Product_Array_2);
-
- if (Product_Header_2.Origination_Date /= Todays_Date) or
- (Product_Header_2.Number_of_Elements /= 4)
- then
- Report.Failed ("Incorrect Header_2 info read from stream");
- end if;
-
- for I in 1 .. Product_Header_2.Number_of_Elements loop
- if (Product_Array_2(I) /= Product_Information_2(I)) then
- Report.Failed ("Incorrect Product_2 info read from" &
- " record: " & Integer'Image (I));
- end if;
- end loop;
-
- exception
-
- when Incomplete =>
- raise;
-
- when Strm_Pack.End_Error => -- If correct number of
- -- items not in file (data
- -- overwritten), then fail.
- Report.Failed ("Incorrect number of record elements in file");
- if not Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- end if;
-
- when others =>
- Report.Failed ("Exception raised in Data Verification Block");
- if not Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- end if;
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the file.
- if Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Delete (The_File);
- else
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- Strm_Pack.Delete (The_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a
deleted file mode 100644
index e4b303c4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a
+++ /dev/null
@@ -1,426 +0,0 @@
--- CXAC002.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 subprograms defined in package Ada.Streams.Stream_IO
--- are accessible, and that they provide the appropriate functionality.
---
--- TEST DESCRIPTION:
--- This test simulates a user filter designed to capitalize the
--- characters of a string. It utilizes a variety of the subprograms
--- contained in the package Ada.Streams.Stream_IO.
--- Its purpose is to demonstrate the use of a variety of the capabilities
--- found in the Ada.Streams.Stream_IO package.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected visibility problems; corrected
--- subtest validating result from function Name
--- for ACVC 2.0.1.
--- 05 Oct 96 SAIC Removed calls to Close/Open in test and replaced
--- them with a single call to Reset (per AI95-0001)
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
--- 09 Feb 01 RLB Corrected non-support check to avoid unintended
--- failures.
---!
-
-package CXAC002_0 is
-
- -- This function searches for the first instance of a specified substring
- -- within a specified string, returning boolean result. (Case insensitive
- -- analysis)
-
- function Find (Str : in String; Sub : in String) return Boolean;
-
-end CXAC002_0;
-
-package body CXAC002_0 is
-
- function Find (Str : in String; Sub : in String) return Boolean is
-
- New_Str : String(Str'First..Str'Last);
- New_Sub : String(Sub'First..Sub'Last);
- Pos : Integer := Str'First; -- Character index.
-
- function Upper_Case (Str : in String) return String is
- subtype Upper is Character range 'A'..'Z';
- subtype Lower is Character range 'a'..'z';
- Ret : String(Str'First..Str'Last);
- Pos : Integer;
- begin
- for I in Str'Range loop
- if (Str(I) in Lower) then
- Pos := Upper'Pos(Upper'First) +
- (Lower'Pos(Str(I)) - Lower'Pos(Lower'First));
- Ret(I) := Upper'Val(Pos);
- else
- Ret(I) := Str (I);
- end if;
- end loop;
- return Ret;
- end Upper_Case;
-
- begin
-
- New_Str := Upper_Case(Str); -- Convert Str and Sub to upper
- New_Sub := Upper_Case(Sub); -- case for comparison.
-
- while (Pos <= New_Str'Last-New_Sub'Length+1) -- Search until no more
- and then -- sub-string-length
- (New_Str(Pos..Pos+New_Sub'Length-1) /= New_Sub) -- slices remain.
- loop
- Pos := Pos + 1;
- end loop;
-
- if (Pos > New_Str'Last-New_Sub'Length+1) then -- Substring not found.
- return False;
- else
- return True;
- end if;
-
- end Find;
-
-end CXAC002_0;
-
-
-with Ada.Streams.Stream_IO, CXAC002_0, Report;
-procedure CXAC002 is
- Filter_File : Ada.Streams.Stream_IO.File_Type;
- Filter_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Filter_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC002" );
- Incomplete : Exception;
-
-begin
-
- Report.Test ("CXAC002", "Check that the subprograms defined in " &
- "package Ada.Streams.Stream_IO are accessible, " &
- "and that they provide the appropriate " &
- "functionality");
-
- Test_for_Stream_IO_Support:
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Filter_File, -- Create.
- Ada.Streams.Stream_IO.Out_File,
- Filter_Filename);
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- use CXAC002_0;
- use type Ada.Streams.Stream_IO.File_Mode;
- use type Ada.Streams.Stream_IO.Count;
-
- File_Size : Ada.Streams.Stream_IO.Count := -- Count.
- Ada.Streams.Stream_IO.Count'First; -- (0)
- File_Index : Ada.Streams.Stream_IO.Positive_Count := -- Pos. Count.
- Ada.Streams.Stream_IO.Positive_Count'First; -- (1)
-
- First_String : constant String := "this is going to be ";
- Second_String : constant String := "the best year of your life";
- Total_Length : constant Natural := First_String'Length +
- Second_String'Length;
- Current_Char : Character := ' ';
-
- Cap_String : String (1..Total_Length) := (others => ' ');
-
- TC_Capital_String : constant String :=
- "THIS IS GOING TO BE THE BEST YEAR OF YOUR LIFE";
-
- begin
-
- if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open
- Report.Failed ("File not open following Create");
- end if;
-
- -- Call function Find to determine if the filename (Sub) is contained
- -- in the result of Function Name.
-
- if not Find(Str => Ada.Streams.Stream_IO.Name(Filter_File), -- Name.
- Sub => Filter_Filename)
- then
- Report.Failed ("Function Name provided incorrect filename");
- end if;
- -- Stream.
- Filter_Stream := Ada.Streams.Stream_IO.Stream (Filter_File);
-
- ---
-
- Enter_Data_In_Stream:
- declare
- Pos : Natural := 1;
- Bad_Character_Found : Boolean := False;
- begin
-
- -- Enter data from the first string into the stream.
- while Pos <= Natural(First_String'Length) loop
- -- Write all characters of the First_String to the stream.
- Character'Write (Filter_Stream, First_String (Pos));
- Pos := Pos + 1;
- -- Ensure data put in file on a regular basis.
- if Pos mod 5 = 0 then
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
- end if;
- end loop;
-
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
- -- Reset to In_File mode and read stream contents.
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset1;
-
- Pos := 1;
- while Pos <= First_String'Length loop
- -- Read one character from the stream.
- Character'Read (Filter_Stream, Current_Char); -- 'Read
- -- Verify character against the original string.
- if Current_Char /= First_String(Pos) then
- Bad_Character_Found := True;
- end if;
- Pos := Pos + 1;
- end loop;
-
- if Bad_Character_Found then
- Report.Failed ("Incorrect character read from stream");
- end if;
-
- -- Following user stream/string processing, the stream file is
- -- appended to as follows:
-
- Reset2:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset2;
-
- if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode.
- Ada.Streams.Stream_IO.Append_File
- then
- Report.Failed ("Incorrect mode following Reset to Append");
- end if;
-
- Pos := 1;
- while Pos <= Natural(Second_String'Length) loop
- -- Write all characters of the Second_String to the stream.
- Character'Write (Filter_Stream, Second_String (Pos)); -- 'Write
- Pos := Pos + 1;
- end loop;
-
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
-
- -- Record file statistics.
- File_Size := Ada.Streams.Stream_IO.Size (Filter_File); -- Size.
-
- Index_Might_Not_Be_Supported:
- begin
- File_Index := Ada.Streams.Stream_IO.Index (Filter_File); -- Index.
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ( "Index not supported for Stream_IO" );
- raise Incomplete;
- end Index_Might_Not_Be_Supported;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Enter_Data_In_Stream block");
- raise;
- end Enter_Data_In_Stream;
-
- ---
-
- Filter_Block:
- declare
- Pos : Positive := 1;
- Full_String : constant String := First_String & Second_String;
-
- function Capitalize (Char : Character) return Character is
- begin
- if Char /= ' ' then
- return Character'Val( Character'Pos(Char) -
- (Character'Pos('a') - Character'Pos('A')));
- else
- return Char;
- end if;
- end Capitalize;
-
- begin
-
- Reset3:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset3;
-
- if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode.
- Ada.Streams.Stream_IO.In_File
- then
- Report.Failed ("Incorrect mode following Reset to In_File");
- end if;
-
- if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open
- Report.Failed ( "Reset command did not leave file open" );
- end if;
-
- if Ada.Streams.Stream_IO.Size (Filter_File) /= -- Size.
- File_Size
- then
- Report.Failed ("Reset file is not correct size");
- end if;
-
- if Ada.Streams.Stream_IO.Index (Filter_File) /= 1 then -- Index.
- -- File position should have been reset to start of file.
- Report.Failed ("Index of file not set to 1 following Reset");
- end if;
-
- while Pos <= Full_String'Length loop
- -- Read one character from the stream.
- Character'Read (Filter_Stream, Current_Char); -- 'Read
- -- Verify character against the original string.
- if Current_Char /= Full_String(Pos) then
- Report.Failed ("Incorrect character read from stream");
- else
- -- Capitalize the characters read from the stream, and
- -- place them in a string variable.
- Cap_String(Pos) := Capitalize (Current_Char);
- end if;
- Pos := Pos + 1;
- end loop;
-
- -- File index should now be set to the position following the final
- -- character in the file (the same as the index value stored at
- -- the completion of the Enter_Data_In_Stream block).
- if Ada.Streams.Stream_IO.Index (Filter_File) /= -- Index.
- File_Index
- then
- Report.Failed ("Incorrect file index position");
- end if;
-
- -- The stream file should now be at EOF. -- EOF.
- if not Ada.Streams.Stream_IO.End_Of_File (Filter_File) then
- Report.Failed ("File not empty following filtering");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Filter_Block");
- raise;
- end Filter_Block;
-
- ---
-
- Verification_Block:
- begin
-
- -- Verify that the entire string was examined, and that the
- -- process of capitalizing the character data was successful.
- if Cap_String /= TC_Capital_String then
- Report.Failed ("Incorrect Capitalization");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception in Verification_Block");
- end Verification_Block;
-
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open.
- Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete.
- else
- Ada.Streams.Stream_IO.Open (Filter_File, -- Open.
- Ada.Streams.Stream_IO.Out_File,
- Filter_Filename);
- Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete.
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a
deleted file mode 100644
index cc1e044..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXAC003.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 correct exceptions are raised when improperly
--- manipulating stream file objects.
---
--- TEST DESCRIPTION:
--- This test is designed to focus on Stream_IO file manipulation
--- exceptions. Several potentially common user errors are examined in
--- the test:
---
--- A Status_Error should be raised whenever an attempt is made to perform
--- an operation on a file that is closed.
---
--- A Status_Error should be raised when an attempt is made to open a
--- stream file that is currently open.
---
--- A Mode_Error should be raised when attempting to read from (use the
--- 'Read attribute) on an Out_File or Append_Mode file.
---
--- A Mode_Error should be raised when checking for End Of File on a
--- file with mode Out_File or Append_Mode.
---
--- A Mode_Error should be raised when attempting to write to (use the
--- 'Output attribute) on a file with mode In_File.
---
--- A Name_Error should be raised when the string provided to the Name
--- parameter of an Open operation does not allow association of an
--- external file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
--- 02 Mar 01 PHL Check that Ada.Streams.Stream_IO.Stream raises
--- Status_Error if the file is not open. (DR 8652/
--- 0056).
--- 15 Mar 01 RLB Readied for release.
---!
-
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXAC003 is
-
- Stream_File_Object : Ada.Streams.Stream_IO.File_Type;
- Stream_Access_Value : Ada.Streams.Stream_IO.Stream_Access;
- Stream_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC003" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAC003", "Check that the correct exceptions are " &
- "raised when improperly manipulating stream " &
- "file objects");
-
- Test_for_Stream_IO_Support:
- begin
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File,
- Stream_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- begin
- -- A potentially common error in a file processing environment
- -- is to attempt to perform an operation on a stream file that is
- -- not currently open. Status_Error should be raised in this case.
- Check_Status_Error:
- begin
- Ada.Streams.Stream_IO.Close (Stream_File_Object);
- -- Attempt to reset a file that is closed.
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- Report.Failed ("Exception not raised on Reset of closed file");
- exception
- when Ada.Streams.Stream_IO.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 1");
- end Check_Status_Error;
-
- -- A similar error is to use Ada.Streams.Stream_IO.Stream
- -- to attempt to perform an operation on a stream file that is
- -- not currently open. Status_Error should be raised in this case.
- -- (Defect Report 8652/0046, as reflected in Technical Corrigendum 1.)
- Check_Status_Error2:
- begin
- -- Ensure that the file is not open.
- if Ada.Streams.Stream_Io.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_Io.Close (Stream_File_Object);
- end if;
- Stream_Access_Value :=
- Ada.Streams.Stream_Io.Stream (Stream_File_Object);
- Report.Failed ("Exception not raised on Stream of closed file");
- exception
- when Ada.Streams.Stream_Io.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 2");
- end Check_Status_Error2;
-
- -- Another potentially common error in a file processing environment
- -- is to attempt to Open a stream file that is currently open.
- -- Status_Error should be raised in this case.
- Check_Status_Error3:
- begin
- -- Ensure that the file is open.
- if not Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File,
- Stream_Filename);
- end if;
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File,
- Stream_Filename);
- Report.Failed ("Exception not raised on Open of open file");
- exception
- when Ada.Streams.Stream_IO.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 3");
- end Check_Status_Error3;
-
- -- Another example of a potential error occurring in a file
- -- processing environment is to attempt to use the 'Read attribute
- -- on a stream file that is currently in Out_File or Append_File
- -- mode. Mode_Error should be raised in both of these cases.
- Check_Mode_Error:
- declare
- Int_Var : Integer := -10;
- begin
-
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Out_File not supported for Stream_IO - 1" );
- raise Incomplete;
- end Reset1;
-
- Stream_Access_Value :=
- Ada.Streams.Stream_IO.Stream (Stream_File_Object);
- Integer'Write (Stream_Access_Value, Int_Var);
-
- -- File contains an integer value, but is of mode Out_File.
- Integer'Read (Stream_Access_Value, Int_Var);
- Report.Failed ("Exception not raised by 'Read of Out_File");
- exception
- when Incomplete =>
- raise;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- Try_Read:
- begin
- Reset2:
- begin
- Ada.Streams.Stream_IO.Reset
- (Stream_File_Object, Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported " &
- "for Stream_IO - 2" );
- raise Incomplete;
- end Reset2;
-
- Integer'Write (Stream_Access_Value, Int_Var);
- -- Attempt read from Append_File mode file.
- Integer'Read (Stream_Access_Value, Int_Var);
- Report.Failed
- ("Exception not raised by 'Read of Append file");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 4b");
- end Try_Read;
-
- when others => Report.Failed ("Incorrect exception raised - 4a");
- end Check_Mode_Error;
-
- -- Another example of a this type of potential error is to attempt
- -- to check for End Of File on a stream file that is currently in
- -- Out_File or Append_File mode. Mode_Error should also be raised
- -- in both of these cases.
- Check_End_File:
- declare
- Test_Boolean : Boolean := False;
- begin
- Reset3:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Out_File not supported for Stream_IO - 3" );
- raise Incomplete;
- end Reset3;
-
- Test_Boolean :=
- Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object);
- Report.Failed ("Exception not raised by EOF on Out_File");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- EOF_For_Append_File:
- begin
- Reset4:
- begin
- Ada.Streams.Stream_IO.Reset
- (Stream_File_Object, Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported " &
- "for Stream_IO - 4" );
- raise Incomplete;
- end Reset4;
-
- Test_Boolean :=
- Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object);
- Report.Failed
- ("Exception not raised by EOF of Append file");
- exception
- when Incomplete =>
- raise;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 5b");
- end EOF_For_Append_File;
-
- when others => Report.Failed ("Incorrect exception raised - 5a");
- end Check_End_File;
-
-
-
- -- In a similar situation to the above cases for attribute 'Read,
- -- an attempt to use the 'Output attribute on a stream file that
- -- is currently in In_File mode should result in Mode_Error being
- -- raised.
- Check_Output_Mode_Error:
- begin
- Reset5:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO - 6" );
- raise Incomplete;
- end Reset5;
-
- Stream_Access_Value :=
- Ada.Streams.Stream_IO.Stream (Stream_File_Object);
- String'Output (Stream_Access_Value, "User-Oriented String");
- Report.Failed ("Exception not raised by 'Output to In_File");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 6");
- end Check_Output_Mode_Error;
-
- -- Any case of attempting to Open a stream file with a string for
- -- the parameter Name that does not allow the identification of an
- -- external file will result in the exception Name_Error being
- -- raised.
- Check_Illegal_File_Name:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Close (Stream_File_Object);
- end if;
- -- No external file exists with this filename, allowing no
- -- association with an internal file object, resulting in the
- -- raising of the exception Name_Error.
- Ada.Streams.Stream_IO.Open(File => Stream_File_Object,
- Mode => Ada.Streams.Stream_IO.Out_File,
- Name => Report.Legal_File_Name(2));
- Report.Failed ("Exception not raised by bad filename on Open");
- exception
- when Ada.Streams.Stream_IO.Name_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 7");
- end Check_Illegal_File_Name;
-
- exception
- when Incomplete =>
- null;
- when others =>
- Report.Failed ("Unexpected exception in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Delete (Stream_File_Object);
- else
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File,
- Stream_Filename);
- Ada.Streams.Stream_IO.Delete (Stream_File_Object);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a
deleted file mode 100644
index 9cc88b9..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a
+++ /dev/null
@@ -1,310 +0,0 @@
--- CXAC004.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 Stream_Access type and Stream function found in package
--- Ada.Text_IO.Text_Streams allows a text file to be processed with the
--- functionality of streams.
---
--- TEST DESCRIPTION:
--- This test verifies that the package Ada.Text_IO.Text_Streams is
--- available and that the functionality it contains allows a text file to
--- be manipulated as a stream.
--- The test defines data objects of a variety of types that can be stored
--- in a text file. A text file and associated text stream are then
--- defined, and the 'Write attribute is used to enter the individual data
--- items into the text stream. Once all the individual data items have
--- been written to the stream, the 'Output attribute is used to write
--- arrays of these same data objects to the stream.
--- The text file is reset to serve as an input file, and the 'Read
--- attribute is used to extract the individual data items from the
--- stream. These items are then verified against the data originally
--- written to the stream. Finally, the 'Input attribute is used to
--- extract the data arrays from the stream. These arrays are then
--- verified against the original data written to the stream.
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations that support external text files.
---
--- CHANGE HISTORY:
--- 06 Jul 95 SAIC Initial prerelease version.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations;
--- removed requirement for support of decimal types.
---!
-
-with Report;
-with Ada.Text_IO;
-with Ada.Text_IO.Text_Streams;
-with Ada.Characters.Latin_1;
-with Ada.Strings.Unbounded;
-
-procedure CXAC004 is
-
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC004" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAC004", "Check that the Stream_Access type and Stream " &
- "function found in package " &
- "Ada.Text_IO.Text_Streams allows a text file to " &
- "be processed with the functionality of streams");
-
- Test_for_IO_Support:
- begin
-
- -- Check for Text_IO support in creating the data file. If the
- -- implementation does not support external files, Name_Error or
- -- Use_Error will be raised at the point of the following call to
- -- Create, resulting in a Not_Applicable test result.
-
- Ada.Text_IO.Create(Data_File, Ada.Text_IO.Out_File, Data_Filename);
-
- exception
-
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_IO_Support;
-
- Test_Block:
- declare
- use Ada.Characters.Latin_1, Ada.Strings.Unbounded;
- TC_Items : constant := 3;
-
- -- Declare types and objects that will be used as data values to be
- -- written to and read from the text file/stream.
-
- type Enum_Type is (Red, Yellow, Green, Blue, Indigo);
- type Fixed_Type is delta 0.125 range 0.0..255.0;
- type Float_Type is digits 7 range 0.0..1.0E5;
- type Modular_Type is mod 256;
- subtype Str_Type is String(1..4);
-
- type Char_Array_Type is array (1..TC_Items) of Character;
- type Enum_Array_Type is array (1..TC_Items) of Enum_Type;
- type Fixed_Array_Type is array (1..TC_Items) of Fixed_Type;
- type Float_Array_Type is array (1..TC_Items) of Float_Type;
- type Int_Array_Type is array (1..TC_Items) of Integer;
- type Mod_Array_Type is array (1..TC_Items) of Modular_Type;
- type Str_Array_Type is array (1..TC_Items) of Str_Type;
- type Unb_Str_Array_Type is array (1..TC_Items) of Unbounded_String;
-
- Char_Array : Char_Array_Type := ('A', 'z', Yen_Sign);
- TC_Char_Array_1,
- TC_Char_Array_2 : Char_Array_Type := (others => Space);
-
- Enum_Array : Enum_Array_Type := (Blue, Yellow, Indigo);
- TC_Enum_Array_1,
- TC_Enum_Array_2 : Enum_Array_Type := (others => Red);
-
- Fix_Array : Fixed_Array_Type := (0.125, 123.5, 250.750);
- TC_Fix_Array_1,
- TC_Fix_Array_2 : Fixed_Array_Type := (others => 0.0);
-
- Flt_Array : Float_Array_Type := (1.0, 150.0, 1500.0);
- TC_Flt_Array_1,
- TC_Flt_Array_2 : Float_Array_Type := (others => 0.0);
-
- Int_Array : Int_Array_Type := (124, 2349, -24_001);
- TC_Int_Array_1,
- TC_Int_Array_2 : Int_Array_Type := (others => -99);
-
- Mod_Array : Mod_Array_Type := (10, 127, 255);
- TC_Mod_Array_1,
- TC_Mod_Array_2 : Mod_Array_Type := (others => 0);
-
- Str_Array : Str_Array_Type := ("abcd", "klmn", "wxyz");
- TC_Str_Array_1,
- TC_Str_Array_2 : Str_Array_Type := (others => " ");
-
- UStr_Array : Unb_Str_Array_Type :=
- (To_Unbounded_String("cat"),
- To_Unbounded_String("testing"),
- To_Unbounded_String("ACVC"));
- TC_UStr_Array_1,
- TC_UStr_Array_2 : Unb_Str_Array_Type :=
- (others => Null_Unbounded_String);
-
- -- Create a stream access object pointing to the data file.
-
- Data_Stream : Ada.Text_IO.Text_Streams.Stream_Access :=
- Ada.Text_IO.Text_Streams.Stream(File => Data_File);
-
- begin
-
- -- Use the 'Write attribute to enter the three sets of data items
- -- into the data stream.
- -- Note that the data will be mixed within the text file.
-
- for i in 1..TC_Items loop
- Character'Write (Data_Stream, Char_Array(i));
- Enum_Type'Write (Data_Stream, Enum_Array(i));
- Fixed_Type'Write (Data_Stream, Fix_Array(i));
- Float_Type'Write (Data_Stream, Flt_Array(i));
- Integer'Write (Data_Stream, Int_Array(i));
- Modular_Type'Write (Data_Stream, Mod_Array(i));
- Str_Type'Write (Data_Stream, Str_Array(i));
- Unbounded_String'Write(Data_Stream, UStr_Array(i));
- end loop;
-
- -- Use the 'Output attribute to enter the entire arrays of each
- -- type of data items into the data stream.
- -- Note that the array bounds will be written to the stream as part
- -- of the action of the 'Output attribute.
-
- Char_Array_Type'Output (Data_Stream, Char_Array);
- Enum_Array_Type'Output (Data_Stream, Enum_Array);
- Fixed_Array_Type'Output (Data_Stream, Fix_Array);
- Float_Array_Type'Output (Data_Stream, Flt_Array);
- Int_Array_Type'Output (Data_Stream, Int_Array);
- Mod_Array_Type'Output (Data_Stream, Mod_Array);
- Str_Array_Type'Output (Data_Stream, Str_Array);
- Unb_Str_Array_Type'Output (Data_Stream, UStr_Array);
-
- -- Reset the data file to mode In_File. The data file will now serve
- -- as the source of data which will be compared to the original data
- -- written to the file above.
- Reset1:
- begin
- Ada.Text_IO.Reset (File => Data_File, Mode => Ada.Text_IO.In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Extract and validate all the single data items from the stream.
-
- for i in 1..TC_Items loop
- Character'Read (Data_Stream, TC_Char_Array_1(i));
- Enum_Type'Read (Data_Stream, TC_Enum_Array_1(i));
- Fixed_Type'Read (Data_Stream, TC_Fix_Array_1(i));
- Float_Type'Read (Data_Stream, TC_Flt_Array_1(i));
- Integer'Read (Data_Stream, TC_Int_Array_1(i));
- Modular_Type'Read (Data_Stream, TC_Mod_Array_1(i));
- Str_Type'Read (Data_Stream, TC_Str_Array_1(i));
- Unbounded_String'Read (Data_Stream, TC_UStr_Array_1(i));
- end loop;
-
- if TC_Char_Array_1 /= Char_Array then
- Report.Failed("Character values do not match");
- end if;
- if TC_Enum_Array_1 /= Enum_Array then
- Report.Failed("Enumeration values do not match");
- end if;
- if TC_Fix_Array_1 /= Fix_Array then
- Report.Failed("Fixed point values do not match");
- end if;
- if TC_Flt_Array_1 /= Flt_Array then
- Report.Failed("Floating point values do not match");
- end if;
- if TC_Int_Array_1 /= Int_Array then
- Report.Failed("Integer values do not match");
- end if;
- if TC_Mod_Array_1 /= Mod_Array then
- Report.Failed("Modular values do not match");
- end if;
- if TC_Str_Array_1 /= Str_Array then
- Report.Failed("String values do not match");
- end if;
- if TC_UStr_Array_1 /= UStr_Array then
- Report.Failed("Unbounded_String values do not match");
- end if;
-
- -- Extract and validate all data arrays from the data stream.
- -- Note that the 'Input attribute denotes a function, whereas the
- -- other stream oriented attributes in this test denote procedures.
-
- TC_Char_Array_2 := Char_Array_Type'Input(Data_Stream);
- TC_Enum_Array_2 := Enum_Array_Type'Input(Data_Stream);
- TC_Fix_Array_2 := Fixed_Array_Type'Input(Data_Stream);
- TC_Flt_Array_2 := Float_Array_Type'Input(Data_Stream);
- TC_Int_Array_2 := Int_Array_Type'Input(Data_Stream);
- TC_Mod_Array_2 := Mod_Array_Type'Input(Data_Stream);
- TC_Str_Array_2 := Str_Array_Type'Input(Data_Stream);
- TC_UStr_Array_2 := Unb_Str_Array_Type'Input(Data_Stream);
-
- if TC_Char_Array_2 /= Char_Array then
- Report.Failed("Character array values do not match");
- end if;
- if TC_Enum_Array_2 /= Enum_Array then
- Report.Failed("Enumeration array values do not match");
- end if;
- if TC_Fix_Array_2 /= Fix_Array then
- Report.Failed("Fixed point array values do not match");
- end if;
- if TC_Flt_Array_2 /= Flt_Array then
- Report.Failed("Floating point array values do not match");
- end if;
- if TC_Int_Array_2 /= Int_Array then
- Report.Failed("Integer array values do not match");
- end if;
- if TC_Mod_Array_2 /= Mod_Array then
- Report.Failed("Modular array values do not match");
- end if;
- if TC_Str_Array_2 /= Str_Array then
- Report.Failed("String array values do not match");
- end if;
- if TC_UStr_Array_2 /= UStr_Array then
- Report.Failed("Unbounded_String array values do not match");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Deletion:
- begin
- -- Delete the data file.
- if not Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename);
- end if;
- Ada.Text_IO.Delete(Data_File);
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a
deleted file mode 100644
index 5032357..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a
+++ /dev/null
@@ -1,347 +0,0 @@
--- CXAC005.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. 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 stream file positioning work as specified. (Defect Report
--- 8652/0055).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version.
--- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check
--- to terminate test gracefully.
--- 05 MAR 2007 RLB Updated to avoid problems with return-by-reference.
---
---!
-with Ada.Streams.Stream_Io;
-use Ada.Streams;
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure CXAC005 is
-
- Incomplete : exception;
-
- procedure TC_Assert (Condition : Boolean; Message : String) is
- begin
- if not Condition then
- Failed (Message);
- end if;
- end TC_Assert;
-
- package Checked_Stream_Io is
-
- type File_Type (Max_Size : Stream_Element_Count) is limited private;
-
- procedure Create (File : in out File_Type;
- Mode : in Stream_Io.File_Mode := Stream_Io.Out_File;
- Name : in String := "";
- Form : in String := "");
-
- procedure Open (File : in out File_Type;
- Mode : in Stream_Io.File_Mode;
- Name : in String;
- Form : in String := "");
-
- procedure Close (File : in out File_Type);
- procedure Delete (File : in out File_Type);
-
- procedure Reset (File : in out File_Type;
- Mode : in Stream_Io.File_Mode);
- procedure Reset (File : in out File_Type);
-
- procedure Read (File : in out File_Type;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset;
- From : in Stream_Io.Positive_Count);
-
- procedure Read (File : in out File_Type;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
-
- procedure Write (File : in out File_Type;
- Item : in Stream_Element_Array;
- To : in Stream_Io.Positive_Count);
-
- procedure Write (File : in out File_Type;
- Item : in Stream_Element_Array);
-
- procedure Set_Index (File : in out File_Type;
- To : in Stream_Io.Positive_Count);
-
- function Index (File : in File_Type) return Stream_Io.Positive_Count;
-
- function Size (File : in File_Type) return Stream_Io.Count;
-
- procedure Set_Mode (File : in out File_Type;
- Mode : in Stream_Io.File_Mode);
-
- private
- type File_Type (Max_Size : Stream_Element_Count) is
- record
- File : Stream_Io.File_Type;
- Index : Stream_Io.Positive_Count;
- Contents :
- Stream_Element_Array
- (Stream_Element_Offset (Ident_Int (1)) .. Max_Size);
- end record;
- end Checked_Stream_Io;
-
- package body Checked_Stream_Io is
-
- use Stream_Io;
-
- procedure Create (File : in out File_Type;
- Mode : in Stream_Io.File_Mode := Stream_Io.Out_File;
- Name : in String := "";
- Form : in String := "") is
- begin
- Stream_Io.Create (File.File, Mode, Name, Form);
- File.Index := Stream_Io.Index (File.File);
- if Mode = Append_File then
- TC_Assert (File.Index = Stream_Io.Size (File.File) + 1,
- "Index /= Size + 1 -- Create - Append_File");
- else
- TC_Assert (File.Index = 1, "Index /= 1 -- Create - " &
- File_Mode'Image (Mode));
- end if;
- end Create;
-
- procedure Open (File : in out File_Type;
- Mode : in Stream_Io.File_Mode;
- Name : in String;
- Form : in String := "") is
- begin
- Stream_Io.Open (File.File, Mode, Name, Form);
- File.Index := Stream_Io.Index (File.File);
- if Mode = Append_File then
- TC_Assert (File.Index = Stream_Io.Size (File.File) + 1,
- "Index /= Size + 1 -- Open - Append_File");
- else
- TC_Assert (File.Index = 1, "Index /= 1 -- Open - " &
- File_Mode'Image (Mode));
- end if;
- end Open;
-
- procedure Close (File : in out File_Type) is
- begin
- Stream_Io.Close (File.File);
- end Close;
-
- procedure Delete (File : in out File_Type) is
- begin
- Stream_Io.Delete (File.File);
- end Delete;
-
- procedure Reset (File : in out File_Type;
- Mode : in Stream_Io.File_Mode) is
- begin
- Stream_Io.Reset (File.File, Mode);
- File.Index := Stream_Io.Index (File.File);
- if Mode = Append_File then
- TC_Assert (File.Index = Stream_Io.Size (File.File) + 1,
- "Index /= Size + 1 -- Reset - Append_File");
- else
- TC_Assert (File.Index = 1, "Index /= 1 -- Reset - " &
- File_Mode'Image (Mode));
- end if;
- end Reset;
-
- procedure Reset (File : in out File_Type) is
- begin
- Reset (File, Stream_Io.Mode (File.File));
- end Reset;
-
-
- procedure Read (File : in out File_Type;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset;
- From : in Stream_Io.Positive_Count) is
- begin
- Set_Index (File, From);
- Read (File, Item, Last);
- end Read;
-
- procedure Read (File : in out File_Type;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- Index : constant Stream_Element_Offset :=
- Stream_Element_Offset (File.Index);
- begin
- Stream_Io.Read (File.File, Item, Last);
- if Last < Item'Last then
- TC_Assert (Item (Item'First .. Last) =
- File.Contents (Index .. Index + Last - Item'First),
- "Incorrect data read from file - 1");
- TC_Assert (Count (Index + Last - Item'First) =
- Stream_Io.Size (File.File),
- "Read stopped before end of file");
- File.Index := Count (Index + Last - Item'First) + 1;
- else
- TC_Assert (Item = File.Contents (Index .. Index + Item'Length - 1),
- "Incorrect data read from file - 2");
- File.Index := File.Index + Item'Length;
- end if;
- end Read;
-
- procedure Write (File : in out File_Type;
- Item : in Stream_Element_Array;
- To : in Stream_Io.Positive_Count) is
- begin
- Set_Index (File, To);
- Write (File, Item);
- end Write;
-
- procedure Write (File : in out File_Type;
- Item : in Stream_Element_Array) is
- Index : constant Stream_Element_Offset :=
- Stream_Element_Offset (File.Index);
- begin
- Stream_Io.Write (File.File, Item);
- File.Contents (Index .. Index + Item'Length - 1) := Item;
- File.Index := File.Index + Item'Length;
- TC_Assert (File.Index = Stream_Io.Index (File.File),
- "Write failed to move the index");
- end Write;
-
- procedure Set_Index (File : in out File_Type;
- To : in Stream_Io.Positive_Count) is
- begin
- Stream_Io.Set_Index (File.File, To);
- File.Index := Stream_Io.Index (File.File);
- TC_Assert (File.Index = To, "Set_Index failed");
- end Set_Index;
-
- function Index (File : in File_Type) return Stream_Io.Positive_Count is
- New_Index : constant Count := Stream_Io.Index (File.File);
- begin
- TC_Assert (New_Index = File.Index, "Index changed unexpectedly");
- return New_Index;
- end Index;
-
- function Size (File : in File_Type) return Stream_Io.Count is
- New_Size : constant Count := Stream_Io.Size (File.File);
- begin
- TC_Assert (New_Size <= Count(File.Max_Size), "File too large");
- return New_Size;
- end Size;
-
- procedure Set_Mode (File : in out File_Type;
- Mode : in Stream_Io.File_Mode) is
- Old_Index : constant Count := File.Index;
- begin
- Stream_Io.Set_Mode (File.File, Mode);
- File.Index := Stream_Io.Index (File.File);
- if Mode = Append_File then
- TC_Assert (File.Index = Stream_Io.Size (File.File) + 1,
- "Index /= Size + 1 -- Set_Mode - Append_File");
- else
- TC_Assert (File.Index = Old_Index, "Set_Mode changed the index");
- end if;
- end Set_Mode;
-
- end Checked_Stream_Io;
-
- package Csio renames Checked_Stream_Io;
-
- F : Csio.File_Type (100);
- S : Stream_Element_Array (1 .. 10);
- Last : Stream_Element_Offset;
-
-begin
-
- Report.Test ("CXAC005",
- "Check that stream file positioning work as specified");
-
- declare
- Name : constant String := Legal_File_Name;
- begin
- begin
- Csio.Create (F, Name => Name);
- exception
- when others =>
- Not_Applicable ("Files not supported - Creation with Out_File for Stream_IO");
- raise Incomplete;
- end;
-
- for I in Stream_Element range 1 .. 10 loop
- Csio.Write (F, ((1 => I + 2)));
- end loop;
- Csio.Write (F, (1 .. 15 => 11));
- Csio.Write (F, (1 .. 15 => 12), To => 15);
-
- Csio.Reset (F);
-
- for I in Stream_Element range 1 .. 10 loop
- Csio.Write (F, (1 => I));
- end loop;
- Csio.Write (F, (1 .. 15 => 13));
- Csio.Write (F, (1 .. 15 => 14), To => 15);
- Csio.Write (F, (1 => 90));
-
- Csio.Set_Mode (F, Stream_Io.In_File);
-
- Csio.Read (F, S, Last);
- Csio.Read (F, S, Last, From => 3);
- Csio.Read (F, S, Last, From => 28);
-
- Csio.Set_Mode (F, Stream_Io.Append_File);
- Csio.Write (F, (1 .. 5 => 88));
-
- Csio.Close (F);
-
- Csio.Open (F, Name => Name, Mode => Stream_Io.Append_File);
- Csio.Write (F, (1 .. 3 => 33));
-
- Csio.Set_Mode (F, Stream_Io.In_File);
- Csio.Read (F, S, Last, From => 20);
- Csio.Read (F, S, Last);
- Csio.Reset (F, Stream_Io.Out_File);
-
- Csio.Write (F, (1 .. 9 => 99));
-
- -- Check the contents of the entire file.
- declare
- S : Stream_Element_Array
- (1 .. Stream_Element_Offset (Csio.Size (F)));
- begin
- Csio.Reset (F, Stream_Io.In_File);
- Csio.Read (F, S, Last);
- end;
-
- Csio.Delete (F);
- end;
-
- Report.Result;
-exception
- when Incomplete =>
- Report.Result;
- when E:others =>
- Report.Failed ("Unexpected exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E));
- Report.Result;
-
-end CXAC005;
-
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a
deleted file mode 100644
index cda8776..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXACA01.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 default attributes 'Write and 'Read work properly when
--- used with objects of a variety of types, including records with
--- default discriminants, records without default discriminants, but
--- which have the discriminant described in a representation clause for
--- the type, and arrays.
---
--- TEST DESCRIPTION:
--- This test simulates a basic sales record system, using Stream_IO to
--- allow the storage of heterogeneous data in a single stream file.
---
--- Four types of data are written to the stream file for each product.
--- First, the "header" information on the product is written.
--- This is an object of a discriminated (with default) record
--- type. This is followed by an integer object containing a count of
--- the number of sales data records to follow. The corresponding number
--- of sales records follow in the stream. These are of a record type
--- with a discriminant without a default, but where the discriminant is
--- included in the representation clause for the type. Finally, an
--- array object with statistical sales information for the product is
--- written to the stream.
---
--- Objects of both record types specified below (discriminated records
--- with defaults, and discriminated records w/o defaults that have the
--- discriminant included in a representation clause for the type) should
--- have their discriminants included in the stream when using 'Write.
--- Likewise, discriminants should be extracted from the stream when
--- using 'Read.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXACA00;
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXACA01 is
-
-begin
-
- Report.Test ("CXACA01", "Check that 'Write and 'Read work properly " &
- "when used with complex data types");
-
- Test_for_Stream_IO_Support:
- declare
-
- Info_File : Ada.Streams.Stream_IO.File_Type;
- Info_Stream : Ada.Streams.Stream_IO.Stream_Access;
- The_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Info_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
-
- Operational_Test_Block:
- declare
-
- begin
-
- Info_Stream := Ada.Streams.Stream_IO.Stream (Info_File);
-
- -- Write all of the product information (record, integer, and array
- -- objects) defined in package FXACA00 into the stream.
-
- Store_Data_Block:
- begin
-
- -- Write information about first product to the stream.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_01);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_01);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_01);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_02);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_01_Stats);
-
- -- Write information about second product to the stream.
- -- Note: No Sales_Record_Type objects.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_02);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_02);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_02_Stats);
-
- -- Write information about third product to the stream.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_03);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_03);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_03);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_04);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_05);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_03_Stats);
-
- end Store_Data_Block;
-
-
- Verify_Data_Block:
- declare
-
- use FXACA00; -- Used within this block only.
-
- type Domestic_Rec_Array_Type is
- array (Positive range <>) of Sales_Record_Type (Domestic);
-
- type Foreign_Rec_Array_Type is
- array (Positive range <>) of Sales_Record_Type (Foreign);
-
- TC_Rec1 : Domestic_Rec_Array_Type (1..2);
- TC_Rec3 : Foreign_Rec_Array_Type (1..3);
-
- TC_Product1 : Product_Type;
- TC_Product2,
- TC_Product3 : Product_Type (Foreign);
-
- TC_Count1,
- TC_Count2,
- TC_Count3 : Integer := -10; -- Initialized to dummy value.
-
- TC_Stat1,
- TC_Stat2,
- TC_Stat3 : Sales_Statistics_Type := (others => 500);
-
- begin
-
- Ada.Streams.Stream_IO.Reset (Info_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Read all of the data that is contained in the stream.
- -- Compare all data with the original data in package FXACA00
- -- that was written to the stream.
- -- The calls to the read attribute are in anticipated order, based
- -- on the order of data written to the stream. Possible errors,
- -- such as data placement, overwriting, etc., will be manifest as
- -- exceptions raised by the attribute during an unsuccessful read
- -- attempt.
-
- -- Extract data on first product.
- Product_Type'Read (Info_Stream, TC_Product1);
- Integer'Read (Info_Stream, TC_Count1);
-
- -- Two "domestic" variant sales records will be read from the
- -- stream.
- for i in 1 .. TC_Count1 loop
- Sales_Record_Type'Read (Info_Stream, TC_Rec1(i) );
- end loop;
-
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat1);
-
-
- -- Extract data on second product.
- Product_Type'Read (Info_Stream, TC_Product2);
- Integer'Read (Info_Stream, TC_Count2);
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat2);
-
-
- -- Extract data on third product.
- Product_Type'Read (Info_Stream, TC_Product3);
- Integer'Read (Info_Stream, TC_Count3);
-
- -- Three "foreign" variant sales records will be read from the
- -- stream.
- for i in 1 .. TC_Count3 loop
- Sales_Record_Type'Read (Info_Stream, TC_Rec3(i) );
- end loop;
-
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat3);
-
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Info_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- -- Verify that the data values read from the stream are the same
- -- as those written to the stream.
-
- -- Verify the information of the first product.
- if ((Product_01 /= TC_Product1) or else
- (Product_01.Manufacture /= TC_Product1.Manufacture) or else
- (Sale_Count_01 /= TC_Count1) or else
- (Sale_Rec_01 /= TC_Rec1(1)) or else
- (Sale_Rec_01.Buyer /= TC_Rec1(1).Buyer) or else
- (Sale_Rec_02 /= TC_Rec1(2)) or else
- (Sale_Rec_02.Buyer /= TC_Rec1(2).Buyer) or else
- (Product_01_Stats /= TC_Stat1))
- then
- Report.Failed ("Product 1 information incorrect");
- end if;
-
- -- Verify the information of the second product.
- if not ((Product_02 = TC_Product2) and then
- (Sale_Count_02 = TC_Count2) and then
- (Product_02_Stats = TC_Stat2))
- then
- Report.Failed ("Product 2 information incorrect");
- end if;
-
- -- Verify the information of the third product.
- if ((Product_03 /= TC_Product3) or else
- (Product_03.Manufacture /= TC_Product3.Manufacture) or else
- (Sale_Count_03 /= TC_Count3) or else
- (Sale_Rec_03 /= TC_Rec3(1)) or else
- (Sale_Rec_03.Buyer /= TC_Rec3(1).Buyer) or else
- (Sale_Rec_04 /= TC_Rec3(2)) or else
- (Sale_Rec_04.Buyer /= TC_Rec3(2).Buyer) or else
- (Sale_Rec_05 /= TC_Rec3(3)) or else
- (Sale_Rec_05.Buyer /= TC_Rec3(3).Buyer) or else
- (Product_03_Stats /= TC_Stat3))
- then
- Report.Failed ("Product 3 information incorrect");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Info_File) then
- Ada.Streams.Stream_IO.Delete (Info_File);
- else
- Ada.Streams.Stream_IO.Open (Info_File,
- Ada.Streams.Stream_IO.In_File,
- The_Filename);
- Ada.Streams.Stream_IO.Delete (Info_File);
- end if;
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on Stream IO Create");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACA01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a
deleted file mode 100644
index 5106dd3..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a
+++ /dev/null
@@ -1,360 +0,0 @@
--- CXACA02.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 user defined subprograms can override the default
--- attributes 'Read and 'Write using attribute definition clauses.
--- Use objects of record types.
---
--- TEST DESCRIPTION:
--- This test demonstrates that the default implementations of the
--- 'Read and 'Write attributes can be overridden by user specified
--- subprograms in conjunction with attribute definition clauses.
--- These attributes have been overridden below, and in the user defined
--- substitutes, values are added or subtracted to global variables.
--- The global variables are evaluated to ensure that the user defined
--- subprograms were used in overriding the type-related default
--- attributes.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC Corrected recursive attribute definitions
--- for ACVC 2.0.1.
--- 24 Aug 96 SAIC Corrected typo in test verification criteria.
---
---!
-
-with Report;
-with Ada.Streams.Stream_IO;
-
-procedure CXACA02 is
-begin
-
- Report.Test ("CXACA02", "Check that user defined subprograms can " &
- "override the default attributes 'Read and " &
- "'Write using attribute definition clauses");
-
- Test_for_Stream_IO_Support:
- declare
-
- Data_File : Ada.Streams.Stream_IO.File_Type;
- Data_Stream : Ada.Streams.Stream_IO.Stream_Access;
- The_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Data_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
-
- Operational_Test_Block:
- declare
-
- type Origin_Type is (Foreign, Domestic);
- subtype String_Data_Type is String(1..8);
-
- type Product_Type is
- record
- Item : String_Data_Type;
- ID : Natural range 1..100;
- Manufacture : Origin_Type := Domestic;
- Distributor : String_Data_Type;
- Importer : String_Data_Type;
- end record;
-
- type Sales_Record_Type is
- record
- Name : String_Data_Type;
- Sale_Item : Boolean := False;
- Buyer : Origin_Type;
- Quantity_Discount : Boolean;
- Cash_Discount : Boolean;
- end record;
-
-
- -- Mode conformant, user defined subprograms that will override
- -- the type-related attributes.
- -- In this test, the user defines these subprograms to add/subtract
- -- specific values from global variables.
-
- procedure Product_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Product_Type );
-
- procedure Product_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Product_Type );
-
- procedure Sales_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Sales_Record_Type );
-
- procedure Sales_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Sales_Record_Type );
-
- -- Attribute definition clauses.
-
- for Product_Type'Read use Product_Read;
- for Product_Type'Write use Product_Write;
-
- for Sales_Record_Type'Read use Sales_Read;
- for Sales_Record_Type'Write use Sales_Write;
-
-
- -- Object Declarations
-
- Product_01 : Product_Type :=
- ("Product1", 1, Domestic, "Distrib1", "Import 1");
- Product_02 : Product_Type :=
- ("Product2", 2, Foreign, "Distrib2", "Import 2");
-
- Sale_Rec_01 : Sales_Record_Type :=
- ("Buyer 01", False, Domestic, True, True);
- Sale_Rec_02 : Sales_Record_Type :=
- ("Buyer 02", True, Domestic, True, False);
- Sale_Rec_03 : Sales_Record_Type := (Name => "Buyer 03",
- Sale_Item => True,
- Buyer => Foreign,
- Quantity_Discount => False,
- Cash_Discount => True);
- Sale_Rec_04 : Sales_Record_Type :=
- ("Buyer 04", True, Foreign, False, False);
- Sale_Rec_05 : Sales_Record_Type :=
- ("Buyer 05", False, Foreign, False, False);
-
- TC_Read_Total : Integer := 100;
- TC_Write_Total : Integer := 0;
-
-
- -- Subprogram bodies.
- -- These subprograms are designed to override the default attributes
- -- 'Read and 'Write for the specified types. Each adds/subtracts
- -- a quantity to/from a program control variable, indicating its
- -- activity. In addition, each component of the record is
- -- individually read from or written to the stream, using the
- -- appropriate 'Read or 'Write attribute for the component type.
- -- The string components are moved to/from the stream using the
- -- 'Input and 'Output attributes for the string subtype, so that
- -- the bounds of the strings are also written/read.
-
- procedure Product_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Product_Type ) is
- begin
- TC_Read_Total := TC_Read_Total - 10;
-
- The_Item.Item := String_Data_Type'Input(Data_Stream); -- Field 1.
- Natural'Read(Data_Stream, The_Item.ID); -- Field 2.
- Origin_Type'Read(Data_Stream, -- Field 3.
- The_Item.Manufacture);
- The_Item.Distributor := -- Field 4.
- String_Data_Type'Input(Data_Stream);
- The_Item.Importer := -- Field 5.
- String_Data_Type'Input(Data_Stream);
- end Product_Read;
-
-
- procedure Product_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Product_Type ) is
- begin
- TC_Write_Total := TC_Write_Total + 5;
-
- String_Data_Type'Output(Data_Stream, The_Item.Item); -- Field 1.
- Natural'Write(Data_Stream, The_Item.ID); -- Field 2.
- Origin_Type'Write(Data_Stream, -- Field 3.
- The_Item.Manufacture);
- String_Data_Type'Output(Data_Stream, -- Field 4.
- The_Item.Distributor);
- String_Data_Type'Output(Data_Stream, -- Field 5.
- The_Item.Importer);
- end Product_Write;
-
-
- procedure Sales_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Sales_Record_Type ) is
- begin
- TC_Read_Total := TC_Read_Total - 20;
-
- The_Item.Name := String_Data_Type'Input(Data_Stream); -- Field 1.
- Boolean'Read(Data_Stream, The_Item.Sale_Item); -- Field 2.
- Origin_Type'Read(Data_Stream, The_Item.Buyer); -- Field 3.
- Boolean'Read(Data_Stream, The_Item.Quantity_Discount); -- Field 4.
- Boolean'Read(Data_Stream, The_Item.Cash_Discount); -- Field 5.
- end Sales_Read;
-
-
- procedure Sales_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Sales_Record_Type ) is
- begin
- TC_Write_Total := TC_Write_Total + 10;
-
- String_Data_Type'Output(Data_Stream, The_Item.Name); -- Field 1.
- Boolean'Write(Data_Stream, The_Item.Sale_Item); -- Field 2.
- Origin_Type'Write(Data_Stream, The_Item.Buyer); -- Field 3.
- Boolean'Write(Data_Stream, The_Item.Quantity_Discount); -- Field 4.
- Boolean'Write(Data_Stream, The_Item.Cash_Discount); -- Field 5.
- end Sales_Write;
-
-
-
- begin
-
- Data_Stream := Ada.Streams.Stream_IO.Stream (Data_File);
-
- -- Write product and sales data to the stream.
-
- Product_Type'Write (Data_Stream, Product_01);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_01);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_02);
-
- Product_Type'Write (Data_Stream, Product_02);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_03);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_04);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_05);
-
- -- Read data from the stream, and verify the use of the user specified
- -- attributes.
-
- Verify_Data_Block:
- declare
-
- TC_Product1,
- TC_Product2 : Product_Type;
-
- TC_Sale1,
- TC_Sale2,
- TC_Sale3,
- TC_Sale4,
- TC_Sale5 : Sales_Record_Type;
-
- begin
-
- -- Reset the mode of the stream file so that Read/Input
- -- operations may be performed.
-
- Ada.Streams.Stream_IO.Reset (Data_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Data is read/reconstructed from the stream, in the order that
- -- the data was placed into the stream.
-
- Product_Type'Read (Data_Stream, TC_Product1);
- Sales_Record_Type'Read (Data_Stream, TC_Sale1);
- Sales_Record_Type'Read (Data_Stream, TC_Sale2);
-
- Product_Type'Read (Data_Stream, TC_Product2);
- Sales_Record_Type'Read (Data_Stream, TC_Sale3);
- Sales_Record_Type'Read (Data_Stream, TC_Sale4);
- Sales_Record_Type'Read (Data_Stream, TC_Sale5);
-
- -- Verify product data was correctly written to/read from stream.
-
- if TC_Product1 /= Product_01 then
- Report.Failed ("Data verification error, Product 1");
- end if;
- if TC_Product2 /= Product_02 then
- Report.Failed ("Data verification error, Product 2");
- end if;
-
- if TC_Sale1 /= Sale_Rec_01 then
- Report.Failed ("Data verification error, Sale_Rec_01");
- end if;
- if TC_Sale2 /= Sale_Rec_02 then
- Report.Failed ("Data verification error, Sale_Rec_02");
- end if;
- if TC_Sale3 /= Sale_Rec_03 then
- Report.Failed ("Data verification error, Sale_Rec_03");
- end if;
- if TC_Sale4 /= Sale_Rec_04 then
- Report.Failed ("Data verification error, Sale_Rec_04");
- end if;
- if TC_Sale5 /= Sale_Rec_05 then
- Report.Failed ("Data verification error, Sale_Rec_05");
- end if;
-
- -- Verify that the user defined subprograms were used to
- -- override the default 'Read and 'Write attributes.
- -- There were two "product" reads and two writes; there
- -- were five "sale record" reads and five writes.
-
- if (TC_Read_Total /= -20) or (TC_Write_Total /= 60) then
- Report.Failed ("Incorrect use of user defined attributes");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Data_File) then
- Ada.Streams.Stream_IO.Delete (Data_File);
- else
- Ada.Streams.Stream_IO.Open (Data_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
- Ada.Streams.Stream_IO.Delete (Data_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACA02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a
deleted file mode 100644
index ac4a905..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a
+++ /dev/null
@@ -1,264 +0,0 @@
--- CXACB01.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 default attributes 'Input and 'Output work properly when
--- used with objects of a variety of types, including two-dimensional
--- arrays and records without default discriminants.
---
--- TEST DESCRIPTION:
--- This test simulates utility company service record storage, using
--- Stream_IO to allow the storage of heterogeneous data in a single
--- stream file.
---
--- Three types of data are written to the stream file for each utility
--- service customer.
--- First, the general information on the customer is written.
--- This is an object of a discriminated (without default) record
--- type. This is followed by an integer object containing a count of
--- the number of service months for the customer. Finally, a
--- two-dimensional array object with monthly consumption information for
--- the customer is written to the stream.
---
--- Objects of record types with discriminants without defaults should
--- have their discriminants included in the stream when using 'Output.
--- Likewise, discriminants should be extracted
--- from the stream when using 'Input. Similarly, array bounds are written
--- to and read from the stream when using 'Output and 'Input with array
--- objects.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXACB00;
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXACB01 is
-begin
-
- Report.Test ("CXACB01", "Check that the default attributes 'Input and " &
- "'Output work properly when used with objects " &
- "of record, natural, and array types" );
-
- Test_for_Stream_IO_Support:
- declare
-
- Util_File : Ada.Streams.Stream_IO.File_Type;
- Util_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Utility_Service_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Service_Filename);
-
- Operational_Test_Block:
- declare
-
- -- The following procedure will store all of the customer specific
- -- information into the stream.
-
- procedure Store_Data_In_Stream
- (Customer : in FXACB00.Service_Type;
- Months : in FXACB00.Months_In_Service_Type;
- History : in FXACB00.Service_History_Type) is
- begin
- FXACB00.Service_Type'Output (Util_Stream, Customer);
- FXACB00.Months_In_Service_Type'Output (Util_Stream, Months);
- FXACB00.Service_History_Type'Output (Util_Stream, History);
- end Store_Data_In_Stream;
-
-
- -- The following procedure will remove from the stream all of the
- -- customer related information.
-
- procedure Retrieve_Data_From_Stream
- (Customer : out FXACB00.Service_Type;
- Months : out FXACB00.Months_In_Service_Type;
- History : out FXACB00.Service_History_Type) is
- begin
- Customer := FXACB00.Service_Type'Input (Util_Stream);
- Months := FXACB00.Months_In_Service_Type'Input (Util_Stream);
- History := FXACB00.Service_History_Type'Input (Util_Stream);
- end Retrieve_Data_From_Stream;
-
-
- begin
-
- Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File);
-
- -- Write all of the customer service information (record, numeric,
- -- and array objects) defined in package FXACB00 into the stream.
-
- Data_Storage_Block:
- begin
-
- Store_Data_In_Stream (Customer => FXACB00.Customer1,
- Months => FXACB00.C1_Months,
- History => FXACB00.C1_Service_History);
-
- Store_Data_In_Stream (FXACB00.Customer2,
- FXACB00.C2_Months,
- History => FXACB00.C2_Service_History);
-
- Store_Data_In_Stream (Months => FXACB00.C3_Months,
- History => FXACB00.C3_Service_History,
- Customer => FXACB00.Customer3);
- end Data_Storage_Block;
-
-
- Data_Verification_Block:
- declare
-
- TC_Residence : FXACB00.Service_Type (FXACB00.Residence);
- TC_Apartment : FXACB00.Service_Type (FXACB00.Apartment);
- TC_Commercial : FXACB00.Service_Type (FXACB00.Commercial);
-
-
- TC_Months1,
- TC_Months2,
- TC_Months3 : FXACB00.Months_In_Service_Type :=
- FXACB00.Months_In_Service_Type'First;
-
-
- TC_History1 :
- FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- TC_History2 :
- FXACB00.Service_History_Type
- (FXACB00.Quarterly_Period_Type range
- FXACB00.Spring .. FXACB00.Summer,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- TC_History3 :
- FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- begin
-
- Ada.Streams.Stream_IO.Reset (Util_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Input all of the data that is contained in the stream.
- -- Compare all data with the original data in package FXACB00
- -- that was written to the stream.
-
- Retrieve_Data_From_Stream (TC_Residence, TC_Months1, TC_History1);
- Retrieve_Data_From_Stream (TC_Apartment, TC_Months2, TC_History2);
- Retrieve_Data_From_Stream (Customer => TC_Commercial,
- Months => TC_Months3,
- History => TC_History3);
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Util_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- -- Verify that the data values read from the stream are the same
- -- as those written to the stream.
-
- if ((FXACB00."/="(FXACB00.Customer1, TC_Residence)) or else
- (FXACB00."/="(FXACB00.Customer2, TC_Apartment)) or else
- (FXACB00."/="(FXACB00.Customer3, TC_Commercial)))
- then
- Report.Failed ("Customer information incorrect");
- end if;
-
- if ((FXACB00."/="(FXACB00.C1_Months, TC_Months1)) or
- (FXACB00."/="(FXACB00.C2_Months, TC_Months2)) or
- (FXACB00."/="(FXACB00.C3_Months, TC_Months3)))
- then
- Report.Failed ("Number of Months information incorrect");
- end if;
-
- if not ((FXACB00."="(FXACB00.C1_Service_History, TC_History1)) and
- (FXACB00."="(FXACB00.C2_Service_History, TC_History2)) and
- (FXACB00."="(FXACB00.C3_Service_History, TC_History3)))
- then
- Report.Failed ("Service history information incorrect");
- end if;
-
- end Data_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- -- Delete the file.
- if Ada.Streams.Stream_IO.Is_Open (Util_File) then
- Ada.Streams.Stream_IO.Delete (Util_File);
- else
- Ada.Streams.Stream_IO.Open (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Service_Filename);
- Ada.Streams.Stream_IO.Delete (Util_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACB01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a
deleted file mode 100644
index a0ade9e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a
+++ /dev/null
@@ -1,421 +0,0 @@
--- CXACB02.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 user defined subprograms can override the default
--- attributes 'Input and 'Output using attribute definition clauses,
--- when used with objects of discriminated record and multi-dimensional
--- array types.
---
--- TEST DESCRIPTION:
--- This test demonstrates that the default implementations of the
--- 'Input and 'Output attributes can be overridden by user specified
--- subprograms in conjunction with attribute definition clauses.
--- These attributes have been overridden below, and in the user defined
--- substitutes, values are added or subtracted to global variables.
--- Following the completion of the writing/reading test, the global
--- variables are evaluated to ensure that the user defined subprograms
--- were used in overriding the type-related default attributes.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected test errors for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Streams.Stream_IO;
-
-procedure CXACB02 is
-begin
-
- Report.Test ("CXACB02", "Check that user defined subprograms can " &
- "override the default attributes 'Input and " &
- "'Output using attribute definition clauses");
-
- Test_for_Stream_IO_Support:
- declare
-
- Util_File : Ada.Streams.Stream_IO.File_Type;
- Util_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Utility_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Filename);
-
- Operational_Test_Block:
- declare
-
- type Customer_Type is (Residence, Apartment, Commercial);
- type Electric_Usage_Type is range 0..100000;
- type Months_In_Service_Type is range 1..12;
- type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter);
- subtype Month_In_Quarter_Type is Positive range 1..3;
- type Service_History_Type is
- array (Quarterly_Period_Type range <>,
- Month_In_Quarter_Type range <>) of Electric_Usage_Type;
-
- type Service_Type (Customer : Customer_Type) is
- record
- Name : String (1..21);
- Account_ID : Natural range 0..100;
- case Customer is
- when Residence | Apartment =>
- Low_Income_Credit : Boolean := False;
- when Commercial =>
- Baseline_Allowance : Natural range 0..1000;
- Quantity_Discount : Boolean := False;
- end case;
- end record;
-
-
- -- Mode conformant, user defined subprograms that will override
- -- the type-related attributes.
- -- In this test, the user defines these subprograms to add/subtract
- -- specific values from global variables.
-
- function Service_Input
- (Stream : access Ada.Streams.Root_Stream_Type'Class)
- return Service_Type;
-
- procedure Service_Output
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_Type);
-
- function History_Input
- (Stream : access Ada.Streams.Root_Stream_Type'Class)
- return Service_History_Type;
-
- procedure History_Output
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_History_Type);
-
-
- -- Attribute definition clauses.
-
- for Service_Type'Input use Service_Input;
- for Service_Type'Output use Service_Output;
-
- for Service_History_Type'Input use History_Input;
- for Service_History_Type'Output use History_Output;
-
-
- -- Object Declarations
-
- Customer1 : Service_Type (Residence) :=
- (Residence, "1221 Morningstar Lane", 44, False);
- Customer2 : Service_Type (Apartment) :=
- (Customer => Apartment,
- Account_ID => 67,
- Name => "15 South Front St. #8",
- Low_Income_Credit => True);
- Customer3 : Service_Type (Commercial) :=
- (Commercial,
- "12442 Central Avenue ",
- 100,
- Baseline_Allowance => 938,
- Quantity_Discount => True);
-
- C1_Service_History :
- Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (Spring => (1 => 35, 2 => 39, 3 => 32),
- Summer => (1 => 34, 2 => 33, 3 => 39),
- Autumn => (1 => 45, 2 => 40, 3 => 38),
- Winter => (1 => 53, 2 => 0, 3 => 0));
-
- C2_Service_History :
- Service_History_Type (Quarterly_Period_Type range Spring..Summer,
- Month_In_Quarter_Type) :=
- (Spring => (23, 22, 0), Summer => (0, 0, 0));
-
- C3_Service_History :
- Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => 200));
-
-
- TC_Input_Total : Integer := 0;
- TC_Output_Total : Integer := 0;
-
-
- -- Subprogram bodies.
- -- These subprograms are designed to override the default attributes
- -- 'Input and 'Output for the specified types. Each adds/subtracts
- -- a quantity to/from a program control variable, indicating its
- -- activity. Each user defined "Input" function uses the 'Read
- -- attribute for the type to accomplish the operation. Likewise,
- -- each user defined "Output" subprogram uses the 'Write attribute
- -- for the type.
-
- function Service_Input
- ( Stream : access Ada.Streams.Root_Stream_Type'Class )
- return Service_Type is
- Customer : Customer_Type;
- begin
- TC_Input_Total := TC_Input_Total + 1;
-
- -- Extract the discriminant value from the stream.
- -- This discriminant would not otherwise be extracted from the
- -- stream when the Service_Type'Read attribute is used below.
- Customer_Type'Read (Stream, Customer);
-
- declare
- -- Declare a constant of Service_Type, using the value just
- -- read from the stream as the discriminant value of the
- -- object.
- Service : Service_Type(Customer);
- begin
- Service_Type'Read (Stream, Service);
- return Service;
- end;
- end Service_Input;
-
-
- procedure Service_Output
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_Type ) is
- begin
- TC_Output_Total := TC_Output_Total + 2;
- -- Write the discriminant value to the stream.
- -- The attribute 'Write (for the record type) will not write the
- -- discriminant of the record object to the stream. Therefore, it
- -- must be explicitly written using the 'Write attribute of the
- -- discriminant type.
- Customer_Type'Write (Stream, Item.Customer);
- -- Write the record component values (but not the discriminant) to
- -- the stream.
- Service_Type'Write (Stream, Item);
- end Service_Output;
-
-
- function History_Input
- ( Stream : access Ada.Streams.Root_Stream_Type'Class )
- return Service_History_Type is
- Quarter_Bound_Low : Quarterly_Period_Type;
- Quarter_Bound_High : Quarterly_Period_Type;
- Month_Bound_Low : Month_In_Quarter_Type;
- Month_Bound_High : Month_In_Quarter_Type;
- begin
- TC_Input_Total := TC_Input_Total + 3;
-
- -- Read the value of the array bounds from the stream.
- -- Use these bounds in the creation of an array object that will
- -- be used to store data from the stream.
- -- The array bound values would not otherwise be read from the
- -- stream by use of the Service_History_Type'Read attribute.
- Quarterly_Period_Type'Read (Stream, Quarter_Bound_Low);
- Quarterly_Period_Type'Read (Stream, Quarter_Bound_High);
- Month_In_Quarter_Type'Read (Stream, Month_Bound_Low);
- Month_In_Quarter_Type'Read (Stream, Month_Bound_High);
-
- declare
- Service_History_Array :
- Service_History_Type
- (Quarterly_Period_Type range
- Quarter_Bound_Low..Quarter_Bound_High,
- Month_In_Quarter_Type range
- Month_Bound_Low .. Month_Bound_High);
- begin
- Service_History_Type'Read (Stream, Service_History_Array);
- return Service_History_Array;
- end;
- end History_Input;
-
-
- procedure History_Output
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_History_Type ) is
- begin
- TC_Output_Total := TC_Output_Total + 7;
- -- Write the upper/lower bounds of the array object dimensions to
- -- the stream.
- Quarterly_Period_Type'Write (Stream, Item'First(1));
- Quarterly_Period_Type'Write (Stream, Item'Last(1));
- Month_In_Quarter_Type'Write (Stream, Item'First(2));
- Month_In_Quarter_Type'Write (Stream, Item'Last(2));
- -- Write the array values to the stream in canonical order (last
- -- dimension varying fastest).
- Service_History_Type'Write (Stream, Item);
- end History_Output;
-
-
-
- begin
-
- Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File);
-
- -- Write data to the stream. A customer service record is followed
- -- by a service history array.
-
- Service_Type'Output (Util_Stream, Customer1);
- Service_History_Type'Output (Util_Stream, C1_Service_History);
-
- Service_Type'Output (Util_Stream, Customer2);
- Service_History_Type'Output (Util_Stream, C2_Service_History);
-
- Service_Type'Output (Util_Stream, Customer3);
- Service_History_Type'Output (Util_Stream, C3_Service_History);
-
-
- -- Read data from the stream, and verify the use of the user specified
- -- attributes.
-
- Verify_Data_Block:
- declare
-
- TC_Residence : Service_Type (Residence);
- TC_Apartment : Service_Type (Apartment);
- TC_Commercial : Service_Type (Commercial);
-
- TC_History1 : Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- TC_History2 : Service_History_Type (Quarterly_Period_Type
- range Spring .. Summer,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- TC_History3 : Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- begin
-
- -- Reset Stream file to mode In_File.
-
- Ada.Streams.Stream_IO.Reset (Util_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Read data from the stream.
-
- TC_Residence := Service_Type'Input (Util_Stream);
- TC_History1 := Service_History_Type'Input (Util_Stream);
-
- TC_Apartment := Service_Type'Input (Util_Stream);
- TC_History2 := Service_History_Type'Input (Util_Stream);
-
- TC_Commercial := Service_Type'Input (Util_Stream);
- TC_History3 := Service_History_Type'Input (Util_Stream);
-
-
- -- Verify product data was correctly written to/read from stream,
- -- including discriminants and array bounds.
-
- if (TC_Residence /= Customer1) or
- (TC_Residence.Customer /= Customer1.Customer) or
- (TC_History1'Last(1) /= C1_Service_History'Last(1)) or
- (TC_History1'First(1) /= C1_Service_History'First(1)) or
- (TC_History1'Last(2) /= C1_Service_History'Last(2)) or
- (TC_History1'First(2) /= C1_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 1");
- end if;
-
- if (TC_Apartment /= Customer2) or
- (TC_Apartment.Customer /= Customer2.Customer) or
- (TC_History2 /= C2_Service_History) or
- (TC_History2'Last(1) /= C2_Service_History'Last(1)) or
- (TC_History2'First(1) /= C2_Service_History'First(1)) or
- (TC_History2'Last(2) /= C2_Service_History'Last(2)) or
- (TC_History2'First(2) /= C2_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 2");
- end if;
-
- if (TC_Commercial /= Customer3) or
- (TC_Commercial.Customer /= Customer3.Customer) or
- (TC_History3 /= C3_Service_History) or
- (TC_History3'Last(1) /= C3_Service_History'Last(1)) or
- (TC_History3'First(1) /= C3_Service_History'First(1)) or
- (TC_History3'Last(2) /= C3_Service_History'Last(2)) or
- (TC_History3'First(2) /= C3_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 3");
- end if;
-
- -- Verify that the user defined subprograms were used to override
- -- the default 'Input and 'Output attributes.
- -- There were three calls on each of the user defined attributes.
-
- if (TC_Input_Total /= 12 ) or (TC_Output_Total /= 27 ) then
- Report.Failed ("Incorrect use of user defined attributes");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Util_File) then
- Ada.Streams.Stream_IO.Delete (Util_File);
- else
- Ada.Streams.Stream_IO.Open (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Filename);
- Ada.Streams.Stream_IO.Delete (Util_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACB02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a
deleted file mode 100644
index 3ab88f4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a
+++ /dev/null
@@ -1,299 +0,0 @@
--- CXACC01.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 use of 'Class'Output and 'Class'Input allow stream
--- manipulation of objects of non-limited class-wide types.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of 'Class'Output and 'Class'Input
--- in moving objects of a particular class to and from a stream file.
--- A procedure uses a class-wide parameter to move objects of specific
--- types in the class to the stream, using the 'Class'Output attribute
--- of the root type of the class. A function returns a class-wide object,
--- using the 'Class'Input attribute of the root type of the class to
--- extract the object from the stream.
--- A field-by-field comparison of record objects is performed to validate
--- the data read from the stream. Operator precedence rules are used
--- in the comparison rather than parentheses.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1.
--- 24 Aug 96 SAIC Changed a call to "Create" to "Reset".
--- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report;
-
-procedure CXACC01 is
-
- Order_File : Ada.Streams.Stream_IO.File_Type;
- Order_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Order_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXACC01" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXACC01", "Check that the use of 'Class'Output " &
- "and 'Class'Input allow stream manipulation " &
- "of objects of non-limited class-wide types");
-
- Test_for_Stream_IO_Support:
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Order_File,
- Ada.Streams.Stream_IO.Out_File,
- Order_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- -- Store tag values associated with objects of tagged types.
-
- TC_Box_Office_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag);
-
- TC_Summer_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag);
-
- TC_Mayoral_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag);
-
- TC_Late_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag);
-
- -- The following procedure will take an object of the Ticket_Request
- -- class and output it to the stream. Objects of any extended type
- -- in the class can be output to the stream with this procedure.
-
- procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is
- begin
- FXACC00.Ticket_Request'Class'Output (Order_Stream, Order);
- end Order_Entry;
-
-
- -- The following function will retrieve from the stream an object of
- -- the Ticket_Request class.
-
- function Order_Retrieval return FXACC00.Ticket_Request'Class is
- begin
- return FXACC00.Ticket_Request'Class'Input (Order_Stream);
- end Order_Retrieval;
-
- begin
-
- Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File);
-
- -- Store the data objects in the stream.
- -- Each of the objects is of a different type within the class.
-
- Order_Entry (FXACC00.Box_Office_Request); -- Object of root type
- Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type
- Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type
- Order_Entry (FXACC00.Late_Request); -- Object of twice
- -- extended type.
-
- -- Reset mode of stream to In_File prior to reading data from it.
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Order_File,
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO - 1" );
- raise Incomplete;
- end Reset1;
-
- Process_Order_Block:
- declare
-
- use FXACC00;
-
- -- Declare variables of the root type class,
- -- and initialize them with class-wide objects returned from
- -- the stream as function result.
-
- Order_1 : Ticket_Request'Class := Order_Retrieval;
- Order_2 : Ticket_Request'Class := Order_Retrieval;
- Order_3 : Ticket_Request'Class := Order_Retrieval;
- Order_4 : Ticket_Request'Class := Order_Retrieval;
-
- -- Declare objects of the specific types from within the class
- -- that correspond to the types of the data written to the
- -- stream. Perform a type conversion on the class-wide objects.
-
- Ticket_Order : Ticket_Request :=
- Ticket_Request(Order_1);
- Subscriber_Order : Subscriber_Request :=
- Subscriber_Request(Order_2);
- VIP_Order : VIP_Request :=
- VIP_Request(Order_3);
- Last_Minute_Order : Last_Minute_Request :=
- Last_Minute_Request(Order_4);
-
- begin
-
- -- Perform a field-by-field comparison of all the class-wide
- -- objects input from the stream with specific type objects
- -- originally written to the stream.
-
- if Ticket_Order.Location /=
- Box_Office_Request.Location or
- Ticket_Order.Number_Of_Tickets /=
- Box_Office_Request.Number_Of_Tickets
- then
- Report.Failed ("Ticket_Request object validation failure");
- end if;
-
- if Subscriber_Order.Location /=
- Summer_Subscription.Location or
- Subscriber_Order.Number_Of_Tickets /=
- Summer_Subscription.Number_Of_Tickets or
- Subscriber_Order.Subscription_Number /=
- Summer_Subscription.Subscription_Number
- then
- Report.Failed ("Subscriber_Request object validation failure");
- end if;
-
- if VIP_Order.Location /=
- Mayoral_Ticket_Request.Location or
- VIP_Order.Number_Of_Tickets /=
- Mayoral_Ticket_Request.Number_Of_Tickets or
- VIP_Order.Rank /=
- Mayoral_Ticket_Request.Rank
- then
- Report.Failed ("VIP_Request object validation failure");
- end if;
-
- if Last_Minute_Order.Location /=
- Late_Request.Location or
- Last_Minute_Order.Number_Of_Tickets /=
- Late_Request.Number_Of_Tickets or
- Last_Minute_Order.Rank /=
- Late_Request.Rank or
- Last_Minute_Order.Special_Consideration /=
- Late_Request.Special_Consideration or
- Last_Minute_Order.Donation /=
- Late_Request.Donation
- then
- Report.Failed ("Last_Minute_Request object validation failure");
- end if;
-
- -- Verify tag values from before and after processing.
- -- The 'Tag attribute is used with objects of a class-wide type.
-
- if TC_Box_Office_Tag /=
- Ada.Tags.External_Tag(Order_1'Tag)
- then
- Report.Failed("Failed tag comparison - 1");
- end if;
-
- if TC_Summer_Tag /=
- Ada.Tags.External_Tag(Order_2'Tag)
- then
- Report.Failed("Failed tag comparison - 2");
- end if;
-
- if TC_Mayoral_Tag /=
- Ada.Tags.External_Tag(Order_3'Tag)
- then
- Report.Failed("Failed tag comparison - 3");
- end if;
-
- if TC_Late_Tag /=
- Ada.Tags.External_Tag(Order_4'Tag)
- then
- Report.Failed("Failed tag comparison - 4");
- end if;
-
- end Process_Order_Block;
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Operational Block");
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Order_File) then
- Ada.Streams.Stream_IO.Delete (Order_File);
- else
- Ada.Streams.Stream_IO.Open (Order_File,
- Ada.Streams.Stream_IO.Out_File,
- Order_Filename);
- Ada.Streams.Stream_IO.Delete (Order_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXACC01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a
deleted file mode 100644
index ae3497a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a
+++ /dev/null
@@ -1,199 +0,0 @@
--- CXAF001.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 implementation supports the functionality defined
--- in Package Ada.Command_Line.
---
--- TEST DESCRIPTION:
--- This test verifies that an implementation supports the subprograms
--- contained in package Ada.Command_Line. Each of the subprograms
--- is exercised in a general sense, to ensure that it is available,
--- and that it provides the prescribed results in a known test
--- environment. Function Argument_Count must return zero, or the
--- number of arguments passed to the program calling it. Function
--- Argument is called with a parameter value one greater than the
--- actual number of arguments passed to the executing program, which
--- must result in Constraint_Error being raised. Function Command_Name
--- should return the name of the executing program that called it
--- (specifically, this test name). Function Set_Exit_Status is called
--- with two different parameter values, the constants Failure and
--- Success defined in package Ada.Command_Line.
---
--- The setting of the variable TC_Verbose allows for some additional
--- output to be displayed during the running of the test as an aid in
--- tracing the processing flow of the test.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations that support the
--- declaration of package Command_Line as defined in the Ada Reference
--- manual.
--- An alternative declaration is allowed for package Command_Line if
--- different functionality is appropriate for the external execution
--- environment.
---
---
--- CHANGE HISTORY:
--- 10 Jul 95 SAIC Initial prerelease version.
--- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 05 AUG 98 EDS Allow Null string result to be returned from
--- Function Command
---!
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Report;
-
-procedure CXAF001 is
-begin
-
- Report.Test ("CXAF001", "Check that an implementation supports the " &
- "functionality defined in Package " &
- "Ada.Command_Line");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- type String_Access is access all String;
-
- TC_Verbose : Boolean := False;
- Number_Of_Arguments : Natural := Natural'Last;
- Name_Of_Command : String_Access;
-
- begin
-
- -- Check the result of function Argument_Count.
- -- Note: If the external environment does not support passing arguments
- -- to the program invoking the function, the function result
- -- will be zero.
-
- Number_Of_Arguments := Ada.Command_Line.Argument_Count;
- if Number_Of_Arguments = Natural'Last then
- Report.Failed("Argument_Count did not provide a return result");
- end if;
- if TC_Verbose then
- Report.Comment
- ("Argument_Count = " & Integer'Image(Number_Of_Arguments));
- end if;
-
-
- -- Check that the result of Function Argument is Constraint_Error
- -- when the Number argument is outside the range of 1..Argument_Count.
-
- Test_Function_Argument_1 :
- begin
- declare
-
- -- Define a value that will be outside the range of
- -- 1..Argument_Count.
- -- Note: If the external execution environment does not support
- -- passing arguments to a program, then Argument(N) for
- -- any N will raise Constraint_Error, since
- -- Argument_Count = 0;
-
- Arguments_Plus_One : Positive :=
- Ada.Command_Line.Argument_Count + 1;
-
- -- Using the above value in a call to Argument must result in
- -- the raising of Constraint_Error.
-
- Argument_String : constant String :=
- Ada.Command_Line.Argument(Arguments_Plus_One);
-
- begin
- Report.Failed("Constraint_Error not raised by Function " &
- "Argument when provided a Number argument " &
- "out of range");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- if TC_Verbose then
- Report.Comment ("Argument_Count raised Constraint_Error");
- end if;
- when others =>
- Report.Failed ("Unexpected exception raised by Argument " &
- "in Test_Function_Argument_1 block");
- end Test_Function_Argument_1;
-
-
- -- Check that Function Argument returns a string result.
-
- Test_Function_Argument_2 :
- begin
- if Ada.Command_Line.Argument_Count > 0 then
- Report.Comment
- ("Last argument is: " &
- Ada.Command_Line.Argument(Ada.Command_Line.Argument_Count));
- elsif TC_Verbose then
- Report.Comment("Argument_Count is zero, no test of Function " &
- "Argument for string result");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised by Argument " &
- "in Test_Function_Argument_2 block");
- end Test_Function_Argument_2;
-
-
- -- Check the result of Function Command_Name.
-
- Name_Of_Command := new String'(Ada.Command_Line.Command_Name);
-
- if Name_Of_Command = null then
- Report.Failed("Null string pointer returned from Function Command");
- elsif Name_Of_Command.all = "" then
- Report.Comment("Null string result returned from Function Command");
- elsif TC_Verbose then
- Report.Comment("Invoking command is " & Name_Of_Command.all);
- end if;
-
-
- -- Check that procedure Set_Exit_Status is available.
- -- Note: If the external execution environment does not support
- -- returning an exit value from a program, then Set_Exit_Status
- -- does nothing.
-
- Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure);
- if TC_Verbose then
- Report.Comment("Exit status set to Failure");
- end if;
-
- Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success);
- if TC_Verbose then
- Report.Comment("Exit status set to Success");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXAF001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a
deleted file mode 100644
index 73f9209..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a
+++ /dev/null
@@ -1,633 +0,0 @@
--- CXB2001.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 subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 8 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 8 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- A check is performed in the test to determine whether the bit
--- ordering method used by the machine/implementation is high-order
--- first ("Big Endian") or low-order first ("Little Endian"). The
--- specific subtests use this information to evaluate the results of
--- each of the functions under test.
---
--- Note: In the string associated with each Report.Failed statement, the
--- acronym BE refers to Big Endian, LE refers to Little Endian.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 8 bits.
---
---
--- CHANGE HISTORY:
--- 21 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2001 is
-begin
-
- Report.Test ("CXB2001",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "produce correct results for values of signed and " &
- "modular integer types of 8 bits");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces;
-
- TC_Amount : Natural := Natural'First;
- Big_Endian : Boolean := False;
-
- -- Range of type Unsigned_8 is 0..255 (0..Modulus-1).
- TC_Val_Unsigned_8,
- TC_Result_Unsigned_8 : Unsigned_8 := Unsigned_8'First;
-
- begin
-
- -- Determine whether the machine uses high-order first or low-order
- -- first bit ordering.
- -- On a high-order first machine, bit zero of a storage element is
- -- the most significant bit (interpreting the sequence of bits that
- -- represent a component as an unsigned integer value).
- -- On a low-order first machine, bit zero is the least significant.
- -- In this check, a right shift of one place on a Big Endian machine
- -- will yield a result of one, while on a Little Endian machine the
- -- result would be four.
-
- TC_Val_Unsigned_8 := 2;
- Big_Endian := (Shift_Right(TC_Val_Unsigned_8, 1) = 1);
-
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
- -- Function Shift_Left.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Left(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed("Incorrect result from BE Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_8, 2) /= 252 or
- Shift_Left(TC_Val_Unsigned_8, 3) /= 248 or
- Shift_Left(TC_Val_Unsigned_8, 5) /= 224 or
- Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 9) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Shift_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Left(TC_Val_Unsigned_8, 1) /= 2 or
- Shift_Left(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from BE Shift_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 7;
- if Shift_Left(TC_Val_Unsigned_8, Amount => 4) /= 112 or
- Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Left - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Left(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 127 then
- Report.Failed("Incorrect result from LE Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_8, 2) /= 63 or
- Shift_Left(TC_Val_Unsigned_8, 3) /= 31 or
- Shift_Left(TC_Val_Unsigned_8, 5) /= 7 or
- Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Shift_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Left(TC_Val_Unsigned_8, 1) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 7) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Shift_Left(TC_Val_Unsigned_8, 4) /= 8 or
- Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Left - 4");
- end if;
-
- end if;
-
-
-
- -- Function Shift_Right.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Right(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 127 then
- Report.Failed("Incorrect result from BE Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_8, 2) /= 63 or
- Shift_Right(TC_Val_Unsigned_8, 3) /= 31 or
- Shift_Right(TC_Val_Unsigned_8, 5) /= 7 or
- Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Shift_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right(TC_Val_Unsigned_8, 1) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 7) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Shift_Right(TC_Val_Unsigned_8, 4) /= 8 or
- Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Right - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Right(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed("Incorrect result from LE Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_8, 2) /= 252 or
- Shift_Right(TC_Val_Unsigned_8, 3) /= 248 or
- Shift_Right(TC_Val_Unsigned_8, 5) /= 224 or
- Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 9) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Shift_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right(TC_Val_Unsigned_8, 1) /= 2 or
- Shift_Right(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from LE Shift_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 7;
- if Shift_Right(TC_Val_Unsigned_8, Amount => 4) /= 112 or
- Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Right - 4");
- end if;
-
- end if;
-
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Val_Unsigned_8 := 32;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 128 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 6) /= 2 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 8) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Val_Unsigned_8 := 32;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 8 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 3) /= 64 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 4) /= 128
- then
- Report.Failed("Incorrect result from LE Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
- end if;
-
-
-
- -- Function Shift_Right_Arithmetic.
-
- if Big_Endian then -- High-order first bit ordering.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
- -- Modulus of type Unsigned_8 is 256; half of the modulus is 128.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 127; -- Less than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- TC_Amount);
- if TC_Result_Unsigned_8 /= 63 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 15 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 3 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 3");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 128; -- One half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 192 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 4");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 192 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 5");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 224 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 240 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 252 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 6");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /=
- Unsigned_8'Last
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 7");
- end if;
-
- else -- Low-order first bit ordering
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 127; -- Less than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 1");
- end if;
-
- TC_Val_Unsigned_8 := 2;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 8 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 64 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 2");
- end if;
-
- TC_Val_Unsigned_8 := 64;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 128 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 3");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 128; -- One half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 4");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 5");
- end if;
-
- TC_Val_Unsigned_8 := 135; -- Greater than one half of modulus.
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 63 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 6");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /=
- Unsigned_8'Last
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 7");
- end if;
-
- end if;
-
-
-
- -- Function Rotate_Left.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129;
- TC_Result_Unsigned_8 := Rotate_Left(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed("Incorrect result from BE Rotate_Left - 1");
- end if;
-
- if Rotate_Left(TC_Val_Unsigned_8, 2) /= 6 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 12 or
- Rotate_Left(TC_Val_Unsigned_8, 5) /= 48 or
- Rotate_Left(TC_Val_Unsigned_8, 8) /= 129 or
- Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Rotate_Left(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or
- Rotate_Left(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 82;
- if Rotate_Left(TC_Val_Unsigned_8, Amount => 4) /= 37 or
- Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 82
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 1;
- TC_Result_Unsigned_8 := Rotate_Left(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 128 then
- Report.Failed("Incorrect result from LE Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_8 := 15;
- if Rotate_Left(TC_Val_Unsigned_8, 2) /= 195 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 225 or
- Rotate_Left(TC_Val_Unsigned_8, 5) /= 120 or
- Rotate_Left(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or
- Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Rotate_Left(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then
- Report.Failed("Incorrect result from LE Rotate_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 12;
- if Rotate_Left(TC_Val_Unsigned_8, 1) /= 6 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 129
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 4");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Rotate_Left(TC_Val_Unsigned_8, 4) /= 24 or
- Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 129
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 5");
- end if;
-
- end if;
-
-
-
- -- Function Rotate_Right.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 1;
- TC_Result_Unsigned_8 := Rotate_Right(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 128 then
- Report.Failed("Incorrect result from BE Rotate_Right - 1");
- end if;
-
- TC_Val_Unsigned_8 := 15;
- if Rotate_Right(TC_Val_Unsigned_8, 2) /= 195 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 225 or
- Rotate_Right(TC_Val_Unsigned_8, 5) /= 120 or
- Rotate_Right(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or
- Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Rotate_Right(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then
- Report.Failed("Incorrect result from BE Rotate_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 12;
- if Rotate_Right(TC_Val_Unsigned_8, 1) /= 6 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 129
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 4");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Rotate_Right(TC_Val_Unsigned_8, 4) /= 24 or
- Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 129
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 5");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129;
- TC_Result_Unsigned_8 := Rotate_Right(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed("Incorrect result from LE Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_8, 2) /= 6 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 12 or
- Rotate_Right(TC_Val_Unsigned_8, 5) /= 48 or
- Rotate_Right(TC_Val_Unsigned_8, 8) /= 129 or
- Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Rotate_Right(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or
- Rotate_Right(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 82;
- if Rotate_Right(TC_Val_Unsigned_8, Amount => 4) /= 37 or
- Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 82
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 4");
- end if;
-
- end if;
-
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Val_Unsigned_8 := 17;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 68 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 17 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 68
- then
- Report.Failed("Incorrect result from BE Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Val_Unsigned_8 := 4;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 1 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 64 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 1
- then
- Report.Failed("Incorrect result from LE Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a
deleted file mode 100644
index 9457222..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CXB2002.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 subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 16 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 16 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 16 bits.
---
---
--- CHANGE HISTORY:
--- 21 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Removed subtests based on Big/Little Endian.
--- 17 Feb 97 PWB.CTA Corrected "-" to "+" in parenthesized expressions.
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2002 is
-begin
-
- Report.Test ("CXB2002",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "produce correct results for values of signed and " &
- "modular integer types of 16 bits");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces;
-
- TC_Amount : Natural := Natural'First;
-
- -- Range of type Unsigned_16 is 0..65535 (0..Modulus-1).
- TC_Val_Unsigned_16,
- TC_Result_Unsigned_16 : Unsigned_16 := Unsigned_16'First;
-
- begin
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
- -- Function Shift_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Shift_Left(TC_Val_Unsigned_16, TC_Amount);
-
- if TC_Result_Unsigned_16 /= Unsigned_16'Last - (2**0 + 2**1 + 2**2)
- then
- Report.Failed("Incorrect result from Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or
- Shift_Left(TC_Val_Unsigned_16, 5) /=
- Unsigned_16'Last - (2**0 + 2**1 + 2**2 + 2**3 +2**4) or
- Shift_Left(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Left - 2");
- end if;
-
-
- -- Function Shift_Right.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Shift_Right(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_16 /= Unsigned_16'Last-(2**15 + 2**14 + 2**13)
- then
- Report.Failed("Incorrect result from Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or
- Shift_Right(TC_Val_Unsigned_16, 5) /=
- Unsigned_16'Last-(2**15 + 2**14 + 2**13 + 2**12 + 2**11) or
- Shift_Right(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Right - 2");
- end if;
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- TC_Val_Unsigned_16 := Unsigned_16'Last;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_16, 4), 4) /=
- Unsigned_16'Last-(2**0 + 2**1 + 2**2 + 2**3) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_16, 1), 3) /=
- Unsigned_16'Last-(2**0 + 2**1 + 2**2) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 4) /=
- Unsigned_16'Last-(2**15+ 2**14 + 2**13 + 2**12) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
-
- -- Function Shift_Right_Arithmetic.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
- -- Modulus of type Unsigned_16 is 2**16; one half is 2**15.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := 2**15 - 1; -- Less than one half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /=
- TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /=
- TC_Val_Unsigned_16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 5) /=
- TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12 + 2**11 + 2**10) or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 2");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**15; -- One half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 3");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**15 + 1; -- Greater than half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 - 2**0 then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 4");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /=
- TC_Val_Unsigned_16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 4) /=
- TC_Val_Unsigned_16 - 2**0 + 2**14 + 2**13 + 2**12 + 2**11 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= Unsigned_16'Last
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 5");
- end if;
-
-
- -- Function Rotate_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Rotate_Left(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
- if TC_Result_Unsigned_16 /= Unsigned_16'Last then
- Report.Failed("Incorrect result from Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_16 := 2**15 + 2**14 + 2**1 + 2**0;
- if Rotate_Left(TC_Val_Unsigned_16, 0) /=
- 2**15 + 2**14 + 2**1 + 2**0 or
- Rotate_Left(TC_Val_Unsigned_16, 5) /=
- 2**6 + 2**5 + 2**4 + 2**3 or
- Rotate_Left(TC_Val_Unsigned_16, 16) /= TC_Val_Unsigned_16
- then
- Report.Failed("Incorrect result from Rotate_Left - 2");
- end if;
-
-
- -- Function Rotate_Right.
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**1 + 2**0;
- TC_Result_Unsigned_16 := Rotate_Right(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
- if TC_Result_Unsigned_16 /= 2**15 + 2**0 then
- Report.Failed("Incorrect result from Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_16, 0) /= 2**1 + 2**0 or
- Rotate_Right(TC_Val_Unsigned_16, 5) /= 2**12 + 2**11 or
- Rotate_Right(TC_Val_Unsigned_16, 16) /= 2**1 + 2**0
- then
- Report.Failed("Incorrect result from Rotate_Right - 2");
- end if;
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- TC_Val_Unsigned_16 := 32769;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 4), 3) /= 49152 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 1), 3) /= 6 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 3), 7) /= 6144 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 1), 16) /= 3
- then
- Report.Failed("Incorrect result from Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a
deleted file mode 100644
index ec3998a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a
+++ /dev/null
@@ -1,255 +0,0 @@
--- CXB2003.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 subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 32 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 32 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 32 bits.
---
---
--- CHANGE HISTORY:
--- 23 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Removed all references to Big/Little endian.
---
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2003 is
-begin
-
- Report.Test ("CXB2003",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "are available and produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
-
- TC_Amount : Natural := Natural'First;
-
- -- Range of type Unsigned_32 is 0..(2**32)-1 (0..Modulus-1).
- TC_Val_Unsigned_32,
- TC_Result_Unsigned_32 : Unsigned_32 := Unsigned_32'First;
-
- begin
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
-
- -- Function Shift_Left.
-
- TC_Amount := 2;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Shift_Left(TC_Val_Unsigned_32, TC_Amount);
-
- if TC_Result_Unsigned_32 /= Unsigned_32'Last - (2**0 + 2**1) then
- Report.Failed("Incorrect result from Shift_Left - 1");
- end if;
-
- TC_Result_Unsigned_32 := Unsigned_32'Last - (2**0 + 2**1 + 2**2 +
- 2**3 + 2**4);
- if Shift_Left(TC_Val_Unsigned_32, 5) /= TC_Result_Unsigned_32 or
- Shift_Left(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last
- then
- Report.Failed("Incorrect result from Shift_Left - 2");
- end if;
-
-
- -- Function Shift_Right.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Shift_Right(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**29)
- then
- Report.Failed("Incorrect result from Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last or
- Shift_Right(TC_Val_Unsigned_32, 2) /= Unsigned_32'Last -
- (2**31 + 2**30)
- then
- Report.Failed("Incorrect result from Shift_Right - 2");
- end if;
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- TC_Val_Unsigned_32 := Unsigned_32'Last;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_32, 4), 4) /=
- Unsigned_32'Last - (2**0 + 2**1 + 2**2 + 2**3) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_32, 3), 1) /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**0) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_32, 5), 3) /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**2 + 2**1 + 2**0) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_32, 2), 1) /=
- Unsigned_32'Last - (2**31 + 2**0)
- then
- Report.Failed("Incorrect result from Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
-
- -- Function Shift_Right_Arithmetic.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := 2**15 + 2**10 + 2**1;
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**12 + 2**7) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /=
- TC_Val_Unsigned_32 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_32, 5) /=
- (2**10 + 2**5)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 2");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_32 := 2**31; -- One half of modulus
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 3");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_32 := (2**31 + 2**1);
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30 + 2**0) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 4");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /=
- TC_Val_Unsigned_32 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_32, 3) /=
- (2**31 + 2**30 + 2**29 + 2**28)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 5");
- end if;
-
-
- -- Function Rotate_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Rotate_Left(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /= Unsigned_32'Last then
- Report.Failed("Incorrect result from Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_32 := 2**31 + 2**30;
- if Rotate_Left(TC_Val_Unsigned_32, 1) /= (2**31 + 2**0) or
- Rotate_Left(TC_Val_Unsigned_32, 5) /= (2**4 + 2**3) or
- Rotate_Left(TC_Val_Unsigned_32, 32) /= TC_Val_Unsigned_32
- then
- Report.Failed("Incorrect result from Rotate_Left - 2");
- end if;
-
-
- -- Function Rotate_Right.
-
- TC_Amount := 2;
- TC_Val_Unsigned_32 := (2**1 + 2**0);
- TC_Result_Unsigned_32 := Rotate_Right(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30) then
- Report.Failed("Incorrect result from Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_32, 3) /= (2**30 + 2**29) or
- Rotate_Right(TC_Val_Unsigned_32, 6) /= (2**27 + 2**26) or
- Rotate_Right(TC_Val_Unsigned_32, 32) /= (2**1 + 2**0)
- then
- Report.Failed("Incorrect result from Rotate_Right - 2");
- end if;
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- TC_Val_Unsigned_32 := (2**31 + 2**15 + 2**3);
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 4), 3) /=
- (2**30 + 2**14 + 2**2) or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 1), 3) /=
- (2**17 + 2**5 + 2**1) or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 3), 7) /=
- (2**31 + 2**27 + 2**11) or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 1), 32) /=
- (2**16 + 2**4 + 2**0)
- then
- Report.Failed("Incorrect result from Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a
deleted file mode 100644
index 4d79b24..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a
+++ /dev/null
@@ -1,179 +0,0 @@
--- CXB3001.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 specifications of the package Interfaces.C are
--- available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present. It just checks for the presence of
--- the subprograms. Other tests are designed to exercise the interface.
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.C, this test
--- must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected To_C parameter list for ACVC 2.0.1.
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-
-procedure CXB3001 is
- package C renames Interfaces.C;
- use type C.signed_char;
- use type C.unsigned_char;
- use type C.char;
-
-begin
-
- Report.Test ("CXB3001", "Check the specification of Interfaces.C");
-
- declare -- encapsulate the test
-
-
- tst_CHAR_BIT : constant := C.CHAR_BIT;
- tst_SCHAR_MIN : constant := C.SCHAR_MIN;
- tst_SCHAR_MAX : constant := C.SCHAR_MAX;
- tst_UCHAR_MAX : constant := C.UCHAR_MAX;
-
- -- Signed and Unsigned Integers
-
- tst_int : C.int := C.int'first;
- tst_short : C.short := C.short'first;
- tst_long : C.long := C.long'first;
-
- tst_signed_char_min : C.signed_char := C.signed_char'first;
- tst_signed_char_max : C.signed_char := C.signed_char'last;
-
- tst_unsigned : C.unsigned;
- tst_unsigned_short : C.unsigned_short;
- tst_unsigned_long : C.unsigned_long;
-
- tst_unsigned_char : C.unsigned_char;
- tst_plain_char : C.plain_char;
-
- tst_ptrdiff_t : C.ptrdiff_t;
- tst_size_t : C.size_t;
-
- -- Floating-Point
-
- tst_C_float : C.C_float;
- tst_double : C.double;
- tst_long_double : C.long_double;
-
- -- Characters and Strings
-
- tst_char : C.char;
- tst_nul : C.char := C.nul;
-
- -- Collect all the subprogram calls such that they are compiled
- -- but not executed
- --
- procedure Collect_All_Calls is
-
- CAC_char : C.char;
- CAC_Character : Character;
- CAC_String : string (1..5);
- CAC_Boolean : Boolean := false;
- CAC_char_array : C.char_array(1..5);
- CAC_Integer : integer;
- CAC_Natural : natural;
- CAC_wchar_t : C.wchar_t;
- CAC_Wide_Character : Wide_Character;
- CAC_wchar_array : C.wchar_array(1..5);
- CAC_Wide_String : Wide_String(1..5);
- CAC_size_t : C.size_t;
-
- begin
-
- CAC_char := C.To_C (CAC_Character);
- CAC_Character := C.To_Ada (CAC_char);
-
- CAC_char_array := C.To_C (CAC_String, CAC_Boolean);
- CAC_String := C.To_Ada (CAC_char_array, CAC_Boolean);
-
- -- This call is out of LRM order so that we can use the
- -- array initialized above
- CAC_Boolean := C.Is_Nul_Terminated (CAC_char_array);
-
- C.To_C (CAC_String, CAC_char_array, CAC_size_t, CAC_Boolean);
- C.To_Ada (CAC_char_array, CAC_String, CAC_Natural, CAC_Boolean);
-
- CAC_wchar_t := C.To_C (CAC_Wide_Character);
- CAC_Wide_Character := C.To_Ada (CAC_wchar_t);
- CAC_wchar_t := C.wide_nul;
-
- CAC_wchar_array := C.To_C (CAC_Wide_String, CAC_Boolean);
- CAC_Wide_String := C.To_Ada (CAC_wchar_array, CAC_Boolean);
-
- -- This call is out of LRM order so that we can use the
- -- array initialized above
- CAC_Boolean := C.Is_Nul_Terminated (CAC_wchar_array);
-
- C.To_C (CAC_Wide_String, CAC_wchar_array, CAC_size_t, CAC_Boolean);
- C.To_Ada (CAC_wchar_array, CAC_Wide_String, CAC_Natural, CAC_Boolean);
-
- raise C.Terminator_Error;
-
- end Collect_All_Calls;
-
-
-
- begin -- encapsulation
-
- if tst_signed_char_min /= C.SCHAR_MIN then
- Report.Failed ("tst_signed_char_min is incorrect");
- end if;
- if tst_signed_char_max /= C.SCHAR_MAX then
- Report.Failed ("tst_signed_char_max is incorrect");
- end if;
- if C.signed_char'Size /= C.CHAR_BIT then
- Report.Failed ("C.signed_char'Size is incorrect");
- end if;
-
- if C.unsigned_char'first /= 0 or
- C.unsigned_char'last /= C.UCHAR_MAX or
- C.unsigned_char'size /= C.CHAR_BIT then
-
- Report.Failed ("unsigned_char is incorrectly defined");
-
- end if;
-
- if tst_nul /= C.char'first then
- Report.Failed ("tst_nul is incorrect");
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a
deleted file mode 100644
index b543d46..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- CXB3002.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 specifications of the package Interfaces.C.Strings
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides packages Interfaces.C and
--- Interfaces.C.Strings, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3002 is
- package Strings renames Interfaces.C.Strings;
- package C renames Interfaces.C;
-
-begin
-
- Report.Test ("CXB3002", "Check the specification of Interfaces.C.Strings");
-
-
- declare -- encapsulate the test
-
- TC_Int_1 : integer := 1;
- TC_Int_2 : integer := 1;
- TC_String : String := "ABCD";
- TC_Boolean : Boolean := true;
- TC_char_array : C.char_array (1..5);
- TC_size_t : C.size_t := C.size_t'first;
-
-
- -- Note In all of the following the Strings spec. being tested
- -- is shown in comment lines
- --
- -- type char_array_access is access all char_array;
- TST_char_array_access : Strings.char_array_access :=
- new Interfaces.C.char_array (1..5);
-
- -- type chars_ptr is private;
- -- Null_Ptr : constant chars_ptr;
- TST_chars_ptr : Strings.chars_ptr := Strings.Null_ptr;
-
- -- type chars_ptr_array is array (size_t range <>) of chars_ptr;
- TST_chars_ptr_array : Strings.chars_ptr_array(1..5);
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int_1, TC_Int_2 ) then
-
- -- function To_Chars_Ptr (Item : in char_array_access;
- -- Nul_Check : in Boolean := False)
- -- return chars_ptr;
- TST_chars_ptr := Strings.To_Chars_Ptr
- (TST_char_array_access, TC_Boolean);
-
- -- This one is out of LRM order so that we can "initialize"
- -- TC_char_array for the "in" parameter of the next one
- --
- -- function Value (Item : in chars_ptr) return char_array;
- TC_char_array := Strings.Value (TST_chars_ptr);
-
- -- function New_Char_Array (Chars : in char_array)
- -- return chars_ptr;
- TST_chars_ptr := Strings.New_Char_Array (TC_char_array);
-
- -- function New_String (Str : in String) return chars_ptr;
- TST_chars_ptr := Strings.New_String ("TEST STRING");
-
- -- procedure Free (Item : in out chars_ptr);
- Strings.Free (TST_chars_ptr);
-
- -- function Value (Item : in chars_ptr; Length : in size_t)
- -- return char_array;
- TC_char_array := Strings.Value (TST_chars_ptr, TC_size_t);
-
- -- Use Report.Comment as a known procedure which takes a string as
- -- a parameter (this does not actually get output)
- -- function Value (Item : in chars_ptr) return String;
- Report.Comment ( Strings.Value (TST_chars_ptr) );
-
- -- function Value (Item : in chars_ptr; Length : in size_t)
- -- return String;
- TC_String := Strings.Value (TST_chars_ptr, TC_size_t);
-
- -- function Strlen (Item : in chars_ptr) return size_t;
- TC_size_t := Strings.Strlen (TST_chars_ptr);
-
- -- procedure Update (Item : in chars_ptr;
- -- Offset : in size_t;
- -- Chars : in char_array;
- -- Check : in Boolean := True);
- Strings.Update (TST_chars_ptr, TC_size_t, TC_char_array, TC_Boolean);
-
- -- procedure Update (Item : in chars_ptr;
- -- Offset : in size_t;
- -- Str : in String;
- -- Check : in Boolean := True);
- Strings.Update (TST_chars_ptr, TC_size_t, TC_String, TC_Boolean);
-
- -- Update_Error : exception;
- raise Strings.Update_Error;
-
- end if;
-
- if not Report.Equal ( TC_Int_2, TC_Int_1 ) then
-
- -- This exception is out of LRM presentation order to avoid
- -- compiler warnings about unreachable code
- -- Dereference_Error : exception;
- raise Strings.Dereference_Error;
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a
deleted file mode 100644
index c395837..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXB3003.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 specifications of the package Interfaces.C.Pointers
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.C.Pointers, this
--- test must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3003 is
- package C renames Interfaces.C;
-
- package Test_Ptrs is new C.Pointers
- (Index => C.size_t,
- Element => C.Char,
- Element_Array => C.Char_Array,
- Default_Terminator => C.Nul);
-
-begin
-
- Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers");
-
-
- declare -- encapsulate the test
-
- TC_Int : integer := 1;
-
- -- Note: In all of the following the Pointers spec. being tested
- -- is shown in comments
- --
- -- type Pointer is access all Element;
- subtype TST_Pointer_Type is Test_Ptrs.Pointer;
-
- TST_Element : C.Char := C.Char'First;
- TST_Pointer : TST_Pointer_Type := null;
- TST_Pointer_2 : TST_Pointer_Type := null;
- TST_Array : C.char_array (1..5);
- TST_Index : C.ptrdiff_t := C.ptrdiff_t'First;
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int, TC_Int ) then
-
-
- -- function Value (Ref : in Pointer;
- -- Terminator : in Element := Default_Terminator)
- -- return Element_Array;
-
- TST_Array := Test_Ptrs.Value ( TST_Pointer ); -- default
- TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element );
-
- -- function Value (Ref : in Pointer; Length : in ptrdiff_t)
- -- return Element_Array;
-
- TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index);
-
- --
- -- -- C-style Pointer arithmetic
- --
- -- function "+" (Left : in Pointer; Right : in ptrdiff_t)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index);
-
- -- function "+" (Left : in Ptrdiff_T; Right : in Pointer)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer);
-
- -- function "-" (Left : in Pointer; Right : in ptrdiff_t)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index);
-
- -- function "-" (Left : in Pointer; Right : in Pointer)
- -- return ptrdiff_t;
- TST_Index := Test_Ptrs."-" (TST_Pointer, TST_Pointer);
-
- -- procedure Increment (Ref : in out Pointer);
- Test_Ptrs.Increment (TST_Pointer);
-
- -- procedure Decrement (Ref : in out Pointer);
- Test_Ptrs.Decrement (TST_Pointer);
-
- -- function Virtual_Length
- -- ( Ref : in Pointer;
- -- Terminator : in Element := Default_Terminator)
- -- return ptrdiff_t;
- TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer);
- TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element);
-
- -- procedure Copy_Terminated_Array
- -- (Source : in Pointer;
- -- Target : in Pointer;
- -- Limit : in ptrdiff_t := ptrdiff_t'Last;
- -- Terminator : in Element := Default_Terminator);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
- TST_Pointer_2,
- TST_Index);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
- TST_Pointer_2,
- TST_Index,
- TST_Element);
-
-
- -- procedure Copy_Array
- -- (Source : in Pointer;
- -- Target : in Pointer;
- -- Length : in ptrdiff_t);
-
- Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index);
-
- -- This is out of LRM order to avoid complaints from compilers
- -- about inaccessible code
- -- Pointer_Error : exception;
-
- raise Test_Ptrs.Pointer_Error;
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c
deleted file mode 100644
index 1e96e4a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c
+++ /dev/null
@@ -1,172 +0,0 @@
-/*
--- CXB30040.C
---
--- 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.
---*
---
--- FUNCTION NAME: CXB30040 ("char_gen")
---
--- FUNCTION DESCRIPTION:
--- This C function returns the value of type char corresponding to the
--- value of its parameter, where
--- Val 0 .. 9 ==> '0' .. '9'
--- Val 10 .. 19 ==> 'A' .. 'J'
--- Val 20 .. 29 ==> 'k' .. 't'
--- Val 30 ==> ' '
--- Val 31 ==> '.'
--- Val 32 ==> ','
---
--- INPUT:
--- This function requires that one int parameter be passed to it.
---
--- OUTPUT:
--- The function will return the appropriate value of type char.
---
--- CHANGE HISTORY:
--- 13 Sep 99 RLB Created function to replace incorrect
--- Unchecked_Conversion.
---
---!
-*/
-
-char CXB30040 (int val)
-
-/* NOTE: The above function definition should be accepted by an ANSI-C */
-/* compiler. Older C compilers may reject it; they may, however */
-/* accept the following two lines. An implementation may comment */
-/* out the above function definition and uncomment the following */
-/* one. Otherwise, an implementation must provide the necessary */
-/* modifications to this C code to satisfy the function */
-/* requirements (see Function Description). */
-/* */
-/* char CXB30040 (val) */
-/* int val; */
-/* */
-
-{ char return_value = ';';
-
- switch (val)
- {
- case 0:
- return_value = '0';
- break;
- case 1:
- return_value = '1';
- break;
- case 2:
- return_value = '2';
- break;
- case 3:
- return_value = '3';
- break;
- case 4:
- return_value = '4';
- break;
- case 5:
- return_value = '5';
- break;
- case 6:
- return_value = '6';
- break;
- case 7:
- return_value = '7';
- break;
- case 8:
- return_value = '8';
- break;
- case 9:
- return_value = '9';
- break;
- case 10:
- return_value = 'A';
- break;
- case 11:
- return_value = 'B';
- break;
- case 12:
- return_value = 'C';
- break;
- case 13:
- return_value = 'D';
- break;
- case 14:
- return_value = 'E';
- break;
- case 15:
- return_value = 'F';
- break;
- case 16:
- return_value = 'G';
- break;
- case 17:
- return_value = 'H';
- break;
- case 18:
- return_value = 'I';
- break;
- case 19:
- return_value = 'J';
- break;
- case 20:
- return_value = 'k';
- break;
- case 21:
- return_value = 'l';
- break;
- case 22:
- return_value = 'm';
- break;
- case 23:
- return_value = 'n';
- break;
- case 24:
- return_value = 'o';
- break;
- case 25:
- return_value = 'p';
- break;
- case 26:
- return_value = 'q';
- break;
- case 27:
- return_value = 'r';
- break;
- case 28:
- return_value = 's';
- break;
- case 29:
- return_value = 't';
- break;
- case 30:
- return_value = ' ';
- break;
- case 31:
- return_value = '.';
- break;
- case 32:
- return_value = ',';
- break;
- }
-
- return (return_value); /* Return character value */
-}
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am
deleted file mode 100644
index 73b874e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am
+++ /dev/null
@@ -1,377 +0,0 @@
--- CXB30041.AM
---
--- 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 functions To_C and To_Ada map between the Ada type
--- Character and the C type char.
---
--- Check that the function Is_Nul_Terminated returns True if the
--- char_array parameter contains nul, and otherwise False.
---
--- Check that the function To_C produces a correct char_array result,
--- with lower bound of 0, and length dependent upon the Item and
--- Append_Nul parameters.
---
--- Check that the function To_Ada produces a correct string result, with
--- lower bound of 1, and length dependent upon the Item and Trim_Nul
--- parameters.
---
--- Check that the function To_Ada raises Terminator_Error if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- does not contain the nul char.
---
--- TEST DESCRIPTION:
--- This test uses a variety of Character, char, String, and char_array
--- objects to test versions of the To_C, To_Ada, and Is_Nul_Terminated
--- functions.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- SPECIAL REQUIREMENTS:
--- The file CXB30040.C must be compiled with a C compiler.
--- Implementation dialects of C may require alteration of
--- the C program syntax (see individual C files).
---
--- Note that the compiled C code must be bound with the compiled Ada
--- code to create an executable image. An implementation must provide
--- the necessary commands to accomplish this.
---
--- Note that the C code included in CXB30040.C conforms
--- to ANSI-C. Modifications to these files may be required for other
--- C compilers. An implementation must provide the necessary
--- modifications to satisfy the function requirements.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CXB30040.C
--- CXB30041.AM
---
--- CHANGE HISTORY:
--- 30 Aug 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a
--- C function character generator.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-with Impdef;
-
-procedure CXB30041 is
-begin
-
- Report.Test ("CXB3004", "Check that the functions To_C and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters, Ada.Characters.Latin_1;
- use Ada.Exceptions;
- use Ada.Strings.Fixed;
-
- Start_Character,
- Stop_Character,
- TC_Character : Character := Character'First;
- TC_char,
- TC_Low_char,
- TC_High_char : char := char'First;
- TC_String : String(1..8) := (others => Latin_1.NUL);
- TC_char_array : char_array(0..7) := (others => C.nul);
-
- -- The function Char_Gen returns a character corresponding to its
- -- argument.
- -- Value 0 .. 9 ==> '0' .. '9'
- -- Value 10 .. 19 ==> 'A' .. 'J'
- -- Value 20 .. 29 ==> 'k' .. 't'
- -- Value 30 ==> ' '
- -- Value 31 ==> '.'
- -- Value 32 ==> ','
-
- function Char_Gen (Value : in int) return char;
-
- -- Use the user-defined C function char_gen as a completion to the
- -- function specification above.
-
- pragma Import (Convention => C,
- Entity => Char_Gen,
- External_Name => Impdef.CXB30040_External_Name);
-
- begin
-
- -- Check that the functions To_C and To_Ada map between the Ada type
- -- Character and the C type char.
-
- if To_C(Ada.Characters.Latin_1.NUL) /= Interfaces.C.nul then
- Report.Failed("Incorrect result from To_C with NUL character input");
- end if;
-
- Start_Character := Report.Ident_Char('k');
- Stop_Character := Report.Ident_Char('t');
- for TC_Character in Start_Character..Stop_Character loop
- if To_C(Item => TC_Character) /=
- Char_Gen(Character'Pos(TC_Character) - Character'Pos('k') + 20) then
- Report.Failed("Incorrect result from To_C with lower case " &
- "alphabetic character input");
- end if;
- end loop;
-
- Start_Character := Report.Ident_Char('A');
- Stop_Character := Report.Ident_Char('J');
- for TC_Character in Start_Character..Stop_Character loop
- if To_C(Item => TC_Character) /=
- Char_Gen(Character'Pos(TC_Character) - Character'Pos('A') + 10) then
- Report.Failed("Incorrect result from To_C with upper case " &
- "alphabetic character input");
- end if;
- end loop;
-
- Start_Character := Report.Ident_Char('0');
- Stop_Character := Report.Ident_Char('9');
- for TC_Character in Start_Character..Stop_Character loop
- if To_C(Item => TC_Character) /=
- Char_Gen(Character'Pos(TC_Character) - Character'Pos('0')) then
- Report.Failed("Incorrect result from To_C with digit " &
- "character input");
- end if;
- end loop;
- if To_C(Item => ' ') /= Char_Gen(30) then
- Report.Failed("Incorrect result from To_C with space " &
- "character input");
- end if;
- if To_C(Item => '.') /= Char_Gen(31) then
- Report.Failed("Incorrect result from To_C with dot " &
- "character input");
- end if;
- if To_C(Item => ',') /= Char_Gen(32) then
- Report.Failed("Incorrect result from To_C with comma " &
- "character input");
- end if;
-
- if To_Ada(Interfaces.C.nul) /= Ada.Characters.Latin_1.NUL then
- Report.Failed("Incorrect result from To_Ada with nul char input");
- end if;
-
- for Code in int range
- int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop
- -- 'k' .. 't'
- if To_Ada(Item => Char_Gen(Code)) /=
- Character'Val (Character'Pos('k') + (Code - 20)) then
- Report.Failed("Incorrect result from To_Ada with lower case " &
- "alphabetic char input");
- end if;
- end loop;
-
- for Code in int range
- int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop
- -- 'A' .. 'J'
- if To_Ada(Item => Char_Gen(Code)) /=
- Character'Val (Character'Pos('A') + (Code - 10)) then
- Report.Failed("Incorrect result from To_Ada with upper case " &
- "alphabetic char input");
- end if;
- end loop;
-
- for Code in int range
- int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop
- -- '0' .. '9'
- if To_Ada(Item => Char_Gen(Code)) /=
- Character'Val (Character'Pos('0') + (Code)) then
- Report.Failed("Incorrect result from To_Ada with digit " &
- "char input");
- end if;
- end loop;
-
- if To_Ada(Item => Char_Gen(30)) /= ' ' then
- Report.Failed("Incorrect result from To_Ada with space " &
- "char input");
- end if;
- if To_Ada(Item => Char_Gen(31)) /= '.' then
- Report.Failed("Incorrect result from To_Ada with dot " &
- "char input");
- end if;
- if To_Ada(Item => Char_Gen(32)) /= ',' then
- Report.Failed("Incorrect result from To_Ada with comma " &
- "char input");
- end if;
-
- -- Check that the function Is_Nul_Terminated produces correct results
- -- whether or not the char_array argument contains the
- -- Ada.Interfaces.C.nul character.
-
- TC_String := "abcdefgh";
- if Is_Nul_Terminated(Item => To_C(TC_String, Append_Nul => False)) then
- Report.Failed("Incorrect result from Is_Nul_Terminated when no " &
- "nul char is present");
- end if;
-
- if not Is_Nul_Terminated(To_C(TC_String, Append_Nul => True)) then
- Report.Failed("Incorrect result from Is_Nul_Terminated when the " &
- "nul char is present");
- end if;
-
-
- -- Now that we've tested the character/char versions of To_Ada and To_C,
- -- use them to test the string versions.
-
- declare
- i : size_t := 0;
- j : integer := 1;
- Incorrect_Conversion : Boolean := False;
-
- TC_No_nul : constant char_array := To_C(TC_String, False);
- TC_nul_Appended : constant char_array := To_C(TC_String, True);
- begin
-
- -- Check that the function To_C produces a char_array result with
- -- lower bound of 0, and length dependent upon the Item and
- -- Append_Nul parameters (if Append_Nul is True, length is
- -- Item'Length + 1; if False, length is Item'Length).
-
- if TC_No_nul'First /= 0 or TC_nul_Appended'First /= 0 then
- Report.Failed("Incorrect lower bound from Function To_C");
- end if;
-
- if TC_No_nul'Length /= TC_String'Length then
- Report.Failed("Incorrect length returned from Function To_C " &
- "when Append_Nul => False");
- end if;
-
- for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop
- if TC_No_nul(i) /= To_C(TC_char) or -- Single character To_C.
- TC_nul_Appended(i) /= To_C(TC_char) then
- Incorrect_Conversion := True;
- end if;
- i := i + 1;
- end loop;
-
- if Incorrect_Conversion then
- Report.Failed("Incorrect result from To_C with string input " &
- "and char_array result");
- end if;
-
-
- if TC_nul_Appended'Length /= TC_String'Length + 1 then
- Report.Failed("Incorrect length returned from Function To_C " &
- "when Append_Nul => True");
- end if;
-
- if not Is_Nul_Terminated(TC_nul_Appended) then
- Report.Failed("No nul appended to the string parameter during " &
- "conversion to char_array by function To_C");
- end if;
-
-
- -- Check that the function To_Ada produces a string result with
- -- lower bound of 1, and length dependent upon the Item and
- -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length;
- -- if True, length will be the length of the slice of Item prior to
- -- the first nul).
-
- declare
- TC_No_NUL_String : constant String :=
- To_Ada(Item => TC_nul_Appended,
- Trim_Nul => True);
- TC_NUL_Appended_String : constant String :=
- To_Ada(TC_nul_Appended, False);
- begin
-
- if TC_No_NUL_String'First /= 1 or
- TC_NUL_Appended_String'First /= 1
- then
- Report.Failed("Incorrect lower bound from Function To_Ada");
- end if;
-
- if TC_No_NUL_String'Length /= TC_String'Length then
- Report.Failed("Incorrect length returned from Function " &
- "To_Ada when Trim_Nul => True");
- end if;
-
- if TC_NUL_Appended_String'Length /= TC_String'Length + 1 then
- Report.Failed("Incorrect length returned from Function " &
- "To_Ada when Trim_Nul => False");
- end if;
-
- Start_Character := Report.Ident_Char('a');
- Stop_Character := Report.Ident_Char('h');
- for TC_Character in Start_Character..Stop_Character loop
- if TC_No_NUL_String(j) /= TC_Character or
- TC_NUL_Appended_String(j) /= TC_Character
- then
- Report.Failed("Incorrect result from To_Ada with " &
- "char_array input, index = " &
- Integer'Image(j));
- end if;
- j := j + 1;
- end loop;
-
- end;
-
-
- -- Check that the function To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the nul char.
-
- begin
- TC_String := To_Ada(TC_No_nul, Trim_Nul => True);
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "nul char, but parameter Trim_Nul => True");
- Report.Comment(TC_String & " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by function " &
- "To_Ada when the Item parameter does not " &
- "contain the nul char, but parameter " &
- "Trim_Nul => True");
- end;
-
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB30041;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a
deleted file mode 100644
index 30b9405..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a
+++ /dev/null
@@ -1,396 +0,0 @@
--- CXB3005.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 procedure To_C converts the character elements of
--- a string parameter into char elements of the char_array parameter
--- Target, with nul termination if parameter Append_Nul is true.
---
--- Check that the out parameter Count of procedure To_C is set to the
--- appropriate value for both the nul/no nul terminated cases.
---
--- Check that Constraint_Error is propagated by procedure To_C if the
--- length of the char_array parameter Target is not sufficient to
--- hold the converted string value.
---
--- Check that the Procedure To_Ada converts char elements of the
--- char_array parameter Item to the corresponding character elements
--- of string out parameter Target.
---
--- Check that Constraint_Error is propagated by Procedure To_Ada if the
--- length of string parameter Target is not long enough to hold the
--- converted char_array value.
---
--- Check that Terminator_Error is propagated by Procedure To_Ada if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- contains no nul char.
---
--- TEST DESCRIPTION:
--- This test uses a variety of String, and char_array objects to test
--- versions of the To_C and To_Ada procedures.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '-'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- CHANGE HISTORY:
--- 01 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-
-procedure CXB3005 is
-begin
-
- Report.Test ("CXB3005", "Check that the procedures To_C and To_Ada " &
- "produce correct results");
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters;
- use Ada.Exceptions;
- use Ada.Strings.Fixed;
-
- TC_Short_String : String(1..4) := (others => 'x');
- TC_String : String(1..8) := (others => 'y');
- TC_char_array : char_array(0..7) := (others => char'Last);
- TC_size_t_Count : size_t := size_t'First;
- TC_Natural_Count : Natural := Natural'First;
-
-
- -- We can use the character forms of To_Ada and To_C here to check
- -- the results; they were tested in CXB3004. We give them different
- -- names to avoid confusion below.
-
- function Character_to_char (Source : in Character) return char
- renames To_C;
- function char_to_Character (Source : in char) return Character
- renames To_Ada;
-
- begin
-
- -- Check that the procedure To_C converts the character elements of
- -- a string parameter into char elements of char_array out parameter
- -- Target.
- --
- -- Case of nul termination.
-
- TC_String(1..6) := "abcdef";
-
- To_C (Item => TC_String(1..6), -- Source slice of length 6.
- Target => TC_char_array, -- Length 8 will accommodate nul.
- Count => TC_size_t_Count,
- Append_Nul => True);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the nul terminated case.
-
- if TC_size_t_Count /= 7 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => True");
- end if;
-
- for i in 1..TC_size_t_Count-1 loop
- if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual char values, case of " &
- "Append_Nul => True; " &
- "char position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if not Is_Nul_Terminated(TC_char_array) then
- Report.Failed("No nul char appended to the char_array result " &
- "from Procedure To_C when Append_Nul => True");
- end if;
-
- if TC_char_array(0..6) /= To_C("abcdef", True) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing char_array results, case " &
- "of Append_Nul => True");
- end if;
-
-
- -- Check Procedure To_C with no nul termination.
-
- TC_char_array := (others => Character_to_char('M')); -- Reinitialize.
- TC_String(1..4) := "WXYZ";
-
- To_C (Item => TC_String(1..4), -- Source slice of length 4.
- Target => TC_char_array,
- Count => TC_size_t_Count,
- Append_Nul => False);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the non-nul terminated case.
-
- if TC_size_t_Count /= 4 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => False");
- end if;
-
- for i in 1..TC_size_t_Count loop
- if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual char values, case of " &
- "Append_Nul => False; " &
- "char position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if Is_Nul_Terminated(TC_char_array) then
- Report.Failed("The nul char was appended to the char_array " &
- "result of Procedure To_C when Append_Nul => False");
- end if;
-
- if TC_char_array(0..3) /= To_C("WXYZ", False) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing char_array results, case " &
- "of Append_Nul => False");
- end if;
-
-
-
- -- Check that Constraint_Error is raised by procedure To_C if the
- -- length of the target char_array parameter is not sufficient to
- -- hold the converted string value (plus nul if Append_Nul is True).
-
- begin
- To_C("A string too long",
- TC_char_array,
- TC_size_t_Count,
- Append_Nul => True);
-
- Report.Failed("Constraint_Error not raised when the Target " &
- "parameter of Procedure To_C is not long enough " &
- "to hold the converted string");
- Report.Comment(char_to_Character(TC_char_array(0)) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_C when the Target parameter is not long " &
- "enough to contain the char_array result");
- end;
-
-
-
- -- Check that the procedure To_Ada converts char elements of the
- -- char_array parameter Item to the corresponding character elements
- -- of string out parameter Target, with result string length based on
- -- the Trim_Nul parameter.
- --
- -- Case of appended nul char on the char_array In parameter.
-
- TC_char_array := To_C ("ACVC-95", Append_Nul => True); -- 8 total chars.
- TC_String := (others => '*'); -- Reinitialize.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => False, when a nul is present in " &
- "the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) /= Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is not Nul, even though a nul was present " &
- "in the char_array argument, and the Trim_Nul " &
- "parameter was set to False");
- end if;
-
-
- TC_char_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars.
- TC_String := (others => '*'); -- Reinit.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- if TC_Natural_Count /= 3 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => True");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => True, when a nul is present in " &
- "the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) = Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is Nul, even though the Trim_Nul " &
- "parameter was set to True");
- end if;
-
- -- Check that TC_String(TC_Natural_Count+1) is unchanged by procedure
- -- To_Ada.
-
- if TC_String(TC_Natural_Count+1) /= '*' then
- Report.Failed("Incorrect modification to TC_String at position " &
- Integer'Image(TC_Natural_Count+1) & " expected = " &
- "*, found = " & TC_String(TC_Natural_Count+1));
- end if;
-
-
- -- Case of no nul char being present in the char_array argument.
-
- TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False);
- TC_String := (others => '*'); -- Reinitialize.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False, " &
- "with no nul char present in the parameter Item");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => False, when a nul is not present " &
- "in the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) = Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is Nul, even though the nul char was " &
- "not present in the parameter Item, with the " &
- "parameter Trim_Nul => False");
- end if;
-
-
-
- -- Check that the Procedure To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the nul char.
-
- begin
- TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False);
- TC_String := (others => '*');
-
- To_Ada(TC_char_array,
- TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "nul char, but parameter Trim_Nul => True");
- Report.Comment(TC_String & " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when the Item parameter does not " &
- "contain the nul char, but parameter " &
- "Trim_Nul => True");
- end;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada if the
- -- length of string parameter Target is not long enough to hold the
- -- converted char_array value (plus nul if Trim_Nul is False).
-
- begin
- TC_char_array(0..4) := To_C ("ABCD", Append_Nul => True);
-
- To_Ada(TC_char_array(0..4), -- 4 chars plus nul char.
- TC_Short_String, -- Length of 4.
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- Report.Failed("Constraint_Error not raised when string " &
- "parameter Target of Procedure To_Ada is not " &
- "long enough to hold the converted chars");
- Report.Comment(TC_Short_String & " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when string parameter Target is " &
- "not long enough to hold the converted chars");
- end;
-
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3005;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c
deleted file mode 100644
index c4df008..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c
+++ /dev/null
@@ -1,174 +0,0 @@
-/*
--- CXB30060.C
---
--- 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.
---*
---
--- FUNCTION NAME: CXB30060 ("wchar_gen")
---
--- FUNCTION DESCRIPTION:
--- This C function returns the value of type wchar_t corresponding to the
--- value of its parameter, where
--- Val 0 .. 9 ==> '0' .. '9'
--- Val 10 .. 19 ==> 'A' .. 'J'
--- Val 20 .. 29 ==> 'k' .. 't'
--- Val 30 ==> ' '
--- Val 31 ==> '.'
--- Val 32 ==> ','
---
--- INPUT:
--- This function requires that one int parameter be passed to it.
---
--- OUTPUT:
--- The function will return the appropriate value of type wchar_t.
---
--- CHANGE HISTORY:
--- 13 Sep 99 RLB Created function to replace incorrect
--- Unchecked_Conversion.
---
---!
-*/
-
-#include <stddef.h>
-
-wchar_t CXB30060 (int val)
-
-/* NOTE: The above function definition should be accepted by an ANSI-C */
-/* compiler. Older C compilers may reject it; they may, however */
-/* accept the following two lines. An implementation may comment */
-/* out the above function definition and uncomment the following */
-/* one. Otherwise, an implementation must provide the necessary */
-/* modifications to this C code to satisfy the function */
-/* requirements (see Function Description). */
-/* */
-/* wchar_t CXB30060 (val) */
-/* int val; */
-/* */
-
-{ wchar_t return_value = ';';
-
- switch (val)
- {
- case 0:
- return_value = '0';
- break;
- case 1:
- return_value = '1';
- break;
- case 2:
- return_value = '2';
- break;
- case 3:
- return_value = '3';
- break;
- case 4:
- return_value = '4';
- break;
- case 5:
- return_value = '5';
- break;
- case 6:
- return_value = '6';
- break;
- case 7:
- return_value = '7';
- break;
- case 8:
- return_value = '8';
- break;
- case 9:
- return_value = '9';
- break;
- case 10:
- return_value = 'A';
- break;
- case 11:
- return_value = 'B';
- break;
- case 12:
- return_value = 'C';
- break;
- case 13:
- return_value = 'D';
- break;
- case 14:
- return_value = 'E';
- break;
- case 15:
- return_value = 'F';
- break;
- case 16:
- return_value = 'G';
- break;
- case 17:
- return_value = 'H';
- break;
- case 18:
- return_value = 'I';
- break;
- case 19:
- return_value = 'J';
- break;
- case 20:
- return_value = 'k';
- break;
- case 21:
- return_value = 'l';
- break;
- case 22:
- return_value = 'm';
- break;
- case 23:
- return_value = 'n';
- break;
- case 24:
- return_value = 'o';
- break;
- case 25:
- return_value = 'p';
- break;
- case 26:
- return_value = 'q';
- break;
- case 27:
- return_value = 'r';
- break;
- case 28:
- return_value = 's';
- break;
- case 29:
- return_value = 't';
- break;
- case 30:
- return_value = ' ';
- break;
- case 31:
- return_value = '.';
- break;
- case 32:
- return_value = ',';
- break;
- }
-
- return (return_value); /* Return character value */
-}
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am
deleted file mode 100644
index d31345a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am
+++ /dev/null
@@ -1,404 +0,0 @@
--- CXB30061.AM
---
--- 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 function To_C maps between the Ada type Wide_Character
--- and the C type wchar_t.
---
--- Check that the function To_Ada maps between the C type wchar_t and
--- the Ada type Wide_Character.
---
--- Check that the function Is_Nul_Terminated returns True if the
--- wchar_array parameter contains wide_nul, and otherwise False.
---
--- Check that the function To_C produces a correct wchar_array result,
--- with lower bound of 0, and length dependent upon the Item and
--- Append_Nul parameters.
---
--- Check that the function To_Ada produces a correct wide_string result,
--- with lower bound of 1, and length dependent upon the Item and
--- Trim_Nul parameters.
---
--- Check that the function To_Ada raises Terminator_Error if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- does not contain the wide_nul wchar_t.
---
--- TEST DESCRIPTION:
--- This test uses a variety of Wide_Character, wchar_t, Wide_String, and
--- wchar_array objects to test versions of the To_C, To_Ada, and
--- Is_Nul_Terminated functions.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.wchar_t:
--- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- SPECIAL REQUIREMENTS:
--- The file CXB30060.C must be compiled with a C compiler.
--- Implementation dialects of C may require alteration of
--- the C program syntax (see individual C files).
---
--- Note that the compiled C code must be bound with the compiled Ada
--- code to create an executable image. An implementation must provide
--- the necessary commands to accomplish this.
---
--- Note that the C code included in CXB30060.C conforms
--- to ANSI-C. Modifications to these files may be required for other
--- C compilers. An implementation must provide the necessary
--- modifications to satisfy the function requirements.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CXB30060.C
--- CXB30061.AM
---
--- CHANGE HISTORY:
--- 07 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a
--- C function character generator.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Strings.Wide_Fixed;
-with Impdef;
-
-procedure CXB30061 is
-begin
-
- Report.Test ("CXB3006", "Check that the functions To_C and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters, Ada.Characters.Latin_1, Ada.Characters.Handling;
- use Ada.Strings.Wide_Fixed;
-
- First_Character,
- Last_Character : Character;
- TC_wchar_t,
- TC_Low_wchar_t,
- TC_High_wchar_t : wchar_t := wchar_t'First;
- TC_Wide_String : Wide_String(1..8) := (others => Wide_Character'First);
- TC_wchar_array : wchar_array(0..7) := (others => C.wide_nul);
-
- -- The function Char_Gen returns a character corresponding to its
- -- argument.
- -- Value 0 .. 9 ==> '0' .. '9'
- -- Value 10 .. 19 ==> 'A' .. 'J'
- -- Value 20 .. 29 ==> 'k' .. 't'
- -- Value 30 ==> ' '
- -- Value 31 ==> '.'
- -- Value 32 ==> ','
-
- function Char_Gen (Value : in int) return wchar_t;
-
- -- Use the user-defined C function char_gen as a completion to the
- -- function specification above.
-
- pragma Import (Convention => C,
- Entity => Char_Gen,
- External_Name => Impdef.CXB30060_External_Name);
-
- begin
-
- -- Check that the functions To_C and To_Ada map between the Ada type
- -- Wide_Character and the C type wchar_t.
-
- if To_C(To_Wide_Character(Ada.Characters.Latin_1.NUL)) /=
- Interfaces.C.wide_nul
- then
- Report.Failed("Incorrect result from To_C with NUL character input");
- end if;
-
- First_Character := Report.Ident_Char('k');
- Last_Character := Report.Ident_Char('t');
- for i in First_Character..Last_Character loop
- if To_C(Item => To_Wide_Character(i)) /=
- Char_Gen(Character'Pos(i) - Character'Pos('k') + 20)
- then
- Report.Failed("Incorrect result from To_C with lower case " &
- "alphabetic wide character input");
- end if;
- end loop;
-
- First_Character := Report.Ident_Char('A');
- Last_Character := Report.Ident_Char('J');
- for i in First_Character..Last_Character loop
- if To_C(Item => To_Wide_Character(i)) /=
- Char_Gen(Character'Pos(i) - Character'Pos('A') + 10)
- then
- Report.Failed("Incorrect result from To_C with upper case " &
- "alphabetic wide character input");
- end if;
- end loop;
-
- First_Character := Report.Ident_Char('0');
- Last_Character := Report.Ident_Char('9');
- for i in First_Character..Last_Character loop
- if To_C(Item => To_Wide_Character(i)) /=
- Char_Gen(Character'Pos(i) - Character'Pos('0'))
- then
- Report.Failed("Incorrect result from To_C with digit " &
- "wide character input");
- end if;
- end loop;
-
- if To_C(Item => To_Wide_Character(' ')) /= Char_Gen(30)
- then
- Report.Failed("Incorrect result from To_C with space " &
- "wide character input");
- end if;
-
- if To_C(Item => To_Wide_Character('.')) /= Char_Gen(31)
- then
- Report.Failed("Incorrect result from To_C with dot " &
- "wide character input");
- end if;
-
- if To_C(Item => To_Wide_Character(',')) /= Char_Gen(32)
- then
- Report.Failed("Incorrect result from To_C with comma " &
- "wide character input");
- end if;
-
- if To_Ada(Interfaces.C.wide_nul) /=
- To_Wide_Character(Ada.Characters.Latin_1.NUL)
- then
- Report.Failed("Incorrect result from To_Ada with wide_nul " &
- "wchar_t input");
- end if;
-
- for Code in int range
- int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop
- -- 'k' .. 't'
- if To_Ada(Item => Char_Gen(Code)) /=
- To_Wide_Character(Character'Val (Character'Pos('k') + (Code - 20)))
- then
- Report.Failed("Incorrect result from To_Ada with lower case " &
- "alphabetic wchar_t input");
- end if;
- end loop;
-
- for Code in int range
- int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop
- -- 'A' .. 'J'
- if To_Ada(Item => Char_Gen(Code)) /=
- To_Wide_Character(Character'Val (Character'Pos('A') + (Code - 10)))
- then
- Report.Failed("Incorrect result from To_Ada with upper case " &
- "alphabetic wchar_t input");
- end if;
- end loop;
-
- for Code in int range
- int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop
- -- '0' .. '9'
- if To_Ada(Item => Char_Gen(Code)) /=
- To_Wide_Character(Character'Val (Character'Pos('0') + (Code)))
- then
- Report.Failed("Incorrect result from To_Ada with digit " &
- "wchar_t input");
- end if;
- end loop;
-
- if To_Ada(Item => Char_Gen(30)) /= ' ' then
- Report.Failed("Incorrect result from To_Ada with space " &
- "char input");
- end if;
- if To_Ada(Item => Char_Gen(31)) /= '.' then
- Report.Failed("Incorrect result from To_Ada with dot " &
- "char input");
- end if;
- if To_Ada(Item => Char_Gen(32)) /= ',' then
- Report.Failed("Incorrect result from To_Ada with comma " &
- "char input");
- end if;
-
- -- Check that the function Is_Nul_Terminated produces correct results
- -- whether or not the wchar_array argument contains the
- -- Ada.Interfaces.C.wide_nul character.
-
- TC_Wide_String := "abcdefgh";
- if Is_Nul_Terminated(Item => To_C(TC_Wide_String, Append_Nul => False))
- then
- Report.Failed("Incorrect result from Is_Nul_Terminated when no " &
- "wide_nul wchar_t is present");
- end if;
-
- if not Is_Nul_Terminated(To_C(TC_Wide_String, Append_Nul => True)) then
- Report.Failed("Incorrect result from Is_Nul_Terminated when the " &
- "wide_nul wchar_t is present");
- end if;
-
-
-
- -- Now that we've tested the character/char versions of To_Ada and To_C,
- -- use them to test the string versions.
-
- declare
- i : size_t := 0;
- j : integer := 1;
- Incorrect_Conversion : Boolean := False;
-
- TC_No_wide_nul : constant wchar_array := To_C(TC_Wide_String,
- False);
- TC_wide_nul_Appended : constant wchar_array := To_C(TC_Wide_String,
- True);
- begin
-
- -- Check that the function To_C produces a wchar_array result with
- -- lower bound of 0, and length dependent upon the Item and
- -- Append_Nul parameters (if Append_Nul is True, length is
- -- Item'Length + 1; if False, length is Item'Length).
-
- if TC_No_wide_nul'First /= 0 or TC_wide_nul_Appended'First /= 0 then
- Report.Failed("Incorrect lower bound from Function To_C");
- end if;
-
- if TC_No_wide_nul'Length /= TC_Wide_String'Length then
- Report.Failed("Incorrect length returned from Function To_C " &
- "when Append_Nul => False");
- end if;
-
- if TC_wide_nul_Appended'Length /= TC_Wide_String'Length + 1 then
- Report.Failed("Incorrect length returned from Function To_C " &
- "when Append_Nul => True");
- end if;
-
- if not Is_Nul_Terminated(TC_wide_nul_Appended) then
- Report.Failed("No wide_nul appended to the wide_string " &
- "parameter during conversion to wchar_array " &
- "by function To_C");
- end if;
-
- for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop
- if TC_No_wide_nul(i) /= To_C(To_Wide_Character(TC_char)) or
- TC_wide_nul_Appended(i) /= To_C(To_Wide_Character(TC_char)) then
- -- Use single character To_C.
- Incorrect_Conversion := True;
- end if;
- i := i + 1;
- end loop;
-
- if Incorrect_Conversion then
- Report.Failed("Incorrect result from To_C with wide_string input " &
- "and wchar_array result");
- end if;
-
-
- -- Check that the function To_Ada produces a wide_string result with
- -- lower bound of 1, and length dependent upon the Item and
- -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length;
- -- if False, length will be the length of the slice of Item prior to
- -- the first wide_nul).
-
- declare
- TC_No_NUL_Wide_String : constant Wide_String :=
- To_Ada(Item => TC_wide_nul_Appended, Trim_Nul => True);
-
- TC_NUL_Appended_Wide_String : constant Wide_String :=
- To_Ada(TC_wide_nul_Appended, False);
-
- begin
-
- if TC_No_NUL_Wide_String'First /= 1 or
- TC_NUL_Appended_Wide_String'First /= 1
- then
- Report.Failed("Incorrect lower bound from Function To_Ada");
- end if;
-
- if TC_No_NUL_Wide_String'Length /= TC_Wide_String'Length then
- Report.Failed("Incorrect length returned from Function " &
- "To_Ada when Trim_Nul => True");
- end if;
-
- if TC_NUL_Appended_Wide_String'Length /=
- TC_Wide_String'Length + 1
- then
- Report.Failed("Incorrect length returned from Function " &
- "To_Ada when Trim_Nul => False");
- end if;
-
- for TC_Character in Wide_Character'('a') .. Wide_Character'('h') loop
- if TC_No_NUL_Wide_String(j) /= TC_Character or
- TC_NUL_Appended_Wide_String(j) /= TC_Character
- then
- Report.Failed("Incorrect result from To_Ada with " &
- "char_array input, index = " &
- Integer'Image(j));
- end if;
- j := j + 1;
- end loop;
-
- end;
-
-
- -- Check that the function To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the wide_nul wchar_t.
-
- begin
- TC_Wide_String := To_Ada(TC_No_wide_nul, Trim_Nul => True);
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "wide_nul wchar_t, but parameter Trim_Nul " &
- "=> True");
- Report.Comment
- (To_String(TC_Wide_String) & " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by function " &
- "To_Ada when the Item parameter does not " &
- "contain the wide_nul wchar_t, but " &
- "parameter Trim_Nul => True");
- end;
-
- end;
-
- exception
- when The_Error : others =>
- Report.Failed
- ("The following exception was raised in the Test_Block: " &
- Ada.Exceptions.Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB30061;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a
deleted file mode 100644
index 3837e0b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a
+++ /dev/null
@@ -1,408 +0,0 @@
--- CXB3007.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 procedure To_C converts the Wide_Character elements
--- of a Wide_String parameter into wchar_t elements of the wchar_array
--- parameter Target, with wide_nul termination if parameter Append_Nul
--- is true.
---
--- Check that the out parameter Count of procedure To_C is set to the
--- appropriate value for both the wide_nul/no wide_nul terminated cases.
---
--- Check that Constraint_Error is propagated by procedure To_C if the
--- length of the wchar_array parameter Target is not sufficient to
--- hold the converted Wide_String value.
---
--- Check that the Procedure To_Ada converts wchar_t elements of the
--- wchar_array parameter Item to the corresponding Wide_Character
--- elements of Wide_String out parameter Target.
---
--- Check that Constraint_Error is propagated by Procedure To_Ada if the
--- length of Wide_String parameter Target is not long enough to hold the
--- converted wchar_array value.
---
--- Check that Terminator_Error is propagated by Procedure To_Ada if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- contains no wide_nul wchar_t.
---
--- TEST DESCRIPTION:
--- This test uses a variety of Wide_String, and wchar_array objects to
--- test versions of the To_C and To_Ada procedures.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.wchar_t:
--- ' ', 'a'..'z', 'A'..'Z', and '-'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- CHANGE HISTORY:
--- 01 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Strings.Wide_Fixed;
-
-procedure CXB3007 is
-begin
-
- Report.Test ("CXB3007", "Check that the procedures To_C and To_Ada " &
- "for wide strings produce correct results");
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters, Ada.Characters.Handling;
- use Ada.Exceptions;
- use Ada.Strings.Wide_Fixed;
-
- TC_Short_Wide_String : Wide_String(1..4) :=
- (others => Wide_Character'First);
- TC_Wide_String : Wide_String(1..8) :=
- (others => Wide_Character'First);
- TC_wchar_array : wchar_array(0..7) := (others => wchar_t'First);
- TC_size_t_Count : size_t := size_t'First;
- TC_Natural_Count : Natural := Natural'First;
-
-
- -- We can use the wide character forms of To_Ada and To_C here to check
- -- the results; they were tested in CXB3006. We give them different
- -- names to avoid confusion below.
-
- function Wide_Character_to_wchar_t (Source : in Wide_Character)
- return wchar_t renames To_C;
- function wchar_t_to_Wide_Character (Source : in wchar_t)
- return Wide_Character renames To_Ada;
-
- begin
-
- -- Check that the procedure To_C converts the Wide_Character elements
- -- of a Wide_String parameter into wchar_t elements of wchar_array out
- -- parameter Target.
- --
- -- Case of wide_nul termination.
-
- TC_Wide_String(1..6) := "abcdef";
-
- To_C (Item => TC_Wide_String(1..6), -- Source slice of length 6.
- Target => TC_wchar_array,
- Count => TC_size_t_Count,
- Append_Nul => True);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the wide_nul terminated case.
-
- if TC_size_t_Count /= 7 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => True");
- end if;
-
- for i in 1..TC_size_t_Count-1 loop
- if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /=
- TC_Wide_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual wchar_t values, case of " &
- "Append_Nul => True; " &
- "wchar_t position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if not Is_Nul_Terminated(TC_wchar_array) then
- Report.Failed("No wide_nul wchar_t appended to the wchar_array " &
- "result from Procedure To_C when Append_Nul => True");
- end if;
-
- if TC_wchar_array(0..6) /= To_C("abcdef", True) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing wchar_array results, case " &
- "of Append_Nul => True");
- end if;
-
-
- -- Check Procedure To_C with no wide_nul termination.
-
- TC_wchar_array := (others => Wide_Character_to_wchar_t('M'));
- TC_Wide_String(1..4) := "WXYZ";
-
- To_C (Item => TC_Wide_String(1..4), -- Source slice of length 4.
- Target => TC_wchar_array,
- Count => TC_size_t_Count,
- Append_Nul => False);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the non-wide_nul terminated case.
-
- if TC_size_t_Count /= 4 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => False");
- end if;
-
- for i in 1..TC_size_t_Count loop
- if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /=
- TC_Wide_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual wchar_t values, case of " &
- "Append_Nul => False; " &
- "wchar_t position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if Is_Nul_Terminated(TC_wchar_array) then
- Report.Failed
- ("The wide_nul wchar_t was appended to the wchar_array " &
- "result of Procedure To_C when Append_Nul => False");
- end if;
-
- if TC_wchar_array(0..3) /= To_C("WXYZ", False) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing wchar_array results, case " &
- "of Append_Nul => False");
- end if;
-
-
-
- -- Check that Constraint_Error is raised by procedure To_C if the
- -- length of the target wchar_array parameter is not sufficient to
- -- hold the converted Wide_String value (plus wide_nul if Append_Nul
- -- is True).
-
- TC_wchar_array := (others => wchar_t'First);
- begin
- To_C("A string too long",
- TC_wchar_array,
- TC_size_t_Count,
- Append_Nul => True);
-
- Report.Failed("Constraint_Error not raised when the Target " &
- "parameter of Procedure To_C is not long enough " &
- "to hold the converted Wide_String");
- Report.Comment
- (To_Character(wchar_t_to_Wide_Character(TC_wchar_array(0))) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_C when the Target parameter is not long " &
- "enough to contain the wchar_array result");
- end;
-
-
-
- -- Check that the procedure To_Ada converts wchar_t elements of the
- -- wchar_array parameter Item to the corresponding Wide_Character
- -- elements of Wide_String out parameter Target, with result wide
- -- string length based on the Trim_Nul parameter.
- --
- -- Case of appended wide_nul wchar_t on the wchar_array In parameter.
-
- TC_wchar_array :=
- To_C ("ACVC-95", Append_Nul => True); -- 8 total chars.
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => False, when a wide_nul is present " &
- "in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) /= To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is not Nul, even though a " &
- "wide_nul was present in the wchar_array argument, " &
- "and the Trim_Nul parameter was set to False");
- end if;
-
-
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars.
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- if TC_Natural_Count /= 3 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => True");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => True, when a wide_nul is present " &
- "in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is Nul, even though the " &
- "Trim_Nul parameter was set to True");
- end if;
-
- if TC_Wide_String(TC_Natural_Count+1) /= Wide_Character'First then
- Report.Failed("Incorrect replacement from To_Ada");
- end if;
-
-
- -- Case of no wide_nul wchar_t present in the wchar_array argument.
-
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False);
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False, " &
- "with no wide_nul wchar_t present in the parameter " &
- "Item");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => False, when a wide_nul is not " &
- "present in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is Nul, even though the wide_nul " &
- "wchar_t was not present in the parameter Item, " &
- "with the parameter Trim_Nul => False");
- end if;
-
-
-
- -- Check that the Procedure To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the wide_nul wchar_t.
-
- begin
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False);
-
- To_Ada(TC_wchar_array,
- TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "wide_nul wchar_t, but parameter Trim_Nul => True");
- Report.Comment(To_String(TC_Wide_String) &
- " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when the Item parameter does not " &
- "contain the wide_nul wchar_t, but parameter " &
- "Trim_Nul => True");
- end;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada if the
- -- length of Wide_String parameter Target is not long enough to hold the
- -- converted wchar_array value (plus wide_nul if Trim_Nul is False).
-
- begin
- TC_wchar_array(0..4) := To_C ("ABCD", Append_Nul => True);
-
- To_Ada(TC_wchar_array(0..4),
- TC_Short_Wide_String, -- Length of 4.
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- Report.Failed("Constraint_Error not raised when Wide_String " &
- "parameter Target of Procedure To_Ada is not " &
- "long enough to hold the converted wchar_ts");
- Report.Comment(To_String(TC_Short_Wide_String) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when Wide_String parameter Target is " &
- "not long enough to hold the converted wchar_ts");
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3007;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a
deleted file mode 100644
index 9df19d8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a
+++ /dev/null
@@ -1,226 +0,0 @@
--- CXB3008.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 functions imported from the C language <string.h> and
--- <stdlib.h> libraries can be called from an Ada program.
---
--- TEST DESCRIPTION:
--- This test checks that C language functions from the <string.h> and
--- <stdlib.h> libraries can be used as completions of Ada subprograms.
--- A pragma Import with convention identifier "C" is used to complete
--- the Ada subprogram specifications.
--- The three subprogram cases tested are as follows:
--- 1) A C function that returns an int value (strcpy) is used as the
--- completion of an Ada procedure specification. The return value
--- is discarded; parameter modification is the desired effect.
--- 2) A C function that returns an int value (strlen) is used as the
--- completion of an Ada function specification.
--- 3) A C function that returns a double value (strtod) is used as the
--- completion of an Ada function specification.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C and Interfaces.C.Strings. If an
--- implementation provides these packages, this test must compile,
--- execute, and report "PASSED".
---
--- SPECIAL REQUIREMENTS:
--- The C language library functions used by this test must be
--- available for importing into the test.
---
---
--- CHANGE HISTORY:
--- 12 Oct 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Replaced all references of C function atof with
--- C function strtod.
--- 29 JUN 98 EDS Give Ada function corresponding to strtod a
--- second parameter.
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-with Interfaces.C.Pointers;
-
-procedure CXB3008 is
-begin
-
- Report.Test ("CXB3008", "Check that functions imported from the " &
- "C language predefined libraries can be " &
- "called from an Ada program");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- package ICP is new Interfaces.C.Pointers
- ( Index => IC.size_t,
- Element => IC.char,
- Element_Array => IC.char_array,
- Default_Terminator => IC.nul );
- use Ada.Exceptions;
-
- use type IC.char;
- use type IC.char_array;
- use type IC.size_t;
- use type IC.double;
-
- -- The String_Copy procedure copies the string pointed to by Source,
- -- including the terminating nul char, into the char_array pointed
- -- to by Target.
-
- procedure String_Copy (Target : out IC.char_array;
- Source : in IC.char_array);
-
- -- The String_Length function returns the length of the nul-terminated
- -- string pointed to by The_String. The nul is not included in
- -- the count.
-
- function String_Length (The_String : in IC.char_array)
- return IC.size_t;
-
- -- The String_To_Double function converts the char_array pointed to
- -- by The_String into a double value returned through the function
- -- name. The_String must contain a valid floating-point number; if
- -- not, the value returned is zero.
-
--- type Acc_ptr is access IC.char_array;
- function String_To_Double (The_String : in IC.char_array ;
- End_Ptr : ICP.Pointer := null)
- return IC.double;
-
-
- -- Use the <string.h> strcpy function as a completion to the procedure
- -- specification. Note that the Ada interface to this C function is
- -- in the form of a procedure (C function return value is not used).
-
- pragma Import (C, String_Copy, "strcpy");
-
- -- Use the <string.h> strlen function as a completion to the
- -- String_Length function specification.
-
- pragma Import (C, String_Length, "strlen");
-
- -- Use the <stdlib.h> strtod function as a completion to the
- -- String_To_Double function specification.
-
- pragma Import (C, String_To_Double, "strtod");
-
-
- TC_String : constant String := "Just a Test";
- Char_Source : IC.char_array(0..30);
- Char_Target : IC.char_array(0..30);
- Double_Result : IC.double;
- Source_Ptr,
- Target_Ptr : ICS.chars_ptr;
-
- begin
-
- -- Check that the imported version of C function strcpy produces
- -- the correct results.
-
- Char_Source(0..21) := "Test of Pragma Import" & IC.nul;
-
- String_Copy(Char_Target, Char_Source);
-
- if Char_Target(0..21) /= Char_Source(0..21) then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 1");
- end if;
-
- if String_Length(Char_Target) /= 21 then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 1");
- end if;
-
- Char_Source(0) := IC.nul;
-
- String_Copy(Char_Target, Char_Source);
-
- if Char_Target(0) /= Char_Source(0) then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 2");
- end if;
-
- if String_Length(Char_Target) /= 0 then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 2");
- end if;
-
- -- The following chars_ptr designates a char_array of 12 chars
- -- (including the terminating nul char).
- Source_Ptr := ICS.New_Char_Array(IC.To_C(TC_String));
-
- String_Copy(Char_Target, ICS.Value(Source_Ptr));
-
- Target_Ptr := ICS.New_Char_Array(Char_Target);
-
- if ICS.Value(Target_Ptr) /= TC_String then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 3");
- end if;
-
- if String_Length(ICS.Value(Target_Ptr)) /= TC_String'Length then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 3");
- end if;
-
-
- Char_Source(0..9) := "100.00only";
-
- Double_Result := String_To_Double(Char_Source);
-
- Char_Source(0..13) := "5050.00$$$$$$$";
-
- if Double_Result + String_To_Double(Char_Source) /= 5150.00 then
- Report.Failed("Incorrect result returned from the imported " &
- "version of function strtod - 1");
- end if;
-
- Char_Source(0..9) := "xxx$10.00x"; -- String doesn't contain a
- -- valid floating point value.
- if String_To_Double(Char_Source) /= 0.0 then
- Report.Failed("Incorrect result returned from the imported " &
- "version of function strtod - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3008;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a
deleted file mode 100644
index 3ea5a62..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CXB3009.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 function To_Chars_Ptr will return a Null_Ptr value
--- when the parameter Item is null. If the parameter Item is not null,
--- and references a chars_array object that does contain the char nul,
--- and parameter Nul_Check is True, check that To_Chars_Ptr performs a
--- pointer conversion from char_array_access type to chars_ptr type.
--- Check that if parameter Item is not null, and references a
--- chars_array object that does not contain nul, and parameter Nul_Check
--- is True, the To_Chars_Ptr function will propagate Terminator_Error.
--- Check that if parameter Item is not null, and parameter Nul_Check
--- is False, check that To_Chars_Ptr performs a pointer conversion from
--- char_array_access type to chars_ptr type.
---
--- Check that the New_Char_Array function will return a chars_ptr type
--- pointer to an allocated object that has been initialized with
--- the value of parameter Chars.
---
--- Check that the function New_String returns a chars_ptr initialized
--- to a nul-terminated string having the value of the Str parameter.
---
--- TEST DESCRIPTION:
--- This test uses a variety of of string, char_array,
--- char_array_access and char_ptr values in order to validate the
--- functions under test, and results are compared for both length
--- and content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'.. 'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 20 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Remove incorrect block of code (previously
--- lines 264-287)
--- 14 Sep 99 RLB Added check for behavior of To_Chars_Ptr when
--- Nul_Check => False. (From Technical
--- Corrigendum 1).
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-
-procedure CXB3009 is
-begin
-
- Report.Test ("CXB3009", "Check that functions To_Chars_Ptr, " &
- "New_Chars_Array, and New_String produce " &
- "correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- use Ada.Exceptions;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- Test_String : constant String := "Test String";
- String_With_nul : String(1..6) := "Addnul";
- String_Without_nul : String(1..6) := "No nul";
-
- Char_Array_With_nul : IC.char_array(0..6) :=
- IC.To_C(String_With_nul, True);
- Char_Array_Without_nul : IC.char_array(0..5) :=
- IC.To_C(String_Without_nul, False);
- Char_Array_W_nul_Ptr : ICS.char_array_access :=
- new IC.char_array'(Char_Array_With_nul);
- Char_Array_WO_nul_Ptr : ICS.char_array_access :=
- new IC.char_array'(Char_Array_Without_nul);
-
- TC_chars_ptr : ICS.chars_ptr;
-
- TC_size_t : IC.size_t := IC.size_t'First;
-
-
- begin
-
- -- Check that the function To_Chars_Ptr will return a Null_Ptr value
- -- when the parameter Item is null.
-
- if ICS.To_Chars_Ptr(Item => Null_Char_Array_Access,
- Nul_Check => False) /= ICS.Null_Ptr or
- ICS.To_Chars_Ptr(Null_Char_Array_Access,
- Nul_Check => True) /= ICS.Null_Ptr or
- ICS.To_Chars_Ptr(Null_Char_Array_Access) /= ICS.Null_Ptr
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being a null value");
- end if;
-
-
- -- Check that if the parameter Item is not null, and references a
- -- chars_array object that does contain the nul char, and parameter
- -- Nul_Check is True, function To_Chars_Ptr performs a pointer
- -- conversion from char_array_access type to chars_ptr type.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_W_nul_Ptr,
- Nul_Check => True);
-
- if ICS.Value(TC_chars_ptr) /= String_With_nul or
- ICS.Value(TC_chars_ptr) /= Char_Array_With_nul
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being non-null and " &
- "containing the nul char");
- end if;
- exception
- when IC.Terminator_Error =>
- Report.Failed("Terminator_Error raised during the validation " &
- "of Function To_Chars_Ptr");
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "validation of Function To_Chars_Ptr");
- end;
-
- -- Check that if parameter Item is not null, and references a
- -- chars_array object that does not contain nul, and parameter
- -- Nul_Check is True, the To_Chars_Ptr function will propagate
- -- Terminator_Error.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Char_Array_WO_nul_Ptr, True);
- Report.Failed("Terminator_Error was not raised by function " &
- "To_Chars_Ptr when given a parameter Item that " &
- "is non-null, and does not contain the nul " &
- "char, but parameter Nul_Check is True");
- TC_size_t := ICS.Strlen(TC_chars_ptr); -- Use TC_chars_ptr to
- -- defeat optimization;
- exception
- when IC.Terminator_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when function " &
- "To_Chars_Ptr is given a parameter Item that " &
- "is non-null, and does not contain the nul " &
- "char, but parameter Nul_Check is True");
- end;
-
- -- Check that if the parameter Item is not null, and parameter
- -- Nul_Check is False, function To_Chars_Ptr performs a pointer
- -- conversion from char_array_access type to chars_ptr type.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_WO_nul_Ptr,
- Nul_Check => False);
-
- if ICS.Value(TC_chars_ptr, 6) /= String_Without_nul or
- ICS.Value(TC_chars_ptr, 6) /= Char_Array_Without_nul
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being non-null and " &
- "Nul_Check False");
- end if;
- exception
- when IC.Terminator_Error =>
- Report.Failed("Terminator_Error raised during the validation " &
- "of Function To_Chars_Ptr");
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "validation of Function To_Chars_Ptr");
- end;
-
-
- -- Check that the New_Char_Array function will return a chars_ptr type
- -- pointer to an allocated object that has been initialized with
- -- the value of parameter Chars.
- TC_chars_ptr := ICS.New_String("");
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
-
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_With_nul);
-
- if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation.
- Report.Failed
- ("No allocation took place in call to New_Char_Array " &
- "with a non-null char_array parameter containing a " &
- "terminating nul char");
- end if;
-
- -- Length of allocated array is determined using Strlen since array
- -- is nul terminated. Contents of array are validated using Value.
-
- if ICS.Value (TC_chars_ptr, Length => 7) /= Char_Array_With_nul or
- ICS.Strlen(Item => TC_chars_ptr) /= 6
- then
- Report.Failed
- ("Incorrect length of allocated char_array resulting " &
- "from call of New_Char_Array with a non-null " &
- "char_array parameter containing a terminating nul char");
- end if;
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_Without_nul);
-
- if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation.
- Report.Failed
- ("No allocation took place in call to New_Char_Array " &
- "with a non-null char_array parameter that did not " &
- "contain a terminating nul char");
- end if;
-
- -- Function Value is used with the total length of the
- -- Char_Array_Without_nul as a parameter to verify the allocation.
-
- if ICS.Value(Item => TC_chars_ptr, Length => 6) /=
- Char_Array_Without_nul or
- ICS.Strlen(Item => TC_chars_ptr) /= 6
- then
- Report.Failed("Incorrect length of allocated char_array " &
- "resulting from call of New_Char_Array with " &
- "a non-null char_array parameter that did not " &
- "contain a terminating nul char");
- end if;
-
-
- -- Check that the function New_String returns a chars_ptr specifying
- -- an allocated object initialized to the value of parameter Str.
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 3");
- end if;
-
- TC_chars_ptr := ICS.New_String(Str => Test_String);
-
- if ICS.Value(TC_chars_ptr) /= Test_String or
- ICS.Value(ICS.New_Char_Array(IC.To_C(Test_String,True))) /=
- Test_String
- then
- Report.Failed("Incorrect allocation resulting from function " &
- "New_String with a string parameter value");
- end if;
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 4");
- end if;
-
- if ICS.Value(ICS.New_String(String_Without_nul)) /=
- String_Without_nul or
- ICS.Value(ICS.New_Char_Array(IC.To_C(String_Without_nul,False))) /=
- String_Without_nul
- then
- Report.Failed("Incorrect allocation resulting from function " &
- "New_String with parameter value String_Without_nul");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3009;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a
deleted file mode 100644
index 25305b2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a
+++ /dev/null
@@ -1,320 +0,0 @@
--- CXB3010.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 Procedure Free resets the parameter Item to
--- Null_Ptr. Check that Free has no effect if Item is Null_Ptr.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- returning a char_array result returns the prefix of an array of
--- chars.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- and a size_t parameter returning a char_array result returns
--- the shorter of:
--- 1) the first size_t number of characters, or
--- 2) the characters up to and including the first nul.
---
--- Check that both of the above versions of Function Value propagate
--- Dereference_Error if the Item parameter is Null_Ptr.
---
--- TEST DESCRIPTION:
--- This test validates the Procedure Free and two versions of Function
--- Value. A variety of char_array and char_ptr values are provided as
--- input, and results are compared for both length and content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 27 Sep 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 01 DEC 97 EDS Replicate line 199 at line 256, to ensure that
--- TC_chars_ptr has a valid pointer.
--- 08 JUL 99 RLB Added a test case to check that Value raises
--- Constraint_Error when Length = 0. (From Technical
--- Corrigendum 1).
--- 25 JAN 01 RLB Repaired previous test case to avoid raising
--- Constraint_Error in test case code.
--- 26 JAN 01 RLB Added an Ident_Int to the test case to prevent
--- optimization.
-
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3010 is
-begin
-
- Report.Test ("CXB3010", "Check that Procedure Free and versions of " &
- "Function Value produce correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
- use type IC.char;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- TC_String_1 : constant String := "Nonul";
- TC_String_2 : constant String := "AbCdE";
- TC_Blank_String : constant String(1..5) := (others => ' ');
-
- -- The initialization of the following char_array objects
- -- includes the appending of a terminating nul char, in order to
- -- prevent the erroneous execution of Function Value.
-
- TC_char_array : IC.char_array :=
- IC.To_C(TC_Blank_String, True);
- TC_char_array_1 : constant IC.char_array :=
- IC.To_C(TC_String_1, True);
- TC_char_array_2 : constant IC.char_array :=
- IC.To_C(TC_String_2, True);
- TC_Blank_char_array : constant IC.char_array :=
- IC.To_C(TC_Blank_String, True);
-
- -- This chars_ptr is initialized via the use of New_Chars_Array to
- -- avoid erroneous execution of procedure Free.
- TC_chars_ptr : ICS.chars_ptr :=
- ICS.New_Char_Array(TC_Blank_char_array);
-
- begin
-
- -- Check that the Procedure Free resets the parameter Item
- -- to Null_Ptr.
-
- if TC_chars_ptr = ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr is currently null; it should not be " &
- "null since it was given default initialization");
- end if;
-
- ICS.Free(TC_chars_ptr);
-
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr was not set to Null_Ptr by " &
- "Procedure Free");
- end if;
-
- -- Check that Free has no effect if Item is Null_Ptr.
-
- begin
- TC_chars_ptr := ICS.Null_Ptr; -- Ensure pointer is null.
- ICS.Free(TC_chars_ptr);
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr was set to a non-Null_Ptr value " &
- "by Procedure Free. It was provided as a null " &
- "parameter to Free, and there should have been " &
- "no effect from a call to Procedure Free");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception raised by Procedure Free " &
- "when parameter Item is Null_Ptr");
- end;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- that returns a char_array result returns an array of chars (up to
- -- and including the first nul).
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_char_array := ICS.Value(Item => TC_chars_ptr);
-
- if TC_char_array /= TC_char_array_1 or
- IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_1)
- then
- Report.Failed("Incorrect result from Function Value - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- TC_char_array := ICS.Value(Item => TC_chars_ptr);
-
- if TC_char_array /= TC_char_array_2 or
- IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_2)
- then
- Report.Failed("Incorrect result from Function Value - 2");
- end if;
-
- if ICS.Value(Item => ICS.New_String("A little longer string")) /=
- IC.To_C("A little longer string")
- then
- Report.Failed("Incorrect result from Function Value - 3");
- end if;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- and a size_t parameter that returns a char_array result returns
- -- the shorter of:
- -- 1) the first size_t number of characters, or
- -- 2) the characters up to and including the first nul.
-
- -- Case 1: the first size_t number of characters (less than the
- -- total length).
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_char_array(0..2) := ICS.Value(Item => TC_chars_ptr, Length => 3);
-
- if TC_char_array(0..2) /= TC_char_array_1(0..2)
- then
- Report.Failed
- ("Incorrect result from Function Value with Length " &
- "parameter - 1");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during Case 1 evaluation");
- end;
-
- -- Case 2: the characters up to and including the first nul.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- -- The length supplied as a parameter exceeds the total length of
- -- TC_char_array_2. The result should be the entire TC_char_array_2
- -- including the terminating nul.
-
- TC_char_array := ICS.Value(Item => TC_chars_ptr, Length => 7);
-
- if TC_char_array /= TC_char_array_2 or
- IC.To_Ada(TC_char_array) /= IC.To_Ada(TC_char_array_2) or
- not (IC.Is_Nul_Terminated(TC_char_array))
- then
- Report.Failed("Incorrect result from Function Value with Length " &
- "parameter - 2");
- end if;
-
-
- -- Check that both of the above versions of Function Value propagate
- -- Dereference_Error if the Item parameter is Null_Ptr.
-
- declare
-
- -- Declare a dummy function to demonstrate one way that a chars_ptr
- -- variable could inadvertantly be set to Null_Ptr prior to a call
- -- to Value (below).
- function Freedom (Condition : Boolean := False;
- Ptr : ICS.chars_ptr) return ICS.chars_ptr is
- Pointer : ICS.chars_ptr := Ptr;
- begin
- if Condition then
- ICS.Free(Pointer);
- else
- null; -- An activity that doesn't set the chars_ptr value to
- -- Null_Ptr.
- end if;
- return Pointer;
- end Freedom;
-
- begin
-
- begin
- TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr));
- Report.Failed
- ("Function Value (without Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_char_array(0) = '6' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with Item parameter, when the Item parameter " &
- "is Null_Ptr");
- end;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- begin
- TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr),
- Length => 4);
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_char_array(0) = '6' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "the Item parameter is Null_Ptr");
- end;
- end;
-
- -- Check that Function Value with two parameters propagates
- -- Constraint_Error if Length is 0.
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- declare
- TC : IC.char_array := ICS.Value(Item => TC_chars_ptr, Length =>
- IC.Size_T(Report.Ident_Int(0)));
- begin
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Constraint_Error when Length = 0");
- if TC'Length <= TC_char_array'Length then
- TC_char_array(1..TC'Length) := TC; -- Block optimization of TC.
- end if;
- end;
-
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Constraint_Error when Length = 0");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "Length = 0");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3010;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a
deleted file mode 100644
index 6930407..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a
+++ /dev/null
@@ -1,282 +0,0 @@
--- CXB3011.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 version of Function Value with a chars_ptr parameter
--- that returns a String result returns an Ada string containing the
--- characters pointed to by the chars_ptr parameter, up to (but not
--- including) the terminating nul.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- and a size_t parameter that returns a String result returns the
--- shorter of:
--- 1) a String of the first size_t number of characters, or
--- 2) a String of characters up to (but not including) the
--- terminating nul.
---
--- Check that the Function Strlen returns a size_t result that
--- corresponds to the number of chars in the array pointed to by Item,
--- up to but not including the terminating nul.
---
--- Check that both of the above versions of Function Value and
--- Function Strlen propagate Dereference_Error if the Item parameter
--- is Null_Ptr.
---
--- TEST DESCRIPTION:
--- This test validates two versions of Function Value, and the Function
--- Strlen. A series of char_ptr values are provided as input, and
--- results are compared for length or content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*' and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 28 Sep 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Characters.Latin_1;
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3011 is
-begin
-
- Report.Test ("CXB3011", "Check that the two versions of Function Value " &
- "returning a String result, and the Function " &
- "Strlen, produce correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- package ACL1 renames Ada.Characters.Latin_1;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- TC_String : String(1..5) := (others => 'X');
- TC_String_1 : constant String := "*.3*0";
- TC_String_2 : constant String := "Two";
- TC_String_3 : constant String := "Five5";
- TC_Blank_String : constant String(1..5) := (others => ' ');
-
- TC_char_array : IC.char_array :=
- IC.To_C(TC_Blank_String, True);
- TC_char_array_1 : constant IC.char_array :=
- IC.To_C(TC_String_1, True);
- TC_char_array_2 : constant IC.char_array :=
- IC.To_C(TC_String_2, True);
- TC_char_array_3 : constant IC.char_array :=
- IC.To_C(TC_String_3, True);
- TC_Blank_char_array : constant IC.char_array :=
- IC.To_C(TC_Blank_String, True);
-
- TC_chars_ptr : ICS.chars_ptr :=
- ICS.New_Char_Array(TC_Blank_char_array);
-
- TC_size_t : IC.size_t := IC.size_t'First;
-
-
- begin
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- that returns a String result returns an Ada string containing the
- -- characters pointed to by the chars_ptr parameter, up to (but not
- -- including) the terminating nul.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_String := ICS.Value(Item => TC_chars_ptr);
-
- if TC_String /= TC_String_1 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- if ICS.Value(Item => TC_chars_ptr) /=
- IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True)
- then
- Report.Failed("Incorrect result from Function Value - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3);
- TC_String := ICS.Value(TC_chars_ptr);
-
- if TC_String /= TC_String_3 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 3");
- end if;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- and a size_t parameter that returns a String result returns the
- -- shorter of:
- -- 1) a String of the first size_t number of characters, or
- -- 2) a String of characters up to (but not including) the
- -- terminating nul.
- --
-
- -- Case 1 : Length parameter specifies a length shorter than total
- -- length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_String := "XXXXX"; -- Reinitialize all characters in string.
- TC_String(1..5) := ICS.Value(Item => TC_chars_ptr, Length => 6);
-
- if TC_String(1..4) /= TC_String_1(1..4) or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 4");
- end if;
-
- -- Case 2 : Length parameter specifies total length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- if ICS.Value(TC_chars_ptr, Length => 5) /=
- IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True)
- then
- Report.Failed("Incorrect result from Function Value - 5");
- end if;
-
- -- Case 3 : Length parameter specifies a length longer than total
- -- length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3);
- TC_String := "XXXXX"; -- Reinitialize all characters in string.
- TC_String := ICS.Value(TC_chars_ptr, 7);
-
- if TC_String /= TC_String_3 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 6");
- end if;
-
-
- -- Check that the Function Strlen returns a size_t result that
- -- corresponds to the number of chars in the array pointed to by
- -- parameter Item, up to but not including the terminating nul.
-
- TC_chars_ptr := ICS.New_Char_Array(IC.To_C("A longer string value"));
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 21 then
- Report.Failed("Incorrect result from Function Strlen - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 3 then -- Nul not included in length.
- Report.Failed("Incorrect result from Function Strlen - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(IC.To_C(""));
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 0 then
- Report.Failed("Incorrect result from Function Strlen - 3");
- end if;
-
-
- -- Check that both of the above versions of Function Value and
- -- function Strlen propagate Dereference_Error if the Item parameter
- -- is Null_Ptr.
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_String := ICS.Value(Item => TC_chars_ptr);
- Report.Failed("Function Value (without Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_String(1) = '1' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with Item parameter, when the Item parameter " &
- "is Null_Ptr");
- end;
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_String := ICS.Value(Item => TC_chars_ptr, Length => 4);
- Report.Failed("Function Value (with Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_String(1) = '1' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "the Item parameter is Null_Ptr");
- end;
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_size_t := ICS.Strlen(Item => TC_chars_ptr);
- Report.Failed("Function Strlen did not raise Dereference_Error" &
- "when provided a null Item parameter input value");
- if TC_size_t = 35 then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Strlen " &
- "when the Item parameter is Null_Ptr");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3011;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a
deleted file mode 100644
index 3771f6e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a
+++ /dev/null
@@ -1,392 +0,0 @@
--- CXB3012.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 Procedure Update modifies the value pointed to by
--- the chars_ptr parameter Item, starting at the position
--- corresponding to parameter Offset, using the chars in
--- char_array parameter Chars.
---
--- Check that the version of Procedure Update with a String parameter
--- behaves in the manner described above, but with the character
--- values in the String overwriting the char values in Item.
---
--- Check that both of the above versions of Procedure Update will
--- propagate Update_Error if Check is True, and if the length of
--- the new chars in Chars, when overlaid starting from position
--- Offset, will overwrite the first nul in Item.
---
--- TEST DESCRIPTION:
--- This test checks two versions of Procedure Update. In the first
--- version of the procedure, the parameter Chars indicates a char_array
--- argument. These char_array parameters are provided through the use
--- of the To_C function (with String IN parameter), both with and
--- without a terminating nul. In the case below where a terminating nul
--- char is appended, the effect of "updating" the value pointed to by the
--- Item parameter will include its shortening, due to the insertion of
--- this additional nul in the middle of the char_array.
---
--- In the second version of Procedure Update evaluated here, the string
--- parameter Str is used to modify the char_array pointed to by Item.
---
--- Finally, both versions of the procedure are evaluated to ensure that
--- they propagate Update_Error and Dereference_Error under the proper
--- conditions.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '-' and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 05 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion. Added check for raising
--- of Dereference_Error for Update (From Technical
--- Corrigendum 1).
--- 07 Jan 05 RLB Modified to reflect change to Update by AI-242
--- (which is expected to be part of Amendment 1).
--- [This version allows either semantics.]
-
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3012 is
-begin
-
- Report.Test ("CXB3012", "Check that both versions of Procedure Update " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- use Ada.Exceptions;
-
- use type IC.char;
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
-
- TC_String_1 : String(1..1) := "J";
- TC_String_2 : String(1..2) := "Ab";
- TC_String_3 : String(1..3) := "xyz";
- TC_String_4 : String(1..4) := "ACVC";
- TC_String_5 : String(1..5) := "1a2b3";
- TC_String_6 : String(1..6) := "---...";
- TC_String_7 : String(1..7) := "AABBBAA";
- TC_String_8 : String(1..8) := "aBcDeFgH";
- TC_String_9 : String(1..9) := "JustATest";
- TC_String_10 : String(1..10) := "0123456789";
-
- TC_Result_String_1 : constant String := "JXXXXXXXXX";
- TC_Result_String_2 : constant String := "XXXXXXXXAb";
- TC_Result_String_3 : constant String := "XXXxyz";
- TC_Result_String_4 : constant String := "XACVC";
- TC_Result_String_5 : constant String := "1a2b3";
- TC_Result_String_6 : constant String := "XXX---...";
-
- TC_Amd_Result_String_4 :
- constant String := "XACVCXXXXX";
- TC_Amd_Result_String_5 :
- constant String := "1a2b3XXXXX";
- TC_Amd_Result_String_6 :
- constant String := "XXX---...X";
- TC_Amd_Result_String_9 :
- constant String := "JustATestX";
-
- TC_char_array : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX");
- TC_Result_char_array : IC.char_array(0..10) := IC.To_C("XXXXXXXXXX");
- TC_chars_ptr : ICS.chars_ptr;
- TC_Length : IC.size_t;
-
- begin
-
- -- Check that Procedure Update modifies the value pointed to by
- -- the chars_ptr parameter Item, starting at the position
- -- corresponding to parameter Offset, using the chars in
- -- char_array parameter Chars.
- -- Note: If parameter Chars contains a nul char (such as a
- -- terminating nul), the result may be the overall shortening
- -- of parameter Item.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
-
- ICS.Update(Item => TC_chars_ptr,
- Offset => 0,
- Chars => IC.To_C(TC_String_1, False), -- No nul char.
- Check => True);
-
- if ICS.Value(TC_chars_ptr) /= TC_Result_String_1 then
- Report.Failed("Incorrect result from Procedure Update - 1");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr,
- Offset => ICS.Strlen(TC_chars_ptr) - 2,
- Chars => IC.To_C(TC_String_2, False), -- No nul char.
- Check => True);
-
- if ICS.Value(TC_chars_ptr) /= TC_Result_String_2 then
- Report.Failed("Incorrect result from Procedure Update - 2");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr,
- 3,
- Chars => IC.To_C(TC_String_3), -- Nul appended, shortens
- Check => False); -- array.
-
- if ICS.Value(TC_chars_ptr) /= TC_Result_String_3 then
- Report.Failed("Incorrect result from Procedure Update - 3");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr,
- 0,
- IC.To_C(TC_String_10), -- Complete replacement of array.
- Check => False);
-
- if ICS.Value(TC_chars_ptr) /= TC_String_10 then
- Report.Failed("Incorrect result from Procedure Update - 4");
- end if;
-
- -- Perform a character-by-character comparison of the result of
- -- Procedure Update. Note that char_array lower bound is 0, and
- -- that the nul char is not compared with any character in the
- -- string (since the string is not nul terminated).
- begin
- TC_Length := ICS.Strlen(TC_chars_ptr);
- TC_Result_char_array(0..10) := ICS.Value(TC_chars_ptr);
- for i in 0..TC_Length-1 loop
- if TC_Result_char_array(i) /=
- IC.To_C(TC_String_10(Integer(i+1)))
- then
- Report.Failed("Incorrect result from the character-by-" &
- "character evaluation of the result of " &
- "Procedure Update");
- end if;
- end loop;
- exception
- when others =>
- Report.Failed("Exception raised during the character-by-" &
- "character evaluation of the result of " &
- "Procedure Update");
- end;
- ICS.Free(TC_chars_ptr);
-
-
-
- -- Check that the version of Procedure Update with a String rather
- -- than a char_array parameter behaves in the manner described above,
- -- but with the character values in the String overwriting the char
- -- values in Item.
- --
- -- Note: In Ada 95, In each of the cases below, the String parameter
- -- Str is treated as if it were nul terminated, which means that
- -- the char_array pointed to by TC_chars_ptr will be "shortened"
- -- so that it ends after the last character of the Str
- -- parameter. For Ada 2005, this rule is dropped, so the
- -- number of characters remains the same.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr, 1, TC_String_4, False);
-
- if ICS.Value(TC_chars_ptr) = TC_Result_String_4 then
- Report.Comment("Ada 95 result from Procedure Update - 5");
- elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_4 then
- Report.Comment("Amendment 1 result from Procedure Update - 5");
- else
- Report.Failed("Incorrect result from Procedure Update - 5");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(Item => TC_chars_ptr,
- Offset => 0,
- Str => TC_String_5);
-
- if ICS.Value(TC_chars_ptr) = TC_Result_String_5 then
- Report.Comment("Ada 95 result from Procedure Update - 6");
- elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_5 then
- Report.Comment("Amendment 1 result from Procedure Update - 6");
- else
- Report.Failed("Incorrect result from Procedure Update - 6");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr,
- 3,
- Str => TC_String_6,
- Check => True);
-
- if ICS.Value(TC_chars_ptr) = TC_Result_String_6 then
- Report.Comment("Ada 95 result from Procedure Update - 7");
- elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_6 then
- Report.Comment("Amendment 1 result from Procedure Update - 7");
- else
- Report.Failed("Incorrect result from Procedure Update - 7");
- end if;
- ICS.Free(TC_chars_ptr);
-
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(TC_chars_ptr, 0, TC_String_9, True);
-
- if ICS.Value(TC_chars_ptr) = TC_String_9 then
- Report.Comment("Ada 95 result from Procedure Update - 8");
- elsif ICS.Value(TC_chars_ptr) = TC_Amd_Result_String_9 then
- Report.Comment("Amendment 1 result from Procedure Update - 8");
- else
- Report.Failed("Incorrect result from Procedure Update - 8");
- end if;
- ICS.Free(TC_chars_ptr);
-
- -- Check what happens if the string and array are the same size (this
- -- is the case that caused the change made by the Amendment).
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(Item => TC_chars_ptr,
- Offset => 0,
- Str => TC_String_10,
- Check => True);
- if ICS.Value(TC_chars_ptr) = TC_String_10 then
- Report.Comment("Amendment 1 result from Procedure Update - 9");
- else
- Report.Failed("Incorrect result from Procedure Update - 9");
- end if;
- exception
- when ICS.Update_Error =>
- Report.Comment("Ada 95 exception expected from Procedure Update - 9");
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Update " &
- "with Str parameter - 9");
- end;
- ICS.Free(TC_chars_ptr);
-
-
- -- Check that both of the above versions of Procedure Update will
- -- propagate Update_Error if Check is True, and if the length of
- -- the new chars in Chars, when overlaid starting from position
- -- Offset, will overwrite the first nul in Item.
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(Item => TC_chars_ptr,
- Offset => 5,
- Chars => IC.To_C(TC_String_7),
- Check => True);
- Report.Failed("Update_Error not raised by Procedure Update with " &
- "Chars parameter");
- Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " &
- "optimization - should never be printed");
- exception
- when ICS.Update_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Update " &
- "with Chars parameter");
- end;
-
- ICS.Free(TC_chars_ptr);
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array);
- ICS.Update(Item => TC_chars_ptr,
- Offset => ICS.Strlen(TC_chars_ptr),
- Str => TC_String_8); -- Default Check parameter value.
- Report.Failed("Update_Error not raised by Procedure Update with " &
- "Str parameter");
- Report.Comment(ICS.Value(TC_chars_ptr) & "used here to defeat " &
- "optimization - should never be printed");
- exception
- when ICS.Update_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Update " &
- "with Str parameter");
- end;
-
- ICS.Free(TC_chars_ptr);
-
- -- Check that both of the above versions of Procedure Update will
- -- propagate Dereference_Error if Item is Null_Ptr.
- -- Note: Free sets TC_chars_ptr to Null_Ptr.
-
- begin
- ICS.Update(Item => TC_chars_ptr,
- Offset => 5,
- Chars => IC.To_C(TC_String_7),
- Check => True);
- Report.Failed("Dereference_Error not raised by Procedure Update with " &
- "Chars parameter");
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Update " &
- "with Chars parameter");
- end;
-
- begin
- ICS.Update(Item => TC_chars_ptr,
- Offset => ICS.Strlen(TC_chars_ptr),
- Str => TC_String_8); -- Default Check parameter value.
- Report.Failed("Dereference_Error not raised by Procedure Update with " &
- "Str parameter");
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Update " &
- "with Str parameter");
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3012;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c
deleted file mode 100644
index 57662a3..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c
+++ /dev/null
@@ -1,86 +0,0 @@
-/*
--- CXB30130.C
---
--- 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.
---*
---
--- FUNCTION NAME: CXB30130 ("square_it")
---
--- FUNCTION DESCRIPTION:
--- This C function returns the square of num1 through the function
--- name, and returns the square of parameters num2, num3, and num4
--- through the argument list (modifying the objects pointed to by
--- the parameters).
---
--- INPUTS:
--- This function requires that four parameters be passed to it.
--- The types of these parameters are, in order: int, pointer to short,
--- pointer to float, and pointer to double.
---
--- PROCESSING:
--- The function will calculate the square of the int parameter (num1),
--- and return this value as the function result through the function
--- name. The function will also calculate the square of the values
--- pointed to by the remaining three parameters (num2, num3, num4),
--- and will modify the referenced memory locations to contain the
--- squared values.
---
--- OUTPUTS:
--- The square of num1 is returned through function name.
--- Parameters num2-num4 now point to values that are the squared results
--- of the originally referenced values (i.e., the original values are
--- modified as a result of this function).
---
--- CHANGE HISTORY:
--- 12 Oct 95 SAIC Initial prerelease version.
---
---!
-*/
-
-int CXB30130 (int num1, short* num2, float* num3, double* num4)
-
-/* NOTE: The above function definition should be accepted by an ANSI-C */
-/* compiler. Older C compilers may reject it; they may, however */
-/* accept the following five lines. An implementation may comment */
-/* out the above function definition and uncomment the following */
-/* one. Otherwise, an implementation must provide the necessary */
-/* modifications to this C code to satisfy the function */
-/* requirements (see Function Description). */
-/* */
-/* int CXB30130 (num1, num2, num3, num4) */
-/* int num1; */
-/* short* num2; */
-/* float* num3; */
-/* double* num4; */
-/* */
-
-{
- int return_value = 0;
-
- return_value = num1 * num1;
- *num2 = *num2 * *num2; /* Return square of these parameters through */
- *num3 = *num3 * *num3; /* the parameter list. */
- *num4 = *num4 * *num4;
-
- return (return_value); /* Return square of num1 through function name */
-}
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c b/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c
deleted file mode 100644
index 6cbbdd1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c
+++ /dev/null
@@ -1,104 +0,0 @@
-/*
--- CXB30131.C
---
--- 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.
---*
---
--- FUNCTION NAME: CXB30131 ("combine_two_strings")
---
--- FUNCTION DESCRIPTION:
--- This C function returns a pointer to the combination of two
--- input strings.
---
--- INPUTS:
--- This function requires that two parameters be passed to it.
--- The type of both of these parameters are pointer to char (which
--- is used to reference an array of chars).
---
--- PROCESSING:
--- The function will create a char array that is equal to the combined
--- length of the char arrays referenced by the two input parameters.
--- The char elements contained in the char arrays specified by the
--- parameters will be combined (in order) into this new char array.
---
--- OUTPUTS:
--- The newly created char array will be returned as the function
--- result through the function name. The char arrays referenced by the
--- two parameters will be unaffected.
---
--- CHANGE HISTORY:
--- 12 Oct 95 SAIC Initial prerelease version.
--- 26 Oct 96 SAIC Modified temp array initialization.
--- 15 Feb 99 RLB Repaired to remove non-standard function strdup.
---!
-*/
-
-#include <string.h>
-#include <stdlib.h>
-
-char *stringdup (char *s)
-{
- char *result = malloc(sizeof(char)*(strlen(s)+1));
- return strcpy(result,s);
-}
-
-char *CXB30131 (char *string1, char *string2)
-
-/* NOTE: The above function definition should be accepted by an ANSI-C */
-/* compiler. Older C compilers may reject it; they may, however */
-/* accept the following three lines. An implementation may comment */
-/* out the above function definition and uncomment the following */
-/* one. Otherwise, an implementation must provide the necessary */
-/* modifications to this C code to satisfy the function */
-/* requirements (see Function Description). */
-/* */
-/* char *CXB30131 (string1, string2) */
-/* char *string1; */
-/* char *string2; */
-
-{
- char temp[100]; /* Local array that holds the combined strings */
- int index; /* Loop counter */
- int length = 0; /* Variable that holds the length of the strings */
-
- /* Initialize the local array */
- for (index = 0; index < 100; index++)
- { temp[index] = 0; }
-
- /* Use the library function strcpy to copy the contents of string1
- into temp. */
- strcpy (temp, string1);
-
- /* Use the library function strlen to determine the number of
- characters in the temp array (without the trailing nul). */
- length = strlen (temp);
-
- /* Add each character in string2 into the temp array, add nul
- to the end of the array. */
- for (index = length; *string2 != '\0'; index++)
- { temp[index] = *string2++; }
- temp[index] = '\0';
-
- /* Use the library function strdup to return a pointer to temp. */
- return (stringdup(temp));
-}
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am b/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am
deleted file mode 100644
index 4cff400..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am
+++ /dev/null
@@ -1,205 +0,0 @@
--- CXB30132.AM
---
--- 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 imported, user-defined C language functions can be
--- called from an Ada program.
---
--- TEST DESCRIPTION:
--- This test checks that user-defined C language functions can be
--- imported and referenced from an Ada program. Two C language
--- functions are specified in files CXB30130.C and CXB30131.C.
--- These two functions are imported to this test program, using two
--- calls to Pragma Import. Each function is then called in this test,
--- and the results of the call are verified.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C and Interfaces.C.Strings. If an
--- implementation provides packages Interfaces.C and
--- Interfaces.C.Strings, this test must compile, execute, and
--- report "PASSED".
---
--- SPECIAL REQUIREMENTS:
--- The files CXB30130.C and CXB30131.C must be compiled with a C
--- compiler. Implementation dialects of C may require alteration of
--- the C program syntax (see individual C files).
---
--- Note that the compiled C code must be bound with the compiled Ada
--- code to create an executable image. An implementation must provide
--- the necessary commands to accomplish this.
---
--- Note that the C code included in CXB30130.C and CXB30131.C conforms
--- to ANSI-C. Modifications to these files may be required for other
--- C compilers. An implementation must provide the necessary
--- modifications to satisfy the function requirements.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CXB30130.C
--- CXB30131.C
--- CXB30132.AM
---
---
--- CHANGE HISTORY:
--- 13 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Impdef;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB30132 is
-begin
-
- Report.Test ("CXB3013", "Check that user-defined C functions can " &
- "be imported into an Ada program");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
-
- use type IC.char_array;
- use type IC.int;
- use type IC.short;
- use type IC.C_float;
- use type IC.double;
-
- type Short_Ptr is access all IC.short;
- type Float_Ptr is access all IC.C_float;
- type Double_Ptr is access all IC.double;
- subtype Char_Array_Type is IC.char_array(0..20);
-
- TC_Default_int : IC.int := 49;
- TC_Default_short : IC.short := 3;
- TC_Default_float : IC.C_float := 50.0;
- TC_Default_double : IC.double := 1209.0;
-
- An_Int_Value : IC.int := TC_Default_int;
- A_Short_Value : aliased IC.short := TC_Default_short;
- A_Float_Value : aliased IC.C_float := TC_Default_float;
- A_Double_Value : aliased IC.double := TC_Default_double;
-
- A_Short_Int_Pointer : Short_Ptr := A_Short_Value'access;
- A_Float_Pointer : Float_Ptr := A_Float_Value'access;
- A_Double_Pointer : Double_Ptr := A_Double_Value'access;
-
- Char_Array_1 : Char_Array_Type;
- Char_Array_2 : Char_Array_Type;
- Char_Pointer : ICS.chars_ptr;
-
- TC_Char_Array : constant Char_Array_Type :=
- "Look before you leap" & IC.nul;
- TC_Return_int : IC.int := 0;
-
- -- The Square_It function returns the square of the value The_Int
- -- through the function name, and returns the square of the other
- -- parameters through the parameter list (the last three parameters
- -- are access values).
-
- function Square_It (The_Int : in IC.int;
- The_Short : in Short_Ptr;
- The_Float : in Float_Ptr;
- The_Double : in Double_Ptr) return IC.int;
-
- -- The Combine_Strings function returns the result of the catenation
- -- of the two string parameters through the function name.
-
- function Combine_Strings (First_Part : in IC.char_array;
- Second_Part : in IC.char_array)
- return ICS.chars_ptr;
-
-
- -- Use the user-defined C function square_it as a completion to the
- -- function specification above.
-
- pragma Import (Convention => C,
- Entity => Square_It,
- External_Name => Impdef.CXB30130_External_Name);
-
- -- Use the user-defined C function combine_two_strings as a completion
- -- to the function specification above.
-
- pragma Import (C, Combine_Strings, Impdef.CXB30131_External_Name);
-
-
- begin
-
- -- Check that the imported version of C function CXB30130 produces
- -- the correct results.
-
- TC_Return_int := Square_It (The_Int => An_Int_Value,
- The_Short => A_Short_Int_Pointer,
- The_Float => A_Float_Pointer,
- The_Double => A_Double_Pointer);
-
- -- Compare the results with the expected results. Note that in the
- -- case of the three "pointer" parameters, the objects being pointed
- -- to have been modified as a result of the function.
-
- if TC_Return_int /= An_Int_Value * An_Int_Value or
- A_Short_Int_Pointer.all /= TC_Default_short * TC_Default_Short or
- A_Short_Value /= TC_Default_short * TC_Default_Short or
- A_Float_Pointer.all /= TC_Default_float * TC_Default_float or
- A_Float_Value /= TC_Default_float * TC_Default_float or
- A_Double_Pointer.all /= TC_Default_double * TC_Default_double or
- A_Double_Value /= TC_Default_double * TC_Default_double
- then
- Report.Failed("Incorrect results returned from function square_it");
- end if;
-
-
- -- Check that two char_array values are combined by the imported
- -- C function CXB30131.
-
- Char_Array_1(0..12) := "Look before " & IC.nul;
- Char_Array_2(0..8) := "you leap" & IC.nul;
-
- Char_Pointer := Combine_Strings (Char_Array_1, Char_Array_2);
-
- if ICS.Value(Char_Pointer) /= TC_Char_Array then
- Report.Failed("Incorrect value returned from imported function " &
- "combine_two_strings");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB30132;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a
deleted file mode 100644
index a9b386f..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a
+++ /dev/null
@@ -1,254 +0,0 @@
--- CXB3014.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 Function Value with Pointer and Element
--- parameters will return an Element_Array result of correct size
--- and content (up to and including the first "terminator" Element).
---
--- Check that the Function Value with Pointer and Length parameters
--- will return an Element_Array result of appropriate size and content
--- (the first Length elements pointed to by the parameter Ref).
---
--- Check that both versions of Function Value will propagate
--- Interfaces.C.Strings.Dereference_Error when the value of
--- the Ref pointer parameter is null.
---
--- TEST DESCRIPTION:
--- This test tests that both versions of Function Value from the
--- generic package Interfaces.C.Pointers are available and produce
--- correct results. The generic package is instantiated with size_t,
--- char, char_array, and nul as actual parameters, and subtests are
--- performed on each of the Value functions resulting from this
--- instantiation.
--- For both function versions, a test is performed where a portion of
--- a char_array is to be returned as the function result. Likewise,
--- a test is performed where each version of the function returns the
--- entire char_array referenced by the in parameter Ref.
--- Finally, both versions of Function Value are called with a null
--- pointer reference, to ensure that Dereference_Error is raised in
--- this case.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an
--- implementation provides packages Interfaces.C.Strings and
--- Interfaces.C.Pointers, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 19 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 23 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3014 is
-
-begin
-
- Report.Test ("CXB3014", "Check that versions of the Value function " &
- "from package Interfaces.C.Pointers produce " &
- "correct results");
-
- Test_Block:
- declare
-
- use type Interfaces.C.char, Interfaces.C.size_t;
-
- Char_a : constant Interfaces.C.char := 'a';
- Char_j : constant Interfaces.C.char := 'j';
- Char_z : constant Interfaces.C.char := 'z';
-
- subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z;
- subtype Char_Range is Interfaces.C.size_t range 0..26;
-
- Local_nul : aliased Interfaces.C.char := Interfaces.C.nul;
- TC_Array_Size : Interfaces.C.size_t := 20;
-
- TC_String_1 : constant String := "abcdefghij";
- TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz";
- TC_String_3 : constant String := "abcdefghijklmnopqrst";
- TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz";
- TC_Blank_String : constant String := " ";
-
- TC_Char_Array : Interfaces.C.char_array(Char_Range) :=
- Interfaces.C.To_C(TC_String_2, True);
-
- TC_Char_Array_1 : Interfaces.C.char_array(0..9);
- TC_Char_Array_2 : Interfaces.C.char_array(Char_Range);
- TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1);
- TC_Char_Array_4 : Interfaces.C.char_array(Char_Range);
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- Char_Ptr : Char_Pointers.Pointer;
-
- use type Char_Pointers.Pointer;
-
- begin
-
- -- Check that the Function Value with Pointer and Terminator Element
- -- parameters will return an Element_Array result of appropriate size
- -- and content (up to and including the first "terminator" Element.)
-
- Char_Ptr := TC_Char_Array(0)'Access;
-
- -- Provide a new Terminator char in the call of Function Value.
- -- This call should return only a portion (the first 10 chars) of
- -- the referenced char_array, up to and including the char 'j'.
-
- TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
- Terminator => Char_j);
-
- if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or
- Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Terminator parameters, when supplied with " &
- "a non-default Terminator char");
- end if;
-
- -- Use the default Terminator char in the call of Function Value.
- -- This call should return the entire char_array, including the
- -- terminating nul char.
-
- TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr);
-
- if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or
- not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Terminator parameters, when using the " &
- "default Terminator char");
- end if;
-
-
-
- -- Check that the Function Value with Pointer and Length parameters
- -- will return an Element_Array result of appropriate size and content
- -- (the first Length elements pointed to by the parameter Ref).
-
- -- This call should return only a portion (the first 20 chars) of
- -- the referenced char_array.
-
- TC_Char_Array_3 :=
- Char_Pointers.Value(Ref => Char_Ptr,
- Length => Interfaces.C.ptrdiff_t(TC_Array_Size));
-
- -- Verify the individual chars of the result.
- for i in 0..TC_Array_Size-1 loop
- if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /=
- TC_String_3(Integer(i)+1)
- then
- Report.Failed("Incorrect result from Function Value with " &
- "Ref and Length parameters, when specifying " &
- "a length less than the full array size");
- exit;
- end if;
- end loop;
-
- -- This call should return the entire char_array, including the
- -- terminating nul char.
-
- TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27);
-
- if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or
- not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Length parameters, when specifying the " &
- "entire array size");
- end if;
-
-
-
- -- Check that both of the above versions of Function Value will
- -- propagate Interfaces.C.Strings.Dereference_Error when the value of
- -- the Ref Pointer parameter is null.
-
- Char_Ptr := null;
-
- begin
- TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
- Terminator => Char_j);
- Report.Failed("Dereference_Error not raised by Function " &
- "Value with Terminator parameter, when " &
- "provided a null reference");
- -- Call Report.Comment to ensure that the assignment to
- -- TC_Char_Array_1 is not "dead", and therefore can not be
- -- optimized away.
- Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False));
- exception
- when Interfaces.C.Strings.Dereference_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function " &
- "Value with Terminator parameter, when " &
- "provided a null reference");
- end;
-
-
- begin
- TC_Char_Array_3 :=
- Char_Pointers.Value(Char_Ptr,
- Interfaces.C.ptrdiff_t(TC_Array_Size));
- Report.Failed("Dereference_Error not raised by Function " &
- "Value with Length parameter, when provided " &
- "a null reference");
- -- Call Report.Comment to ensure that the assignment to
- -- TC_Char_Array_3 is not "dead", and therefore can not be
- -- optimized away.
- Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False));
- exception
- when Interfaces.C.Strings.Dereference_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function " &
- "Value with Length parameter, when " &
- "provided a null reference");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3014;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a
deleted file mode 100644
index 24ec826..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a
+++ /dev/null
@@ -1,520 +0,0 @@
--- CXB3015.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 "+" and "-" functions with Pointer and ptrdiff_t
--- parameters that return Pointer values produce correct results,
--- based on the size of the array elements.
---
--- Check that the "-" function with two Pointer parameters that
--- returns a ptrdiff_t type parameter produces correct results,
--- based on the size of the array elements.
---
--- Check that each of the "+" and "-" functions above will
--- propagate Pointer_Error if a Pointer parameter is null.
---
--- Check that the Increment and Decrement procedures provide the
--- correct "pointer arithmetic" operations.
---
--- TEST DESCRIPTION:
--- This test checks that the functions "+" and "-", and the procedures
--- Increment and Decrement in the generic package Interfaces.C.Pointers
--- will allow the user to perform "pointer arithmetic" operations on
--- Pointer values.
--- Package Interfaces.C.Pointers is instantiated three times, for
--- short values, chars, and arrays of arrays. Pointers from each
--- instantiated package are then used to reference different elements
--- of array objects. Pointer arithmetic operations are performed on
--- these pointers, and the results of these operations are verified
--- against expected pointer positions along the referenced arrays.
--- The propagation of Pointer_Error is checked for when the function
--- Pointer parameter is null.
---
--- The following chart indicates the combinations of subprograms and
--- parameter types used in this test.
---
---
--- Short Char Array
--- --------------------------
--- "+" Pointer, ptrdiff_t | X | | X |
--- |--------------------------|
--- "+" ptrdiff_t, Pointer | X | | X |
--- |--------------------------|
--- "-" Pointer, ptrdiff_t | | X | X |
--- |--------------------------|
--- "-" Pointer, Pointer | | X | X |
--- |--------------------------|
--- Increment (Pointer) | X | | X |
--- |--------------------------|
--- Decrement (Pointer) | X | | X |
--- --------------------------
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', and 'a'..'z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Pointers. If an implementation provides
--- package Interfaces.C.Pointers, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 26 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 06 Mar 00 RLB Repaired so that array of arrays component
--- type is statically constrained. (C does not have
--- an analog to an array of dynamically constrained
--- arrays.)
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3015 is
-begin
-
- Report.Test ("CXB3015", "Check that +, -, Increment, and Decrement " &
- "subprograms in Package Interfaces.C.Pointers " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use type Interfaces.C.short;
- use type Interfaces.C.size_t, Interfaces.C.ptrdiff_t;
- use type Interfaces.C.char, Interfaces.C.char_array;
-
- TC_Count : Interfaces.C.size_t;
- TC_Increment : Interfaces.C.ptrdiff_t;
- TC_ptrdiff_t : Interfaces.C.ptrdiff_t;
- TC_Short : Interfaces.C.short := 0;
- TC_Verbose : Boolean := False;
- Constant_Min_Array_Size : constant Interfaces.C.size_t := 0;
- Constant_Max_Array_Size : constant Interfaces.C.size_t := 20;
- Min_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t(
- Report.Ident_Int(Integer(Constant_Min_Array_Size)));
- Max_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t(
- Report.Ident_Int(Integer(Constant_Max_Array_Size)));
- Min_size_t,
- Max_size_t : Interfaces.C.size_t;
- Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last;
- Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz";
-
-
- type Short_Array_Type is
- array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short;
-
- type Constrained_Array_Type is
- array (Min_Array_Size..Max_Array_Size) of aliased Interfaces.C.short;
-
- type Static_Constrained_Array_Type is
- array (Constant_Min_Array_Size .. Constant_Max_Array_Size) of
- aliased Interfaces.C.short;
-
- type Array_of_Arrays_Type is
- array (Interfaces.C.size_t range <>) of aliased
- Static_Constrained_Array_Type;
-
-
- Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
-
- Constrained_Array : Constrained_Array_Type;
-
- Terminator_Array : Static_Constrained_Array_Type :=
- (others => Short_Terminator);
-
- Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Alphabet'Length)) :=
- Interfaces.C.To_C(Alphabet, True);
-
- Array_of_Arrays : Array_of_Arrays_Type
- (Min_Array_Size..Max_Array_Size);
-
-
- package Short_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.short,
- Element_Array => Short_Array_Type,
- Default_Terminator => Short_Terminator);
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Interfaces.C.size_t,
- Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- package Array_Pointers is new
- Interfaces.C.Pointers (Interfaces.C.size_t,
- Static_Constrained_Array_Type,
- Array_of_Arrays_Type,
- Terminator_Array);
-
-
- use Short_Pointers, Char_Pointers, Array_Pointers;
-
- Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access;
- Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access;
- Start_Char_Ptr : Char_Pointers.Pointer := Ch_Array(1)'Access;
- End_Char_Ptr : Char_Pointers.Pointer := Ch_Array(10)'Access;
- Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(0)'Access;
- Start_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(1)'Access;
- End_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(10)'Access;
-
- begin
-
- -- Provide initial values for the arrays that hold short int values.
-
- for i in Min_Array_Size..Max_Array_Size-1 loop
- Short_Array(i) := Interfaces.C.short(i);
- for j in Min_Array_Size..Max_Array_Size loop
- -- Initialize this "array of arrays" so that element (i)(0)
- -- is different for each value of i.
- Array_of_Arrays(i)(j) := TC_Short;
- TC_Short := TC_Short + 1;
- end loop;
- end loop;
-
- -- Set the final element of each array object to be the "terminator"
- -- element used in the instantiations above.
-
- Short_Array(Max_Array_Size) := Short_Terminator;
- Array_of_Arrays(Max_Array_Size) := Terminator_Array;
-
- -- Check starting pointer positions.
-
- if Short_Ptr.all /= 0 or
- Char_Ptr.all /= Ch_Array(0) or
- Array_Ptr.all /= Array_of_Arrays(0)
- then
- Report.Failed("Incorrect initial value for the first " &
- "Short_Array, Ch_Array, or Array_of_Array values");
- end if;
-
-
- -- Check that both versions of the "+" function with Pointer and
- -- ptrdiff_t parameters, that return a Pointer value, produce correct
- -- results, based on the size of the array elements.
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
-
- if Integer(i)/2*2 /= Integer(i) then -- Odd numbered loops.
- -- Pointer + ptrdiff_t, increment by 1.
- Short_Ptr := Short_Ptr + 1;
- else -- Even numbered loops.
- -- ptrdiff_t + Pointer, increment by 1.
- Short_Ptr := 1 + Short_Ptr;
- end if;
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the function +, incrementing by 1, " &
- "array position : " & Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access;
- TC_Count := Min_Array_Size;
- TC_Increment := 3;
- while TC_Count+Interfaces.C.size_t(TC_Increment) < Max_Array_Size loop
-
- if Integer(TC_Count)/2*2 /= Integer(TC_Count) then
- -- Odd numbered loops.
- -- Pointer + ptrdiff_t, increment by 3.
- Array_Ptr := Array_Pointers."+"(Array_Ptr, TC_Increment);
- else
- -- Odd numbered loops.
- -- ptrdiff_t + Pointer, increment by 3.
- Array_Ptr := Array_Pointers."+"(Left => TC_Increment,
- Right => Array_Ptr);
- end if;
-
- if Array_Ptr.all /=
- Array_of_Arrays(TC_Count+Interfaces.C.size_t(TC_Increment))
- then
- Report.Failed("Incorrect value returned following use " &
- "of the function +, incrementing by " &
- Integer'Image(Integer(TC_Increment)) &
- ", array position : " &
- Integer'Image(Integer(TC_Count) +
- Integer(TC_Increment)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
-
- TC_Count := TC_Count + Interfaces.C.size_t(TC_Increment);
- end loop;
-
-
-
- -- Check that the "-" function with Pointer and ptrdiff_t parameters,
- -- that returns a Pointer result, produces correct results, based
- -- on the size of the array elements.
-
- -- Set the pointer to the last element in the char_array, which is a
- -- nul char.
- Char_Ptr := Ch_Array(Interfaces.C.size_t(Alphabet'Length))'Access;
-
- if Char_Ptr.all /= Interfaces.C.nul then
- Report.Failed("Incorrect initial value for the last " &
- "Ch_Array value");
- end if;
-
- Min_size_t := 1;
- Max_size_t := Interfaces.C.size_t(Alphabet'Length);
-
- for i in reverse Min_size_t..Max_size_t loop
-
- -- Subtract 1 from the pointer; it should now point to the previous
- -- element in the array.
- Char_Ptr := Char_Ptr - 1;
-
- if Char_Ptr.all /= Ch_Array(i-1) then
- Report.Failed("Incorrect value returned following use " &
- "of the function '-' with char element values, " &
- "array position : " & Integer'Image(Integer(i-1)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
- TC_Count := Max_Array_Size;
- TC_Increment := 3;
- while TC_Count > Min_Array_Size+Interfaces.C.size_t(TC_Increment) loop
-
- -- Decrement the pointer by 3.
- Array_Ptr := Array_Pointers."-"(Array_Ptr, Right => 3);
-
- if Array_Ptr.all /=
- Array_of_Arrays(TC_Count - Interfaces.C.size_t(TC_Increment))
- then
- Report.Failed("Incorrect value returned following use " &
- "of the function -, decrementing by " &
- Integer'Image(Integer(TC_Increment)) &
- ", array position : " &
- Integer'Image(Integer(TC_Count-3)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
-
- TC_Count := TC_Count - Interfaces.C.size_t(TC_Increment);
- end loop;
-
-
-
- -- Check that the "-" function with two Pointer parameters, that
- -- returns a ptrdiff_t type result, produces correct results,
- -- based on the size of the array elements.
-
- TC_ptrdiff_t := 9;
- if Char_Pointers."-"(Left => End_Char_Ptr,
- Right => Start_Char_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 1");
- end if;
-
- Start_Char_Ptr := Ch_Array(1)'Access;
- End_Char_Ptr := Ch_Array(25)'Access;
-
- TC_ptrdiff_t := 24;
- if Char_Pointers."-"(End_Char_Ptr,
- Right => Start_Char_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 2");
- end if;
-
- TC_ptrdiff_t := 9;
- if Array_Pointers."-"(End_Array_Ptr,
- Start_Array_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 3");
- end if;
-
- Start_Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access;
- End_Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
-
- TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) -
- Interfaces.C.ptrdiff_t(Min_Array_Size);
- if End_Array_Ptr - Start_Array_Ptr /= TC_ptrdiff_t then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 4");
- end if;
-
-
-
- -- Check that the Increment procedure produces correct results,
- -- based upon the size of the array elements.
-
- Short_Ptr := Short_Array(0)'Access;
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
- -- Increment the value of the Pointer; it should now point
- -- to the next element in the array.
- Increment(Ref => Short_Ptr);
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Increment on pointer to an " &
- "array of short values, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(0)'Access;
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
- -- Increment the value of the Pointer; it should now point
- -- to the next element in the array.
- Increment(Array_Ptr);
-
- if Array_Ptr.all /= Array_of_Arrays(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Increment on an array of " &
- "arrays, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
-
- -- Check that the Decrement procedure produces correct results,
- -- based upon the size of the array elements.
-
- Short_Ptr := Short_Array(Max_Array_Size)'Access;
-
- for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop
- -- Decrement the value of the Pointer; it should now point
- -- to the previous element in the array.
- Decrement(Ref => Short_Ptr);
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Decrement on pointer to an " &
- "array of short values, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
-
- for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop
- -- Decrement the value of the Pointer; it should now point
- -- to the previous array element.
- Decrement(Array_Ptr);
-
- if Array_Ptr.all /= Array_of_Arrays(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Decrement on an array of " &
- "arrays, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
-
-
- -- Check that each of the "+" and "-" functions above will
- -- propagate Pointer_Error if a Pointer parameter is null.
-
- begin
- Short_Ptr := null;
- Short_Ptr := Short_Ptr + 4;
- Report.Failed("Pointer_Error not raised by Function + when " &
- "the Pointer parameter is null");
- if Short_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Short_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function + " &
- "when the Pointer parameter is null");
- end;
-
-
- begin
- Char_Ptr := null;
- Char_Ptr := Char_Ptr - 1;
- Report.Failed("Pointer_Error not raised by Function - when " &
- "the Pointer parameter is null");
- if Char_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Char_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function - " &
- "when the Pointer parameter is null");
- end;
-
-
- begin
- Array_Ptr := null;
- Decrement(Array_Ptr);
- Report.Failed("Pointer_Error not raised by Procedure Decrement " &
- "when the Pointer parameter is null");
- if Array_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Array_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Procedure " &
- "Decrement when the Pointer parameter is null");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3015;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a
deleted file mode 100644
index 362a062..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a
+++ /dev/null
@@ -1,516 +0,0 @@
--- CXB3016.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 function Virtual_Length returns the number of elements
--- in the array referenced by the Pointer parameter Ref, up to (but
--- not including) the (first) instance of the element specified in
--- the Terminator parameter.
---
--- Check that the procedure Copy_Terminated_Array copies the array of
--- elements referenced by Pointer parameter Source, into the array
--- pointed to by parameter Target, based on which of the following
--- two scenarios occurs first:
--- 1) copying the Terminator element, or
--- 2) copying the number of elements specified in parameter Limit.
---
--- Check that procedure Copy_Terminated_Array will propagate
--- Dereference_Error if either the Source or Target parameter is null.
---
--- Check that procedure Copy_Array will copy an array of elements
--- of length specified in parameter Length, referenced by the
--- Pointer parameter Source, into the array pointed to by parameter
--- Target.
---
--- Check that procedure Copy_Array will propagate Dereference_Error
--- if either the Source or Target parameter is null.
---
--- TEST DESCRIPTION:
--- This test checks that the function Virtual_Length and the procedures
--- Copy_Terminated_Array and Copy_Array in the generic package
--- Interfaces.C.Pointers will allow the user to manipulate arrays of
--- char and short values through the pointers that reference the
--- arrays.
---
--- Package Interfaces.C.Pointers is instantiated twice, once for
--- short values and once for chars. Pointers from each instantiated
--- package are then used to reference arrays of the appropriate
--- element type. The subprograms under test are used to determine the
--- length, and to copy, either portions or the entire content of the
--- arrays. The results of these operations are then compared against
--- expected results.
---
--- The propagation of Dereference_Error is checked for when either
--- of the two procedures is supplied with a null Pointer parameter.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', and 'a'..'z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C, Interfaces.C.Strings, and
--- Interfaces.C.Pointers. If an implementation provides these packages,
--- this test must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 01 Feb 96 SAIC Initial release for 2.1
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 26 Feb 97 PWB.CTA Moved code using null pointer to avoid errors
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Pointers; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3016 is
-begin
-
- Report.Test ("CXB3016", "Check that subprograms Virtual_Length, " &
- "Copy_Terminated_Array, and Copy_Array " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces.C.Strings;
-
- use type Interfaces.C.char,
- Interfaces.C.char_array,
- Interfaces.C.ptrdiff_t,
- Interfaces.C.short,
- Interfaces.C.size_t;
-
- TC_char : Interfaces.C.char := 'a';
- TC_ptrdiff_t : Interfaces.C.ptrdiff_t;
- TC_Short : Interfaces.C.short := 0;
- Min_Array_Size : Interfaces.C.size_t := 0;
- Max_Array_Size : Interfaces.C.size_t := 20;
- Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last;
- Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz";
- Blank_String : constant String := " ";
-
- type Short_Array_Type is
- array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short;
-
- Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Alphabet'Length)) :=
- Interfaces.C.To_C(Alphabet, True);
-
- TC_Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Blank_String'Length)) :=
- Interfaces.C.To_C(Blank_String, True);
-
- Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
- TC_Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
-
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- package Short_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.short,
- Element_Array => Short_Array_Type,
- Default_Terminator => Short_Terminator);
-
- use Short_Pointers, Char_Pointers;
-
- Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access;
- TC_Short_Ptr : Short_Pointers.Pointer := TC_Short_Array(0)'Access;
- Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access;
- TC_Char_Ptr : Char_Pointers.Pointer := TC_Ch_Array(0)'Access;
-
- begin
-
- -- Provide initial values for the array that holds short int values.
-
- for i in Min_Array_Size..Max_Array_Size loop
- Short_Array(i) := Interfaces.C.short(i);
- TC_Short_Array(i) := 100;
- end loop;
-
- -- Set the final element of the short array object to be the "terminator"
- -- element used in the instantiation above.
-
- Short_Array(Max_Array_Size) := Short_Terminator;
-
- -- Check starting pointer positions.
-
- if Short_Ptr.all /= 0 or
- Char_Ptr.all /= Ch_Array(0)
- then
- Report.Failed("Incorrect initial value for the first " &
- "Char_Array or Short_Array values");
- end if;
-
-
-
- -- Check that function Virtual_Length returns the number of elements
- -- in the array referenced by the Pointer parameter Ref, up to (but
- -- not including) the (first) instance of the element specified in
- -- the Terminator parameter.
-
- TC_char := 'j';
-
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Ref => Char_Ptr,
- Terminator => TC_char);
- if TC_ptrdiff_t /= 9 then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Char_ptr parameter - 1");
- end if;
-
- TC_char := Interfaces.C.nul;
-
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr,
- Terminator => TC_char);
- if TC_ptrdiff_t /= Interfaces.C.ptrdiff_t(Alphabet'Length) then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Char_ptr parameter - 2");
- end if;
-
- TC_Short := 10;
-
- TC_ptrdiff_t := Short_Pointers.Virtual_Length(Short_Ptr, TC_Short);
-
- if TC_ptrdiff_t /= 10 then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Short_ptr parameter - 1");
- end if;
-
- -- Replace an element of the Short_Array with the element used as the
- -- terminator of the entire array; now there are two occurrences of the
- -- terminator element in the array. The call to Virtual_Length should
- -- return the number of array elements prior to the first terminator.
-
- Short_Array(5) := Short_Terminator;
-
- if Short_Pointers.Virtual_Length(Short_Ptr, Short_Terminator) /= 5
- then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Short_ptr parameter - 2");
- end if;
-
-
-
- -- Check that the procedure Copy_Terminated_Array copies the array of
- -- elements referenced by Pointer parameter Source, into the array
- -- pointed to by parameter Target, based on which of the following
- -- two scenarios occurs first:
- -- 1) copying the Terminator element, or
- -- 2) copying the number of elements specified in parameter Limit.
- -- Note: Terminator element must be copied to Target, as well as
- -- all array elements prior to the terminator element.
-
- if TC_Ch_Array = Ch_Array then
- Report.Failed("The two char arrays are equivalent prior to the " &
- "call to Copy_Terminated_Array - 1");
- end if;
-
-
- -- Case 1: Copying the Terminator Element. (Default terminator)
-
- Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr);
-
- if TC_Ch_Array /= Ch_Array then
- Report.Failed("The two char arrays are not equal following the " &
- "call to Copy_Terminated_Array, case of copying " &
- "the Terminator Element, using default terminator");
- end if;
-
- -- Reset the Target Pointer array.
-
- TC_Ch_Array := Interfaces.C.To_C(Blank_String, True);
- TC_Char_Ptr := TC_Ch_Array(0)'Access;
-
- if TC_Ch_Array = Ch_Array then
- Report.Failed("The two char arrays are equivalent prior to the " &
- "call to Copy_Terminated_Array - 2");
- end if;
-
-
- -- Case 2: Copying the Terminator Element. (Non-Default terminator)
-
- TC_char := 'b'; -- Second char in char_array pointed to by Char_Ptr
- Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr,
- Terminator => TC_char);
-
- if TC_Ch_Array(0) /= Ch_Array(0) or -- Initial value modified.
- TC_Ch_Array(1) /= Ch_Array(1) or -- Initial value modified.
- TC_Ch_Array(2) = Ch_Array(2) or -- Initial value not modified.
- TC_Ch_Array(5) = Ch_Array(5) or -- Initial value not modified.
- TC_Ch_Array(15) = Ch_Array(15) or -- Initial value not modified.
- TC_Ch_Array(25) = Ch_Array(25) -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two char arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the " &
- "Terminator Element, using non-default terminator");
- end if;
-
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 1");
- end if;
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Terminator => 2);
-
- if TC_Short_Array(0) /= Short_Array(0) or
- TC_Short_Array(1) /= Short_Array(1) or
- TC_Short_Array(2) /= Short_Array(2) or
- TC_Short_Array(3) /= 100 -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two short int " &
- "arrays are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the " &
- "Terminator Element, using non-default terminator");
- end if;
-
-
- -- Case 3: Copying the number of elements specified in parameter Limit.
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 2");
- end if;
-
- TC_ptrdiff_t := 5;
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Limit => TC_ptrdiff_t,
- Terminator => Short_Terminator);
-
- if TC_Short_Array(0) /= Short_Array(0) or
- TC_Short_Array(1) /= Short_Array(1) or
- TC_Short_Array(2) /= Short_Array(2) or
- TC_Short_Array(3) /= Short_Array(3) or
- TC_Short_Array(4) /= Short_Array(4) or
- TC_Short_Array(5) /= 100 -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two Short arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the number " &
- "of elements specified in parameter Limit");
- end if;
-
-
- -- Case 4: Copying the number of elements specified in parameter Limit,
- -- which also happens to be the number of elements up to and
- -- including the first terminator.
-
- -- Reset initial values for the array that holds short int values.
-
- for i in Min_Array_Size..Max_Array_Size loop
- Short_Array(i) := Interfaces.C.short(i);
- TC_Short_Array(i) := 100;
- end loop;
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 3");
- end if;
-
- TC_ptrdiff_t := 3; -- Specifies three elements to be copied.
- Short_Terminator := 2; -- Value held in Short_Array third element,
- -- will serve as the "terminator" element.
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Limit => TC_ptrdiff_t,
- Terminator => Short_Terminator);
-
- if TC_Short_Array(0) /= Short_Array(0) or -- First element copied.
- TC_Short_Array(1) /= Short_Array(1) or -- Second element copied.
- TC_Short_Array(2) /= Short_Array(2) or -- Third element copied.
- TC_Short_Array(3) /= 100 -- Initial value of fourth element
- then -- not modified.
- Report.Failed("The appropriate portions of the two Short arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the number " &
- "of elements specified in parameter " &
- "Limit, which also happens to be the number of " &
- "elements up to and including the first terminator");
- end if;
-
-
-
- -- Check that procedure Copy_Terminated_Array will propagate
- -- Dereference_Error if either the Source or Target parameter is null.
-
- Char_Ptr := null;
- begin
- Char_Pointers.Copy_Terminated_Array(Char_Ptr, TC_Char_Ptr);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Terminated_Array with null Source parameter");
- if TC_Char_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Terminated_Array with null Source parameter");
- end;
-
- TC_Short_Ptr := null;
- begin
- Short_Pointers.Copy_Terminated_Array(Short_Ptr, TC_Short_Ptr);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Terminated_Array with null Target parameter");
- if Short_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Terminated_Array with null Target parameter");
- end;
-
-
-
- -- Check that the procedure Copy_Array will copy the array of
- -- elements of length specified in parameter Length, referenced by
- -- the Pointer parameter Source, into the array pointed to by
- -- parameter Target.
-
- -- Reinitialize Target arrays prior to test cases below.
-
- TC_Ch_Array := Interfaces.C.To_C(Blank_String, True);
-
- for i in Min_Array_Size..Max_Array_Size loop
- TC_Short_Array(i) := 100;
- end loop;
-
- Char_Ptr := Ch_Array(0)'Access;
- TC_Char_Ptr := TC_Ch_Array(0)'Access;
- Short_Ptr := Short_Array(0)'Access;
- TC_Short_Ptr := TC_Short_Array(0)'Access;
-
- TC_ptrdiff_t := 4;
-
- Char_Pointers.Copy_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr,
- Length => TC_ptrdiff_t);
-
- if TC_Ch_Array(0) /= Ch_Array(0) or
- TC_Ch_Array(1) /= Ch_Array(1) or
- TC_Ch_Array(2) /= Ch_Array(2) or
- TC_Ch_Array(3) /= Ch_Array(3) or
- TC_Ch_Array(4) = Ch_Array(4)
- then
- Report.Failed("Incorrect result from Copy_Array when using " &
- "char pointer arguments, partial array copied");
- end if;
-
-
- TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) + 1;
-
- Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t);
-
- if TC_Short_Array /= Short_Array then
- Report.Failed("Incorrect result from Copy_Array when using Short " &
- "pointer arguments, entire array copied");
- end if;
-
-
-
- -- Check that procedure Copy_Array will propagate Dereference_Error
- -- if either the Source or Target parameter is null.
-
- Char_Ptr := null;
- begin
- Char_Pointers.Copy_Array(Char_Ptr, TC_Char_Ptr, TC_ptrdiff_t);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Array with null Source parameter");
- if TC_Char_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Array with null Source parameter");
- end;
-
- TC_Short_Ptr := null;
- begin
- Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Array with null Target parameter");
- if Short_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Array with null Target parameter");
- end;
-
-
- -- Check that function Virtual_Length will propagate Dereference_Error
- -- if the Source parameter is null.
-
- Char_Ptr := null;
- begin
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr,
- Terminator => TC_char);
- Report.Failed("Dereference_Error not raised by call to " &
- "Virtual_Length with null Source parameter");
- if TC_ptrdiff_t = 100 then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Virtual_Length with null Source parameter");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3016;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a
deleted file mode 100644
index 0c9ab1a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a
+++ /dev/null
@@ -1,230 +0,0 @@
--- CXB4001.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 specifications of the package Interfaces.COBOL
--- are available for use
---
--- TEST DESCRIPTION:
--- This test verifies that the type and the subprograms specified for
--- the interface are present.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected visibility errors for ACVC 2.0.1.
--- 28 Feb 96 SAIC Added applicability criteria.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
--- 01 DEC 97 EDS Change "To_Comp" to "To_Binary".
---!
-
-with Report;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4001 is
-
- package COBOL renames Interfaces.COBOL;
- use type COBOL.Byte;
- use type COBOL.Decimal_Element;
-
-begin
-
- Report.Test ("CXB4001", "Check the specification of Interfaces.COBOL");
-
-
- declare -- encapsulate the test
-
- -- Types and operations for internal data representations
-
- TST_Floating : COBOL.Floating;
- TST_Long_Floating : COBOL.Long_Floating;
-
- TST_Binary : COBOL.Binary;
- TST_Long_Binary : COBOL.Long_Binary;
-
- TST_Max_Digits_Binary : constant := COBOL.Max_Digits_Binary;
- TST_Max_Digits_Long_Binary : constant := COBOL.Max_Digits_Long_Binary;
-
- TST_Decimal_Element : COBOL.Decimal_Element;
-
- TST_Packed_Decimal : COBOL.Packed_Decimal (1..5) :=
- (others => COBOL.Decimal_Element'First);
-
- -- initialize it so it can reasonably be used later
- TST_COBOL_Character : COBOL.COBOL_Character :=
- COBOL.COBOL_Character'First;
-
- TST_Ada_To_COBOL : COBOL.COBOL_Character :=
- COBOL.Ada_To_COBOL (Character'First);
-
- TST_COBOL_To_Ada : Character :=
- COBOL.COBOL_To_Ada (COBOL.COBOL_Character'First);
-
- -- assignment to make sure it is an array of COBOL_Character
- TST_Alphanumeric : COBOL.Alphanumeric (1..5) :=
- (others => TST_COBOL_Character);
-
-
- -- assignment to make sure it is an array of COBOL_Character
- TST_Numeric : COBOL.Numeric (1..5) := (others => TST_COBOL_Character);
-
-
- procedure Collect_All_Calls is
-
- CAC_Alphanumeric : COBOL.Alphanumeric(1..5) :=
- COBOL.To_COBOL("abcde");
- CAC_String : String (1..5) := "vwxyz";
- CAC_Natural : natural := 0;
-
- begin
-
- CAC_Alphanumeric := COBOL.To_COBOL (CAC_String);
- CAC_String := COBOL.To_Ada (CAC_Alphanumeric);
-
- COBOL.To_COBOL (CAC_String, CAC_Alphanumeric, CAC_Natural);
- COBOL.To_Ada (CAC_Alphanumeric, CAC_String, CAC_Natural);
-
- raise COBOL.Conversion_Error;
-
- end Collect_All_Calls;
-
-
-
- -- Formats for COBOL data representations
-
- TST_Unsigned : COBOL.Display_Format := COBOL.Unsigned;
- TST_Leading_Separate : COBOL.Display_Format := COBOL.Leading_Separate;
- TST_Trailing_Separate : COBOL.Display_Format := COBOL.Trailing_Separate;
- TST_Leading_Nonseparate : COBOL.Display_Format :=
- COBOL.Leading_Nonseparate;
- TST_Trailing_Nonseparate : COBOL.Display_Format :=
- COBOL.Trailing_Nonseparate;
-
-
- TST_High_Order_First : COBOL.Binary_Format := COBOL.High_Order_First;
- TST_Low_Order_First : COBOL.Binary_Format := COBOL.Low_Order_First;
- TST_Native_Binary : COBOL.Binary_Format := COBOL.Native_Binary;
-
-
- TST_Packed_Unsigned : COBOL.Packed_Format := COBOL.Packed_Unsigned;
- TST_Packed_Signed : COBOL.Packed_Format := COBOL.Packed_Signed;
-
-
- -- Types for external representation of COBOL binary data
-
- TST_Byte_Array : COBOL.Byte_Array(1..5) := (others => COBOL.Byte'First);
-
- -- Now instantiate one version of the generic
- --
- type bx4001_Decimal is delta 0.1 digits 5;
- package bx4001_conv is new COBOL.Decimal_Conversions (bx4001_Decimal);
-
- procedure Collect_All_Generic_Calls is
- CAGC_natural : natural;
- CAGC_Display_Format : COBOL.Display_Format;
- CAGC_Boolean : Boolean;
- CAGC_Numeric : COBOL.Numeric(1..5);
- CAGC_Num : bx4001_Decimal;
- CAGC_Packed_Decimal : COBOL.Packed_Decimal (1..5);
- CAGC_Packed_Format : COBOL.Packed_Format;
- CAGC_Byte_Array : COBOL.Byte_Array (1..5);
- CAGC_Binary_Format : COBOL.Binary_Format;
- CAGC_Binary : COBOL.Binary;
- CAGC_Long_Binary : COBOL.Long_Binary;
- begin
-
- -- Display Formats: data values are represented as Numeric
-
- CAGC_Boolean := bx4001_conv.Valid (CAGC_Numeric, CAGC_Display_Format);
- CAGC_Natural := bx4001_conv.Length (CAGC_Display_Format);
-
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Numeric, CAGC_Display_Format);
- CAGC_Numeric := bx4001_conv.To_Display
- (CAGC_Num, CAGC_Display_Format);
-
-
- -- Packed Formats: data values are represented as Packed_Decimal
-
- CAGC_Boolean := bx4001_conv.Valid
- (CAGC_Packed_Decimal, CAGC_Packed_Format);
-
- CAGC_Natural := bx4001_conv.Length (CAGC_Packed_Format);
-
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Packed_Decimal, CAGC_Packed_Format);
-
- CAGC_Packed_Decimal := bx4001_conv.To_Packed
- (CAGC_Num, CAGC_Packed_Format);
-
-
- -- Binary Formats: external data values are represented as
- -- Byte_Array
-
- CAGC_Boolean := bx4001_conv.Valid
- (CAGC_Byte_Array, CAGC_Binary_Format);
-
- CAGC_Natural := bx4001_conv.Length (CAGC_Binary_Format);
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Byte_Array, CAGC_Binary_Format);
-
- CAGC_Byte_Array := bx4001_conv.To_Binary (CAGC_Num, CAGC_Binary_Format);
-
-
- -- Internal Binary formats: data values are of type
- -- Binary/Long_Binary
-
- CAGC_Num := bx4001_conv.To_Decimal (CAGC_Binary);
- CAGC_Num := bx4001_conv.To_Decimal (CAGC_Long_Binary);
-
- CAGC_Binary := bx4001_conv.To_Binary (CAGC_Num);
- CAGC_Long_Binary := bx4001_conv.To_Long_Binary (CAGC_Num);
-
-
- end Collect_All_Generic_Calls;
-
-
- begin -- encapsulation
-
- if COBOL.Byte'First /= 0 or
- COBOL.Byte'Last /= (2 ** COBOL.COBOL_Character'Size) - 1 then
- Report.Failed ("Byte is incorrectly defined");
- end if;
-
- if COBOL.Decimal_Element'First /= 0 then
- Report.Failed ("Decimal_Element is incorrectly defined");
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB4001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a
deleted file mode 100644
index e3934a5..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a
+++ /dev/null
@@ -1,308 +0,0 @@
--- CXB4002.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 procedure To_COBOL converts the character elements
--- of the String parameter Item into COBOL_Character elements of the
--- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
--- as the basis of conversion.
--- Check that the parameter Last contains the index of the last element
--- of parameter Target that was assigned by To_COBOL.
---
--- Check that Constraint_Error is propagated by procedure To_COBOL
--- when the length of String parameter Item exceeds the length of
--- Alphanumeric parameter Target.
---
--- Check that the procedure To_Ada converts the COBOL_Character
--- elements of the Alphanumeric parameter Item into Character elements
--- of the String parameter Target, using the COBOL_to_Ada mapping array
--- as the basis of conversion.
--- Check that the parameter Last contains the index of the last element
--- of parameter Target that was assigned by To_Ada.
---
--- Check that Constraint_Error is propagated by procedure To_Ada when
--- the length of Alphanumeric parameter Item exceeds the length of
--- String parameter Target.
---
--- TEST DESCRIPTION:
--- This test checks that the procedures To_COBOL and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the Out parameter results of
--- procedure To_COBOL are compared against expected results,
--- which includes (in the parameter Last) the index in Target of the
--- last element assigned. The situation where procedure To_COBOL raises
--- Constraint_Error (when Item'Length exceeds Target'Length) is also
--- verified.
---
--- In the second series of subtests, the Out parameter results of
--- procedure To_Ada are verified, in a similar manner as is done for
--- procedure To_COBOL. The case of procedure To_Ada raising
--- Constraint_Error is also verified.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', '$', '-', '_', and '#'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 12 Jan 96 SAIC Initial prerelease version.
--- 30 May 96 SAIC Added applicability criteria for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4002 is
-begin
-
- Report.Test ("CXB4002", "Check that the procedures To_COBOL and " &
- "To_Ada produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Interfaces;
- use Bnd, Unb;
- use type Interfaces.COBOL.Alphanumeric;
-
-
- Alphanumeric_1 : COBOL.Alphanumeric(1..1) := " ";
- Alphanumeric_5 : COBOL.Alphanumeric(1..5) := " ";
- Alphanumeric_10 : COBOL.Alphanumeric(1..10) := " ";
- Alphanumeric_20 : COBOL.Alphanumeric(1..20) := " ";
- TC_Alphanumeric_1 : COBOL.Alphanumeric(1..1) := "A";
- TC_Alphanumeric_5 : COBOL.Alphanumeric(1..5) := "ab*de";
- TC_Alphanumeric_10 : COBOL.Alphanumeric(1..10) := "$1a2b3C4D5";
- TC_Alphanumeric_20 : COBOL.Alphanumeric(1..20) := "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
-
- TC_Alphanumeric : constant COBOL.Alphanumeric := ""; -- null array.
- TC_String : constant String := ""; -- null string.
- TC_Natural : Natural := 0;
-
-
- begin
-
- -- Check that the procedure To_COBOL converts the character elements
- -- of the String parameter Item into COBOL_Character elements of the
- -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
- -- as the basis of conversion.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_COBOL.
-
- COBOL.To_COBOL(Item => TC_String_1,
- Target => Alphanumeric_1,
- Last => TC_Natural);
-
- if Alphanumeric_1 /= TC_Alphanumeric_1 or
- TC_Natural /= TC_Alphanumeric_1'Length or
- TC_Natural /= 1
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 1");
- end if;
-
- COBOL.To_COBOL(To_String(TC_Unb_String),
- Target => Alphanumeric_5,
- Last => TC_Natural);
-
- if Alphanumeric_5 /= TC_Alphanumeric_5 or
- TC_Natural /= TC_Alphanumeric_5'Length or
- TC_Natural /= 5
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 2");
- end if;
-
- COBOL.To_COBOL(To_String(TC_Bnd_String),
- Alphanumeric_10,
- Last => TC_Natural);
-
- if Alphanumeric_10 /= TC_Alphanumeric_10 or
- TC_Natural /= TC_Alphanumeric_10'Length or
- TC_Natural /= 10
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 3");
- end if;
-
- COBOL.To_COBOL(TC_String_20,
- Alphanumeric_20,
- TC_Natural);
-
- if Alphanumeric_20 /= TC_Alphanumeric_20 or
- TC_Natural /= TC_Alphanumeric_20'Length or
- TC_Natural /= 20
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 4");
- end if;
-
- COBOL.To_COBOL(Item => TC_String, -- null string
- Target => Alphanumeric_1,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_COBOL, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_COBOL
- -- when the length of String parameter Item exceeds the length of
- -- Alphanumeric parameter Target.
-
- begin
-
- COBOL.To_COBOL(Item => TC_String_20,
- Target => Alphanumeric_10,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_COBOL " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by procedure To_COBOL " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- -- Check that the procedure To_Ada converts the COBOL_Character
- -- elements of the Alphanumeric parameter Item into Character elements
- -- of the String parameter Target, using the COBOL_to_Ada mapping array
- -- as the basis of conversion.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_Ada.
-
- COBOL.To_Ada(Item => TC_Alphanumeric_1,
- Target => String_1,
- Last => TC_Natural);
-
- if String_1 /= TC_String_1 or
- TC_Natural /= TC_String_1'Length or
- TC_Natural /= 1
- then
- Report.Failed("Incorrect result from procedure To_Ada - 1");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_5,
- Target => String_5,
- Last => TC_Natural);
-
- if String_5 /= To_String(TC_Unb_String) or
- TC_Natural /= Length(TC_Unb_String) or
- TC_Natural /= 5
- then
- Report.Failed("Incorrect result from procedure To_Ada - 2");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_10,
- String_10,
- Last => TC_Natural);
-
- if String_10 /= To_String(TC_Bnd_String) or
- TC_Natural /= Length(TC_Bnd_String) or
- TC_Natural /= 10
- then
- Report.Failed("Incorrect result from procedure To_Ada - 3");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_20,
- String_20,
- TC_Natural);
-
- if String_20 /= TC_String_20 or
- TC_Natural /= TC_String_20'Length or
- TC_Natural /= 20
- then
- Report.Failed("Incorrect result from procedure To_Ada - 4");
- end if;
-
- COBOL.To_Ada(Item => TC_Alphanumeric, -- null array.
- Target => String_20,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Ada, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada when
- -- the length of Alphanumeric parameter Item exceeds the length of
- -- String parameter Target.
-
- begin
-
- COBOL.To_Ada(Item => TC_Alphanumeric_10,
- Target => String_5,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB4002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a
deleted file mode 100644
index 609dabc..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a
+++ /dev/null
@@ -1,310 +0,0 @@
--- CXB4003.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 function Valid, with the Display_Format parameter
--- set to Unsigned, will return True if Numeric parameter Item
--- comprises one or more decimal digit characters; check that it
--- returns False if the parameter Item is otherwise comprised.
---
--- Check that function Valid, with Display_Format parameter set to
--- Leading_Separate, will return True if Numeric parameter Item
--- comprises a single occurrence of a Plus_Sign or Minus_Sign
--- character, and then by one or more decimal digit characters;
--- check that it returns False if the parameter Item is otherwise
--- comprised.
---
--- Check that function Valid, with Display_Format parameter set to
--- Trailing_Separate, will return True if Numeric parameter Item
--- comprises one or more decimal digit characters, and then by a
--- single occurrence of the Plus_Sign or Minus_Sign character;
--- check that it returns False if the parameter Item is otherwise
--- comprised.
---
--- TEST DESCRIPTION:
--- This test checks that a version of function Valid, from an instance
--- of the generic package Decimal_Conversions, will produce correct
--- results based on the particular Numeric and Display_Format
--- parameters provided. Arrays of both valid and invalid Numeric
--- data items have been created to correspond to a particular
--- value of Display_Format. The result of the function is compared
--- against the expected result for each appropriate combination of
--- Numeric and Display_Format parameter.
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'A'..'Z', '+', '-', '.', '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
---
--- CHANGE HISTORY:
--- 18 Jan 96 SAIC Initial version for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4003 is
-begin
-
- Report.Test ("CXB4003", "Check that function Valid, with various " &
- "Display_Format parameters, produces correct " &
- "results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
-
- type A_Numeric_Type is delta 0.01 digits 16;
- type Numeric_Access is access COBOL.Numeric;
- type Numeric_Items_Type is array(Integer range <>) of Numeric_Access;
-
- package Display_Format is
- new COBOL.Decimal_Conversions(Num => A_Numeric_Type);
-
-
- Number_Of_Valid_Unsigned_Items : constant := 5;
- Number_Of_Invalid_Unsigned_Items : constant := 21;
- Number_Of_Valid_Leading_Separate_Items : constant := 5;
- Number_Of_Invalid_Leading_Separate_Items : constant := 23;
- Number_Of_Valid_Trailing_Separate_Items : constant := 5;
- Number_Of_Invalid_Trailing_Separate_Items : constant := 22;
-
- Valid_Unsigned_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Unsigned_Items) :=
- (new COBOL.Numeric'("0"),
- new COBOL.Numeric'("1"),
- new COBOL.Numeric'("0000000001"),
- new COBOL.Numeric'("1234567890123456"),
- new COBOL.Numeric'("0000"));
-
- Invalid_Unsigned_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Unsigned_Items) :=
- (new COBOL.Numeric'(" 12345"),
- new COBOL.Numeric'(" 12345"),
- new COBOL.Numeric'("1234567890 "),
- new COBOL.Numeric'("1234567890 "),
- new COBOL.Numeric'("1.01"),
- new COBOL.Numeric'(".0000000001"),
- new COBOL.Numeric'("12345 6"),
- new COBOL.Numeric'("MCXVIII"),
- new COBOL.Numeric'("15F"),
- new COBOL.Numeric'("+12345"),
- new COBOL.Numeric'("$12.30"),
- new COBOL.Numeric'("1234-"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("++99--"),
- new COBOL.Numeric'("-1.01"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("123,456"),
- new COBOL.Numeric'("101."),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("1.0000"));
-
- Valid_Leading_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Leading_Separate_Items) :=
- (new COBOL.Numeric'("+1000"),
- new COBOL.Numeric'("-1"),
- new COBOL.Numeric'("-0000000001"),
- new COBOL.Numeric'("+1234567890123456"),
- new COBOL.Numeric'("-0000"));
-
- Invalid_Leading_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Leading_Separate_Items) :=
- (new COBOL.Numeric'("123456"),
- new COBOL.Numeric'(" +12345"),
- new COBOL.Numeric'(" +12345"),
- new COBOL.Numeric'("- 0000000001"),
- new COBOL.Numeric'("1234567890- "),
- new COBOL.Numeric'("1234567890+ "),
- new COBOL.Numeric'("123-456"),
- new COBOL.Numeric'("+15F"),
- new COBOL.Numeric'("++123"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("+/-12"),
- new COBOL.Numeric'("++99--"),
- new COBOL.Numeric'("1.01"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("+123,456"),
- new COBOL.Numeric'("+15FF"),
- new COBOL.Numeric'("- 123"),
- new COBOL.Numeric'("+$123"),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("-"),
- new COBOL.Numeric'("-1.01"),
- new COBOL.Numeric'("1.0000+"));
-
- Valid_Trailing_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Trailing_Separate_Items) :=
- (new COBOL.Numeric'("1001-"),
- new COBOL.Numeric'("1+"),
- new COBOL.Numeric'("0000000001+"),
- new COBOL.Numeric'("1234567890123456-"),
- new COBOL.Numeric'("0000-"));
-
- Invalid_Trailing_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Trailing_Separate_Items) :=
- (new COBOL.Numeric'("123456"),
- new COBOL.Numeric'("+12345"),
- new COBOL.Numeric'("12345 "),
- new COBOL.Numeric'("123- "),
- new COBOL.Numeric'("123- "),
- new COBOL.Numeric'("12345 +"),
- new COBOL.Numeric'("12345+ "),
- new COBOL.Numeric'("-0000000001"),
- new COBOL.Numeric'("123-456"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("99+-"),
- new COBOL.Numeric'("12+/-"),
- new COBOL.Numeric'("12.01-"),
- new COBOL.Numeric'("$12.01+"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("DM12-"),
- new COBOL.Numeric'("123,456+"),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("-"),
- new COBOL.Numeric'("1.01-"),
- new COBOL.Numeric'("+1.0000"));
-
- begin
-
- -- Check that function Valid, with the Display_Format parameter
- -- set to Unsigned, will return True if Numeric parameter Item
- -- comprises one or more decimal digit characters; check that it
- -- returns False if the parameter Item is otherwise comprised.
-
- for i in 1..Number_of_Valid_Unsigned_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Item => Valid_Unsigned_Items(i).all,
- Format => COBOL.Unsigned)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Unsigned, for valid " &
- "format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Unsigned_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Item => Invalid_Unsigned_Items(i).all,
- Format => COBOL.Unsigned)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Unsigned, for invalid " &
- "format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
-
- -- Check that function Valid, with Display_Format parameter set to
- -- Leading_Separate, will return True if Numeric parameter Item
- -- comprises a single occurrence of a Plus_Sign or Minus_Sign
- -- character, and then by one or more decimal digit characters;
- -- check that it returns False if the parameter Item is otherwise
- -- comprised.
-
- for i in 1..Number_of_Valid_Leading_Separate_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Valid_Leading_Separate_Items(i).all,
- Format => COBOL.Leading_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Leading_Separate, " &
- "for valid format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Leading_Separate_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Invalid_Leading_Separate_Items(i).all,
- Format => COBOL.Leading_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Leading_Separate, " &
- "for invalid format item number " &
- Integer'Image(i));
- end if;
- end loop;
-
-
-
- -- Check that function Valid, with Display_Format parameter set to
- -- Trailing_Separate, will return True if Numeric parameter Item
- -- comprises one or more decimal digit characters, and then by a
- -- single occurrence of the Plus_Sign or Minus_Sign character;
- -- check that it returns False if the parameter Item is otherwise
- -- comprised.
-
- for i in 1..Number_of_Valid_Trailing_Separate_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Valid_Trailing_Separate_Items(i).all,
- COBOL.Trailing_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Trailing_Separate, " &
- "for valid format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Trailing_Separate_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Invalid_Trailing_Separate_Items(i).all,
- COBOL.Trailing_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Trailing_Separate, " &
- "for invalid format item number " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a
deleted file mode 100644
index 0046c5e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a
+++ /dev/null
@@ -1,443 +0,0 @@
--- CXB4004.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 function Length, with Display_Format parameter, will
--- return the minimal length of a Numeric value that will be required
--- to hold the largest value of type Num represented as Format.
---
--- Check that function To_Decimal will produce a decimal type Num
--- result that corresponds to parameter Item as represented by
--- parameter Format.
---
--- Check that function To_Decimal propagates Conversion_Error when
--- the value represented by parameter Item is outside the range of
--- the Decimal_Type Num used to instantiate the package
--- Decimal_Conversions
---
--- Check that function To_Display returns a Numeric type result that
--- represents Item under the specific Display_Format.
---
--- Check that function To_Display propagates Conversion_Error when
--- parameter Item is negative and the specified Display_Format
--- parameter is Unsigned.
---
--- TEST DESCRIPTION:
--- This test checks the results from instantiated versions of three
--- functions within generic package Interfaces.COBOL.Decimal_Conversions.
--- This generic package is instantiated twice, with decimal types having
--- four and ten digits representation.
--- The function Length is validated with the Unsigned, Leading_Separate,
--- and Trailing_Separate Display_Format specifiers.
--- The results of function To_Decimal are verified in cases where it
--- is given a variety of Numeric and Display_Format type parameters.
--- Function To_Decimal is also checked to propagate Conversion_Error
--- when the value represented by parameter Item is outside the range
--- of the type used to instantiate the package.
--- The results of function To_Display are verified in cases where it
--- is given a variety of Num and Display_Format parameters. It is also
--- checked to ensure that it propagates Conversion_Error if parameter
--- Num is negative and the Format parameter is Unsigned.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', '0'..'9', '+', '-', and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.COBOL; -- N/A => ERROR
-with Ada.Exceptions;
-
-procedure CXB4004 is
-begin
-
- Report.Test ("CXB4004", "Check that the functions Length, To_Decimal, " &
- "and To_Display produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- Number_Of_Unsigned_Items : constant := 6;
- Number_Of_Leading_Separate_Items : constant := 6;
- Number_Of_Trailing_Separate_Items : constant := 6;
- Number_Of_Decimal_Items : constant := 9;
-
- type Decimal_Type_1 is delta 0.01 digits 4;
- type Decimal_Type_2 is delta 1.0 digits 10;
- type Numeric_Access is access COBOL.Numeric;
- type Numeric_Items_Type is array(Integer range <>) of Numeric_Access;
-
- Correct_Result : Boolean := False;
- TC_Num_1 : Decimal_Type_1 := 0.0;
- TC_Num_2 : Decimal_Type_2 := 0.0;
-
- package Package_1 is new COBOL.Decimal_Conversions(Decimal_Type_1);
- package Package_2 is new COBOL.Decimal_Conversions(Decimal_Type_2);
-
-
- Package_1_Numeric_Items :
- Numeric_Items_Type(1..Number_Of_Decimal_Items) :=
- (new COBOL.Numeric'("0"),
- new COBOL.Numeric'("591"),
- new COBOL.Numeric'("6342"),
- new COBOL.Numeric'("+0"),
- new COBOL.Numeric'("-1539"),
- new COBOL.Numeric'("+9199"),
- new COBOL.Numeric'("0-"),
- new COBOL.Numeric'("8934+"),
- new COBOL.Numeric'("9949-"));
-
- Package_2_Numeric_Items :
- Numeric_Items_Type(1..Number_Of_Decimal_Items) :=
- (new COBOL.Numeric'("3"),
- new COBOL.Numeric'("105"),
- new COBOL.Numeric'("1234567899"),
- new COBOL.Numeric'("+8"),
- new COBOL.Numeric'("-12345601"),
- new COBOL.Numeric'("+9123459999"),
- new COBOL.Numeric'("1-"),
- new COBOL.Numeric'("123456781+"),
- new COBOL.Numeric'("9499999999-"));
-
-
- Decimal_Type_1_Items : array (1..Number_Of_Decimal_Items)
- of Decimal_Type_1 :=
- (0.0, 5.91, 63.42, 0.0, -15.39, 91.99, 0.0, 89.34, -99.49);
-
- Decimal_Type_2_Items : array (1..Number_Of_Decimal_Items)
- of Decimal_Type_2 :=
- ( 3.0, 105.0, 1234567899.0,
- 8.0, -12345601.0, 9123459999.0,
- -1.0, 123456781.0, -9499999999.0);
-
- begin
-
- -- Check that function Length with Display_Format parameter will
- -- return the minimal length of a Numeric value (number of
- -- COBOL_Characters) that will be required to hold the largest
- -- value of type Num.
-
- if Package_1.Length(COBOL.Unsigned) /= 4 or
- Package_2.Length(COBOL.Unsigned) /= 10
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter Unsigned");
- end if;
-
- if Package_1.Length(Format => COBOL.Leading_Separate) /= 5 or
- Package_2.Length(Format => COBOL.Leading_Separate) /= 11
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter " &
- "Leading_Separate");
- end if;
-
- if Package_1.Length(COBOL.Trailing_Separate) /= 5 or
- Package_2.Length(COBOL.Trailing_Separate) /= 11
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter " &
- "Trailing_Separate");
- end if;
-
-
- -- Check that function To_Decimal with Numeric and Display_Format
- -- parameters will produce a decimal type Num result that corresponds
- -- to parameter Item as represented by parameter Format.
-
- for i in 1..Number_Of_Decimal_Items loop
- case i is
- when 1..3 => -- Unsigned Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- Format => COBOL.Unsigned) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Unsigned, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- Format => COBOL.Unsigned) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Unsigned, subtest index: " &
- Integer'Image(i));
- end if;
-
- when 4..6 => -- Leading_Separate Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- Format => COBOL.Leading_Separate) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Leading_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- Format => COBOL.Leading_Separate) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Leading_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- when 7..9 => -- Trailing_Separate Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- COBOL.Trailing_Separate) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Trailing_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- COBOL.Trailing_Separate) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Trailing_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- end case;
- end loop;
-
-
- -- Check that function To_Decimal propagates Conversion_Error when
- -- the value represented by Numeric type parameter Item is outside
- -- the range of the Decimal_Type Num used to instantiate the package
- -- Decimal_Conversions.
-
- declare
- TC_Numeric_1 : Decimal_Type_1 := Decimal_Type_1_Items(1);
- begin
- -- The COBOL.Numeric type used as parameter Item represents a
- -- Decimal value that is outside the range of the Decimal type
- -- used to instantiate Package_1.
- TC_Numeric_1 :=
- Package_1.To_Decimal(Item => Package_2_Numeric_Items(8).all,
- Format => COBOL.Trailing_Separate);
- Report.Failed("Conversion_Error not raised by To_Decimal " &
- "when the value represented by parameter " &
- "Item is outside the range of the Decimal_Type " &
- "used to instantiate the package " &
- "Decimal_Conversions");
- if TC_Numeric_1 = Decimal_Type_1_Items(1) then
- Report.Comment("To Guard Against Dead Assignment Elimination " &
- "-- Should never be printed");
- end if;
- exception
- when COBOL.Conversion_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by To_Decimal " &
- "when the value represented by parameter " &
- "Item is outside the range of the Decimal_Type " &
- "used to instantiate the package " &
- "Decimal_Conversions");
- end;
-
-
- -- Check that function To_Display with decimal type Num and
- -- Display_Format parameters returns a Numeric type result that
- -- represents Item under the specific Display_Format.
-
- -- Unsigned Display_Format parameter.
- TC_Num_1 := 13.04;
- Correct_Result := (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) =
- "1304") AND
- (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) /=
- "13.04");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Unsigned Display_Format parameter - 1");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Unsigned) = "1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Unsigned Display_Format parameter - 2");
- end if;
-
- -- Leading_Separate Display_Format parameter.
- TC_Num_1 := -34.29;
- Correct_Result := (Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) =
- "-3429") AND
- (Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) /=
- "-34.29");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 1");
- end if;
-
- TC_Num_1 := 19.01;
- Correct_Result := Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) =
- "+1901";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 2");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Leading_Separate) =
- "+1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 3");
- end if;
-
- TC_Num_2 := -1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Leading_Separate) =
- "-1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 4");
- end if;
-
- -- Trailing_Separate Display_Format parameter.
- TC_Num_1 := -99.91;
- Correct_Result := (Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) =
- "9991-") AND
- (Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) /=
- "99.91-");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 1");
- end if;
-
- TC_Num_1 := 51.99;
- Correct_Result := Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) =
- "5199+";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 2");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Trailing_Separate) =
- "1234567890+";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 3");
- end if;
-
- TC_Num_2 := -1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Trailing_Separate) =
- "1234567890-";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 4");
- end if;
-
-
- -- Check that function To_Display propagates Conversion_Error when
- -- parameter Item is negative and the specified Display_Format
- -- parameter is Unsigned.
-
- begin
- if Package_2.To_Display(Item => Decimal_Type_2_Items(9),
- Format => COBOL.Unsigned) =
- Package_2_Numeric_Items(2).all
- then
- Report.Comment("To Guard Against Dead Assignment Elimination " &
- "-- Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised by To_Display " &
- "when the value represented by parameter " &
- "Item is negative and the Display_Format " &
- "parameter is Unsigned");
- exception
- when COBOL.Conversion_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by To_Display " &
- "when the value represented by parameter " &
- "Item is negative and the Display_Format " &
- "parameter is Unsigned");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4004;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a
deleted file mode 100644
index 01f1ded..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a
+++ /dev/null
@@ -1,332 +0,0 @@
--- CXB4005.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 function To_COBOL will convert a String
--- parameter value into a type Alphanumeric array of
--- COBOL_Characters, with lower bound of one, and length
--- equal to length of the String parameter, based on the
--- mapping Ada_to_COBOL.
---
--- Check that the function To_Ada will convert a type
--- Alphanumeric parameter value into a String type result,
--- with lower bound of one, and length equal to the length
--- of the Alphanumeric parameter, based on the mapping
--- COBOL_to_Ada.
---
--- Check that the Ada_to_COBOL and COBOL_to_Ada mapping
--- arrays provide a mapping capability between Ada's type
--- Character and COBOL run-time character sets.
---
--- TEST DESCRIPTION:
--- This test checks that the functions To_COBOL and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the results of the function
--- To_COBOL are compared against expected Alphanumeric type results,
--- and the length and lower bound of the alphanumeric result are
--- also verified. In the second series of subtests, the results of
--- the function To_Ada are compared against expected String type
--- results, and the length of the String result is also verified
--- against the Alphanumeric type parameter.
---
--- This test also verifies that two mapping array variables defined
--- in package Interfaces.COBOL, Ada_To_COBOL and COBOL_To_Ada, are
--- available, and that they can be modified by a user at runtime.
--- Finally, the effects of user modifications on these mapping
--- variables is checked in the test.
---
--- This test uses Fixed, Bounded, and Unbounded_Strings in combination
--- with the functions under validation.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', ',', '.', and '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 11 Jan 96 SAIC Initial prerelease version for ACVC 2.1
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4005 is
-begin
-
- Report.Test ("CXB4005", "Check that the functions To_COBOL and " &
- "To_Ada produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(5);
- package Unb renames Ada.Strings.Unbounded;
-
- use Ada.Exceptions;
- use Interfaces;
- use Bnd;
- use type Unb.Unbounded_String;
- use type Interfaces.COBOL.Alphanumeric;
-
- TC_Alphanumeric_1 : Interfaces.COBOL.Alphanumeric(1..1);
- TC_Alphanumeric_5 : Interfaces.COBOL.Alphanumeric(1..5);
- TC_Alphanumeric_10 : Interfaces.COBOL.Alphanumeric(1..10);
- TC_Alphanumeric_20 : Interfaces.COBOL.Alphanumeric(1..20);
-
- Bnd_String,
- TC_Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- Unb_String,
- TC_Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
-
- The_String,
- TC_String : String(1..20) := (" ");
-
- begin
-
- -- Check that the function To_COBOL will convert a String
- -- parameter value into a type Alphanumeric array of
- -- COBOL_Characters, with lower bound of one, and length
- -- equal to length of the String parameter, based on the
- -- mapping Ada_to_COBOL.
-
- Unb_String := Unb.To_Unbounded_String("A");
- TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_1 /= "A" or
- TC_Alphanumeric_1'Length /= Unb.Length(Unb_String) or
- TC_Alphanumeric_1'Length /= 1 or
- COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 1");
- end if;
-
- Bnd_String := Bnd.To_Bounded_String("abcde");
- TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String));
-
- if TC_Alphanumeric_5 /= "abcde" or
- TC_Alphanumeric_5'Length /= Bnd.Length(Bnd_String) or
- TC_Alphanumeric_5'Length /= 5 or
- COBOL.To_COBOL(Bnd.To_String(Bnd_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 2");
- end if;
-
- Unb_String := Unb.To_Unbounded_String("1A2B3c4d5F");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_10 /= "1A2B3c4d5F" or
- TC_Alphanumeric_10'Length /= Unb.Length(Unb_String) or
- TC_Alphanumeric_10'Length /= 10 or
- COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 3");
- end if;
-
- The_String := "abcd ghij" & "1234 7890";
- TC_Alphanumeric_20 := COBOL.To_COBOL(The_String);
-
- if TC_Alphanumeric_20 /= "abcd ghij1234 7890" or
- TC_Alphanumeric_20'Length /= The_String'Length or
- TC_Alphanumeric_20'Length /= 20 or
- COBOL.To_COBOL(The_String)'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 4");
- end if;
-
-
-
- -- Check that the function To_Ada will convert a type
- -- Alphanumeric parameter value into a String type result,
- -- with lower bound of one, and length equal to the length
- -- of the Alphanumeric parameter, based on the mapping
- -- COBOL_to_Ada.
-
- TC_Unb_String := Unb.To_Unbounded_String
- (COBOL.To_Ada(TC_Alphanumeric_1));
-
- if TC_Unb_String /= "A" or
- TC_Alphanumeric_1'Length /= Unb.Length(TC_Unb_String) or
- Unb.Length(TC_Unb_String) /= 1 or
- COBOL.To_Ada(TC_Alphanumeric_1)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 1");
- end if;
-
- TC_Bnd_String := Bnd.To_Bounded_String
- (COBOL.To_Ada(TC_Alphanumeric_5));
-
- if TC_Bnd_String /= "abcde" or
- TC_Alphanumeric_5'Length /= Bnd.Length(TC_Bnd_String) or
- Bnd.Length(TC_Bnd_String) /= 5 or
- COBOL.To_Ada(TC_Alphanumeric_5)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String
- (COBOL.To_Ada(TC_Alphanumeric_10));
-
- if TC_Unb_String /= "1A2B3c4d5F" or
- TC_Alphanumeric_10'Length /= Unb.Length(TC_Unb_String) or
- Unb.Length(TC_Unb_String) /= 10 or
- COBOL.To_Ada(TC_Alphanumeric_10)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 3");
- end if;
-
- TC_String := COBOL.To_Ada(TC_Alphanumeric_20);
-
- if TC_String /= "abcd ghij1234 7890" or
- TC_Alphanumeric_20'Length /= TC_String'Length or
- TC_String'Length /= 20 or
- COBOL.To_Ada(TC_Alphanumeric_20)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 4");
- end if;
-
-
- -- Check the two functions when used in combination.
-
- if COBOL.To_COBOL(Item => COBOL.To_Ada("This is a test")) /=
- "This is a test" or
- COBOL.To_COBOL(COBOL.To_Ada("1234567890abcdeFGHIJ")) /=
- "1234567890abcdeFGHIJ"
- then
- Report.Failed("Incorrect result returned when using the " &
- "functions To_Ada and To_COBOL in combination");
- end if;
-
-
-
- -- Check that the Ada_to_COBOL and COBOL_to_Ada mapping
- -- arrays provide a mapping capability between Ada's type
- -- Character and COBOL run-time character sets.
-
- Interfaces.COBOL.Ada_To_COBOL('a') := 'A';
- Interfaces.COBOL.Ada_To_COBOL('b') := 'B';
- Interfaces.COBOL.Ada_To_COBOL('c') := 'C';
- Interfaces.COBOL.Ada_To_COBOL('d') := '1';
- Interfaces.COBOL.Ada_To_COBOL('e') := '2';
- Interfaces.COBOL.Ada_To_COBOL('f') := '3';
- Interfaces.COBOL.Ada_To_COBOL(' ') := '*';
-
- Unb_String := Unb.To_Unbounded_String("b");
- TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_1 /= "B" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 1");
- end if;
-
- Bnd_String := Bnd.To_Bounded_String("abcde");
- TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String));
-
- if TC_Alphanumeric_5 /= "ABC12" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 2");
- end if;
-
- Unb_String := Unb.To_Unbounded_String("1a2B3c4d5e");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_10 /= "1A2B3C4152" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 3");
- end if;
-
- The_String := "abcd ghij" & "1234 7890";
- TC_Alphanumeric_20 := COBOL.To_COBOL(The_String);
-
- if TC_Alphanumeric_20 /= "ABC1**ghij1234**7890" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 4");
- end if;
-
-
- -- Reset the Ada_To_COBOL mapping array to its original state.
-
- Interfaces.COBOL.Ada_To_COBOL('a') := 'a';
- Interfaces.COBOL.Ada_To_COBOL('b') := 'b';
- Interfaces.COBOL.Ada_To_COBOL('c') := 'c';
- Interfaces.COBOL.Ada_To_COBOL('d') := 'd';
- Interfaces.COBOL.Ada_To_COBOL('e') := 'e';
- Interfaces.COBOL.Ada_To_COBOL('f') := 'f';
- Interfaces.COBOL.Ada_To_COBOL(' ') := ' ';
-
- -- Modify the COBOL_To_Ada mapping array to check its effect on
- -- the function To_Ada.
-
- Interfaces.COBOL.COBOL_To_Ada(' ') := '*';
- Interfaces.COBOL.COBOL_To_Ada('$') := 'F';
- Interfaces.COBOL.COBOL_To_Ada('1') := '7';
- Interfaces.COBOL.COBOL_To_Ada('.') := ',';
-
- Unb_String := Unb.To_Unbounded_String(" $$100.00");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
- TC_Unb_String := Unb.To_Unbounded_String(
- COBOL.To_Ada(TC_Alphanumeric_10));
-
- if Unb.To_String(TC_Unb_String) /= "**FF700,00" then
- Report.Failed("Incorrect result from function To_Ada after " &
- "modification of COBOL_To_Ada mapping array - 1");
- end if;
-
- Interfaces.COBOL.COBOL_To_Ada('*') := ' ';
- Interfaces.COBOL.COBOL_To_Ada('F') := '$';
- Interfaces.COBOL.COBOL_To_Ada('7') := '1';
- Interfaces.COBOL.COBOL_To_Ada(',') := '.';
-
- if COBOL.To_Ada(COBOL.To_COBOL(Unb.To_String(TC_Unb_String))) /=
- Unb_String
- then
- Report.Failed("Incorrect result from function To_Ada after " &
- "modification of COBOL_To_Ada mapping array - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4005;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a
deleted file mode 100644
index 6e491ee..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- CXB4006.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 function Valid with Packed_Decimal and Packed_Format
--- parameters returns True if Item (the Packed_Decimal parameter) has
--- a value consistent with the Packed_Format parameter.
---
--- Check that the function Length with Packed_Format parameter returns
--- the minimal length of a Packed_Decimal value sufficient to hold any
--- value of type Num when represented according to parameter Format.
---
--- Check that the function To_Decimal with Packed_Decimal and
--- Packed_Format parameters produces a decimal type value corresponding
--- to the Packed_Decimal parameter value Item, under the conditions of
--- the Packed_Format parameter Format.
---
--- Check that the function To_Packed with Decimal (Num) and
--- Packed_Format parameters produces a Packed_Decimal result that
--- corresponds to the decimal parameter under conditions of the
--- Packed_Format parameter.
---
--- Check that Conversion_Error is propagated by function To_Packed if
--- the value of the decimal parameter Item is negative and the specified
--- Packed_Format parameter is Packed_Unsigned.
---
---
--- TEST DESCRIPTION:
--- This test checks the results from instantiated versions of
--- several functions that deal with parameters or results of type
--- Packed_Decimal. Since the rules for the formation of Packed_Decimal
--- values are implementation defined, several of the subtests cannot
--- directly check the accuracy of the results produced. Instead, they
--- verify that the result is within a range of possible values, or
--- that the result of one function can be converted back to the original
--- actual parameter using a "mirror image" conversion function.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 12 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4006 is
-begin
-
- Report.Test ("CXB4006", "Check that the functions Valid, Length, " &
- "To_Decimal, and To_Packed specific to " &
- "Packed_Decimal parameters produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits 8;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits 12;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.6;
- TC_Dec_2 : Decimal_Type_2 := 123456.78;
- TC_Dec_3 : Decimal_Type_3 := 1234567.890;
- TC_Dec_4 : Decimal_Type_4 := 12345678.9012;
- TC_Min_Length : Natural := 1;
- TC_Max_Length : Natural := 16;
-
- begin
-
- -- Check that the function Valid with Packed_Decimal and Packed_Format
- -- parameters returns True if Item (the Packed_Decimal parameter) has
- -- a value consistent with the Packed_Format parameter.
- -- Note: Since the formation rules for Packed_Decimal values are
- -- implementation defined, the parameter values here are
- -- created by function To_Packed.
-
- TC_Dec_1 := 1434.3;
- if not Pack_1.Valid(Item => Pack_1.To_Packed(TC_Dec_1,
- Packed_Unsigned),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 1");
- end if;
-
- TC_Dec_2 := -4321.03;
- if not Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Signed) or
- Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 2");
- end if;
-
- TC_Dec_3 := 1234567.890;
- if not Pack_3.Valid(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned),
- Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 3");
- end if;
-
- TC_Dec_4 := -234.6789;
- if not Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4,
- Packed_Signed),
- Format => Packed_Signed) or
- Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, Packed_Signed),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 4");
- end if;
-
-
-
- -- Check that the function Length with Packed_Format parameter returns
- -- the minimal length of a Packed_Decimal value sufficient to hold any
- -- value of type Num when represented according to parameter Format.
-
- if NOT (Pack_1.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_1.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_1.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_1.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 1");
- end if;
-
- if NOT (Pack_2.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_2.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_2.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_2.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 2");
- end if;
-
- if NOT (Pack_3.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_3.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_3.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_3.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 3");
- end if;
-
- if NOT (Pack_4.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_4.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_4.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_4.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 4");
- end if;
-
-
-
- -- Check that the function To_Decimal with Packed_Decimal and
- -- Packed_Format parameters produces a decimal type value corresponding
- -- to the Packed_Decimal parameter value Item, under the conditions of
- -- the Packed_Format parameter Format.
-
- begin
- TC_Dec_1 := 1234.5;
- if Pack_1.To_Decimal(Item => Pack_1.To_Packed(TC_Dec_1,
- Packed_Unsigned),
- Format => Packed_Unsigned) /= TC_Dec_1
- then
- Report.Failed("Incorrect result from function To_Decimal - 1");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 1 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_2 := -123456.50;
- if Pack_2.To_Decimal(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Signed) /= TC_Dec_2
- then
- Report.Failed("Incorrect result from function To_Decimal - 2");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 2 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_3 := 1234567.809;
- if Pack_3.To_Decimal(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned),
- Packed_Unsigned) /= TC_Dec_3
- then
- Report.Failed("Incorrect result from function To_Decimal - 3");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 3 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_4 := -789.1234;
- if Pack_4.To_Decimal(Item => Pack_4.To_Packed(TC_Dec_4,
- Packed_Signed),
- Format => Packed_Signed) /= TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal - 4");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 4 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
-
-
- -- Check that the function To_Packed with Decimal (Num) and
- -- Packed_Format parameters produces a Packed_Decimal result that
- -- corresponds to the decimal parameter under conditions of the
- -- Packed_Format parameter.
-
- if Pack_1.To_Packed(Item => 123.4, Format => Packed_Unsigned) =
- Pack_1.To_Packed(Item => -123.4, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 1");
- end if;
-
- if Pack_2.To_Packed( 123.45, Format => Packed_Unsigned) =
- Pack_2.To_Packed(-123.45, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 2");
- end if;
-
- if Pack_3.To_Packed(Item => 123.456, Format => Packed_Unsigned) =
- Pack_3.To_Packed(Item => -123.456, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 3");
- end if;
-
- if (Pack_4.To_Packed( 123.4567, Packed_Unsigned) =
- Pack_4.To_Packed(-123.4567, Packed_Signed)) or
- (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) =
- Pack_4.To_Packed(12345678.9013, Packed_Unsigned)) or
- (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) =
- Pack_4.To_Packed(22345678.9012, Packed_Unsigned))
- then
- Report.Failed("Incorrect result from function To_Packed - 4");
- end if;
-
-
- -- Check that Conversion_Error is propagated by function To_Packed if
- -- the value of the decimal parameter Item is negative and the
- -- specified Packed_Format parameter is Packed_Unsigned.
-
- begin
- if Pack_1.To_Packed(Item => -12.3, Format => Packed_Unsigned) =
- Pack_1.To_Packed(Item => 12.3, Format => Packed_Signed)
- then
- Report.Comment("Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised following call to " &
- "function To_Packed with a negative parameter " &
- "Item and Packed_Format parameter Packed_Unsigned");
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Exception_Name(The_Error) & " was incorrectly " &
- "raised following call to function To_Packed " &
- "with a negative parameter Item and " &
- "Packed_Format parameter Packed_Unsigned");
- end;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4006;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a
deleted file mode 100644
index c4e0641..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CXB4007.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 function Valid with Byte_Array and Binary_Format
--- parameters returns True if the Byte_Array parameter corresponds
--- to any value inside the range of type Num.
--- Check that function Valid returns False if the Byte_Array parameter
--- corresponds to a value outside the range of Num.
---
--- Check that function Length with Binary_Format parameter will return
--- the minimum length of a Byte_Array value required to hold any value
--- of decimal type Num.
---
--- Check that function To_Decimal with Byte_Array and Binary_Format
--- parameters will return a decimal type value that corresponds to
--- parameter Item (of type Byte_Array) under the specified Format.
---
--- Check that Conversion_Error is propagated by function To_Decimal if
--- the Byte_Array parameter Item represents a decimal value outside the
--- range of decimal type Num.
---
--- Check that function To_Binary will produce a Byte_Array result that
--- corresponds to the decimal type parameter Item, under the specified
--- Binary_Format.
---
--- TEST DESCRIPTION:
--- This test uses several instantiations of generic package
--- Decimal_Conversions to provide appropriate test material.
--- This test uses the function To_Binary to create all Byte_Array
--- parameter values used in calls to functions Valid and To_Decimal.
--- The function Valid is tested with parameters to provide both
--- valid and invalid expected results. This test also checks that
--- Function To_Decimal produces expected results in cases where each
--- of the three predefined Binary_Format constants are used in the
--- function calls. In addition, the prescribed propagation of
--- Conversion_Error by function To_Decimal is verified.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 14 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
--- 05 JAN 98 EDS Remove incorrect subtest.
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4007 is
-begin
-
- Report.Test ("CXB4007", "Check that functions Valid, Length, To_Decimal " &
- "and To_Binary specific to Byte_Array and " &
- "Binary_Format parameters produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits 8;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits 12;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.6;
- TC_Dec_2 : Decimal_Type_2 := 123456.78;
- TC_Dec_3 : Decimal_Type_3 := 1234567.890;
- TC_Dec_4 : Decimal_Type_4 := 12345678.9012;
- TC_Min_Length : Natural := 1;
- TC_Max_Length : Natural := 16;
- TC_Valid : Boolean := False;
-
- begin
-
- -- Check that the function Valid with Byte_Array and Binary_Format
- -- parameters returns True if the Byte_Array parameter corresponds to
- -- any value inside the range of type Num.
-
- if not Pack_1.Valid(Item => Pack_1.To_Binary(TC_Dec_1,
- High_Order_First),
- Format => High_Order_First) or
- not Pack_1.Valid(Pack_1.To_Binary(0.0, Low_Order_First),
- Format => Low_Order_First)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 1");
- end if;
-
- TC_Valid := (Pack_2.Valid(Pack_2.To_Binary(TC_Dec_2, High_Order_First),
- Format => High_Order_First) and
- Pack_2.Valid(Pack_2.To_Binary(0.01, Low_Order_First),
- Format => Low_Order_First));
- if not TC_Valid then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 2");
- end if;
-
- if not Pack_3.Valid(Item => Pack_3.To_Binary(TC_Dec_3,
- Low_Order_First),
- Format => Low_Order_First) or
- not Pack_3.Valid(Pack_3.To_Binary(0.001, High_Order_First),
- Format => High_Order_First) or
- not Pack_3.Valid(Pack_3.To_Binary(123.456, Native_Binary),
- Native_Binary)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 3");
- end if;
-
-
- -- Check that function Valid returns False if the Byte_Array parameter
- -- corresponds to a value outside the range of Num.
- -- Note: use a Byte_Array value Item created by an instantiation of
- -- To_Binary with a larger Num type as the generic formal.
-
- if Pack_1.Valid(Item => Pack_2.To_Binary(TC_Dec_2, Low_Order_First),
- Format => Low_Order_First) or
- Pack_2.Valid(Pack_3.To_Binary(TC_Dec_3, High_Order_First),
- Format => High_Order_First) or
- Pack_3.Valid(Pack_4.To_Binary(TC_Dec_4, Native_Binary),
- Native_Binary)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a negative result");
- end if;
-
-
- -- Check that function Length with Binary_Format parameter will return
- -- the minimum length of a Byte_Array value required to hold any value
- -- of decimal type Num.
-
- if not (Pack_1.Length(Native_Binary) >= TC_Min_Length and
- Pack_1.Length(Low_Order_First) <= TC_Max_Length and
- Pack_2.Length(High_Order_First) >= TC_Min_Length and
- Pack_2.Length(Native_Binary) <= TC_Max_Length and
- Pack_3.Length(Low_Order_First) >= TC_Min_Length and
- Pack_3.Length(High_Order_First) <= TC_Max_Length and
- Pack_4.Length(Native_Binary) >= TC_Min_Length and
- Pack_4.Length(Low_Order_First) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length");
- end if;
-
-
-
- -- Check that function To_Decimal with Byte_Array and Binary_Format
- -- parameters will return a decimal type value that corresponds to
- -- parameter Item (of type Byte_Array) under the specified Format.
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(Item => TC_Dec_1,
- Format => Native_Binary),
- Format => Native_Binary) /=
- TC_Dec_1
- then
- Report.Failed("Incorrect result from function To_Decimal - 1");
- end if;
-
- if Pack_3.To_Decimal(Pack_3.To_Binary(TC_Dec_3, High_Order_First),
- Format => High_Order_First) /=
- TC_Dec_3
- then
- Report.Failed("Incorrect result from function To_Decimal - 2");
- end if;
-
- if Pack_4.To_Decimal(Pack_4.To_Binary(TC_Dec_4, Low_Order_First),
- Low_Order_First) /=
- TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal - 3");
- end if;
-
-
-
- -- Check that Conversion_Error is propagated by function To_Decimal
- -- if the Byte_Array parameter Item represents a decimal value outside
- -- the range of decimal type Num.
- -- Note: use a Byte_Array value Item created by an instantiation of
- -- To_Binary with a larger Num type as the generic formal.
-
- begin
- TC_Dec_4 := 99999.9001;
- TC_Dec_1 := Pack_1.To_Decimal(Pack_4.To_Binary(TC_Dec_4,
- Native_Binary),
- Format => Native_Binary);
- if TC_Dec_1 = 99999.9 then
- Report.Comment("Minimize dead assignment optimization -- " &
- "Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised following call to " &
- "function To_Decimal if the Byte_Array parameter " &
- "Item represents a decimal value outside the " &
- "range of decimal type Num");
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Exception_Name(The_Error) & " was incorrectly " &
- "raised following call to function To_Decimal " &
- "if the Byte_Array parameter Item represents " &
- "a decimal value outside the range of decimal " &
- "type Num");
- end;
-
-
-
- -- Check that function To_Binary will produce a Byte_Array result that
- -- corresponds to the decimal type parameter Item, under the specified
- -- Binary_Format.
-
- -- Different ordering.
- TC_Dec_1 := 12345.6;
- if Pack_1.To_Binary(TC_Dec_1, Low_Order_First) =
- Pack_1.To_Binary(TC_Dec_1, High_Order_First)
- then
- Report.Failed("Incorrect result from function To_Binary - 1");
- end if;
-
- -- Variable vs. literal.
- TC_Dec_2 := 12345.00;
- if Pack_2.To_Binary(TC_Dec_2, Native_Binary) /=
- Pack_2.To_Binary(12345.00, Native_Binary)
- then
- Report.Failed("Incorrect result from function To_Binary - 2");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4007;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a
deleted file mode 100644
index 5ab8e6b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a
+++ /dev/null
@@ -1,248 +0,0 @@
--- CXB4008.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 function To_Decimal with Binary parameter will return
--- the corresponding value of the decimal type Num.
---
--- Check that the function To_Decimal with Long_Binary parameter will
--- return the corresponding value of the decimal type Num.
---
--- Check that both of the To_Decimal functions described above will
--- propagate Conversion_Error if the converted value Item is outside
--- the range of type Num.
---
--- Check that the function To_Binary converts a value of the Ada
--- decimal type Num into a Binary type value.
---
--- Check that the function To_Long_Binary converts a value of the Ada
--- decimal type Num into a Long_Binary type value.
---
--- TEST DESCRIPTION:
--- This test uses several instantiations of generic package
--- Decimal_Conversions to provide appropriate test material.
--- Two of the instantiations use decimal types as generic actuals
--- that include the implementation defined constants Max_Digits_Binary
--- and Max_Digits_Long_Binary in their definition.
---
--- Subtests are included for both versions of function To_Decimal,
--- (Binary and Long_Binary parameters), and include checks that
--- Conversion_Error is propagated under the appropriate circumstances.
--- Functions To_Binary and To_Long_Binary are "sanity" checked, to
--- ensure that the functions are available, and that the results are
--- appropriate based on their parameter input.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 21 Feb 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4008 is
-begin
-
- Report.Test ("CXB4008", "Check that functions To_Decimal, To_Binary, and " &
- "To_Long_Binary produce the correct results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits Max_Digits_Binary;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits Max_Digits_Long_Binary;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.0;
- TC_Dec_2 : Decimal_Type_2 := 123456.00;
- TC_Dec_3 : Decimal_Type_3 := 1234567.000;
- TC_Dec_4 : Decimal_Type_4 := 12345678.0000;
- TC_Binary : Interfaces.COBOL.Binary;
- TC_Long_Binary : Interfaces.COBOL.Long_Binary;
-
- begin
-
- -- Check that the function To_Decimal with Binary parameter will
- -- return the corresponding value of the decimal type Num.
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(TC_Dec_1)) /= TC_Dec_1 or
- Pack_2.To_Decimal(Pack_2.To_Binary(TC_Dec_2)) /= TC_Dec_2
- then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 1");
- end if;
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(1234.0)) /= 1234.0 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 2");
- end if;
-
- TC_Binary := Pack_2.To_Binary(TC_Dec_2);
- if Pack_2.To_Decimal(TC_Binary) /= TC_Dec_2 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 3");
- end if;
-
-
-
- -- Check that the function To_Decimal with Long_Binary parameter
- -- will return the corresponding value of the decimal type Num.
-
- if Pack_3.To_Decimal(Item => Pack_3.To_Long_Binary(TC_Dec_3)) /=
- TC_Dec_3 or
- Pack_4.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)) /=
- TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 1");
- end if;
-
- if Pack_3.To_Decimal(Pack_3.To_Long_Binary(1234567.0)) /= 1234567.0 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 2");
- end if;
-
- TC_Long_Binary := Pack_4.To_Long_Binary(TC_Dec_4);
- if Pack_4.To_Decimal(TC_Long_Binary) /= TC_Dec_4 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 3");
- end if;
-
-
-
- -- Check that both of the To_Decimal functions described above
- -- will propagate Conversion_Error if the converted value Item is
- -- outside the range of type Num.
- -- Note: Binary/Long_Binary parameter values are created by an
- -- instantiation of To_Binary/To_Long_Binary with a larger
- -- Num type as the generic formal.
-
- Binary_Parameter:
- begin
- TC_Dec_1 := Pack_1.To_Decimal(Pack_2.To_Binary(123456.78));
- Report.Failed("Conversion_Error was not raised by function " &
- "To_Decimal with Binary parameter, when the " &
- "converted value Item was outside the range " &
- "of type Num");
- if TC_Dec_1 = 12345.6 then -- Avoid dead assignment optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " &
- "was incorrectly raised by function To_Decimal " &
- "with Binary parameter, when the converted " &
- "value Item was outside the range of type Num");
- end Binary_Parameter;
-
- Long_Binary_Parameter:
- begin
- TC_Dec_3 := Pack_3.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4));
- Report.Failed("Conversion_Error was not raised by function " &
- "To_Decimal with Long_Binary parameter, when " &
- "the converted value Item was outside the range " &
- "of type Num");
- if TC_Dec_3 = 123456.78 then -- Avoid dead assignment optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " &
- "was incorrectly raised by function To_Decimal " &
- "with Long_Binary parameter, when the converted " &
- "value Item was outside the range of type Num");
- end Long_Binary_Parameter;
-
-
-
- -- Check that the function To_Binary converts a value of the Ada
- -- decimal type Num into a Binary type value.
-
- TC_Dec_1 := 123.4;
- TC_Dec_2 := 9.99;
- if Pack_1.To_Binary(TC_Dec_1) = Pack_1.To_Binary(-TC_Dec_1) or
- Pack_2.To_Binary(TC_Dec_2) = Pack_2.To_Binary(-TC_Dec_2)
- then
- Report.Failed("Incorrect result from function To_Binary - 1");
- end if;
-
- if Pack_1.To_Binary(1.1) = Pack_1.To_Binary(-1.1) or
- Pack_2.To_Binary(9999.99) = Pack_2.To_Binary(-9999.99)
- then
- Report.Failed("Incorrect result from function To_Binary - 2");
- end if;
-
-
- -- Check that the function To_Long_Binary converts a value of the
- -- Ada decimal type Num into a Long_Binary type value.
-
- TC_Dec_3 := 9.001;
- TC_Dec_4 := 123.4567;
- if Pack_3.To_Long_Binary(TC_Dec_3) = Pack_3.To_Long_Binary(-TC_Dec_3) or
- Pack_4.To_Long_Binary(TC_Dec_4) = Pack_4.To_Long_Binary(-TC_Dec_4)
- then
- Report.Failed("Incorrect result from function To_Long_Binary - 1");
- end if;
-
- if Pack_3.To_Long_Binary(1.011) =
- Pack_3.To_Long_Binary(-1.011) or
- Pack_4.To_Long_Binary(2345678.9012) =
- Pack_4.To_Long_Binary(-2345678.9012)
- then
- Report.Failed("Incorrect result from function To_Long_Binary - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4008;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a
deleted file mode 100644
index a681c5f..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- CXB5001.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 specification of the package Interfaces.Fortran
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.Fortran, this test
--- must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.Fortran; -- N/A => ERROR
-
-procedure CXB5001 is
- package Fortran renames Interfaces.FORTRAN;
-
-begin
-
- Report.Test ("CXB5001", "Check the specification of Interfaces.Fortran");
-
-
- declare -- encapsulate the test
-
-
- TC_Int : integer := 1;
- TC_Natural : natural;
- TC_String : String := "ABCD";
- TC_Character : Character := 'a';
-
- TST_Fortran_Integer : FORTRAN.Fortran_Integer;
-
- TST_Real : Fortran.Real;
- TST_Double_Precision : Fortran.Double_Precision;
-
- TST_Logical : Fortran.Logical := FORTRAN.true;
- -- verify it is a Boolean
- TST_Complex : Fortran.Complex;
-
- TST_Imaginary_i : Fortran.Imaginary := FORTRAN.i;
- TST_Imaginary_j : Fortran.Imaginary := FORTRAN.j;
-
-
- -- Initialize it so we can use it below
- TST_Character_Set : Fortran.Character_Set :=
- Fortran.Character_Set'First;
-
- TST_Fortran_Character : FORTRAN.Fortran_Character (1..5) :=
- (others => TST_Character_Set);
-
-
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int, TC_Int ) then
-
- TST_Character_Set := Fortran.To_Fortran (TC_Character);
- TC_Character := Fortran.To_Ada (TST_Character_Set);
-
-
- TST_Fortran_Character := FORTRAN.To_Fortran ("TEST STRING");
- Report.Comment ( Fortran.To_Ada (TST_Fortran_Character) );
-
- Fortran.To_Fortran ( TC_String, TST_Fortran_Character, TC_Natural );
- Fortran.To_Ada ( TST_Fortran_Character, TC_String, TC_Natural );
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB5001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a
deleted file mode 100644
index 3da7cc9..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXB5002.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 Function To_Fortran with a Character parameter will
--- return the corresponding Fortran Character_Set value.
---
--- Check that the Function To_Ada with a Character_Set parameter will
--- return the corresponding Ada Character value.
---
--- Check that the Function To_Fortran with a String parameter will
--- return the corresponding Fortran_Character value.
---
--- Check that the Function To_Ada with a Fortran_Character parameter
--- will return the corresponding Ada String value.
---
--- TEST DESCRIPTION:
--- This test checks that the functions To_Fortran and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the results of the function
--- To_Fortran are compared against expected Character_Set type results.
--- In the second series of subtests, the results of the function To_Ada
--- are compared against expected String type results, and the length of
--- the String result is also verified against the Fortran_Character type
--- parameter.
---
--- This test uses Fixed, Bounded, and Unbounded_Strings in combination
--- with the functions under validation.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.Fortran.Character_Set:
--- ' ', 'a'..'z', 'A'..'Z', '1'..'9', '-', '_', '$', '#', and '*'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.Fortran. If an implementation provides
--- package Interfaces.Fortran, this test must compile, execute, and
--- report "PASSED".
---
--- This test does not apply to an implementation in which the Fortran
--- character set ranges are not contiguous (e.g., EBCDIC).
---
---
---
--- CHANGE HISTORY:
--- 11 Mar 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Ada.Unchecked_Conversion;
-with Interfaces.Fortran; -- N/A => ERROR
-with Report;
-
-procedure CXB5002 is
-begin
-
- Report.Test ("CXB5002", "Check that functions To_Fortran and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package ACL renames Ada.Characters.Latin_1;
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Bnd, Unb;
- use Interfaces.Fortran;
- use Ada.Exceptions;
-
- Null_Fortran_Character : constant Fortran_Character := "";
- Fortran_Character_1 : Fortran_Character(1..1) := " ";
- Fortran_Character_5 : Fortran_Character(1..5) := " ";
- Fortran_Character_10 : Fortran_Character(1..10) := " ";
- Fortran_Character_20 : Fortran_Character(1..20) :=
- " ";
- TC_Fortran_Character_1 : Fortran_Character(1..1) := "A";
- TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de";
- TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5";
- TC_Fortran_Character_20 : Fortran_Character(1..20) :=
- "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
- Null_String : constant String := "";
-
- Null_Character : constant Character := ACL.Nul;
- Character_A : constant Character := Character'Val(65);
- Character_Z : constant Character := Character'Val(90);
- TC_Character : Character := Character'First;
-
- Null_Character_Set : Character_Set := To_Fortran(ACL.Nul);
- TC_Character_Set,
- TC_Low_Character_Set,
- TC_High_Character_Set : Character_Set := Character_Set'First;
-
-
- -- The following procedure checks the results of function To_Ada.
-
- procedure Check_Length (Str : in String;
- Ftn : in Fortran_Character;
- Num : in Natural) is
- begin
- if Str'Length /= Ftn'Length or
- Str'Length /= Num
- then
- Report.Failed("Incorrect result from Function To_Ada " &
- "with string length " & Integer'Image(Num));
- end if;
- end Check_Length;
-
- -- To facilitate the conversion of Character-Character_Set data, the
- -- following functions have been instantiated.
-
- function Character_to_Character_Set is
- new Ada.Unchecked_Conversion(Character, Character_Set);
-
- function Character_Set_to_Character is
- new Ada.Unchecked_Conversion(Character_Set, Character);
-
- begin
-
- -- Check that the Function To_Fortran with a Character parameter
- -- will return the corresponding Fortran Character_Set value.
-
- for TC_Character in ACL.LC_A..ACL.LC_Z loop
- if To_Fortran(Item => TC_Character) /=
- Character_to_Character_Set(TC_Character)
- then
- Report.Failed("Incorrect result from To_Fortran with lower " &
- "case alphabetic character input");
- end if;
- end loop;
-
- for TC_Character in Character_A..Character_Z loop
- if To_Fortran(TC_Character) /=
- Character_to_Character_Set(TC_Character)
- then
- Report.Failed("Incorrect result from To_Fortran with upper " &
- "case alphabetic character input");
- end if;
- end loop;
-
- if To_Fortran(Null_Character) /=
- Character_to_Character_Set(Null_Character)
- then
- Report.Failed
- ("Incorrect result from To_Fortran with null character input");
- end if;
-
-
- -- Check that the Function To_Ada with a Character_Set parameter
- -- will return the corresponding Ada Character value.
-
- TC_Low_Character_Set := Character_to_Character_Set('a');
- TC_High_Character_Set := Character_to_Character_Set('z');
- for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop
- if To_Ada(Item => TC_Character_Set) /=
- Character_Set_to_Character(TC_Character_Set)
- then
- Report.Failed("Incorrect result from To_Ada with lower case " &
- "alphabetic Character_Set input");
- end if;
- end loop;
-
- TC_Low_Character_Set := Character_to_Character_Set('A');
- TC_High_Character_Set := Character_to_Character_Set('Z');
- for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop
- if To_Ada(TC_Character_Set) /=
- Character_Set_to_Character(TC_Character_Set)
- then
- Report.Failed("Incorrect result from To_Ada with upper case " &
- "alphabetic Character_Set input");
- end if;
- end loop;
-
- if To_Ada(Character_to_Character_Set(Null_Character)) /=
- Null_Character
- then
- Report.Failed("Incorrect result from To_Ada with a null " &
- "Character_Set input");
- end if;
-
-
- -- Check that the Function To_Fortran with a String parameter
- -- will return the corresponding Fortran_Character value.
- -- Note: The type Fortran_Character is a character array type that
- -- corresponds to Ada type String.
-
- Fortran_Character_1 := To_Fortran(Item => TC_String_1);
-
- if Fortran_Character_1 /= TC_Fortran_Character_1 then
- Report.Failed("Incorrect result from procedure To_Fortran - 1");
- end if;
-
- Fortran_Character_5 := To_Fortran(To_String(TC_Unb_String));
-
- if Fortran_Character_5 /= TC_Fortran_Character_5 then
- Report.Failed("Incorrect result from procedure To_Fortran - 2");
- end if;
-
- Fortran_Character_10 := To_Fortran(To_String(TC_Bnd_String));
-
- if Fortran_Character_10 /= TC_Fortran_Character_10 then
- Report.Failed("Incorrect result from procedure To_Fortran - 3");
- end if;
-
- Fortran_Character_20 := To_Fortran(Item => TC_String_20);
-
- if Fortran_Character_20 /= TC_Fortran_Character_20 then
- Report.Failed("Incorrect result from procedure To_Fortran - 4");
- end if;
-
- if To_Fortran(Null_String) /= Null_Fortran_Character then
- Report.Failed("Incorrect result from procedure To_Fortran - 5");
- end if;
-
-
- -- Check that the Function To_Ada with a Fortran_Character parameter
- -- will return the corresponding Ada String value.
-
- String_1 := To_Ada(TC_Fortran_Character_1);
-
- if String_1 /= TC_String_1 then
- Report.Failed("Incorrect value returned from function To_Ada - 1");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_1),
- TC_Fortran_Character_1,
- Num => 1);
-
-
- Unb_String := Unb.To_Unbounded_String(To_Ada(TC_Fortran_Character_5));
-
- if Unb_String /= TC_Unb_String then
- Report.Failed("Incorrect value returned from function To_Ada - 2");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_5),
- TC_Fortran_Character_5,
- Num => 5);
-
-
- Bnd_String := Bnd.To_Bounded_String
- (To_Ada(TC_Fortran_Character_10));
-
- if Bnd_String /= TC_Bnd_String then
- Report.Failed("Incorrect value returned from function To_Ada - 3");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_10),
- TC_Fortran_Character_10,
- Num => 10);
-
-
- String_20 := To_Ada(TC_Fortran_Character_20);
-
- if String_20 /= TC_String_20 then
- Report.Failed("Incorrect value returned from function To_Ada - 4");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_20),
- TC_Fortran_Character_20,
- Num => 20);
-
- if To_Ada(Null_Character_Set) /= Null_Character then
- Report.Failed("Incorrect value returned from function To_Ada - 5");
- end if;
-
-
- -- Check the two functions when used in combination.
-
- if To_Ada(Item => To_Fortran("This is a test")) /=
- "This is a test" or
- To_Ada(To_Fortran("1234567890abcdeFGHIJ")) /=
- Report.Ident_Str("1234567890abcdeFGHIJ")
- then
- Report.Failed("Incorrect result returned when using the " &
- "functions To_Ada and To_Fortran in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB5002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a
deleted file mode 100644
index 1c2b1c5..0000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- CXB5003.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 procedure To_Fortran converts the character elements
--- of the String parameter Item into Character_Set elements of the
--- Fortran_Character type parameter Target. Check that the parameter
--- Last contains the index of the last element of parameter Target
--- that was assigned by To_Fortran.
---
--- Check that Constraint_Error is propagated by procedure To_Fortran
--- when the length of String parameter Item exceeds the length of
--- Fortran_Character parameter Target.
---
--- Check that the procedure To_Ada converts the Character_Set
--- elements of the Fortran_Character parameter Item into Character
--- elements of the String parameter Target. Check that the parameter
--- Last contains the index of the last element of parameter Target
--- that was assigned by To_Ada.
---
--- Check that Constraint_Error is propagated by procedure To_Ada when
--- the length of Fortran_Character parameter Item exceeds the length of
--- String parameter Target.
---
--- TEST DESCRIPTION:
--- This test checks that the procedures To_Fortran and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the Out parameter results of
--- procedure To_Fortran are compared against expected results,
--- which includes (in the parameter Last) the index in Target of the
--- last element assigned. The situation where procedure To_Fortran
--- raises Constraint_Error (when Item'Length exceeds Target'Length)
--- is also verified.
---
--- In the second series of subtests, the Out parameter results of
--- procedure To_Ada are verified, in a similar manner as is done for
--- procedure To_Fortran. The case of procedure To_Ada raising
--- Constraint_Error is also verified.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.Fortran.Character_Set:
--- ' ', 'a'..'j', 'A'..'D', '1'..'9', '-', '_', '$', '#', and '*'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.Fortran. If an implementation provides
--- package Interfaces.Fortran, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 14 Mar 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.Fortran; -- N/A => ERROR
-with Report;
-
-procedure CXB5003 is
-begin
-
- Report.Test ("CXB5003", "Check that procedures To_Fortran and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Bnd, Unb;
- use Interfaces.Fortran;
- use Ada.Exceptions;
-
- Fortran_Character_1 : Fortran_Character(1..1) := " ";
- Fortran_Character_5 : Fortran_Character(1..5) := " ";
- Fortran_Character_10 : Fortran_Character(1..10) := " ";
- Fortran_Character_20 : Fortran_Character(1..20) :=
- " ";
- TC_Fortran_Character_1 : Fortran_Character(1..1) := "A";
- TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de";
- TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5";
- TC_Fortran_Character_20 : Fortran_Character(1..20) :=
- "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
-
- TC_Fortran_Character : constant Fortran_Character := "";
- TC_String : constant String := "";
- TC_Natural : Natural := 0;
-
-
- begin
-
- -- Check that the procedure To_Fortran converts the character elements
- -- of the String parameter Item into Character_Set elements of the
- -- Fortran_Character type parameter Target.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_Fortran.
-
- To_Fortran(Item => TC_String_1,
- Target => Fortran_Character_1,
- Last => TC_Natural);
-
- if Fortran_Character_1 /= TC_Fortran_Character_1 or
- TC_Natural /= TC_Fortran_Character_1'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 1");
- end if;
-
- To_Fortran(To_String(TC_Unb_String),
- Target => Fortran_Character_5,
- Last => TC_Natural);
-
- if Fortran_Character_5 /= TC_Fortran_Character_5 or
- TC_Natural /= TC_Fortran_Character_5'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 2");
- end if;
-
- To_Fortran(To_String(TC_Bnd_String),
- Fortran_Character_10,
- Last => TC_Natural);
-
- if Fortran_Character_10 /= TC_Fortran_Character_10 or
- TC_Natural /= TC_Fortran_Character_10'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 3");
- end if;
-
- To_Fortran(TC_String_20, Fortran_Character_20, TC_Natural);
-
- if Fortran_Character_20 /= TC_Fortran_Character_20 or
- TC_Natural /= TC_Fortran_Character_20'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 4");
- end if;
-
- To_Fortran(Item => TC_String, -- null string
- Target => Fortran_Character_1,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Fortran, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
- -- Check that Constraint_Error is propagated by procedure To_Fortran
- -- when the length of String parameter Item exceeds the length of
- -- Fortran_Character parameter Target.
-
- begin
-
- To_Fortran(Item => TC_String_20,
- Target => Fortran_Character_10,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure " &
- "To_Fortran when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed("The following exception was raised by procedure " &
- "To_Fortran when Item'Length exceeds " &
- "Target'Length: " & Exception_Name(The_Error));
- end;
-
-
- -- Check that the procedure To_Ada converts the Character_Set
- -- elements of the Fortran_Character parameter Item into Character
- -- elements of the String parameter Target.
- -- Check that the parameter Last contains the index of the last
- -- element of parameter Target that was assigned by To_Ada.
-
- To_Ada(Item => TC_Fortran_Character_1,
- Target => String_1,
- Last => TC_Natural);
-
- if String_1 /= TC_String_1 or
- TC_Natural /= TC_String_1'Length
- then
- Report.Failed("Incorrect result from procedure To_Ada - 1");
- end if;
-
- To_Ada(TC_Fortran_Character_5,
- Target => String_5,
- Last => TC_Natural);
-
- if String_5 /= To_String(TC_Unb_String) or
- TC_Natural /= Length(TC_Unb_String)
- then
- Report.Failed("Incorrect result from procedure To_Ada - 2");
- end if;
-
- To_Ada(TC_Fortran_Character_10,
- String_10,
- Last => TC_Natural);
-
- if String_10 /= To_String(TC_Bnd_String) or
- TC_Natural /= Length(TC_Bnd_String)
- then
- Report.Failed("Incorrect result from procedure To_Ada - 3");
- end if;
-
- To_Ada(TC_Fortran_Character_20, String_20, TC_Natural);
-
- if String_20 /= TC_String_20 or
- TC_Natural /= TC_String_20'Length
- then
- Report.Failed("Incorrect result from procedure To_Ada - 4");
- end if;
-
- To_Ada(Item => TC_Fortran_Character, -- null array.
- Target => String_20,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Ada, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada
- -- when the length of Fortran_Character parameter Item exceeds the
- -- length of String parameter Target.
-
- begin
-
- To_Ada(Item => TC_Fortran_Character_10,
- Target => String_5,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed("Incorrect exception raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB5003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a
deleted file mode 100644
index be7e506..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a
+++ /dev/null
@@ -1,261 +0,0 @@
--- CXF1001.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 values of 2 and 10 are allowable values for Machine_Radix
--- of a decimal first subtype.
--- Check that the value of Decimal.Max_Decimal_Digits is at least 18;
--- the value of Decimal.Max_Scale is at least 18; the value of
--- Decimal.Min_Scale is at most 0.
---
--- TEST DESCRIPTION:
--- This test examines the Machine_Radix attribute definition clause
--- and its effect on Decimal fixed point types, as well as several
--- constants from the package Ada.Decimal.
--- The first subtest checks that the Machine_Radix attribute will
--- return the value set for Machine_Radix by an attribute definition
--- clause. The second and third subtests examine differences between
--- the binary and decimal scaling of a type, based on the radix
--- representation. The final subtest examines the values
--- assigned to constants Min_Scale, Max_Scale, and Max_Decimal_Digits,
--- found in the package Ada.Decimal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Restructured Radix 10 and Radix 2 test blocks.
---
---!
-
-with Report;
-with Ada.Decimal;
-
-procedure CXF1001 is
-begin
-
- Report.Test ("CXF1001", "Check that values of 2 and 10 are allowable " &
- "values for Machine_Radix of a decimal first " &
- "subtype. Check that the value of " &
- "Decimal.Max_Decimal_Digits is at least 18; " &
- "the value of Decimal.Max_Scale is at least " &
- "18; the value of Decimal.Min_Scale is at " &
- "most 0");
-
- Attribute_Check_Block:
- declare
-
- Del : constant := 1.0/10**2;
- Const_Digits : constant := 3;
- Two : constant := 2;
- Ten : constant := 10;
-
- type Radix_2_Type_1 is delta 0.01 digits 7;
- type Radix_2_Type_2 is delta Ada.Decimal.Min_Delta digits 10;
- type Radix_2_Type_3 is
- delta 0.000_1 digits Ada.Decimal.Max_Decimal_Digits;
-
- type Radix_10_Type_1 is delta 10.0**(-Ada.Decimal.Max_Scale) digits 8;
- type Radix_10_Type_2 is delta 10.0**(-Ada.Decimal.Min_Scale) digits 6;
- type Radix_10_Type_3 is delta Ada.Decimal.Max_Delta digits 15;
-
-
- -- Use an attribute definition clause to set the Machine_Radix for a
- -- decimal first subtype to either 2 or 10.
- for Radix_2_Type_1'Machine_Radix use 2;
- for Radix_2_Type_2'Machine_Radix use Two;
- for Radix_2_Type_3'Machine_Radix use 10-8;
-
- for Radix_10_Type_1'Machine_Radix use 2*15/Const_Digits;
- for Radix_10_Type_2'Machine_Radix use Ten;
- for Radix_10_Type_3'Machine_Radix use Radix_10_Type_2'Machine_Radix;
-
-
- begin
-
- -- Check that the attribute 'Machine_Radix returns the value assigned
- -- by the attribute definition clause.
-
- if Radix_2_Type_1'Machine_Radix /= 2 or else
- Radix_2_Type_2'Machine_Radix /= 2 or else
- Radix_2_Type_3'Machine_Radix /= 2
- then
- Report.Failed("Incorrect radix value returned, 2 expected");
- end if;
-
- if Radix_10_Type_1'Machine_Radix /= 10 or else
- Radix_10_Type_2'Machine_Radix /= 10 or else
- Radix_10_Type_3'Machine_Radix /= 10
- then
- Report.Failed("Incorrect radix value returned, 10 expected");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Attr_Check_Block");
- end Attribute_Check_Block;
-
-
-
- Radix_Block:
- -- Premises:
- -- 1) Choose several numbers, from types using either decimal scaling or
- -- binary scaling.
- -- 1) Repetitively add these numbers to themselves.
- -- 3) Validate that the result is the expected result, regardless of the
- -- scaling used in the definition of the type.
- declare
-
- Number_Of_Values : constant := 3;
- Loop_Count : constant := 1000;
-
- type Radix_2_Type is delta 0.0001 digits 10;
- type Radix_10_Type is delta 0.0001 digits 10;
-
- for Radix_2_Type'Machine_Radix use 2;
- for Radix_10_Type'Machine_Radix use 10;
-
- type Result_Record_Type is record
- Rad_2 : Radix_2_Type;
- Rad_10 : Radix_10_Type;
- end record;
-
- type Result_Array_Type is array (1..Number_Of_Values)
- of Result_Record_Type;
-
- Result_Array : Result_Array_Type := ((50.00, 50.00),
- (613.00, 613.00),
- (72.70, 72.70));
-
- function Repetitive_Radix_2_Add (Value : in Radix_2_Type)
- return Radix_2_Type is
- Result : Radix_2_Type := 0.0;
- begin
- for i in 1..Loop_Count loop
- Result := Result + Value;
- end loop;
- return Result;
- end Repetitive_Radix_2_Add;
-
- function Repetitive_Radix_10_Add (Value : in Radix_10_Type)
- return Radix_10_Type is
- Result : Radix_10_Type := 0.0;
- begin
- for i in 1..Loop_Count loop
- Result := Result + Value;
- end loop;
- return Result;
- end Repetitive_Radix_10_Add;
-
- begin
-
- -- Radix 2 Cases, three different values.
- -- Compare the result of the repetitive addition with the expected
- -- Radix 2 result, as well as with the Radix 10 value after type
- -- conversion.
-
- if Repetitive_Radix_2_Add(0.05) /= Result_Array(1).Rad_2 or
- Repetitive_Radix_2_Add(0.05) /= Radix_2_Type(Result_Array(1).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 1");
- end if;
-
- if Repetitive_Radix_2_Add(0.613) /=
- Result_Array(2).Rad_2 or
- Repetitive_Radix_2_Add(0.613) /=
- Radix_2_Type(Result_Array(2).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 2");
- end if;
-
- if Repetitive_Radix_2_Add(0.0727) /=
- Result_Array(3).Rad_2 or
- Repetitive_Radix_2_Add(0.0727) /=
- Radix_2_Type(Result_Array(3).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 3");
- end if;
-
- -- Radix 10 Cases, three different values.
- -- Compare the result of the repetitive addition with the expected
- -- Radix 10 result, as well as with the Radix 2 value after type
- -- conversion.
-
- if Repetitive_Radix_10_Add(0.05) /= Result_Array(1).Rad_10 or
- Repetitive_Radix_10_Add(0.05) /= Radix_10_Type(Result_Array(1).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 1");
- end if;
-
- if Repetitive_Radix_10_Add(0.613) /=
- Result_Array(2).Rad_10 or
- Repetitive_Radix_10_Add(0.613) /=
- Radix_10_Type(Result_Array(2).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 2");
- end if;
-
- if Repetitive_Radix_10_Add(0.0727) /=
- Result_Array(3).Rad_10 or
- Repetitive_Radix_10_Add(0.0727) /=
- Radix_10_Type(Result_Array(3).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 3");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Radix_Block");
- end Radix_Block;
-
-
-
- Size_Block:
- -- Check the implementation max/min values of constants declared in
- -- package Ada.Decimal.
- declare
- Minimum_Required_Size : constant := 18;
- Maximum_Allowed_Size : constant := 0;
- begin
-
- -- Check that the Max_Decimal_Digits value is at least 18.
- if not (Ada.Decimal.Max_Decimal_Digits >= Minimum_Required_Size) then
- Report.Failed("Insufficient size provided for Max_Decimal_Digits");
- end if;
-
- -- Check that the Max_Scale value is at least 18.
- if not (Ada.Decimal.Max_Scale >= Minimum_Required_Size) then
- Report.Failed("Insufficient size provided for Max_Scale");
- end if;
-
- -- Check that the Min_Scale value is at most 0.
- if not (Ada.Decimal.Min_Scale <= Maximum_Allowed_Size) then
- Report.Failed("Too large a value provided for Min_Scale");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Size_Block");
- end Size_Block;
-
- Report.Result;
-
-end CXF1001;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a
deleted file mode 100644
index a9f4bb2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a
+++ /dev/null
@@ -1,755 +0,0 @@
--- CXF2001.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 Divide procedure provides the following results:
--- Quotient = Dividend divided by Divisor and
--- Remainder = Dividend - (Divisor * Quotient)
--- Check that the Remainder is calculated exactly.
---
--- TEST DESCRIPTION:
--- This test is designed to test the generic procedure Divide found in
--- package Ada.Decimal.
---
--- The table below attempts to portray the design approach used in this
--- test. There are three "dimensions" of concern:
--- 1) the delta value of the Quotient and Remainder types, shown as
--- column headers,
--- 2) specific choices for the Dividend and Divisor numerical values
--- (i.e., whether they yielded a repeating/non-terminating result,
--- or a terminating result ["exact"]), displayed on the left side
--- of the tables, and
--- 3) the delta for the Dividend and Divisor.
---
--- Each row in the tables indicates a specific test case, showing the
--- specific quotient and remainder (under the appropriate Delta column)
--- for each combination of dividend and divisor values. Test cases
--- follow the top-to-bottom sequence shown in the tables.
---
--- Most of the test case sets (same dividend/divisor combinations -
--- indicated by dashed horizontal lines in the tables) vary the
--- delta of the quotient and remainder types between test cases. This
--- allows for an examination of how different deltas for a quotient
--- and/or remainder type can influence the results of a division with
--- identical dividend and divisor.
---
--- Note: Test cases are performed for both Radix 10 and Radix 2 types.
---
---
--- Divid Divis Delta Delta Delta Delta Delta
--- (Delta)(Delta)| .1 | .01 | .001 | .0001 | .00001 |Test
--- |---|---|-----|-----|-----|-----|-----|-----|-----|-----|Case
--- quotient | Q | R | Q | R | Q | R | Q | R | Q | R | No.
--- ---------------------------------------------------------------------------
--- .05 .3 |.1 .02 1,21
--- (.01) (.1) |.1 0 2,22
--- | .16 .002 3,23
--- 0.166666.. | .16 .00 4,24
--- | .166 .0002 5,25
--- ---------------------------------------------------------------------------
--- .15 20 | .00 .1500 6,26
--- (.01) (1) | .00 .150 7,27
--- | .00 .15 8,28
--- 0.0075 | .01 .007 9,29
--- | .007 .010 10,30
--- | .0075 .0000 11,31
--- ---------------------------------------------------------------------------
--- .03125 .5 | .0625 .0000 12,32
--- (.00001) (.1) | .062 .00025 13,33
--- | .062 .0002 14,34
--- 0.0625 | .062 .000 15,35
--- | .00 .062 16,36
--- | .06 .00125 17,37
--- | .06 .0012 18,38
--- | .06 .001 19,39
--- | .06 .00 20,40
--- ---------------------------------------------------------------------------
--- Divide by Zero| Raise Constraint_Error 41
--- ---------------------------------------------------------------------------
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Modified Radix 2 cases to match Radix 10 cases.
--- 03 Oct 95 RBKD Modified to fix incorrect remainder results.
--- 15 Nov 95 SAIC Incorporated reviewer fixes for ACVC 2.0.1.
--- 18 Dec 06 RLB Fixed failure message to have correct block name.
---!
-
-with Report;
-with Ada.Decimal;
-
-procedure CXF2001 is
-
- TC_Verbose : Boolean := False;
-
-begin
-
- Report.Test ("CXF2001", "Check that the Divide procedure provides " &
- "correct results. Check that the Remainder " &
- "is calculated exactly");
- Radix_10_Block:
- declare
-
-
- -- Declare all types and variables used in the various blocks below
- -- for all Radix 10 evaluations.
-
- type DT_1 is delta 1.0 digits 5;
- type DT_0_1 is delta 0.1 digits 10;
- type DT_0_01 is delta 0.01 digits 10;
- type DT_0_001 is delta 0.001 digits 10;
- type DT_0_0001 is delta 0.0001 digits 10;
- type DT_0_00001 is delta 0.00001 digits 10;
-
- for DT_1'Machine_Radix use 10;
- for DT_0_1'Machine_Radix use 10;
- for DT_0_01'Machine_Radix use 10;
- for DT_0_001'Machine_Radix use 10;
- for DT_0_0001'Machine_Radix use 10;
- for DT_0_00001'Machine_Radix use 10;
-
- Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0;
- Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0;
- Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0;
- Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0;
- Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0;
- Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0;
-
- begin
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(Dividend_Type => DT_0_01,
- Divisor_Type => DT_0_1,
- Quotient_Type => DT_0_1,
- Remainder_Type => DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 1"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_01);
- if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then
- Report.Failed("Incorrect values returned, Case 1");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1);
- begin
- if TC_Verbose then Report.Comment("Case 2"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_1);
- if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then
- Report.Failed("Incorrect values returned, Case 2");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 3"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then
- Report.Failed("Incorrect values returned, Case 3");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 4"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then
- Report.Failed("Incorrect values returned, Case 4");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 5"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.166) or
- Rem_0_0001 /= DT_0_0001(0.0002)
- then
- Report.Failed("Incorrect values returned, Case 5");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 6"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then
- Report.Failed("Incorrect values returned, Case 6");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 7"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then
- Report.Failed("Incorrect values returned, Case 7");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 8"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then
- Report.Failed("Incorrect values returned, Case 8");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 9"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001);
- if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then
- Report.Failed("Incorrect values returned, Case 9");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 10"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01);
- if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then
- Report.Failed("Incorrect values returned, Case 10");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 11"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0075) or
- Rem_0_0001 /= DT_0_0001(0.0)
- then
- Report.Failed("Incorrect values returned, Case 11");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 12"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0625) or
- Rem_0_0001 /= DT_0_0001(0.0)
- then
- Report.Failed("Incorrect values returned, Case 12");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001);
- begin
- if TC_Verbose then Report.Comment("Case 13"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001);
- if Quot_0_001 /= DT_0_001(0.062) or
- Rem_0_00001 /= DT_0_00001(0.00025)
- then
- Report.Failed("Incorrect values returned, Case 13");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 14"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.062) or
- Rem_0_0001 /= DT_0_0001(0.0002)
- then
- Report.Failed("Incorrect values returned, Case 14");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 15"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_001);
- if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000)
- then
- Report.Failed("Incorrect values returned, Case 15");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 16"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_01);
- if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then
- Report.Failed("Incorrect values returned, Case 16");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001);
- begin
- if TC_Verbose then Report.Comment("Case 17"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
- then
- Report.Failed("Incorrect values returned, Case 17");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 18"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
- then
- Report.Failed("Incorrect values returned, Case 18");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 19"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then
- Report.Failed("Incorrect values returned, Case 19");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 20"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then
- Report.Failed("Incorrect values returned, Case 20");
- end if;
- end;
-
-
- exception
- when others => Report.Failed("Exception raised in Radix_10_Block");
- end Radix_10_Block;
-
-
-
- Radix_2_Block:
- declare
-
- -- Declare all types and variables used in the various blocks below
- -- for all Radix 2 evaluations.
-
- type DT_1 is delta 1.0 digits 5;
- type DT_0_1 is delta 0.1 digits 10;
- type DT_0_01 is delta 0.01 digits 10;
- type DT_0_001 is delta 0.001 digits 10;
- type DT_0_0001 is delta 0.0001 digits 10;
- type DT_0_00001 is delta 0.00001 digits 10;
-
- for DT_1'Machine_Radix use 2;
- for DT_0_1'Machine_Radix use 2;
- for DT_0_01'Machine_Radix use 2;
- for DT_0_001'Machine_Radix use 2;
- for DT_0_0001'Machine_Radix use 2;
- for DT_0_00001'Machine_Radix use 2;
-
- Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0;
- Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0;
- Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0;
- Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0;
- Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0;
- Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0;
-
- begin
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(Dividend_Type => DT_0_01,
- Divisor_Type => DT_0_1,
- Quotient_Type => DT_0_1,
- Remainder_Type => DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 21"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_01);
- if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then
- Report.Failed("Incorrect values returned, Case 21");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1);
- begin
- if TC_Verbose then Report.Comment("Case 22"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_1);
- if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then
- Report.Failed("Incorrect values returned, Case 22");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 23"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then
- Report.Failed("Incorrect values returned, Case 23");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 24"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then
- Report.Failed("Incorrect values returned, Case 24");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 25"); end if;
- Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3);
- Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.166) or
- Rem_0_0001 /= DT_0_0001(0.0002)
- then
- Report.Failed("Incorrect values returned, Case 25");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 26"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then
- Report.Failed("Incorrect values returned, Case 26");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 27"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then
- Report.Failed("Incorrect values returned, Case 27");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 28"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then
- Report.Failed("Incorrect values returned, Case 28");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 29"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001);
- if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then
- Report.Failed("Incorrect values returned, Case 29");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 30"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01);
- if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then
- Report.Failed("Incorrect values returned, Case 30");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 31"); end if;
- Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20);
- Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0075) or
- Rem_0_0001 /= DT_0_0001(0.0)
- then
- Report.Failed("Incorrect values returned, Case 31");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 32"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001);
- if Quot_0_0001 /= DT_0_0001(0.0625) or
- Rem_0_0001 /= DT_0_0001(0.0)
- then
- Report.Failed("Incorrect values returned, Case 32");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001);
- begin
- if TC_Verbose then Report.Comment("Case 33"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001);
- if Quot_0_001 /= DT_0_001(0.062) or
- Rem_0_00001 /= DT_0_00001(0.00025)
- then
- Report.Failed("Incorrect values returned, Case 33");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 34"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001);
- if Quot_0_001 /= DT_0_001(0.062) or
- Rem_0_0001 /= DT_0_0001(0.0002)
- then
- Report.Failed("Incorrect values returned, Case 34");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 35"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_001);
- if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000)
- then
- Report.Failed("Incorrect values returned, Case 35");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 36"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_01);
- if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then
- Report.Failed("Incorrect values returned, Case 36");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001);
- begin
- if TC_Verbose then Report.Comment("Case 37"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125)
- then
- Report.Failed("Incorrect values returned, Case 37");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 38"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012)
- then
- Report.Failed("Incorrect values returned, Case 38");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001);
- begin
- if TC_Verbose then Report.Comment("Case 39"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_001);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then
- Report.Failed("Incorrect values returned, Case 39");
- end if;
- end;
-
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01);
- begin
- if TC_Verbose then Report.Comment("Case 40"); end if;
- Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5);
- Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_01);
- if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then
- Report.Failed("Incorrect values returned, Case 40");
- end if;
- end;
-
- declare
- procedure Div is
- new Ada.Decimal.Divide(DT_0_0001, DT_1, DT_0_0001, DT_0_0001);
- begin
- if TC_Verbose then Report.Comment("Case 41"); end if;
- Dd_0_0001 := (DT_0_0001(6062.0) / DT_0_0001(16384.0));
- Dv_1 := DT_1(0.0);
- Div(Dd_0_0001, Dv_1, Quot_0_0001, Rem_0_0001);
- Report.Failed("Divide by Zero didn't raise Constraint_Error, " &
- "Case 41");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Divide by Zero," &
- "Case 41");
- end;
-
- exception
- when others => Report.Failed("Exception raised in Radix_2_Block");
- end Radix_2_Block;
-
-
- Report.Result;
-
-end CXF2001;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a
deleted file mode 100644
index 984daa9..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a
+++ /dev/null
@@ -1,352 +0,0 @@
--- CXF2002.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 multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the operand and result types are the same.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types are declared, one with a Machine_Radix
--- value of 2, and one with a value of 10. For each type, checks are
--- performed on the following operations, where the operand and result
--- types are the same:
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 27 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
-package CXF2002_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed);
-
-end CXF2002_0;
-
-
- --==================================================================--
-
-
-package body CXF2002_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2002_0;
-
-
- --==================================================================--
-
-
-package CXF2002_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-end CXF2002_1;
-
-
- --==================================================================--
-
-
-with CXF2002_0;
-with CXF2002_1;
-
-with Report;
-procedure CXF2002 is
-
- Loop_Count : constant := 300;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2002", "Check decimal multiplication and division, and " &
- "'Round, where the operand and result types are " &
- "the same");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2002_0 (CXF2002_1.Money_Radix2);
- use type CXF2002_1.Money_Radix2;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2002_1.Money_Radix2 := 0.12;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix2 := Rate / Period;
-
- Initial : constant CXF2002_1.Money_Radix2 := 100_000.00;
- Trunc_Expected : constant CXF2002_1.Money_Radix2 := 1_978_837.50;
- Round_Expected : constant CXF2002_1.Money_Radix2 := 1_978_846.75;
-
- Balance : CXF2002_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2002_1.Money_Radix2 := 0.25;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix2 := Rate / Period;
- Divisor : constant CXF2002_1.Money_Radix2 := 1.0 / Factor;
-
- Initial : constant CXF2002_1.Money_Radix2 := 5_500.36;
- Trunc_Expected : constant CXF2002_1.Money_Radix2 := 2_091_332.87;
- Round_Expected : constant CXF2002_1.Money_Radix2 := 2_091_436.88;
-
- Balance : CXF2002_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2002_0 (CXF2002_1.Money_Radix10);
- use type CXF2002_1.Money_Radix10;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2002_1.Money_Radix10 := 0.37;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix10 := Rate / Period;
-
- Initial : constant CXF2002_1.Money_Radix10 := 459.33;
- Trunc_Expected : constant CXF2002_1.Money_Radix10 := 3_259_305.54;
- Round_Expected : constant CXF2002_1.Money_Radix10 := 3_260_544.11;
-
- Balance : CXF2002_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2002_1.Money_Radix10 := 0.15;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix10 := Rate / Period;
- Divisor : constant CXF2002_1.Money_Radix10 := 1.0 / Factor;
-
- Initial : constant CXF2002_1.Money_Radix10 := 29_842.08;
- Trunc_Expected : constant CXF2002_1.Money_Radix10 := 590_519.47;
- Round_Expected : constant CXF2002_1.Money_Radix10 := 590_528.98;
-
- Balance : CXF2002_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a
deleted file mode 100644
index 133dc48..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a
+++ /dev/null
@@ -1,363 +0,0 @@
--- CXF2003.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 multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the two operands are of different decimal
--- fixed point types.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. A third decimal
--- fixed point type C is declared with digits and delta values different
--- from those of A and B. For type A (and B), checks are performed
--- on the following operations, where one operand type is C, and the
--- other operand type and the result type is A (or B):
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed_1 is delta <> digits <>;
- type Decimal_Fixed_2 is delta <> digits <>;
-package CXF2003_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2);
-
-end CXF2003_0;
-
-
- --==================================================================--
-
-
-package body CXF2003_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed_1'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed_1'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2003_0;
-
-
- --==================================================================--
-
-
-package CXF2003_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-
- type Interest_Rate is delta 0.00001 digits 9; -- range -9999.99999 ..
- -- +9999.99999
-
-end CXF2003_1;
-
-
- --==================================================================--
-
-
-with CXF2003_0;
-with CXF2003_1;
-
-with Report;
-procedure CXF2003 is
-
- Loop_Count : constant := 1825;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2003", "Check decimal multiplication and division, and " &
- "'Round, where the operand types are different");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2003_0 (CXF2003_1.Money_Radix2,
- CXF2003_1.Interest_Rate);
- use type CXF2003_1.Money_Radix2;
- use type CXF2003_1.Interest_Rate;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.198;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
-
- Initial : constant CXF2003_1.Money_Radix2 := 1_000.00;
- Trunc_Expected : constant CXF2003_1.Money_Radix2 := 2_662.94;
- Round_Expected : constant CXF2003_1.Money_Radix2 := 2_678.34;
-
- Balance : CXF2003_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.129;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
- Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor;
-
- Initial : constant CXF2003_1.Money_Radix2 := 14_626.52;
- Trunc_Expected : constant CXF2003_1.Money_Radix2 := 27_688.26;
- Round_Expected : constant CXF2003_1.Money_Radix2 := 27_701.12;
-
- Balance : CXF2003_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2003_0 (CXF2003_1.Money_Radix10,
- CXF2003_1.Interest_Rate);
- use type CXF2003_1.Money_Radix10;
- use type CXF2003_1.Interest_Rate;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.063;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
-
- Initial : constant CXF2003_1.Money_Radix10 := 314_036.10;
- Trunc_Expected : constant CXF2003_1.Money_Radix10 := 428_249.48;
- Round_Expected : constant CXF2003_1.Money_Radix10 := 428_260.52;
-
- Balance : CXF2003_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.273;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
- Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor;
-
- Initial : constant CXF2003_1.Money_Radix10 := 25.72;
- Trunc_Expected : constant CXF2003_1.Money_Radix10 := 79.05;
- Round_Expected : constant CXF2003_1.Money_Radix10 := 97.46;
-
- Balance : CXF2003_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a
deleted file mode 100644
index 9651384..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a
+++ /dev/null
@@ -1,513 +0,0 @@
--- CXF2004.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 multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where one operand is of an ordinary fixed point type.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. An ordinary
--- fixed point type C is declared with a delta value different from
--- those of A and B (although still a power of 10). For type A (and B),
--- checks are performed on the following operations, where one operand
--- type is C, and the other operand type and the result type is A (or B):
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Prerelease version for ACVC 2.1.
--- 11 Aug 96 SAIC ACVC 2.1: In RADIX_2_MULTIPLICATION, corrected
--- value of Rate. Corrected associated commentary.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
- type Ordinary_Fixed is delta <>;
-package CXF2004_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed);
-
-end CXF2004_0;
-
-
- --==================================================================--
-
-
-package body CXF2004_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2004_0;
-
-
- --==================================================================--
-
-
-package CXF2004_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-
- type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0;
- for Interest_Rate'Small use 0.001; -- Power of 10.
-
-end CXF2004_1;
-
-
- --==================================================================--
-
-
-with CXF2004_0;
-with CXF2004_1;
-
-with Report;
-procedure CXF2004 is
-
- Loop_Count : constant := 180;
- type Loop_Range is range 1 .. Loop_Count;
-
- type Rounding_Scheme is ( Rounds, Truncates );
- Machine : Rounding_Scheme;
-
-begin
-
- Report.Test ("CXF2004", "Check decimal multiplication and division, and " &
- "'Round, where one operand type is ordinary fixed");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- if CXF2004_1.Interest_Rate'Machine_Rounds then -- Determine machine's
- Machine := Rounds; -- rounding scheme.
- else
- Machine := Truncates;
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2004_0 (CXF2004_1.Money_Radix2,
- CXF2004_1.Interest_Rate);
- use type CXF2004_1.Money_Radix2;
- use type CXF2004_1.Interest_Rate;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.154;
- Period : constant Integer := 12;
- Factor : CXF2004_1.Interest_Rate := Rate / Period;
-
- -- The exact value of Factor is:
- --
- -- 0.154/12 = 0.01283333...
- --
- -- The adjacent multiples of small are 0.012 and 0.013. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains is determined by the
- -- value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.012
- -- If Machine_Rounds = TRUE : Factor = 0.013
-
- Initial : constant CXF2004_1.Money_Radix2 := 1_000.00;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_557.07;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_560.47;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_222.65;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_225.81;
-
- Balance : CXF2004_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 multiply and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 multiply and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 multiply and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 multiply and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.210;
- Period : constant Integer := 12;
- Factor : constant CXF2004_1.Interest_Rate := Rate / Period;
- Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor;
-
- -- The exact value of Factor is:
- --
- -- 0.210/12 = 0.0175
- --
- -- The adjacent multiples of small are 0.017 and 0.018. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains is determined by the
- -- value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.017
- -- If Machine_Rounds = TRUE : Factor = 0.018
- --
- -- The exact value of Divisor is one of the following values:
- --
- -- 1.0/0.017 = 58.82352... (Adjacent smalls 58.823 and 58.824)
- -- 1.0/0.018 = 55.55555... (Adjacent smalls 55.555 and 55.556)
- --
- -- Again, since "1.0 / Factor" is static, the value Divisor contains
- -- is determined by the value of CXF2004_1.Interest_Rate'Rounds:
- --
- -- If Machine_Rounds = FALSE : Divisor = 58.823
- -- If Machine_Rounds = TRUE : Divisor = 55.556
-
- Initial : constant CXF2004_1.Money_Radix2 := 260.13;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_401.46;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_406.95;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_446.56;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_453.78;
-
- Balance : CXF2004_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 divide and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 divide and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 divide and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 divide and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2004_0 (CXF2004_1.Money_Radix10,
- CXF2004_1.Interest_Rate);
- use type CXF2004_1.Money_Radix10;
- use type CXF2004_1.Interest_Rate;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.095;
- Period : constant Integer := 12;
- Factor : CXF2004_1.Interest_Rate := Rate / Period;
-
- -- The exact value of Factor is:
- --
- -- 0.095/12 = 0.00791666...
- --
- -- The adjacent multiples of small are 0.007 and 0.008. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains can be determined based
- -- on the value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.007
- -- If Machine_Rounds = TRUE : Factor = 0.008
-
- Initial : constant CXF2004_1.Money_Radix10 := 2_125.00;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_456.90;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_458.77;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_915.74;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_917.84;
-
- Balance : CXF2004_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 multiply and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 multiply and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 multiply and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 multiply and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.295;
- Period : constant Integer := 12;
- Factor : constant CXF2004_1.Interest_Rate := Rate / Period;
- Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor;
-
- -- The exact value of Factor is:
- --
- -- 0.295/12 = 0.02458333...
- --
- -- The adjacent multiples of small are 0.024 and 0.025. Thus, the
- -- exact value of Divisor is one of the following:
- --
- -- 1.0/0.024 = 41.66666... (Adjacent smalls 41.666 and 41.667)
- -- 1.0/0.025 = 40.0
- --
- -- The value of CXF2004_1.Interest_Rate'Machine_Rounds determines
- -- what Divisor contains:
- --
- -- If Machine_Rounds = FALSE : Divisor = 41.666
- -- If Machine_Rounds = TRUE : Divisor = 40.000
-
- Initial : constant CXF2004_1.Money_Radix10 := 72.19;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_144.60;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_157.80;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_133.28;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_149.06;
-
- Balance : CXF2004_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 divide and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 divide and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 divide and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 divide and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2004;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a
deleted file mode 100644
index 71cd5bb..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXF2005.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 multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where one operand is of the predefined type Integer.
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. A variable of
--- each type is multiplied repeatedly by a series of different Integer
--- values. A cumulative result is kept and compared to an expected
--- final result. Similar checks are performed for division.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 28 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
-package CXF2005_0 is
-
- function Multiply (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed;
-
- function Divide (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed;
-
-end CXF2005_0;
-
-
- --==================================================================--
-
-
-package body CXF2005_0 is
-
- function Multiply (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed is
- begin
- return Operand * Interval; -- Fixed-Integer multiplication.
- end Multiply;
-
-
- function Divide (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed is
- begin
- return Operand / Interval; -- Fixed-Integer division.
- end Divide;
-
-end CXF2005_0;
-
-
- --==================================================================--
-
-
-package CXF2005_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0;
- for Interest_Rate'Small use 0.001; -- Power of 10.
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix2;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix10;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2005_1;
-
-
- --==================================================================--
-
-
-package body CXF2005_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix2 is
- begin
- return Money_Radix2( Rate / Interval );
- end Factor;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix10 is
- begin
- return Money_Radix10( Rate / Interval );
- end Factor;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2005_1;
-
-
- --==================================================================--
-
-
-with CXF2005_0;
-with CXF2005_1;
-
-with Report;
-procedure CXF2005 is
-
- Loop_Count : constant := 25_000;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2005", "Check decimal multiplication and division, " &
- "where one operand type is Integer");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2005_0 (CXF2005_1.Money_Radix2);
- use type CXF2005_1.Money_Radix2;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.127;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix2 := 2_624.88;
- Balance : CXF2005_1.Money_Radix2 := 1_000.00;
-
- Operand : CXF2005_1.Money_Radix2;
- Increment : CXF2005_1.Money_Radix2;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_2.Multiply (Operand, Interval);
- Balance := Balance + Increment;
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 2 multiply");
- end if;
-
- end RADIX_2_MULTIPLICATION;
-
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.377;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix2 := 36_215.58;
- Balance : CXF2005_1.Money_Radix2 := 456_985.01;
-
- Operand : CXF2005_1.Money_Radix2;
- Increment : CXF2005_1.Money_Radix2;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_2.Divide (Balance, Interval);
- Balance := Balance - (Operand * Increment);
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 2 divide");
- end if;
-
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2005_0 (CXF2005_1.Money_Radix10);
- use type CXF2005_1.Money_Radix10;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.721;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix10 := 9_875.62;
- Balance : CXF2005_1.Money_Radix10 := 126.34;
-
- Operand : CXF2005_1.Money_Radix10;
- Increment : CXF2005_1.Money_Radix10;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_10.Multiply (Operand, Interval);
- Balance := Balance + Increment;
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 10 multiply");
- end if;
-
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.547;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix10 := 26_116.37;
- Balance : CXF2005_1.Money_Radix10 := 770_082.46;
-
- Operand : CXF2005_1.Money_Radix10;
- Increment : CXF2005_1.Money_Radix10;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_10.Divide (Balance, Interval);
- Balance := Balance - (Operand * Increment);
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 10 divide");
- end if;
-
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2005;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a
deleted file mode 100644
index 002c59d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a
+++ /dev/null
@@ -1,448 +0,0 @@
--- CXF2A01.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 binary adding operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
---
--- TEST DESCRIPTION:
--- The test verifies that decimal addition and subtraction behave as
--- expected for types with various digits, delta, and Machine_Radix
--- values. Types with the minimum values for Decimal.Max_Digits and
--- Decimal.Max_Scale (18) are included.
---
--- Two kinds of checks are performed for each type. In the first check,
--- the iteration, operation, and operand counts in the foundation and
--- the operation tables in this test are given values such that, when the
--- operations loop is complete, each operand will have been added to and
--- subtracted from the loop's cumulator variable the same number of times,
--- albeit in varying order. Thus, the result returned by the operations
--- loop should have the same value as that used to initialize the
--- cumulator (in this test, zero).
---
--- In the second check, the same operation (addition for some types and
--- subtraction for others) is performed during each loop iteration,
--- resulting in a cumulative total which is checked against an expected
--- value.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF2A00.A
--- -> CXF2A01.A
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 08 Apr 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-package CXF2A01_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro is delta 10.0**(-18) digits 18; -- range -0.999999999999999999 ..
- for Micro'Machine_Radix use 10; -- +0.999999999999999999
-
- function Add (Left, Right : Micro) return Micro;
- function Subtract (Left, Right : Micro) return Micro;
-
-
- type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro;
-
- Micro_Add : Micro_Optr_Ptr := Add'Access;
- Micro_Sub : Micro_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money'Machine_Radix use 2; -- +999,999,999.99
-
- function Add (Left, Right : Money) return Money;
- function Subtract (Left, Right : Money) return Money;
-
-
- type Money_Optr_Ptr is access function (Left, Right : Money) return Money;
-
- Money_Add : Money_Optr_Ptr := Add'Access;
- Money_Sub : Money_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- -- Same as Money, but with Radix 10:
-
- type Cash is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Cash'Machine_Radix use 10; -- +999,999,999.99
-
- function Add (Left, Right : Cash) return Cash;
- function Subtract (Left, Right : Cash) return Cash;
-
-
- type Cash_Optr_Ptr is access function (Left, Right : Cash) return Cash;
-
- Cash_Add : Cash_Optr_Ptr := Add'Access;
- Cash_Sub : Cash_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad is delta 10.0**(-9) digits 18; -- range -999,999,999.999999999 ..
- for Broad'Machine_Radix use 10; -- +999,999,999.999999999
-
- function Add (Left, Right : Broad) return Broad;
- function Subtract (Left, Right : Broad) return Broad;
-
-
- type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad;
-
- Broad_Add : Broad_Optr_Ptr := Add'Access;
- Broad_Sub : Broad_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0;
-
-
- --==================================================================--
-
-
-package body CXF2A01_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Micro) return Micro is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Micro) return Micro is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Money) return Money is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Money) return Money is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Cash) return Cash is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Cash) return Cash is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Broad) return Broad is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Broad) return Broad is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0;
-
-
- --==================================================================--
-
-
-with FXF2A00;
-package CXF2A01_0.CXF2A01_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr;
- type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro;
-
- Micro_Optr_Table_Cancel : Micro_Ops := ( Micro_Add, Micro_Sub,
- Micro_Add, Micro_Sub,
- Micro_Add, Micro_Sub );
-
- Micro_Optr_Table_Cumul : Micro_Ops := ( others => Micro_Add );
-
- Micro_Opnd_Table_Cancel : Micro_Opnds := ( 0.001025000235111997,
- 0.000000000000000003,
- 0.724902903219925400,
- 0.000459228020000011,
- 0.049832104921096533 );
-
- Micro_Opnd_Table_Cumul : Micro_Opnds := ( 0.000002309540000000,
- 0.000000278060000000,
- 0.000000000000070000,
- 0.000010003000000000,
- 0.000000023090000000 );
-
- function Test_Micro_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Micro,
- Operator_Ptr => Micro_Optr_Ptr,
- Operator_Table => Micro_Ops,
- Operand_Table => Micro_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Ops is array (FXF2A00.Optr_Range) of Money_Optr_Ptr;
- type Money_Opnds is array (FXF2A00.Opnd_Range) of Money;
-
- Money_Optr_Table_Cancel : Money_Ops := ( Money_Add, Money_Add,
- Money_Sub, Money_Add,
- Money_Sub, Money_Sub );
-
- Money_Optr_Table_Cumul : Money_Ops := ( others => Money_Sub );
-
- Money_Opnd_Table_Cancel : Money_Opnds := ( 127.10,
- 5600.44,
- 0.05,
- 189662.78,
- 226900402.99 );
-
- Money_Opnd_Table_Cumul : Money_Opnds := ( 17.99,
- 500.41,
- 92.78,
- 0.38,
- 2942.99 );
-
- function Test_Money_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Money,
- Operator_Ptr => Money_Optr_Ptr,
- Operator_Table => Money_Ops,
- Operand_Table => Money_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Cash_Ops is array (FXF2A00.Optr_Range) of Cash_Optr_Ptr;
- type Cash_Opnds is array (FXF2A00.Opnd_Range) of Cash;
-
- Cash_Optr_Table_Cancel : Cash_Ops := ( Cash_Add, Cash_Add,
- Cash_Sub, Cash_Add,
- Cash_Sub, Cash_Sub );
-
- Cash_Optr_Table_Cumul : Cash_Ops := ( others => Cash_Add );
-
- Cash_Opnd_Table_Cancel : Cash_Opnds := ( 127.10,
- 5600.44,
- 0.05,
- 189662.78,
- 226900402.99 );
-
- Cash_Opnd_Table_Cumul : Cash_Opnds := ( 3.33,
- 100056.14,
- 22.87,
- 3901.55,
- 111.21 );
-
- function Test_Cash_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Cash,
- Operator_Ptr => Cash_Optr_Ptr,
- Operator_Table => Cash_Ops,
- Operand_Table => Cash_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr;
- type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad;
-
- Broad_Optr_Table_Cancel : Broad_Ops := ( Broad_Sub, Broad_Add,
- Broad_Add, Broad_Sub,
- Broad_Sub, Broad_Add );
-
- Broad_Optr_Table_Cumul : Broad_Ops := ( others => Broad_Sub );
-
- Broad_Opnd_Table_Cancel : Broad_Opnds := ( 1.000009092,
- 732919479.445022293,
- 89662.787000006,
- 660.101010133,
- 1121127.999905594 );
-
- Broad_Opnd_Table_Cumul : Broad_Opnds := ( 12.000450223,
- 479.430320780,
- 0.003492096,
- 8.112888400,
- 1002.994937800 );
-
- function Test_Broad_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Broad,
- Operator_Ptr => Broad_Optr_Ptr,
- Operator_Table => Broad_Ops,
- Operand_Table => Broad_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0.CXF2A01_1;
-
-
- --==================================================================--
-
-
-with CXF2A01_0.CXF2A01_1;
-
-with Report;
-procedure CXF2A01 is
- package Data renames CXF2A01_0.CXF2A01_1;
-
- use type CXF2A01_0.Micro;
- use type CXF2A01_0.Money;
- use type CXF2A01_0.Cash;
- use type CXF2A01_0.Broad;
-
- Micro_Cancel_Expected : constant CXF2A01_0.Micro := 0.0;
- Money_Cancel_Expected : constant CXF2A01_0.Money := 0.0;
- Cash_Cancel_Expected : constant CXF2A01_0.Cash := 0.0;
- Broad_Cancel_Expected : constant CXF2A01_0.Broad := 0.0;
-
- Micro_Cumul_Expected : constant CXF2A01_0.Micro := 0.075682140420000000;
- Money_Cumul_Expected : constant CXF2A01_0.Money := -21327300.00;
- Cash_Cumul_Expected : constant CXF2A01_0.Cash := 624570600.00;
- Broad_Cumul_Expected : constant CXF2A01_0.Broad := -9015252.535794000;
-
- Micro_Actual : CXF2A01_0.Micro;
- Money_Actual : CXF2A01_0.Money;
- Cash_Actual : CXF2A01_0.Cash;
- Broad_Actual : CXF2A01_0.Broad;
-begin
-
- Report.Test ("CXF2A01", "Check decimal addition and subtraction");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Micro_Actual := Data.Test_Micro_Ops (0.0,
- Data.Micro_Optr_Table_Cancel,
- Data.Micro_Opnd_Table_Cancel);
-
- if Micro_Actual /= Micro_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Micro");
- end if;
-
- ---=---=---=---=---=---=---
-
-
- Micro_Actual := Data.Test_Micro_Ops (0.0,
- Data.Micro_Optr_Table_Cumul,
- Data.Micro_Opnd_Table_Cumul);
-
- if Micro_Actual /= Micro_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Micro");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Money_Actual := Data.Test_Money_Ops (0.0,
- Data.Money_Optr_Table_Cancel,
- Data.Money_Opnd_Table_Cancel);
-
- if Money_Actual /= Money_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Money");
- end if;
-
- ---=---=---=---=---=---=---
-
-
- Money_Actual := Data.Test_Money_Ops (0.0,
- Data.Money_Optr_Table_Cumul,
- Data.Money_Opnd_Table_Cumul);
-
- if Money_Actual /= Money_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Money");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Cash_Actual := Data.Test_Cash_Ops (0.0,
- Data.Cash_Optr_Table_Cancel,
- Data.Cash_Opnd_Table_Cancel);
-
- if Cash_Actual /= Cash_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Cash");
- end if;
-
-
- ---=---=---=---=---=---=---
-
-
- Cash_Actual := Data.Test_Cash_Ops (0.0,
- Data.Cash_Optr_Table_Cumul,
- Data.Cash_Opnd_Table_Cumul);
-
- if Cash_Actual /= Cash_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Cash");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Broad_Actual := Data.Test_Broad_Ops (0.0,
- Data.Broad_Optr_Table_Cancel,
- Data.Broad_Opnd_Table_Cancel);
-
- if Broad_Actual /= Broad_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Broad");
- end if;
-
-
- ---=---=---=---=---=---=---
-
-
- Broad_Actual := Data.Test_Broad_Ops (0.0,
- Data.Broad_Optr_Table_Cumul,
- Data.Broad_Opnd_Table_Cumul);
-
- if Broad_Actual /= Broad_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Broad");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a
deleted file mode 100644
index e9977b0..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- CXF2A02.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 multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the operand and result types are the same.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
---
--- TEST DESCRIPTION:
--- The test verifies that decimal multiplication and division behave as
--- expected for types with various digits, delta, and Machine_Radix
--- values.
---
--- The iteration, operation, and operand counts in the foundation, and
--- the operations and operand tables in the test, are given values such
--- that, when the operations loop is complete, truncation of inexact
--- results should cause the result returned by the operations loop to be
--- the same as that used to initialize the loop's cumulator variable (in
--- this test, one).
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FXF2A00.A
--- -> CXF2A02.A
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 13 Mar 96 SAIC Prerelease version for ACVC 2.1.
--- 04 Aug 96 SAIC Updated prologue.
---
---!
-
-package CXF2A02_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro is delta 10.0**(-5) digits 6; -- range -9.99999 ..
- for Micro'Machine_Radix use 2; -- +9.99999
-
- function Multiply (Left, Right : Micro) return Micro;
- function Divide (Left, Right : Micro) return Micro;
-
-
- type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro;
-
- Micro_Mult : Micro_Optr_Ptr := Multiply'Access;
- Micro_Div : Micro_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Basic is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Basic'Machine_Radix use 10; -- +999,999,999.99
-
- function Multiply (Left, Right : Basic) return Basic;
- function Divide (Left, Right : Basic) return Basic;
-
-
- type Basic_Optr_Ptr is access function (Left, Right : Basic) return Basic;
-
- Basic_Mult : Basic_Optr_Ptr := Multiply'Access;
- Basic_Div : Basic_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad is delta 10.0**(-3) digits 10; -- range -9,999,999.999 ..
- for Broad'Machine_Radix use 2; -- +9,999,999.999
-
- function Multiply (Left, Right : Broad) return Broad;
- function Divide (Left, Right : Broad) return Broad;
-
-
- type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad;
-
- Broad_Mult : Broad_Optr_Ptr := Multiply'Access;
- Broad_Div : Broad_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0;
-
-
- --==================================================================--
-
-
-package body CXF2A02_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Micro) return Micro is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Micro) return Micro is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Basic) return Basic is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Basic) return Basic is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Broad) return Broad is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Broad) return Broad is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0;
-
-
- --==================================================================--
-
-
-with FXF2A00;
-package CXF2A02_0.CXF2A02_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr;
- type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro;
-
- Micro_Mult_Operator_Table : Micro_Ops := ( Micro_Mult, Micro_Mult,
- Micro_Mult, Micro_Mult,
- Micro_Mult, Micro_Mult );
-
- Micro_Div_Operator_Table : Micro_Ops := ( Micro_Div, Micro_Div,
- Micro_Div, Micro_Div,
- Micro_Div, Micro_Div );
-
- Micro_Mult_Operand_Table : Micro_Opnds := ( 2.35119,
- 0.05892,
- 9.58122,
- 0.80613,
- 0.93462 );
-
- Micro_Div_Operand_Table : Micro_Opnds := ( 0.58739,
- 4.90012,
- 0.08765,
- 0.71577,
- 5.53768 );
-
- function Test_Micro_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Micro,
- Operator_Ptr => Micro_Optr_Ptr,
- Operator_Table => Micro_Ops,
- Operand_Table => Micro_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Basic_Ops is array (FXF2A00.Optr_Range) of Basic_Optr_Ptr;
- type Basic_Opnds is array (FXF2A00.Opnd_Range) of Basic;
-
- Basic_Mult_Operator_Table : Basic_Ops := ( Basic_Mult, Basic_Mult,
- Basic_Mult, Basic_Mult,
- Basic_Mult, Basic_Mult );
-
- Basic_Div_Operator_Table : Basic_Ops := ( Basic_Div, Basic_Div,
- Basic_Div, Basic_Div,
- Basic_Div, Basic_Div );
-
- Basic_Mult_Operand_Table : Basic_Opnds := ( 127.10,
- 0.02,
- 0.87,
- 45.67,
- 0.01 );
-
- Basic_Div_Operand_Table : Basic_Opnds := ( 0.03,
- 0.08,
- 23.57,
- 0.11,
- 159.11 );
-
- function Test_Basic_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Basic,
- Operator_Ptr => Basic_Optr_Ptr,
- Operator_Table => Basic_Ops,
- Operand_Table => Basic_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr;
- type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad;
-
- Broad_Mult_Operator_Table : Broad_Ops := ( Broad_Mult, Broad_Mult,
- Broad_Mult, Broad_Mult,
- Broad_Mult, Broad_Mult );
-
- Broad_Div_Operator_Table : Broad_Ops := ( Broad_Div, Broad_Div,
- Broad_Div, Broad_Div,
- Broad_Div, Broad_Div );
-
- Broad_Mult_Operand_Table : Broad_Opnds := ( 589.720,
- 0.106,
- 21.018,
- 0.002,
- 0.381 );
-
- Broad_Div_Operand_Table : Broad_Opnds := ( 0.008,
- 0.793,
- 9.092,
- 214.300,
- 0.080 );
-
- function Test_Broad_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Broad,
- Operator_Ptr => Broad_Optr_Ptr,
- Operator_Table => Broad_Ops,
- Operand_Table => Broad_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0.CXF2A02_1;
-
-
- --==================================================================--
-
-
-with CXF2A02_0.CXF2A02_1;
-
-with Report;
-procedure CXF2A02 is
- package Data renames CXF2A02_0.CXF2A02_1;
-
- use type CXF2A02_0.Micro;
- use type CXF2A02_0.Basic;
- use type CXF2A02_0.Broad;
-
- Micro_Expected : constant CXF2A02_0.Micro := 1.0;
- Basic_Expected : constant CXF2A02_0.Basic := 1.0;
- Broad_Expected : constant CXF2A02_0.Broad := 1.0;
-
- Micro_Actual : CXF2A02_0.Micro;
- Basic_Actual : CXF2A02_0.Basic;
- Broad_Actual : CXF2A02_0.Broad;
-begin
-
- Report.Test ("CXF2A02", "Check decimal multiplication and division, " &
- "where the operand and result types are the same");
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Micro_Actual := 0.0;
- Micro_Actual := Data.Test_Micro_Ops (1.0,
- Data.Micro_Mult_Operator_Table,
- Data.Micro_Mult_Operand_Table);
-
- if Micro_Actual /= Micro_Expected then
- Report.Failed ("Wrong result for type Micro multiplication");
- end if;
-
-
- Micro_Actual := 0.0;
- Micro_Actual := Data.Test_Micro_Ops (1.0,
- Data.Micro_Div_Operator_Table,
- Data.Micro_Div_Operand_Table);
-
- if Micro_Actual /= Micro_Expected then
- Report.Failed ("Wrong result for type Micro division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Basic_Actual := 0.0;
- Basic_Actual := Data.Test_Basic_Ops (1.0,
- Data.Basic_Mult_Operator_Table,
- Data.Basic_Mult_Operand_Table);
-
- if Basic_Actual /= Basic_Expected then
- Report.Failed ("Wrong result for type Basic multiplication");
- end if;
-
-
- Basic_Actual := 0.0;
- Basic_Actual := Data.Test_Basic_Ops (1.0,
- Data.Basic_Div_Operator_Table,
- Data.Basic_Div_Operand_Table);
-
- if Basic_Actual /= Basic_Expected then
- Report.Failed ("Wrong result for type Basic division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Broad_Actual := 0.0;
- Broad_Actual := Data.Test_Broad_Ops (1.0,
- Data.Broad_Mult_Operator_Table,
- Data.Broad_Mult_Operand_Table);
-
- if Broad_Actual /= Broad_Expected then
- Report.Failed ("Wrong result for type Broad multiplication");
- end if;
-
-
- Broad_Actual := 0.0;
- Broad_Actual := Data.Test_Broad_Ops (1.0,
- Data.Broad_Div_Operator_Table,
- Data.Broad_Div_Operand_Table);
-
- if Broad_Actual /= Broad_Expected then
- Report.Failed ("Wrong result for type Broad division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Report.Result;
-
-end CXF2A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a
deleted file mode 100644
index 1b9abca..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- CXF3001.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 edited output string value returned by Function Image
--- is correct.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings.
---
--- Each picture string is checked for validity, and an invalid picture
--- string will cause immediate test failure on its first pass through
--- the evaluation loop. Inside the evaluation loop, each decimal data
--- item is combined with each of the picture strings as parameters to a
--- call to Image, and the result of each call is compared to an
--- expected edited output result string.
---
---
--- CHANGE HISTORY:
--- 24 Feb 95 SAIC Initial prerelease version.
--- 23 Jun 95 SAIC Corrected call to functions Valid and To_Picture.
--- 22 Aug 95 SAIC Test name changed to CXF3001 (from CXF3301) to
--- conform to naming conventions.
--- 24 Feb 97 CTA.PWB Corrected picture strings and expected results.
---!
-
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3001 is
-begin
-
- Report.Test ("CXF3001", "Check that the string value returned by " &
- "Function Image is correct");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- Number_Of_Decimal_Items : constant := 5;
- Number_Of_Picture_Strings : constant := 4;
- Number_Of_Expected_Results : constant := Number_Of_Decimal_Items *
- Number_Of_Picture_Strings;
-
- type String_Pointer_Type is access String;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
- package Ed_Out is new Editing.Decimal_Output (Decimal_Data_Type);
-
- -- Define types for the arrays of data that will hold the decimal data
- -- values, picture strings, and expected edited output results.
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- type Picture_String_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- -- Define the data arrays for this test.
-
- Decimal_Data :
- Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) :=
- ( 1 => 5678.90,
- 2 => -6789.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45
- );
-
- Picture_Strings :
- Picture_String_Array_Type(1..Number_Of_Picture_Strings) :=
- ( 1 => new String'("-$$_$$9.99"),
- 2 => new String'("-$$_$$$.$$"),
- 3 => new String'("-ZZZZ.ZZ"),
- 4 => new String'("-$$$_999.99")
- );
-
- Edited_Output :
- Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) :=
- ( 1 => new String'(" $5,678.90"),
- 2 => new String'(" $5,678.90"),
- 3 => new String'(" 5678.90"),
- 4 => new String'(" $5,678.90"),
-
- 5 => new String'("-$6,789.01"),
- 6 => new String'("-$6,789.01"),
- 7 => new String'("-6789.01"),
- 8 => new String'("- $6,789.01"),
-
- 9 => new String'(" $0.00"),
- 10 => new String'(" "),
- 11 => new String'(" "),
- 12 => new String'(" $ 000.00"),
-
- 13 => new String'(" $0.20"),
- 14 => new String'(" $.20"),
- 15 => new String'(" .20"),
- 16 => new String'(" $ 000.20"),
-
- 17 => new String'(" $3.45"),
- 18 => new String'(" $3.45"),
- 19 => new String'(" 3.45"),
- 20 => new String'(" $ 003.45")
- );
-
- TC_Picture : Editing.Picture;
- TC_Loop_Count : Natural := 0;
-
- begin
-
- -- Compare string result of Image with expected edited output string.
-
- Evaluate_Edited_Output:
- for i in 1..Number_Of_Decimal_Items loop
- for j in 1..Number_Of_Picture_Strings loop
-
- TC_Loop_Count := TC_Loop_Count + 1;
-
- -- Check on the validity of the picture strings prior to
- -- processing.
-
- if Editing.Valid(Picture_Strings(j).all) then
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Picture_Strings(j).all);
-
- -- Compare actual edited output result of Function Image with
- -- the expected result.
-
- if Ed_Out.Image(Decimal_Data(i), TC_Picture) /=
- Edited_Output(TC_Loop_Count).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with decimal data item # " &
- Integer'Image(i) &
- " and picture string # " &
- Integer'Image(j));
- end if;
-
- else
- Report.Failed("Picture String # " & Integer'Image(j) &
- "reported as being invalid");
- -- Immediate test failure if a string is invalid.
- exit Evaluate_Edited_Output;
- end if;
-
- end loop;
- end loop Evaluate_Edited_Output;
-
- exception
- when Editing.Picture_Error =>
- Report.Failed ("Picture_Error raised in Test_Block");
- when Layout_Error =>
- Report.Failed ("Layout_Error raised in Test_Block");
- when others =>
- Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a
deleted file mode 100644
index 8444244..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a
+++ /dev/null
@@ -1,231 +0,0 @@
--- CXF3002.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 functionality contained in package
--- Ada.Wide_Text_IO.Editing is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test is designed to validate the procedures and functions that
--- are found in package Ada.Wide_Text_IO.Editing, the "wide"
--- complementary package to Ada.Text_IO.Editing. The test is similar
--- to CXF3301, which tested a large portion of the Ada.Text_IO.Editing
--- package. Additional testing has been added here to cover the balance
--- of the Wide_Text_IO.Editing child package.
-
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings.
---
--- Each picture string is checked for validity, and an invalid picture
--- string will cause immediate test failure on its first pass through
--- the evaluation loop. Inside the evaluation loop, each decimal data
--- item is combined with each of the picture strings as parameters to a
--- call to Image, and the result of each call is compared to an
--- expected edited output result string.
---
--- Note: Each of the functions Valid, To_Picture, and Pic_String has
--- String (rather than Wide_String) as its parameter or result
--- subtype, since a picture String is not localizable.
---
---
--- CHANGE HISTORY:
--- 22 Jun 95 SAIC Initial prerelease version.
--- 22 Aug 95 SAIC Test name changed to CXF3002 (from CXF3401) to
--- conform with naming conventions.
--- 24 Feb 97 PWB.CTA Corrected picture strings and expected values.
---!
-
-with Ada.Wide_Text_IO.Editing;
-with Report;
-
-procedure CXF3002 is
-begin
-
- Report.Test ("CXF3002", "Check that the functionality contained " &
- "in package Ada.Wide_Text_IO.Editing is " &
- "available and produces correct results");
-
- Test_Block:
- declare
-
- use Ada.Wide_Text_IO;
-
- Number_Of_Decimal_Items : constant := 5;
- Number_Of_Picture_Strings : constant := 4;
- Number_Of_Expected_Results : constant := Number_Of_Decimal_Items *
- Number_Of_Picture_Strings;
-
- Def_Cur : constant Wide_String := "$";
- Def_Fill : constant Wide_Character := '*';
- Def_Sep : constant Wide_Character := Editing.Default_Separator;
- Def_Radix : constant Wide_Character := Editing.Default_Radix_Mark;
-
- type String_Pointer_Type is access String;
- type Wide_String_Pointer_Type is access Wide_String;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Wide_Ed_Out is
- new Editing.Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => Def_Cur,
- Default_Fill => Def_Fill,
- Default_Separator => Def_Sep,
- Default_Radix_Mark => Def_Radix);
-
- -- Define types for the arrays of data that will hold the decimal data
- -- values, picture strings, and expected edited output results.
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- type Picture_String_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of Wide_String_Pointer_Type;
-
- -- Define the data arrays for this test.
-
- Decimal_Data :
- Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) :=
- ( 1 => 5678.90,
- 2 => -6789.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45
- );
-
- Picture_Strings :
- Picture_String_Array_Type(1..Number_Of_Picture_Strings) :=
- ( 1 => new String'("-$$_$$9.99"),
- 2 => new String'("-$$_$$$.$$"),
- 3 => new String'("-ZZZZ.ZZ"),
- 4 => new String'("-$$$_999.99")
- );
-
-
- Edited_Output :
- Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) :=
- ( 1 => new Wide_String'(" $5,678.90"),
- 2 => new Wide_String'(" $5,678.90"),
- 3 => new Wide_String'(" 5678.90"),
- 4 => new Wide_String'(" $5,678.90"),
-
- 5 => new Wide_String'("-$6,789.01"),
- 6 => new Wide_String'("-$6,789.01"),
- 7 => new Wide_String'("-6789.01"),
- 8 => new Wide_String'("- $6,789.01"),
-
- 9 => new Wide_String'(" $0.00"),
- 10 => new Wide_String'(" "),
- 11 => new Wide_String'(" "),
- 12 => new Wide_String'(" $ 000.00"),
-
- 13 => new Wide_String'(" $0.20"),
- 14 => new Wide_String'(" $.20"),
- 15 => new Wide_String'(" .20"),
- 16 => new Wide_String'(" $ 000.20"),
-
- 17 => new Wide_String'(" $3.45"),
- 18 => new Wide_String'(" $3.45"),
- 19 => new Wide_String'(" 3.45"),
- 20 => new Wide_String'(" $ 003.45")
- );
-
- TC_Picture : Editing.Picture;
- TC_Loop_Count : Natural := 0;
-
- begin
-
- -- Compare string result of Image with expected edited output wide
- -- string.
-
- Evaluate_Edited_Output:
- for i in 1..Number_Of_Decimal_Items loop
- for j in 1..Number_Of_Picture_Strings loop
-
- TC_Loop_Count := TC_Loop_Count + 1;
-
- -- Check on the validity of the picture strings prior to
- -- processing.
-
- if Editing.Valid(Picture_Strings(j).all) then
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Picture_Strings(j).all);
-
- -- Check results of function Decimal_Output.Valid.
- if not Wide_Ed_Out.Valid(Decimal_Data(i), TC_Picture) then
- Report.Failed("Incorrect result from function Valid " &
- "when examining the picture string that " &
- "was produced from string " &
- Integer'Image(j) & " in conjunction with " &
- "decimal data item # " & Integer'Image(i));
- end if;
-
- -- Check results of function Editing.Pic_String.
- if Editing.Pic_String(TC_Picture) /= Picture_Strings(j).all then
- Report.Failed("Incorrect result from To_Picture/" &
- "Pic_String conversion for picture " &
- "string # " & Integer'Image(j));
- end if;
-
- -- Compare actual edited output result of Function Image with
- -- the expected result.
-
- if Wide_Ed_Out.Image(Decimal_Data(i), TC_Picture) /=
- Edited_Output(TC_Loop_Count).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with decimal data item # " &
- Integer'Image(i) &
- " and picture string # " &
- Integer'Image(j));
- end if;
-
- else
- Report.Failed("Picture String # " & Integer'Image(j) &
- "reported as being invalid");
- end if;
-
- end loop;
- end loop Evaluate_Edited_Output;
-
- exception
- when Editing.Picture_Error =>
- Report.Failed ("Picture_Error raised in Test_Block");
- when Layout_Error =>
- Report.Failed ("Layout_Error raised in Test_Block");
- when others =>
- Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a
deleted file mode 100644
index 7cfce61..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXF3003.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 statically identifiable picture strings can be used to
--- produce correctly formatted edited output.
---
--- TEST DESCRIPTION:
--- This test defines several picture strings that are statically
--- identifiable, (i.e., Pic : Picture := To_Picture("..."); ).
--- These picture strings are used in conjunction with decimal data
--- as parameters in calls to functions Valid and Image. These
--- functions are created by an instantiation of the generic package
--- Ada.Text_IO.Editing.Decimal_Output.
---
---
--- CHANGE HISTORY:
--- 04 Apr 96 SAIC Initial release for 2.1.
--- 13 Feb 97 PWB.CTA corrected incorrect picture strings.
---!
-
-with Report;
-with Ada.Text_IO.Editing;
-with Ada.Exceptions;
-
-procedure CXF3003 is
-begin
-
- Report.Test ("CXF3003", "Check that statically identifiable " &
- "picture strings can be used to produce " &
- "correctly formatted edited output");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Text_IO.Editing;
-
- Def_Cur : constant String := "$";
- Def_Fill : constant Character := '*';
- Def_Sep : constant Character := Default_Separator;
- Def_Radix : constant Character :=
- Ada.Text_IO.Editing.Default_Radix_Mark;
-
- type Str_Ptr is access String;
- type Edited_Output_Array_Type is array (Integer range <>) of Str_Ptr;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Image_IO is
- new Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => Def_Cur,
- Default_Fill => '*',
- Default_Separator => Default_Separator,
- Default_Radix_Mark => Def_Radix);
-
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- Decimal_Data : Decimal_Data_Array_Type(1..5) :=
- (1 => 1357.99,
- 2 => -9029.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45);
-
- -- Statically identifiable picture strings.
-
- Picture_1 : Picture := To_Picture("-$$_$$9.99");
- Picture_2 : Picture := To_Picture("-$$_$$$.$$");
- Picture_3 : Picture := To_Picture("-ZZZZ.ZZ");
- Picture_5 : Picture := To_Picture("-$$$_999.99");
- Picture_6 : Picture := To_Picture("-###**_***_**9.99");
- Picture_7 : Picture := To_Picture("-$**_***_**9.99");
- Picture_8 : Picture := To_Picture("-$$$$$$.$$");
- Picture_9 : Picture := To_Picture("-$$$$$$.$$");
- Picture_10 : Picture := To_Picture("+BBBZZ_ZZZ_ZZZ.ZZ");
- Picture_11 : Picture := To_Picture("--_---_---_--9");
- Picture_12 : Picture := To_Picture("-$_$$$_$$$_$$9.99");
- Picture_14 : Picture := To_Picture("$_$$9.99");
- Picture_15 : Picture := To_Picture("$$9.99");
-
-
- Picture_1_Output : Edited_Output_Array_Type(1..5) :=
- ( 1 => new String'(" $1,357.99"),
- 2 => new String'("-$9,029.01"),
- 3 => new String'(" $0.00"),
- 4 => new String'(" $0.20"),
- 5 => new String'(" $3.45"));
-
- Picture_2_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" $1,357.99"),
- 2 => new String'("-$9,029.01"),
- 3 => new String'(" "),
- 4 => new String'(" $.20"),
- 5 => new String'(" $3.45"));
-
- Picture_3_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" 1357.99"),
- 2 => new String'("-9029.01"),
- 3 => new String'(" "),
- 4 => new String'(" .20"),
- 5 => new String'(" 3.45"));
-
- Picture_5_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" $1,357.99"),
- 2 => new String'("- $9,029.01"),
- 3 => new String'(" $ 000.00"),
- 4 => new String'(" $ 000.20"),
- 5 => new String'(" $ 003.45"));
-
- begin
-
- -- Check the results of function Valid, using the first five decimal
- -- data items and picture strings.
-
- if not Image_IO.Valid(Decimal_Data(1), Picture_1) then
- Report.Failed("Picture string 1 not valid");
- elsif not Image_IO.Valid(Decimal_Data(2), Picture_2) then
- Report.Failed("Picture string 2 not valid");
- elsif not Image_IO.Valid(Decimal_Data(3), Picture_3) then
- Report.Failed("Picture string 3 not valid");
- elsif not Image_IO.Valid(Decimal_Data(5), Picture_5) then
- Report.Failed("Picture string 5 not valid");
- end if;
-
-
- -- Check the results of function Image, using the picture strings
- -- constructed above, with a variety of named vs. positional
- -- parameter notation and defaulted parameters.
-
- for i in 1..5 loop
- if Image_IO.Image(Item => Decimal_Data(i), Pic => Picture_1) /=
- Picture_1_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_1 picture string." &
- "Expected: " & Picture_1_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_1));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Pic => Picture_2) /=
- Picture_2_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_2 picture string." &
- "Expected: " & Picture_2_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_2));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Picture_3) /=
- Picture_3_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_3 picture string." &
- "Expected: " & Picture_3_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_3));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Picture_5) /=
- Picture_5_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_5 picture string." &
- "Expected: " & Picture_5_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_5));
- end if;
- end loop;
-
-
- if Image_IO.Image(Item => 123456.78,
- Pic => Picture_6,
- Currency => "$",
- Fill => Def_Fill,
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " $***123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_6");
- end if;
-
- if Image_IO.Image(123456.78,
- Pic => Picture_7,
- Currency => Def_Cur,
- Fill => '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " $***123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_7");
- end if;
-
- if Image_IO.Image(0.0,
- Picture_8,
- Currency => "$",
- Fill => '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " "
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_8");
- end if;
-
- if Image_IO.Image(0.20,
- Picture_9,
- Def_Cur,
- Fill => Def_Fill,
- Separator => Default_Separator,
- Radix_Mark => Default_Radix_Mark) /= " $.20"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_9");
- end if;
-
- if Image_IO.Image(123456.00,
- Picture_10,
- "$",
- '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= "+ 123,456.00"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_10");
- end if;
-
- if Image_IO.Image(-123456.78,
- Picture_11,
- Default_Currency,
- Default_Fill,
- Default_Separator,
- Radix_Mark => Def_Radix) /= " -123,457"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_11");
- end if;
-
- if Image_IO.Image(123456.78, Picture_12, "$", '*', ',', '.') /=
- " $123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_12");
- end if;
-
- if Image_IO.Image(1.23,
- Picture_14,
- Currency => Def_Cur,
- Fill => Def_Fill) /= " $1.23"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_14");
- end if;
-
- if Image_IO.Image(12.34, Pic => Picture_15) /= "$12.34"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_15");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXF3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a
deleted file mode 100644
index 146047b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CXF3004.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 statically identifiable picture strings can be used
--- in conjunction with function Image to produce output strings
--- appropriate to foreign currency representations.
---
--- Check that statically identifiable picture strings will cause
--- function Image to raise Layout_Error under the appropriate
--- conditions.
---
--- TEST DESCRIPTION:
--- This test defines several picture strings that are statically
--- identifiable, (i.e., Pic : Picture := To_Picture("..."); ).
--- These picture strings are used in conjunction with decimal data
--- as parameters in calls to function Image.
---
---
--- CHANGE HISTORY:
--- 11 Apr 96 SAIC Initial release for 2.1.
---
---!
-
-with Report;
-with Ada.Text_IO.Editing;
-with Ada.Exceptions;
-
-procedure CXF3004 is
-begin
-
- Report.Test ("CXF3004", "Check that statically identifiable " &
- "picture strings will cause function Image " &
- "to raise Layout_Error under appropriate " &
- "conditions");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Text_IO.Editing;
-
- FF_Currency : constant String := "FF";
- DM_Currency : constant String := "DM";
- FF_Separator : constant Character := '.';
- DM_Separator : constant Character := ',';
- FF_Radix : constant Character := ',';
- DM_Radix : constant Character := '.';
- Blank_Fill : constant Character := ' ';
- Star_Fill : constant Character := '*';
-
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Image_IO is
- new Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => "$",
- Default_Fill => Star_Fill,
- Default_Separator => Default_Separator,
- Default_Radix_Mark => DM_Radix);
-
-
-
- -- The following decimal data items are used with picture strings
- -- in evaluating use of foreign currency symbols.
-
- Dec_Data_1 : Decimal_Data_Type := 123456.78;
- Dec_Data_2 : Decimal_Data_Type := 32.10;
- Dec_Data_3 : Decimal_Data_Type := -1234.57;
- Dec_Data_4 : Decimal_Data_Type := 123456.78;
- Dec_Data_5 : Decimal_Data_Type := 12.34;
- Dec_Data_6 : Decimal_Data_Type := 12.34;
- Dec_Data_7 : Decimal_Data_Type := 12345.67;
-
-
- -- Statically identifiable picture strings.
- -- These strings are used in conjunction with non-default values
- -- for Currency string, Radix mark, and Separator in calls to
- -- function Image.
-
- Picture_1 : Picture := To_Picture("-###**_***_**9.99"); -- FF
- Picture_2 : Picture := To_Picture("###z_ZZ9.99"); -- FF
- Picture_3 : Picture := To_Picture("<<<<_<<<.<<###>"); -- DM
- Picture_4 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); -- DM
- Picture_5 : Picture := To_Picture("$Zz9.99"); -- DM
- Picture_6 : Picture := To_Picture("$$$9.99"); -- DM
- Picture_7 : Picture := To_Picture("###_###_##9.99"); -- CHF
-
-
- -- The following ten edited output strings correspond to the ten
- -- foreign currency picture strings.
-
- Output_1 : constant String := " FF***123.456,78";
- Output_2 : constant String := " FF 32,10";
- Output_3 : constant String := " (1,234.57DM )";
- Output_4 : constant String := " DM123,456.78";
- Output_5 : constant String := "DM 12.34";
- Output_6 : constant String := " DM12.34";
- Output_7 : constant String := " CHF12,345.67";
-
-
- begin
-
- -- Check the results of function Image, using the picture strings
- -- constructed above, in creating foreign currency edited output
- -- strings.
-
- if Image_IO.Image(Item => Dec_Data_1,
- Pic => Picture_1,
- Currency => FF_Currency,
- Fill => Star_Fill,
- Separator => FF_Separator,
- Radix_Mark => FF_Radix) /= Output_1
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_1");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_2,
- Pic => Picture_2,
- Currency => FF_Currency,
- Fill => Blank_Fill,
- Separator => FF_Separator,
- Radix_Mark => FF_Radix) /= Output_2
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_2");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_3,
- Pic => Picture_3,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_3
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_3");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_4,
- Pic => Picture_4,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_4
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_4");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_5,
- Pic => Picture_5,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_5
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_5");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_6,
- Pic => Picture_6,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_6
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_6");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_7,
- Pic => Picture_7,
- Currency => "CHF",
- Fill => Blank_Fill,
- Separator => ',',
- Radix_Mark => '.') /= Output_7
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_7");
- end if;
-
-
- -- The following calls of Function Image, using the specific
- -- decimal values and picture strings provided, will cause
- -- a Layout_Error to be raised.
- -- Note: The data and the picture strings used in the following
- -- evaluations are not themselves erroneous, but when used in
- -- combination will cause Layout_Error to be raised.
-
- Exception_Block_1 :
- declare
- Erroneous_Data_1 : Decimal_Data_Type := 12.34;
- Erroneous_Picture_1 : Picture := To_Picture("9.99");
- N : constant Natural := Image_IO.Length(Erroneous_Picture_1);
- TC_String : String(1..N);
- begin
- TC_String := Image_IO.Image(Erroneous_Data_1, Erroneous_Picture_1);
- Report.Failed("Layout_Error not raised by combination of " &
- "Erroneous_Picture_1 and Erroneous_Data_1");
- Report.Comment("Should never be printed: " & TC_String);
- exception
- when Ada.Text_IO.Layout_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed
- ("The following exception was incorrectly raised in " &
- "Exception_Block_1: " & Exception_Name(The_Error));
- end Exception_Block_1;
-
- Exception_Block_2 :
- declare
- Erroneous_Data_2 : Decimal_Data_Type := -12.34;
- Erroneous_Picture_2 : Picture := To_Picture("99.99");
- N : constant Natural := Image_IO.Length(Erroneous_Picture_2);
- TC_String : String(1..N);
- begin
- TC_String := Image_IO.Image(Erroneous_Data_2, Erroneous_Picture_2);
- Report.Failed("Layout_Error not raised by combination of " &
- "Erroneous_Picture_2 and Erroneous_Data_2");
- Report.Comment("Should never be printed: " & TC_String);
- exception
- when Ada.Text_IO.Layout_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed
- ("The following exception was incorrectly raised in " &
- "Exception_Block_2: " & Exception_Name(The_Error));
- end Exception_Block_2;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXF3004;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a
deleted file mode 100644
index 202a699..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXF3A01.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 function Ada.Text_IO.Editing.Valid returns False if
--- a) Pic_String is not a well-formed Picture string, or
--- b) the length of Pic_String exceeds Max_Picture_Length, or
--- c) Blank_When_Zero is True and Pic_String contains '*';
--- Check that Valid otherwise returns True.
---
--- TEST DESCRIPTION:
--- This test validates the results of function Editing.Valid under a
--- variety of conditions. Both valid and invalid picture strings are
--- provided as input parameters to the function. The use of the
--- Blank_When_Zero parameter is evaluated with strings that contain the
--- zero suppression character '*'.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A01 is
-begin
-
- Report.Test ("CXF3A01", "Check that the Valid function from package " &
- "Ada.Text_IO.Editing returns False for strings " &
- "that fail to comply with the composition " &
- "constraints defined for picture strings. " &
- "Check that the Valid function returns True " &
- "for strings that conform to the composition " &
- "constraints defined for picture strings");
-
- Test_Block:
- declare
- use FXF3A00;
- use Ada.Text_IO;
- begin
-
- -- Use a series of picture strings that conform to the composition
- -- constraints to validate the Ada.Text_IO.Editing.Valid function.
- -- The result for each of these calls should be True.
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is used.
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
-
- if not Editing.Valid(Pic_String => FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- end loop;
-
-
- for i in 1..FXF3A00.Number_Of_Foreign_Strings loop
-
- if not Editing.Valid(Pic_String => FXF3A00.Foreign_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Foreign_String = " &
- FXF3A00.Foreign_Strings(i).all);
- end if;
-
- end loop;
-
-
- -- Use a series of picture strings that violate one or more of the
- -- composition constraints to validate the Ada.Text_IO.Editing.Valid
- -- function. The result for each of these calls should be False.
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is used.
-
- for i in 1..FXF3A00.Number_Of_Invalid_Strings loop
-
- if Editing.Valid(Pic_String => FXF3A00.Invalid_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Invalid_String = " &
- FXF3A00.Invalid_Strings(i).all);
- end if;
-
- end loop;
-
-
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is overridden with a True actual parameter value. Using
- -- valid picture strings that contain the '*' zero suppression character
- -- when this parameter value is True must result in a False result
- -- from function Valid. Valid picture strings that do not contain the
- -- '*' character should return a function result of True with True
- -- provided as the actual parameter to Blank_When_Zero.
-
- -- Check entries 1, 2, 25, 36 from the Valid_Strings array, all of
- -- which contain the '*' zero suppression character.
-
- if Editing.Valid(Valid_Strings(1).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(2).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(25).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(36).all, Blank_When_Zero => True)
- then
- Report.Failed
- ("Incorrect result from Function Valid when setting " &
- "the value of the Blank_When_Zero parameter to True, " &
- "and using picture strings with the '*' character");
- end if;
-
-
- -- Check entries from the Valid_Strings array, none of
- -- which contain the '*' zero suppression character.
-
- for i in 3..24 loop
-
- if not Editing.Valid(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => True)
- then
- Report.Failed("Incorrect result from Function Valid when " &
- "setting the value of the Blank_When_Zero " &
- "parameter to True, and using picture strings " &
- "without the '*' character, Valid_String = " &
- FXF3A00.Valid_Strings(i).all);
- end if;
-
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a
deleted file mode 100644
index 4231b56..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- CXF3A02.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 function Ada.Text_IO.Editing.To_Picture raises
--- Picture_Error if the picture string provided as input parameter does
--- not conform to the composition constraints defined for picture
--- strings.
--- Check that when Pic_String is applied to To_Picture, the result
--- is equivalent to the actual string parameter of To_Picture;
--- Check that when Blank_When_Zero is applied to To_Picture, the result
--- is the same value as the Blank_When_Zero parameter of To_Picture.
---
--- TEST DESCRIPTION:
--- This test validates that function Editing.To_Picture returns a
--- Picture result when provided a valid picture string, and raises a
--- Picture_Error exception when provided an invalid picture string
--- input parameter. In addition, the Picture result of To_Picture is
--- converted back to a picture string value using function Pic_String,
--- and the result of function Blank_When_Zero is validated based on the
--- value of parameter Blank_When_Zero used in the formation of the Picture
--- by function To_Picture.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Mar 97 PWB.CTA Corrected invalid picture string and uppercase
--- problem.
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Ada.Strings.Maps;
-with Ada.Strings.Fixed;
-with Report;
-
-procedure CXF3A02 is
-
- Lower_Alpha : constant String := "abcdefghijklmnopqrstuvwxyz";
- Upper_Alpha : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
- function UpperCase ( Source : String ) return String is
- begin
- return
- Ada.Strings.Fixed.Translate
- ( Source => Source,
- Mapping => Ada.Strings.Maps.To_Mapping
- ( From => Lower_Alpha,
- To => Upper_Alpha ) );
- end UpperCase;
-
-begin
-
- Report.Test ("CXF3A02", "Check that the function " &
- "Ada.Text_IO.Editing.To_Picture raises " &
- "Picture_Error if the picture string provided " &
- "as input parameter does not conform to the " &
- "composition constraints defined for picture " &
- "strings");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
- use FXF3A00;
-
- TC_Picture : Editing.Picture;
- TC_Blank_When_Zero : Boolean;
-
- begin
-
-
- -- Validate that function To_Picture does not raise Picture_Error when
- -- provided a valid picture string as an input parameter.
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
- begin
- TC_Picture :=
- Editing.To_Picture(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => False );
- exception
- when Editing.Picture_Error =>
- Report.Failed
- ("Picture_Error raised by function To_Picture " &
- "with a valid picture string as input parameter, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- when others =>
- Report.Failed("Unexpected exception raised - 1, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
-
- -- Validate that function To_Picture raises Picture_Error when an
- -- invalid picture string is provided as an input parameter.
- -- Default value used for parameter Blank_When_Zero.
-
- for i in 1..FXF3A00.Number_Of_Invalid_Strings loop
- begin
- TC_Picture :=
- Editing.To_Picture(Pic_String => FXF3A00.Invalid_Strings(i).all);
- Report.Failed
- ("Picture_Error not raised by function To_Picture " &
- "with an invalid picture string as input parameter, " &
- "Invalid_String = " & FXF3A00.Invalid_Strings(i).all);
- exception
- when Editing.Picture_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised, " &
- "Invalid_String = " &
- FXF3A00.Invalid_Strings(i).all);
- end;
- end loop;
-
-
-
- -- Validate that To_Picture and Pic_String/Blank_When_Zero provide
- -- "inverse" results.
-
- -- Use the default value of the Blank_When_Zero parameter (False) for
- -- these evaluations (some valid strings have the '*' zero suppression
- -- character, which would result in an invalid string if used with a
- -- True value for the Blank_When_Zero parameter).
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
- begin
-
- -- Format a picture string using function To_Picture.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Reconvert the Picture result from To_Picture to a string value
- -- using function Pic_String, and compare to the original string.
-
- if Editing.Pic_String(Pic => TC_Picture) /=
- Uppercase (FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed
- ("Inverse result incorrect from Editing.Pic_String, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- -- Ensure that function Blank_When_Zero returns the correct value
- -- of the Blank_When_Zero parameter used in forming the Picture
- -- (default parameter value False used in call to To_Picture
- -- above).
-
- if Editing.Blank_When_Zero(Pic => TC_Picture) then
- Report.Failed
- ("Inverse result incorrect from Editing.Blank_When_Zero, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised - 2, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
- -- Specifically check that any lower case letters in the original
- -- picture string have been converted to upper case form following
- -- the To_Picture/Pic_String conversion (as shown in previous loop).
-
- declare
- The_Picture : Editing.Picture;
- The_Picture_String : constant String := "+bBbZz_zZz_Zz9.99";
- The_Expected_Result : constant String := "+BBBZZ_ZZZ_ZZ9.99";
- begin
- -- Convert Picture String to Picture.
- The_Picture := Editing.To_Picture(Pic_String => The_Picture_String);
-
- declare
- -- Reconvert the Picture to a Picture String.
- The_Result : constant String := Editing.Pic_String(The_Picture);
- begin
- if The_Result /= The_Expected_Result then
- Report.Failed("Conversion to Picture/Reconversion to String " &
- "did not produce expected result when Picture " &
- "String had lower case letters");
- end if;
- end;
- end;
-
-
- -- Use a value of True for the Blank_When_Zero parameter for the
- -- following evaluations (picture strings that do not have the '*' zero
- -- suppression character, which would result in an invalid string when
- -- used here with a True value for the Blank_When_Zero parameter).
-
- for i in 3..24 loop
- begin
-
- -- Format a picture string using function To_Picture.
-
- TC_Picture :=
- Editing.To_Picture(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => True);
-
- -- Reconvert the Picture result from To_Picture to a string value
- -- using function Pic_String, and compare to the original string.
-
- if Editing.Pic_String(Pic => TC_Picture) /=
- UpperCase (FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed
- ("Inverse result incorrect from Editing.Pic_String, used " &
- "on Picture formed with parameter Blank_When_Zero = True, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- -- Ensure that function Blank_When_Zero returns the correct value
- -- of the Blank_When_Zero parameter used in forming the Picture
- -- (default parameter value False overridden in call to
- -- To_Picture above).
-
- if not Editing.Blank_When_Zero(Pic => TC_Picture) then
- Report.Failed
- ("Inverse result incorrect from Editing.Blank_When_Zero, " &
- "used on a Picture formed with parameter Blank_When_Zero " &
- "= True, Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised - 3, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a
deleted file mode 100644
index 8670960..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a
+++ /dev/null
@@ -1,429 +0,0 @@
--- CXF3A03.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 function Length in the generic package Decimal_Output
--- returns the number of characters in the edited output string
--- produced by function Image, for a particular decimal type,
--- currency string, and radix mark.
--- Check that function Valid in the generic package Decimal_Output
--- returns correct results based on the particular decimal value,
--- and the Picture and Currency string parameters.
---
--- TEST DESCRIPTION:
--- This test uses two instantiations of package Decimal_Output, one
--- for decimal data with delta 0.01, the other for decimal data with
--- delta 1.0. The functions Length and Valid found in this generic
--- package are evaluated for each instantiation.
--- Function Length is examined with picture and currency string input
--- parameters of different sizes.
--- Function Valid is examined with a decimal type data item, picture
--- object, and currency string, for cases that are both valid and
--- invalid (Layout_Error would result from the particular items as
--- input parameters to function Image).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A03 is
-begin
-
- Report.Test ("CXF3A03", "Check that function Length returns the " &
- "number of characters in the edited output " &
- "string produced by function Image, for a " &
- "particular decimal type, currency string, " &
- "and radix mark. Check that function Valid " &
- "returns correct results based on the " &
- "particular decimal value, and the Picture " &
- "and Currency string parameters");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
- use FXF3A00;
-
- type Instantiation_Type is (NDP, TwoDP);
-
- -- Defaults used for all other generic parameters in these
- -- instantiations.
- package Pack_NDP is new Editing.Decimal_Output (Decimal_Type_NDP);
- package Pack_2DP is new Editing.Decimal_Output (Decimal_Type_2DP);
-
- TC_Lower_Bound,
- TC_Higher_Bound : Integer := 0;
-
- TC_Picture : Editing.Picture;
- TC_US_String : constant String := "$";
- TC_FF_String : constant String := "FF";
- TC_DM_String : constant String := "DM";
- TC_CHF_String : constant String := "CHF";
-
-
- function Dollar_Sign_Present (Str : String) return Boolean is
- begin
- for i in 1..Str'Length loop
- if Str(i) = '$' then
- return True;
- end if;
- end loop;
- return False;
- end Dollar_Sign_Present;
-
- function V_Present (Str : String) return Boolean is
- begin
- for i in 1..Str'Length loop
- if Str(i) = 'V' or Str(i) = 'v' then
- return True;
- end if;
- end loop;
- return False;
- end V_Present;
-
-
- function Accurate_Length (Pict_Str : String;
- Inst : Instantiation_Type;
- Currency_String : String)
- return Boolean is
-
- TC_Length : Natural := 0;
- TC_Currency_Length_Adjustment : Natural := 0;
- TC_Radix_Adjustment : Natural := 0;
- begin
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Pict_Str);
-
- -- Calculate the currency length adjustment.
- if Dollar_Sign_Present (Editing.Pic_String(TC_Picture)) then
- TC_Currency_Length_Adjustment := Currency_String'Length - 1;
- end if;
-
- -- Calculate the Radix adjustment.
- if V_Present (Editing.Pic_String(TC_Picture)) then
- TC_Radix_Adjustment := 1;
- end if;
-
- -- Calculate the length, using the version of Length that comes
- -- from the appropriate instantiation of Decimal_Output, based
- -- on the decimal type used in the instantiation.
- if Inst = NDP then
- TC_Length := Pack_NDP.Length(TC_Picture,
- Currency_String);
- else
- TC_Length := Pack_2DP.Length(TC_Picture,
- Currency_String);
- end if;
-
- return TC_Length = Editing.Pic_String(TC_Picture)'Length +
- TC_Currency_Length_Adjustment -
- TC_Radix_Adjustment;
- end Accurate_Length;
-
-
- begin
-
- Length_Block:
- begin
-
- -- The first 10 picture strings in the Valid_Strings array correspond
- -- to data values of a decimal type with delta 0.01.
- -- Note: The appropriate instantiation of the Decimal_Output package
- -- (and therefore function Length) is used by function
- -- Accurate_Length to calculate length.
-
- for i in 1..10 loop
- if not Accurate_Length (FXF3A00.Valid_Strings(i).all,
- TwoDP,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 17-20 in the Valid_Strings array correspond
- -- to data values of a decimal type with delta 1.0. Again, the
- -- instantiation of Decimal_Output used is based on this particular
- -- decimal type.
-
- for i in 17..20 loop
- if not Accurate_Length (FXF3A00.Valid_Strings(i).all,
- NDP,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta 1.0 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- The first 4 picture strings in the Foreign_Strings array
- -- correspond to data values of a decimal type with delta 0.01,
- -- and to the currency string "FF" (two characters).
-
- for i in 1..FXF3A00.Number_of_FF_Strings loop
- if not Accurate_Length (FXF3A00.Foreign_Strings(i).all,
- TwoDP,
- TC_FF_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_FF_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 5-9 in the Foreign_Strings array correspond
- -- to data values of a decimal type with delta 0.01, and to the
- -- currency string "DM" (two characters).
-
- TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1;
- TC_Higher_Bound := FXF3A00.Number_of_FF_Strings +
- FXF3A00.Number_of_DM_Strings;
-
- for i in TC_Lower_Bound..TC_Higher_Bound loop
- if not Accurate_Length (FXF3A00.Foreign_Strings(i).all,
- TwoDP,
- TC_DM_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_DM_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture string #10 in the Foreign_Strings array corresponds
- -- to a data value of a decimal type with delta 0.01, and to the
- -- currency string "CHF" (three characters).
-
- if not Accurate_Length (FXF3A00.Foreign_Strings(10).all,
- TwoDP,
- TC_CHF_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " &
- TC_CHF_String);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Length_Block");
- end Length_Block;
-
-
- Valid_Block:
- declare
-
- -- This offset value is used to align picture string and decimal
- -- data values from package FXF3A00 for proper correspondence for
- -- the evaluations below.
-
- TC_Offset : constant Natural := 10;
-
- begin
-
- -- The following four For Loops examine cases where the
- -- decimal data/picture string/currency combinations used will
- -- generate valid Edited Output strings. These combinations, when
- -- provided to the Function Valid (from instantiations of
- -- Decimal_Output), should result in a return result of True.
- -- The particular instantiated version of Valid used in these loops
- -- is that for decimal data with delta 0.01.
-
- -- The first 4 picture strings in the Foreign_Strings array
- -- correspond to data values of a decimal type with delta 0.01,
- -- and to the currency string "FF" (two characters).
-
- for i in 1..FXF3A00.Number_of_FF_Strings loop
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i),
- TC_Picture,
- TC_FF_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_FF_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 5-9 in the Foreign_Strings array correspond
- -- to data values of a decimal type with delta 0.01, and to the
- -- currency string "DM" (two characters).
-
- TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1;
- TC_Higher_Bound := FXF3A00.Number_of_FF_Strings +
- FXF3A00.Number_of_DM_Strings;
-
- for i in TC_Lower_Bound..TC_Higher_Bound loop
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i),
- TC_Picture,
- TC_DM_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_DM_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture string #10 in the Foreign_Strings array corresponds
- -- to a data value of a decimal type with delta 0.01, and to the
- -- currency string "CHF" (three characters).
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(10).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + 10),
- TC_Picture,
- TC_CHF_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " &
- TC_CHF_String);
- end if;
-
-
- -- The following For Loop examines cases where the
- -- decimal data/picture string/currency combinations used will
- -- generate valid Edited Output strings.
- -- The particular instantiated version of Valid used in this loop
- -- is that for decimal data with delta 1.0; the others above have
- -- been for decimal data with delta 0.01.
- -- Note: TC_Offset is used here to align picture strings from the
- -- FXF3A00.Valid_Strings table with the appropriate decimal
- -- data in the FXF3A00.Data_With_NDP table.
-
- for i in 1..FXF3A00.Number_Of_NDP_Items loop
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(TC_Offset + i).all);
-
- if not Pack_NDP.Valid (FXF3A00.Data_With_NDP(i),
- TC_Picture,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- The following three evaluations of picture strings, used in
- -- conjunction with the specific decimal values provided, will cause
- -- Editing.Image to raise Layout_Error (to be examined in other
- -- tests). Function Valid should return a False result for these
- -- combinations.
- -- The first two evaluations use the instantiation of Decimal_Output
- -- with a decimal type with delta 0.01, while the last evaluation
- -- uses the instantiation with decimal type with delta 1.0.
-
- for i in 1..FXF3A00.Number_of_Erroneous_Conditions loop
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all);
-
- if i < 3 then -- Choose the appropriate instantiation.
- if Pack_2DP.Valid(Item => FXF3A00.Erroneous_Data(i),
- Pic => TC_Picture,
- Currency => TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta " &
- "0.01 and with the currency string " &
- TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- else
- if Pack_NDP.Valid(Item => FXF3A00.Decimal_Type_NDP(
- FXF3A00.Erroneous_Data(i)),
- Pic => TC_Picture,
- Currency => TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta " &
- "1.0 and with the currency string " &
- TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end if;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Valid_Block");
- end Valid_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A03;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a
deleted file mode 100644
index 9eee39b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXF3A04.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 edited output string value returned by Function Image
--- is correct.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The results of the Image function are examined under a number of
--- circumstances. The generic package Decimal_Output is instantiated
--- twice, for decimal data with delta 0.01 and delta 1.0. Each version
--- of Image is called with both default parameters and user-provided
--- parameters. The results of each call to Image are compared to an
--- expected edited output result string.
---
--- In addition, three calls to Image are designed to raise Layout_Error,
--- due to the combination of decimal value and picture string provided
--- as input parameters. If Layout_Error is not raised, or an alternate
--- exception is raised instead, test failure results.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A04.A
---
---
--- CHANGE HISTORY:
--- 22 JAN 95 SAIC Initial prerelease version.
--- 11 MAR 97 PWB.CTA Corrected incorrect index expression
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A04 is
-begin
-
- Report.Test ("CXF3A04", "Check that the string value returned by " &
- "Function Image is correct, based on the " &
- "numerical data and picture formatting " &
- "parameters provided to the function");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for the two data
- -- types, using the default values for the Default_Currency,
- -- Default_Fill, Default_Separator, and Default_Radix_Mark
- -- parameters.
-
- package Pack_NDP is
- new Editing.Decimal_Output (FXF3A00.Decimal_Type_NDP);
-
- package Pack_2DP is
- new Editing.Decimal_Output (FXF3A00.Decimal_Type_2DP);
-
- TC_Currency : constant String := "$";
- TC_Fill : constant Character := '*';
- TC_Separator : constant Character := ',';
- TC_Radix_Mark : constant Character := '.';
-
- TC_Picture : Editing.Picture;
-
-
- begin
-
- Two_Decimal_Place_Data:
- -- Use a decimal fixed point type with delta 0.01 (two decimal places)
- -- and valid picture strings. Evaluate the result of function Image
- -- with the expected edited output result string.
- declare
-
- TC_Loop_End : constant := -- 10
- FXF3A00.Number_Of_2DP_Items - FXF3A00.Number_Of_Foreign_Strings;
-
- begin
- -- The first 10 picture strings in the Valid_Strings array
- -- correspond to data values of a decimal type with delta 0.01.
-
- -- Compare string result of Image with expected edited output
- -- string. Evaluate data using both default parameters of Image
- -- and user-provided parameter values.
- for i in 1..TC_Loop_End loop
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Use the default parameters for this loop evaluation of Image.
- if Pack_2DP.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "0.01, picture string " &
- FXF3A00.Valid_Strings(i).all &
- ", and the default parameters of Image");
- end if;
-
- -- Use user-provided parameters for this loop evaluation of Image.
-
- if Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "0.01, picture string " &
- FXF3A00.Valid_Strings(i).all &
- ", and user-provided parameters");
- end if;
-
- end loop;
-
- exception
- when others =>
- Report.Failed("Exception raised in Two_Decimal_Place_Data block");
- end Two_Decimal_Place_Data;
-
-
-
- No_Decimal_Place_Data:
- -- Use a decimal fixed point type with delta 1.00 (no decimal places)
- -- and valid picture strings. Evaluate the result of function Image
- -- with the expected result string.
- declare
-
- use Editing, FXF3A00;
-
- TC_Offset : constant := 10;
- TC_Loop_Start : constant := TC_Offset + 1; -- 11
- TC_Loop_End : constant := TC_Loop_Start +
- Number_Of_NDP_Items - 1; -- 22
-
- begin
- -- The following evaluations correspond to data values of a
- -- decimal type with delta 1.0.
-
- -- Compare string result of Image with expected edited output
- -- string. Evaluate data using both default parameters of Image
- -- and user-provided parameter values.
- -- Note: TC_Offset is used to align corresponding data the various
- -- data tables in foundation package FXF3A00.
-
- for i in TC_Loop_Start..TC_Loop_End loop
-
- -- Create the picture object from the picture string.
- TC_Picture := To_Picture(Valid_Strings(i).all);
-
- -- Use the default parameters for this loop evaluation of Image.
- if not (Pack_NDP.Image(Data_With_NDP(i-TC_Offset), TC_Picture) =
- Edited_Output(TC_Offset+i).all)
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "1.0, picture string " &
- Valid_Strings(i).all &
- ", and the default parameters of Image");
- end if;
-
- -- Use user-provided parameters for this loop evaluation of Image.
- if Pack_NDP.Image(Item => Data_With_NDP(i - TC_Offset),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark) /=
- Edited_Output(TC_Offset+i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "1.0, picture string " &
- Valid_Strings(i).all &
- ", and user-provided parameters");
- end if;
-
- end loop;
-
- exception
- when others =>
- Report.Failed("Exception raised in No_Decimal_Place_Data block");
- end No_Decimal_Place_Data;
-
-
-
- Exception_Block:
- -- The following three calls of Function Image, using the specific
- -- decimal values and picture strings provided, will cause
- -- a Layout_Error to be raised.
- -- The first two evaluations use the instantiation of Decimal_Output
- -- with a decimal type with delta 0.01, while the last evaluation
- -- uses the instantiation with decimal type with delta 1.0.
-
- -- Note: The data and the picture strings used in the following
- -- evaluations are not themselves erroneous, but when used in
- -- combination will cause Layout_Error to be raised.
-
- begin
-
- for i in 1..FXF3A00.Number_Of_Erroneous_Conditions loop -- 1..3
- begin
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all);
-
- -- Layout_Error must be raised by the following calls to
- -- Function Image.
-
- if i < 3 then -- Choose the appropriate instantiation.
- declare
- N : constant Natural := Pack_2DP.Length(TC_Picture);
- TC_String : String(1..N);
- begin
- TC_String := Pack_2DP.Image(FXF3A00.Erroneous_Data(i),
- TC_Picture);
- end;
- else
- declare
- use FXF3A00;
- N : constant Natural := Pack_NDP.Length(TC_Picture,
- TC_Currency);
- TC_String : String(1..N);
- begin
- TC_String :=
- Pack_NDP.Image(Item => Decimal_Type_NDP(
- Erroneous_Data(i)),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark);
- end;
- end if;
-
- Report.Failed("Layout_Error not raised by combination " &
- "# " & Integer'Image(i) & " " &
- "of decimal data and picture string");
-
- exception
- when Layout_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by combination " &
- "# " & Integer'Image(i) & " " &
- "of decimal data and picture string");
- end;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Exception_Block");
- end Exception_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A04;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a
deleted file mode 100644
index 3fb3933..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a
+++ /dev/null
@@ -1,266 +0,0 @@
--- CXF3A05.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 Function Image produces correct results when provided
--- non-default parameters for Currency, Fill, Separator, and
--- Radix_Mark at either the time of package Decimal_Output instantiation,
--- or in a call to Image. Check non-default parameters that are
--- appropriate for foreign currency representations.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The results of the Image function, resulting from several different
--- instantiations of Decimal_Output, are compared with expected
--- edited output string results. The primary focus of this test is to
--- examine the effect of non-default parameters, provided during the
--- instantiation of package Decimal_Output, or provided as part of a
--- call to Function Image (that resulted from an instantiation of
--- Decimal_Output that used default parameters). The non-default
--- parameters provided correspond to foreign currency representations.
---
--- For each picture string/decimal data combination examined, two
--- evaluations of Image are performed. These correspond to the two
--- methods of providing the appropriate non-default parameters described
--- above. Both forms of Function Image should produce the same expected
--- edited output string.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A05.A
---
---
--- CHANGE HISTORY:
--- 26 JAN 95 SAIC Initial prerelease version.
--- 17 FEB 97 PWB.CTA Correct array indices for Foreign_Strings array
--- references.
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A05 is
-begin
-
- Report.Test ("CXF3A05", "Check that Function Image produces " &
- "correct results when provided non-default " &
- "parameters for Currency, Fill, Separator, " &
- "and Radix_Mark, appropriate to foreign " &
- "currency representations");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for the several
- -- combinations of Default_Currency, Default_Fill, Default_Separator,
- -- and Default_Radix_Mark.
-
- package Pack_Def is -- Uses default parameter values.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_FF is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "FF",
- Default_Fill => '*',
- Default_Separator => '.',
- Default_Radix_Mark => ',');
-
- package Pack_DM is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "DM",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- package Pack_CHF is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "CHF",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : constant := 11;
- TC_End_Loop : constant := TC_Start_Loop + -- 20
- FXF3A00.Number_Of_Foreign_Strings - 1;
-
- begin
-
- -- In the case of each particular type of foreign string examined,
- -- two versions of Function Image are examined. First, a version of
- -- the function that originated from an instantiation of Decimal_Output
- -- with non-default parameters is checked. This version of Image is
- -- called making use of default parameters in the actual function call.
- -- In addition, a version of Function Image is checked that resulted
- -- from an instantiation of Decimal_Output using default parameters,
- -- but which uses non-default parameters in the function call.
-
- for i in TC_Start_Loop..TC_End_Loop loop
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture
- (FXF3A00.Foreign_Strings(i - TC_Start_Loop + 1).all);
-
- -- Based on the ordering of the specific foreign picture strings
- -- in the FXF3A00.Foreign_Strings table, the following conditional
- -- is used to determine which type of currency is being examined
- -- as the loop executes.
-
- if i < TC_Start_Loop + FXF3A00.Number_Of_FF_Strings then -- (11-14)
- -- Process the FF picture strings.
-
- -- Check the result of Function Image from an instantiation
- -- of Decimal_Output that provided non-default actual
- -- parameters at the time of package instantiation, and uses
- -- default parameters in the call of Image.
-
- if Pack_FF.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with FF " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Check the result of Function Image that originated from
- -- an instantiation of Decimal_Output where default parameters
- -- were used at the time of package Instantiation, but where
- -- non-default parameters are provided in the call of Image.
-
- if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "FF",
- Fill => '*',
- Separator => '.',
- Radix_Mark => ',') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and FF related parameters in call to Image");
- end if;
-
-
- elsif i < TC_Start_Loop + -- (15-19)
- FXF3A00.Number_Of_FF_Strings +
- FXF3A00.Number_Of_DM_Strings then
- -- Process the DM picture strings.
-
- -- Non-default instantiation parameters, default function call
- -- parameters.
-
- if Pack_DM.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with DM " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Default instantiation parameters, non-default function call
- -- parameters.
-
- if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "DM",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and DM related parameters in call to Image");
- end if;
-
-
- else -- (i=20)
- -- Process the CHF string.
-
- -- Non-default instantiation parameters, default function call
- -- parameters.
-
- if Pack_CHF.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with CHF " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Default instantiation parameters, non-default function call
- -- parameters.
-
- if Pack_Def.Image(FXF3A00.Data_With_2DP(i),
- TC_Picture,
- "CHF",
- '*',
- ',',
- '.') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and CHF related parameters in call to Image");
- end if;
-
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A05;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a
deleted file mode 100644
index 7b769ba..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- CXF3A06.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 Ada.Text_IO.Editing.Put and Ada.Text_IO.Put have the same
--- effect.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The testing approach used in this test is that of writing edited
--- output data to a text file, using two different approaches. First,
--- Ada.Text_IO.Put is used, with a call to an instantiated version of
--- Function Image supplied as the actual for parameter Item. The
--- second approach is to use a version of Function Put from an
--- instantiation of Ada.Text_IO.Editing.Decimal_Output, with the
--- appropriate parameters for decimal data, picture, and format
--- specific parameters. A call to New_Line follows each Put, so that
--- each entry is placed on a separate line in the text file.
---
--- Edited output for decimal data with two decimal places is in the
--- first loop, and once the data has been written to the file, the
--- text file is closed, then opened in In_File mode. The edited
--- output data is read from the file, and data on successive lines
--- is compared with the expected edited output result. The edited
--- output data produced by both of the Put procedures should be
--- identical.
---
--- This process is repeated for decimal data with no decimal places.
--- The file is reopened in Append_File mode, and the edited output
--- data is added to the file in the same manner as described above.
--- The file is closed, and reopened to verify the data written.
--- The data written above (with two decimal places) is skipped, then
--- the data to be verified is extracted as above and verified against
--- the expected edited output string values.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support
--- external text files.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A06.A
---
---
--- CHANGE HISTORY:
--- 26 JAN 95 SAIC Initial prerelease version.
--- 26 FEB 97 PWB.CTA Made input buffers sufficiently long
--- and removed code depending on shorter buffers
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A06 is
- use Ada;
-begin
-
- Report.Test ("CXF3A06", "Check that Ada.Text_IO.Editing.Put and " &
- "Ada.Text_IO.Put have the same effect");
-
- Test_for_Text_IO_Support:
- declare
- Text_File : Ada.Text_IO.File_Type;
- Text_Filename : constant String := Report.Legal_File_Name(1);
- begin
-
- -- Use_Error will be raised if Text_IO operations or external files
- -- are not supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- Test_Block:
- declare
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
-
- package Pack_2DP is -- Uses decimal type with delta 0.01.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : constant := 1;
- TC_End_Loop_1 : constant := FXF3A00.Number_Of_2DP_Items - -- 20-10
- FXF3A00.Number_Of_Foreign_Strings;
- TC_End_Loop_2 : constant := FXF3A00.Number_Of_NDP_Items; -- 12
- TC_Offset : constant := FXF3A00.Number_Of_2DP_Items; -- 20
-
- TC_String_1, TC_String_2 : String(1..255) := (others => ' ');
- TC_Last_1, TC_Last_2 : Natural := 0;
-
- begin
-
- -- Use the two versions of Put, for data with two decimal points,
- -- to write edited output strings to the text file. Use a separate
- -- line for each string entry.
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Use the Text_IO version of Put to place an edited output
- -- string into a text file. Use default parameters in the call
- -- to Image for Currency, Fill, Separator, and Radix_Mark.
-
- Text_IO.Put(Text_File,
- Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture));
- Text_IO.New_Line(Text_File);
-
- -- Use the version of Put from the instantiation of
- -- Decimal_Output to place an edited output string on a separate
- -- line of the Text_File. Use default parameters for Currency,
- -- Fill, Separator, and Radix_Mark.
-
- Pack_2DP.Put(File => Text_File,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture);
- Text_IO.New_Line(Text_File);
-
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in In_File mode, and verify the edited
- -- output found on consecutive lines of the file.
-
- Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename);
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop
- -- Read successive lines in the text file.
- Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1);
- Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2);
-
- -- Compare the two strings for equality with the expected edited
- -- output result. Failure results if strings don't match, or if
- -- a reading error occurred from the attempted Get_Line resulting
- -- from an improperly formed edited output string.
-
- if TC_String_1(1..TC_Last_1) /= FXF3A00.Edited_Output(i).all or
- TC_String_2(1..TC_Last_2) /= FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Failed comparison of two edited output " &
- "strings from data with two decimal points " &
- ", loop number = " & Integer'Image(i));
- end if;
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in Append_File mode.
- -- Use the two versions of Put, for data with no decimal points,
- -- to write edited output strings to the text file. Use a separate
- -- line for each string entry.
-
- Text_IO.Open(Text_File, Text_IO.Append_File, Text_Filename);
-
- for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12
-
- -- Create the picture object from the picture string specific to
- -- data with no decimal points. Use appropriate offset into the
- -- Valid_Strings array to account for the string data used above.
-
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(i+TC_End_Loop_1).all);
-
- -- Use the Text_IO version of Put to place an edited output
- -- string into a text file. Use non-default parameters in the
- -- call to Image for Currency, Fill, Separator, and Radix_Mark.
-
- Text_IO.Put(Text_File,
- Pack_NDP.Image(Item => FXF3A00.Data_With_NDP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.'));
- Text_IO.New_Line(Text_File);
-
- -- Use the version of Put from the instantiation of
- -- Decimal_Output to place an edited output string on a separate
- -- line of the Text_File. Use non-default parameters for
- -- Currency, Fill, Separator, and Radix_Mark.
-
- Pack_NDP.Put(File => Text_File,
- Item => FXF3A00.Data_With_NDP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
- Text_IO.New_Line(Text_File);
-
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in In_File mode, and verify the edited
- -- output found on consecutive lines of the file.
-
- Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename);
-
- -- Read past data that has been verified above, skipping two lines
- -- of the data file for each loop.
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10
- Text_IO.Skip_Line(Text_File, 2);
- end loop;
-
- -- Verify the last data set that was written to the file.
-
- for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12
- Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1);
- Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2);
-
- -- Compare the two strings for equality with the expected edited
- -- output result. Failure results if strings don't match, or if
- -- a reading error occurred from the attempted Get_Line resulting
- -- from an improperly formed edited output string.
-
- if TC_String_1(1..TC_Last_1) /=
- FXF3A00.Edited_Output(i+TC_Offset).all or
- TC_String_2(1..TC_Last_2) /=
- FXF3A00.Edited_Output(i+TC_Offset).all
- then
- Report.Failed("Failed comparison of two edited output " &
- "strings from data with no decimal points " &
- ", loop number = " &
- Integer'Image(i));
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised in Create block");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXF3A06;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a
deleted file mode 100644
index 7cb2c36..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a
+++ /dev/null
@@ -1,337 +0,0 @@
--- CXF3A07.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 Ada.Text_IO.Editing.Put and Ada.Strings.Fixed.Move
--- have the same effect in putting edited output results into string
--- variables.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The operation of the two above subprograms are examined twice, first
--- with the output of an edited output string to a receiving string
--- object of equal size, the other to a receiving string object of
--- larger size, where justification and padding are considered.
--- The procedure Editing.Put will place an edited output string into
--- a larger receiving string with right justification and blank fill.
--- Procedure Move has parameter control of justification and fill, and
--- in this test will mirror Put by specifying right justification and
--- blank fill.
---
--- In the cases where the edited output string is of shorter length
--- than the receiving string object, a blank-filled constant string
--- will be catenated to the front of the expected edited output string
--- for comparison with the receiving string object, enabling direct
--- string comparison for result verification.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A07.A
---
---
--- CHANGE HISTORY:
--- 30 JAN 95 SAIC Initial prerelease version.
--- 11 MAR 97 PWB.CTA Fixed string lengths
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Ada.Strings.Fixed;
-with Report;
-
-procedure CXF3A07 is
-begin
-
- Report.Test ("CXF3A07", "Check that Ada.Text_IO.Editing.Put and " &
- "Ada.Strings.Fixed.Move have the same " &
- "effect in putting edited output results " &
- "into string variables");
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
-
- package Pack_2DP is -- Uses decimal type with delta 0.01.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : Integer := 0;
- TC_End_Loop : Integer := 0;
- TC_Offset : Integer := 0;
- TC_Length : Natural := 0;
-
- TC_Put_String_20, -- Longer than the longest edited
- TC_Move_String_20 : String(1..20); -- output string.
-
- TC_Put_String_17, -- Exact length of longest edited
- TC_Move_String_17 : String(1..17); -- output string in 2DP-US data set.
-
- TC_Put_String_8, -- Exact length of longest edited
- TC_Move_String_8 : String(1..8); -- output string in NDP-US data set.
-
-
- begin
-
- -- Examine cases where the output string is longer than the length
- -- of the edited output result. Use the instantiation of
- -- Decimal_Output specific to data with two decimal places.
-
- TC_Start_Loop := 1;
- TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all,
- Blank_When_Zero => False);
-
- -- Determine the actual length of the edited output string
- -- that is expected from Put and Image.
-
- TC_Length := Pack_2DP.Length(Pic => TC_Picture,
- Currency => "$");
-
- -- Determine the difference in length between the receiving string
- -- object and the expected length of the edited output string.
- -- Define a blank filled string constant with length equal to this
- -- length difference.
-
- declare
- TC_Length_Diff : Integer := TC_Put_String_20'Length -
- TC_Length;
- TC_Buffer_String : constant String(1..TC_Length_Diff) :=
- (others => ' ');
- begin
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
-
- Pack_2DP.Put(To => TC_Put_String_20,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
-
- Ada.Strings.Fixed.Move
- (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.'),
- Target => TC_Move_String_20,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right,
- Pad => Ada.Strings.Space);
-
- -- Each receiving string object is now filled with the edited
- -- output result, right justified.
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if TC_Buffer_String & FXF3A00.Edited_Output(i).all /=
- TC_Put_String_20 or
- TC_Buffer_String & FXF3A00.Edited_Output(i).all /=
- TC_Move_String_20
- then
- Report.Failed("Failed case where the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- end if;
-
- exception
- when Layout_Error =>
- Report.Failed("Layout_Error raised when the output string " &
- "is longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- when others =>
- Report.Failed("Exception raised when the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- end;
- end loop;
-
-
- -- Repeat the above loop, but only evaluate three cases - those where
- -- the length of the expected edited output string is the exact length
- -- of the receiving strings (no justification will be required within
- -- the string. This series of evaluations again uses decimal data
- -- with two decimal places.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- case i is
- when 1 | 5 | 7 =>
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
- -- Use default parameters in the various calls where possible.
-
- Pack_2DP.Put(To => TC_Put_String_17,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture);
-
-
- Ada.Strings.Fixed.Move
- (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture),
- Target => TC_Move_String_17);
-
- -- Each receiving string object is now filled with the edited
- -- output result. Compare these two string objects with the
- -- expected edited output value.
-
- if FXF3A00.Edited_Output(i).all /= TC_Put_String_17 or
- FXF3A00.Edited_Output(i).all /= TC_Move_String_17
- then
- Report.Failed("Failed case where the output string is " &
- "the exact length of the edited output " &
- "result, loop #" & Integer'Image(i));
- end if;
-
- when others => null;
- end case;
- end loop;
-
-
- -- Evaluate a mix of cases, where the expected edited output string
- -- length is either exactly as long or shorter than the receiving
- -- output string parameter. This series of evaluations uses decimal
- -- data with no decimal places.
-
- TC_Start_Loop := TC_End_Loop + 1; -- 11
- TC_End_Loop := TC_Start_Loop + -- 22
- FXF3A00.Number_of_NDP_Items - 1;
- TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10
- -- This offset is required due to the arrangement of data within the
- -- tables found in FXF3A00.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 11..22
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Determine the actual length of the edited output string
- -- that is expected from Put and Image.
-
- TC_Length := Pack_NDP.Length(TC_Picture);
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
-
- Pack_NDP.Put(TC_Put_String_8,
- FXF3A00.Data_With_NDP(i-TC_Offset),
- TC_Picture);
-
- Ada.Strings.Fixed.Move
- (Pack_NDP.Image(FXF3A00.Data_With_NDP(i-TC_Offset), TC_Picture),
- TC_Move_String_8,
- Ada.Strings.Error,
- Ada.Strings.Right,
- Ada.Strings.Space);
-
- -- Determine if there is a difference in length between the
- -- receiving string object and the expected length of the edited
- -- output string. If so, then define a blank filled string constant
- -- with length equal to this length difference.
-
- if TC_Length < TC_Put_String_8'Length then
- declare
- TC_Length_Diff : Integer := TC_Put_String_8'Length -
- TC_Length;
- TC_Buffer_String : constant String(1..TC_Length_Diff) :=
- (others => ' ');
- begin
-
- -- Each receiving string object is now filled with the edited
- -- output result, right justified.
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /=
- TC_Put_String_8 or
- TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /=
- TC_Move_String_8
- then
- Report.Failed("Failed case where the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i) &
- ", using data with no decimal places");
- end if;
- end;
- else
-
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Put_String_8 or
- FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Move_String_8
- then
- Report.Failed("Failed case where the output string is " &
- "the same length as the edited output " &
- "result, loop #" & Integer'Image(i) &
- ", using data with no decimal places");
- end if;
- end if;
- end loop;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A07;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a
deleted file mode 100644
index 871ab56..0000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a
+++ /dev/null
@@ -1,289 +0,0 @@
--- CXF3A08.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 version of Ada.Text_IO.Editing.Put with an out
--- String parameter propagates Layout_Error if the edited output string
--- result of Put exceeds the length of the out String parameter.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- This test examines the case of the out string parameter to Procedure
--- Put being insufficiently long to hold the entire edited output
--- string result of the procedure. In this case, Layout_Error is to be
--- raised. Test failure results if Layout_Error is not raised, or if an
--- exception other than Layout_Error is raised.
---
--- A number of data combinations are examined, using instantiations
--- of Package Decimal_Output with different decimal data types and
--- both default and non-default parameters as generic actual parameters.
--- In addition, calls to Procedure Put are performed using default
--- parameters, non-default parameters, and non-default parameters that
--- override the generic actual parameters provided at the time of
--- instantiation of Decimal_Output.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A08.A
---
---
--- CHANGE HISTORY:
--- 31 JAN 95 SAIC Initial prerelease version.
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A08 is
-begin
-
- Report.Test ("CXF3A08", "Check that the version of " &
- "Ada.Text_IO.Editing.Put with an out " &
- "String parameter propagates Layout_Error " &
- "if the output string exceeds the length " &
- "of the out String parameter");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
- -- Uses decimal type with delta 0.01 and
- package Pack_2DP is -- non-default generic actual parameters.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_NDP);
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : Integer := 0;
- TC_End_Loop : Integer := 0;
- TC_Offset : Integer := 0;
-
- TC_Short_String : String(1..4); -- Shorter than the shortest edited
- -- output string result.
-
- begin
-
- -- Examine cases where the out string parameter is shorter than
- -- the length of the edited output result. Use the instantiation of
- -- Decimal_Output specific to data with two decimal places.
-
- TC_Start_Loop := 1;
- TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture :=
- Editing.To_Picture(Pic_String => FXF3A00.Valid_Strings(i).all,
- Blank_When_Zero => False);
-
- -- The out parameter string provided in the call to Put is
- -- shorter than the edited output result of the procedure.
- -- This will result in a Layout_Error being raised and handled.
- -- Test failure results from no exception being raised, or from
- -- the wrong exception being raised.
-
- begin
-
- -- Use the instantiation of Decimal_Output specific to decimal
- -- data with two decimal places, as well as non-default
- -- parameters and named parameter association.
-
- Pack_2DP.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
- -- Test failure if exception not raised.
-
- Report.Failed
- ("Layout_Error not raised, decimal data with two decimal " &
- "places, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised, Layout_Error expected, " &
- "decimal data with two decimal places, loop #" &
- Integer'Image(i));
- end;
- end loop;
-
-
- -- Perform similar evaluations as above, but use the instantiation
- -- of Decimal_Output specific to decimal data with no decimal places.
-
- TC_Start_Loop := TC_End_Loop + 1; -- 11
- TC_End_Loop := TC_Start_Loop + -- 22
- FXF3A00.Number_of_NDP_Items - 1;
- TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10
- -- This offset is required due to the arrangement of data within the
- -- tables found in FXF3A00.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 11..22
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- begin
-
- -- Use the instantiation of Decimal_Output specific to decimal
- -- data with no decimal places, as well as default parameters
- -- and positional parameter association.
-
- Pack_NDP.Put(TC_Short_String,
- FXF3A00.Data_With_NDP(i-TC_Offset),
- TC_Picture);
-
- -- Test failure if exception not raised.
-
- Report.Failed
- ("Layout_Error not raised, decimal data with no decimal " &
- "places, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised, Layout_Error expected, " &
- "decimal data with no decimal places, loop #" &
- Integer'Image(i));
- end;
-
- end loop;
-
-
- -- Check that Layout_Error is raised by Put resulting from an
- -- instantiation of Decimal_Output specific to foreign currency
- -- representations.
- -- Note: Both of the following evaluation sets use decimal data with
- -- two decimal places.
-
- declare
-
- package Pack_FF is
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP,
- Default_Currency => "FF",
- Default_Fill => '*',
- Default_Separator => '.',
- Default_Radix_Mark => ',');
-
- begin
-
- TC_Offset := FXF3A00.Number_Of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in 1..FXF3A00.Number_Of_FF_Strings loop -- 1..4
- begin
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- Pack_FF.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i+TC_Offset),
- Pic => TC_Picture);
-
- Report.Failed("Layout_Error was not raised by Put from " &
- "an instantiation of Decimal_Output using " &
- "non-default parameters specific to FF " &
- "currency, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Put from " &
- "an instantiation of Decimal_Output using " &
- "non-default parameters specific to FF " &
- "currency, loop #" & Integer'Image(i));
- end;
- end loop;
-
-
- -- These evaluations use a version of Put resulting from a
- -- non-default instantiation of Decimal_Output, but which has
- -- specific foreign currency parameters provided in the call that
- -- override the generic actual parameters provided at instantiation.
-
- TC_Offset := TC_Offset + FXF3A00.Number_Of_FF_Strings; -- 14
-
- for i in 1..FXF3A00.Number_Of_DM_Strings loop -- 1..5
- begin
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Foreign_Strings
- (i+FXF3A00.Number_Of_FF_Strings).all);
-
- Pack_2DP.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i+TC_Offset),
- Pic => TC_Picture,
- Currency => "DM",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
- Report.Failed("Layout_Error was not raised by Put using " &
- "non-default parameters specific to DM " &
- "currency, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Put using " &
- "non-default parameters specific to DM " &
- "currency, loop #" & Integer'Image(i));
- end;
- end loop;
-
- end;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A08;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a
deleted file mode 100644
index 01a0f06..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a
+++ /dev/null
@@ -1,276 +0,0 @@
--- CXG1001.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 subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Types provide correct results.
--- Specifically, check the functions Re, Im (both versions), procedures
--- Set_Re, Set_Im (both versions), functions Compose_From_Cartesian (all
--- versions), Compose_From_Polar, Modulus, Argument, and "abs".
---
--- TEST DESCRIPTION:
--- The generic package Generic_Complex_Types
--- is instantiated with a real type (new Float), and the results
--- produced by the specified subprograms are verified.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- Modified subtest for Compose_From_Polar.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1001 is
-
-begin
-
- Report.Test ("CXG1001", "Check that the subprograms defined in " &
- "the package Ada.Numerics.Generic_Complex_Types " &
- "provide correct results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- use type Complex_Pack.Complex;
-
- -- Declare a zero valued complex number.
- Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
-
- TC_Complex : Complex_Pack.Complex := Complex_Zero;
- TC_Imaginary : Complex_Pack.Imaginary;
-
- begin
-
- -- Check that the procedures Set_Re and Set_Im (both versions) provide
- -- correct results.
-
- declare
- TC_Complex_Real_Field : Complex_Pack.Complex := (5.0, 0.0);
- TC_Complex_Both_Fields : Complex_Pack.Complex := (5.0, 7.0);
- begin
-
- Complex_Pack.Set_Re(X => TC_Complex, Re => 5.0);
-
- if TC_Complex /= TC_Complex_Real_Field then
- Report.Failed("Incorrect results from Procedure Set_Re");
- end if;
-
- Complex_Pack.Set_Im(X => TC_Complex, Im => 7.0);
-
- if TC_Complex.Re /= 5.0 or
- TC_Complex.Im /= 7.0 or
- TC_Complex /= TC_Complex_Both_Fields
- then
- Report.Failed("Incorrect results from Procedure Set_Im " &
- "with Complex argument");
- end if;
-
- Complex_Pack.Set_Im(X => TC_Imaginary, Im => 3.0);
-
-
- if Complex_Pack.Im(TC_Imaginary) /= 3.0 then
- Report.Failed("Incorrect results returned following the use " &
- "of Procedure Set_Im with Imaginary argument");
- end if;
-
- end;
-
-
- -- Check that the functions Re and Im (both versions) provide
- -- correct results.
-
- declare
- TC_Complex_1 : Complex_Pack.Complex := (1.0, 0.0);
- TC_Complex_2 : Complex_Pack.Complex := (0.0, 2.0);
- TC_Complex_3 : Complex_Pack.Complex := (4.0, 3.0);
- begin
-
- -- Function Re.
-
- if Complex_Pack.Re(X => TC_Complex_1) /= 1.0 or
- Complex_Pack.Re(X => TC_Complex_2) /= 0.0 or
- Complex_Pack.Re(X => TC_Complex_3) /= 4.0
- then
- Report.Failed("Incorrect results from Function Re");
- end if;
-
- -- Function Im; version with Complex argument.
-
- if Complex_Pack.Im(X => TC_Complex_1) /= 0.0 or
- Complex_Pack.Im(X => TC_Complex_2) /= 2.0 or
- Complex_Pack.Im(X => TC_Complex_3) /= 3.0
- then
- Report.Failed("Incorrect results from Function Im " &
- "with Complex argument");
- end if;
-
-
- -- Function Im; version with Imaginary argument.
-
- if Complex_Pack.Im(Complex_Pack.i) /= 1.0 or
- Complex_Pack.Im(Complex_Pack.j) /= 1.0
- then
- Report.Failed("Incorrect results from use of Function Im " &
- "when used with an Imaginary argument");
- end if;
-
- end;
-
-
- -- Verify the results of the three versions of Function
- -- Compose_From_Cartesian
-
- declare
-
- Zero : constant Real_Type := 0.0;
- Six : constant Real_Type := 6.0;
-
- TC_Complex_1 : Complex_Pack.Complex := (3.0, 8.0);
- TC_Complex_2 : Complex_Pack.Complex := (Six, Zero);
- TC_Complex_3 : Complex_Pack.Complex := (Zero, 1.0);
-
- begin
-
- TC_Complex := Complex_Pack.Compose_From_Cartesian(3.0, 8.0);
-
- if TC_Complex /= TC_Complex_1 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 1");
- end if;
-
- -- If only one component is given, the other component is
- -- implicitly zero (Both components are set by the following two
- -- function calls).
-
- TC_Complex := Complex_Pack.Compose_From_Cartesian(Re => 6.0);
-
- if TC_Complex /= TC_Complex_2 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 2");
- end if;
-
- TC_Complex :=
- Complex_Pack.Compose_From_Cartesian(Im => Complex_Pack.i);
-
- if TC_Complex /= TC_Complex_3 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 3");
- end if;
-
- end;
-
-
- -- Verify the results of Function Compose_From_Polar, Modulus, "abs",
- -- and Argument.
-
- declare
-
- use Complex_Pack;
-
- TC_Modulus,
- TC_Argument : Real_Type := 0.0;
-
-
- Angle_0 : constant Real_Type := 0.0;
- Angle_90 : constant Real_Type := 90.0;
- Angle_180 : constant Real_Type := 180.0;
- Angle_270 : constant Real_Type := 270.0;
- Angle_360 : constant Real_Type := 360.0;
-
- begin
-
- -- Verify the result of Function Compose_From_Polar.
- -- When the value of the parameter Modulus is zero, the
- -- Compose_From_Polar function yields a result of zero.
-
- if Compose_From_Polar(0.0, 30.0, 360.0) /= Complex_Zero
- then
- Report.Failed("Incorrect result from Function " &
- "Compose_From_Polar - 1");
- end if;
-
- -- When the value of the parameter Argument is equal to a multiple
- -- of the quarter cycle, the result of the Compose_From_Polar
- -- function with specified cycle lies on one of the axes.
-
- if Compose_From_Polar( 5.0, Angle_0, Angle_360) /= (5.0, 0.0) or
- Compose_From_Polar( 5.0, Angle_90, Angle_360) /= (0.0, 5.0) or
- Compose_From_Polar(-5.0, Angle_180, Angle_360) /= (5.0, 0.0) or
- Compose_From_Polar(-5.0, Angle_270, Angle_360) /= (0.0, 5.0) or
- Compose_From_Polar(-5.0, Angle_90, Angle_360) /= (0.0, -5.0) or
- Compose_From_Polar( 5.0, Angle_270, Angle_360) /= (0.0, -5.0)
- then
- Report.Failed("Incorrect result from Function " &
- "Compose_From_Polar - 2");
- end if;
-
- -- When the parameter to Function Argument represents a point on
- -- the non-negative real axis, the function yields a zero result.
-
- if Argument(Complex_Zero, Angle_360) /= 0.0 then
- Report.Failed("Incorrect result from Function Argument");
- end if;
-
- -- Function Modulus
-
- if Modulus(Complex_Zero) /= 0.0 or
- Modulus(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
- Modulus(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
- then
- Report.Failed("Incorrect results from Function Modulus");
- end if;
-
- -- Function "abs", a rename of Function Modulus.
-
- if "abs"(Complex_Zero) /= 0.0 or
- "abs"(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
- "abs"(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
- then
- Report.Failed("Incorrect results from Function abs");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1001;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a
deleted file mode 100644
index 39f5f00..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a
+++ /dev/null
@@ -1,198 +0,0 @@
--- CXG1002.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 subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Types provide the prescribed results.
--- Specifically, check the various versions of functions "+" and "-".
---
--- TEST DESCRIPTION:
--- This test checks that the subprograms "+" and "-" defined in the
--- Generic_Complex_Types package provide the results prescribed for the
--- evaluation of these complex arithmetic operations. The functions
--- Re and Im are used to extract the appropriate component of the
--- complex result, in order that the prescribed result component can be
--- verified.
--- The generic package is instantiated with a real type (new Float),
--- and the results produced by the specified subprograms are verified.
---
--- SPECIAL REQUIREMENTS:
--- This test can be run in either "relaxed" or "strict" mode.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1002 is
-
-begin
-
- Report.Test ("CXG1002", "Check that the subprograms defined in " &
- "the package Ada.Numerics.Generic_Complex_Types " &
- "provide the prescribed results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
- use Complex_Pack;
-
- -- Declare a zero valued complex number using the record
- -- aggregate approach.
-
- Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
-
- TC_Complex,
- TC_Complex_Right,
- TC_Complex_Left : Complex_Pack.Complex := Complex_Zero;
-
- TC_Real : Real_Type := 0.0;
-
- TC_Imaginary : Complex_Pack.Imaginary;
-
- begin
-
-
- -- Check that the imaginary component of the result of a binary addition
- -- operator that yields a result of complex type is exact when either
- -- of its operands is of pure-real type.
-
- TC_Complex := Compose_From_Cartesian(2.0, 3.0);
- TC_Real := 3.0;
-
- if Im("+"(Left => TC_Complex, Right => TC_Real)) /= 3.0 or
- Im("+"(TC_Complex, 6.0)) /= 3.0 or
- Im(TC_Complex + TC_Real) /= 3.0 or
- Im(TC_Complex + 5.0) /= 3.0 or
- Im((7.0, 2.0) + 1.0) /= 2.0 or
- Im((7.0, 5.0) + (-2.0)) /= 5.0 or
- Im((-7.0, -2.0) + 1.0) /= -2.0 or
- Im((-7.0, -3.0) + (-3.0)) /= -3.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Real argument - 1");
- end if;
-
- if Im("+"(Left => TC_Real, Right => TC_Complex)) /= 3.0 or
- Im("+"(4.0, TC_Complex)) /= 3.0 or
- Im(TC_Real + TC_Complex) /= 3.0 or
- Im(9.0 + TC_Complex) /= 3.0 or
- Im(1.0 + (7.0, -9.0)) /= -9.0 or
- Im((-2.0) + (7.0, 2.0)) /= 2.0 or
- Im(1.0 + (-7.0, -5.0)) /= -5.0 or
- Im((-3.0) + (-7.0, 16.0)) /= 16.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Real argument - 2");
- end if;
-
-
- -- Check that the imaginary component of the result of a binary
- -- subtraction operator that yields a result of complex type is exact
- -- when its right operand is of pure-real type.
-
- TC_Complex := (8.0, -4.0);
- TC_Real := 2.0;
-
- if Im("-"(Left => TC_Complex, Right => TC_Real)) /= -4.0 or
- Im("-"(TC_Complex, 5.0)) /= -4.0 or
- Im(TC_Complex - TC_Real) /= -4.0 or
- Im(TC_Complex - 4.0) /= -4.0 or
- Im((6.0, 5.0) - 1.0) /= 5.0 or
- Im((6.0, 13.0) - 7.0) /= 13.0 or
- Im((-5.0, 3.0) - (2.0)) /= 3.0 or
- Im((-5.0, -6.0) - (-3.0)) /= -6.0
- then
- Report.Failed("Incorrect results from Function ""-"" with " &
- "one Complex and one Real argument");
- end if;
-
-
- -- Check that the real component of the result of a binary addition
- -- operator that yields a result of complex type is exact when either
- -- of its operands is of pure-imaginary type.
-
- TC_Complex := (5.0, 0.0);
-
- if Re("+"(Left => TC_Complex, Right => i)) /= 5.0 or
- Re("+"(Complex_Pack.j, TC_Complex)) /= 5.0 or
- Re((-8.0, 5.0) + ( 2.0*i)) /= -8.0 or
- Re((2.0, 5.0) + (-2.0*i)) /= 2.0 or
- Re((-20.0, -5.0) + ( 3.0*i)) /= -20.0 or
- Re((6.0, -5.0) + (-3.0*i)) /= 6.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Imaginary argument");
- end if;
-
-
- -- Check that the real component of the result of a binary
- -- subtraction operator that yields a result of complex type is exact
- -- when its right operand is of pure-imaginary type.
-
- TC_Complex := TC_Complex + i; -- Should produce (5.0, 1.0)
-
- if Re("-"(TC_Complex, i)) /= 5.0 or
- Re((-4.0, 4.0) - ( 2.0*i)) /= -4.0 or
- Re((9.0, 4.0) - ( 5.0*i)) /= 9.0 or
- Re((16.0, -5.0) - ( 3.0*i)) /= 16.0 or
- Re((-3.0, -5.0) - (-4.0*i)) /= -3.0
- then
- Report.Failed("Incorrect results from Function ""-"" with " &
- "one Complex and one Imaginary argument");
- end if;
-
-
- -- Check that the result of a binary addition operation is exact when
- -- one of its operands is of real type and the other is of
- -- pure-imaginary type; the operator is analogous to the
- -- Compose_From_Cartesian function; it performs no arithmetic.
-
- TC_Complex := Complex_Pack."+"(5.0, Complex_Pack.i);
-
- if TC_Complex /= (5.0, 1.0) or
- (4.0 + i) /= (4.0, 1.0) or
- "+"(Left => j, Right => 3.0) /= (3.0, 1.0)
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Real and one Imaginary argument");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1002;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a
deleted file mode 100644
index c388513..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a
+++ /dev/null
@@ -1,478 +0,0 @@
--- CXG1003.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 subprograms defined in the package Text_IO.Complex_IO
--- provide correct results.
---
--- TEST DESCRIPTION:
--- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
--- with a real type (new Float). The resulting new package is used as
--- the generic actual to package Complex_IO.
--- Two different versions of Put and Get are examined in this test,
--- those that input/output complex data values from/to Text_IO files,
--- and those that input/output complex data values from/to strings.
--- Two procedures are defined to perform the file data manipulations;
--- one to place complex data into the file, and one to retrieve the data
--- from the file and verify its correctness.
--- Complex data is also put into string variables using the Procedure
--- Put for strings, and this data is then retrieved and reconverted into
--- complex values using the Get procedure.
---
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable to implementations that:
--- support Annex G,
--- support Text_IO and external files
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Modified Width parameter in Get function calls.
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Text_IO.Complex_IO;
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1003 is
-begin
-
- Report.Test ("CXG1003", "Check that the subprograms defined in " &
- "the package Text_IO.Complex_IO " &
- "provide correct results");
-
- Test_for_Text_IO_Support:
- declare
- use Ada;
-
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- An application creates a text file in mode Out_File, with the
- -- intention of entering complex data into the file as appropriate.
- -- In the event that the particular environment where the application
- -- is running does not support Text_IO, Use_Error or Name_Error will be
- -- raised on calls to Text_IO operations. Either of these exceptions
- -- will be handled to produce a Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Data_Filename);
-
- Test_Block:
- declare
-
- TC_Verbose : Boolean := False;
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package C_IO is new Ada.Text_IO.Complex_IO(Complex_Pack);
-
- use Ada.Text_IO, C_IO;
- use type Complex_Pack.Complex;
-
- Number_Of_Complex_Items : constant := 6;
- Number_Of_Error_Items : constant := 2;
-
- TC_Complex : Complex_Pack.Complex;
- TC_Last_Character_Read : Positive;
-
- Complex_Array : array (1..Number_Of_Complex_Items)
- of Complex_Pack.Complex := ( (3.0, 9.0),
- (4.0, 7.0),
- (5.0, 6.0),
- (6.0, 3.0),
- (2.0, 5.0),
- (3.0, 7.0) );
-
-
- procedure Load_Data_File (The_File : in out Text_IO.File_Type) is
- use Ada.Text_IO;
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- This procedure is designed to load complex data into a data
- -- file twice, first using Text_IO, then Complex_IO. In this
- -- first case, the complex data values are entered as strings,
- -- assuming a variety of legal formats, as provided in the
- -- reference manual.
-
- Put_Line(The_File, "(3.0, 9.0)");
- Put_Line(The_File, "+4. +7."); -- Relaxed real literal format.
- Put_Line(The_File, "(5.0 6.)");
- Put_Line(The_File, "6., 3.0");
- Put_Line(The_File, " ( 2.0 , 5.0 ) ");
- Put_Line(The_File, "("); -- Complex data separated over
- Put_Line(The_File, "3.0"); -- several (5) lines.
- Put_Line(The_File, " , ");
- Put_Line(The_File, "7.0 ");
- Put_Line(The_File, ")");
-
- if TC_Verbose then
- Report.Comment("Complex values entered into data file using " &
- "Text_IO, Procedure Load_Data_File");
- end if;
-
- -- Use the Complex_IO procedure Put to enter Complex data items
- -- into the data file.
- -- Note: Data is being entered into the file for the *second* time
- -- at this point. (Using Complex_IO here, Text_IO above)
-
- for i in 1..Number_Of_Complex_Items loop
- C_IO.Put(File => The_File,
- Item => Complex_Array(i),
- Fore => 1,
- Aft => 1,
- Exp => 0);
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values entered into data file using " &
- "Complex_IO, Procedure Load_Data_File");
- end if;
-
- Put_Line(The_File, "(5A,3)"); -- data to raise Data_Error.
- Put_Line(The_File, "(3.0,,8.0)"); -- data to raise Data_Error.
-
- end Load_Data_File;
-
-
-
- procedure Process_Data_File (The_File : in out Text_IO.File_Type) is
- TC_Complex : Complex_Pack.Complex := (0.0, 0.0);
- TC_Width : Integer := 0;
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- Use procedure Get (for Files) to extract the complex data from
- -- the Text_IO file. This data was placed into the file using
- -- Text_IO.
-
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(The_File, TC_Complex, TC_Width);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data read from file " &
- "when using Text_IO procedure Get, " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("First set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
- -- Use procedure Get (for Files) to extract the complex data from
- -- the Text_IO file. This data was placed into the file using
- -- procedure Complex_IO.Put.
- -- Note: Data is being extracted from the file for the *second*
- -- time at this point (Using Complex_IO here, Text_IO above)
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(The_File, TC_Complex, TC_Width);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data read from file " &
- "when using Complex_IO procedure Get, " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Second set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
- -- The final items in the Data_File are complex values with
- -- incorrect syntax, which should raise Data_Error on an attempt
- -- to read them from the file.
- TC_Width := 10;
- for i in 1..Number_Of_Error_Items loop
- begin
- C_IO.Get(The_File, TC_Complex, TC_Width);
- Report.Failed
- ("Exception Data_Error not raised when Complex_IO.Get " &
- "was used to read complex data with incorrect " &
- "syntax from the Data_File, data item #" &
- Integer'Image(i));
- exception
- when Ada.Text_IO.Data_Error => -- OK, expected exception.
- Text_IO.Skip_Line(The_File);
- when others =>
- Report.Failed
- ("Unexpected exception raised when Complex_IO.Get " &
- "was used to read complex data with incorrect " &
- "syntax from the Data_File, data item #" &
- Integer'Image(i));
- end;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Erroneous set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
-
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised in Process_Data_File");
- end Process_Data_File;
-
-
-
- begin -- Test_Block.
-
- -- Place complex values into data file.
-
- Load_Data_File(Data_File);
- Text_IO.Close(Data_File);
-
- if TC_Verbose then
- Report.Comment("Data file loaded with Complex values");
- end if;
-
- -- Read complex values from data file.
-
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Process_Data_File(Data_File);
-
- if TC_Verbose then
- Report.Comment("Complex values extracted from data file");
- end if;
-
-
-
- -- Verify versions of Procedures Put and Get for Strings.
-
- declare
- TC_String_Array : array (1..Number_Of_Complex_Items)
- of String(1..15) := (others =>(others => ' '));
- begin
-
- -- Place complex values into strings using the Procedure Put.
-
- for i in 1..Number_Of_Complex_Items loop
- C_IO.Put(To => TC_String_Array(i),
- Item => Complex_Array(i),
- Aft => 1,
- Exp => 0);
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values placed into string array");
- end if;
-
- -- Check the format of the strings containing a complex number.
- -- The resulting strings are of 15 character length, with the
- -- real component left justified within the string, followed by
- -- a comma, and with the imaginary component and closing
- -- parenthesis right justified in the string, with blank fill
- -- for the balance of the string.
-
- if TC_String_Array(1) /= "(3.0, 9.0)" or
- TC_String_Array(2) /= "(4.0, 7.0)" or
- TC_String_Array(3) /= "(5.0, 6.0)" or
- TC_String_Array(4) /= "(6.0, 3.0)" or
- TC_String_Array(5) /= "(2.0, 5.0)" or
- TC_String_Array(6) /= "(3.0, 7.0)"
- then
- Report.Failed("Incorrect format for complex values that " &
- "have been placed into string variables " &
- "using the Complex_IO.Put procedure for " &
- "strings");
- end if;
-
- if TC_Verbose then
- Report.Comment("String format of Complex values verified");
- end if;
-
- -- Get complex values from strings using the Procedure Get.
- -- Compare with expected complex values.
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(From => TC_String_Array(i),
- Item => TC_Complex,
- Last => TC_Last_Character_Read);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data value obtained " &
- "from String following use of Procedures " &
- "Put and Get from Strings, Complex_Array " &
- "item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values removed from String array");
- end if;
-
- -- Verify that Layout_Error is raised if the given string is
- -- too short to hold the formatted output.
- Layout_Error_On_Put:
- declare
- Much_Too_Short : String(1..2);
- Complex_Value : Complex_Pack.Complex := (5.0, 0.0);
- begin
- C_IO.Put(Much_Too_Short, Complex_Value);
- Report.Failed("Layout_Error not raised by Procedure Put " &
- "when the given string was too short to " &
- "hold the formatted output");
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Procedure Put when " &
- "the given string was too short to hold the " &
- "formatted output");
- end Layout_Error_On_Put;
-
- if TC_Verbose then
- Report.Comment("Layout Errors verified");
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Put and Get for Strings");
- end;
-
-
- -- Place complex values into strings using a variety of legal
- -- complex data formats.
- declare
-
- type String_Ptr is access String;
-
- TC_Complex_String_Array :
- array (1..Number_Of_Complex_Items) of String_Ptr :=
- (new String'( "(3.0, 9.0 )" ),
- new String'( "+4.0 +7.0" ),
- new String'( "(5.0 6.0)" ),
- new String'( "6.0, 3.0" ),
- new String'( " ( 2.0 , 5.0 ) " ),
- new String'( "(3.0 7.0)" ));
-
- -- The following array contains Positive values that correspond
- -- to the last character that will be read by Procedure Get when
- -- given each of the above strings as input.
-
- TC_Last_Char_Array : array (1..Number_Of_Complex_Items)
- of Positive := (12,10,9,8,20,22);
-
- begin
-
- -- Get complex values from strings using the Procedure Get.
- -- Compare with expected complex values.
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(TC_Complex_String_Array(i).all,
- TC_Complex,
- TC_Last_Character_Read);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed
- ("Incorrect complex data value obtained from " &
- "Procedure Get with complex data input of: " &
- TC_Complex_String_Array(i).all);
- end if;
-
- if TC_Last_Character_Read /= TC_Last_Char_Array(i) then
- Report.Failed
- ("Incorrect value returned as the last character of " &
- "the input string processed by Procedure Get, " &
- "string value : " & TC_Complex_String_Array(i).all &
- " expected last character value read : " &
- Positive'Image(TC_Last_Char_Array(i)) &
- " last character value read : " &
- Positive'Image(TC_Last_Character_Read));
- end if;
-
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values removed from strings and " &
- "verified against expected values");
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Get for Strings");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Delete(Data_File);
- else
- Ada.Text_IO.Open(Data_File,
- Ada.Text_IO.In_File,
- Data_Filename);
- Ada.Text_IO.Delete(Data_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Ada.Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on text file Create");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXG1003;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a
deleted file mode 100644
index f026eae..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a
+++ /dev/null
@@ -1,360 +0,0 @@
--- CXG1004.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 specified exceptions are raised by the subprograms
--- defined in package Ada.Numerics.Generic_Complex_Elementary_Functions
--- given the prescribed input parameter values.
---
--- TEST DESCRIPTION:
--- This test checks that specific subprograms defined in the
--- package Ada.Numerics.Generic_Complex_Elementary_Functions raise the
--- exceptions Argument_Error and Constraint_Error when their input
--- parameter value are those specified as causing each exception.
--- In the case of Constraint_Error, the exception will be raised in
--- each test case, provided that the value of the attribute
--- 'Machine_Overflows (for the actual type of package
--- Generic_Complex_Type) is True.
---
--- APPLICABILITY CRITERIA:
--- This test only applies to implementations supporting the
--- numerics annex.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
--- 02 Jun 98 EDS Replace "_i" with "_One".
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with Report;
-
-procedure CXG1004 is
-begin
-
- Report.Test ("CXG1004", "Check that the specified exceptions are " &
- "raised by the subprograms defined in package " &
- "Ada.Numerics.Generic_Complex_Elementary_" &
- "Functions given the prescribed input " &
- "parameter values");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- TC_Overflows : Boolean := Real_Type'Machine_Overflows;
-
- package Complex_Pack is
- new Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package CEF is
- new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
-
- use Ada.Numerics, Complex_Pack, CEF;
-
- Complex_Zero : constant Complex := Compose_From_Cartesian(0.0, 0.0);
- Plus_One : constant Complex := Compose_From_Cartesian(1.0, 0.0);
- Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
- Plus_i : constant Complex := Compose_From_Cartesian(i);
- Minus_i : constant Complex := Compose_From_Cartesian(-i);
-
- Complex_Negative_Real : constant Complex :=
- Compose_From_Cartesian(-4.0, 2.0);
- Complex_Negative_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, -5.0);
-
- TC_Complex : Complex;
-
-
- -- This procedure is used in "Exception Raising" calls below in an
- -- attempt to avoid elimination of the subtest through optimization.
-
- procedure No_Optimize (The_Complex_Number : Complex) is
- begin
- Report.Comment("No Optimize: Should never be printed " &
- Integer'Image(Integer(The_Complex_Number.Im)));
- end No_Optimize;
-
-
- begin
-
- -- Check that the exception Numerics.Argument_Error is raised by the
- -- exponentiation operator when the value of the left operand is zero,
- -- and the real component of the exponent (or the exponent itself) is
- -- zero.
-
- begin
- TC_Complex := "**"(Left => Complex_Zero, Right => Complex_Zero);
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = complex zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = complex zero");
- end;
-
- begin
- TC_Complex := Complex_Zero**0.0;
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = real zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = real zero");
- end;
-
-
- begin
- TC_Complex := "**"(Left => 0.0, Right => Complex_Zero);
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = real zero, right " &
- "operand = complex zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = real zero, right " &
- "operand = complex zero");
- end;
-
-
- -- Check that the exception Constraint_Error is raised under the
- -- specified circumstances, provided that
- -- Complex_Types.Real'Machine_Overflows is True.
-
- if TC_Overflows then
-
- -- Raised by Log, when the value of the parameter X is zero.
- begin
- TC_Complex := Log (X => Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Log given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Log given parameter value of complex zero");
- end;
-
- -- Raised by Cot, when the value of the parameter X is zero.
- begin
- TC_Complex := Cot (X => Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Cot given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Cot given parameter value of complex zero");
- end;
-
- -- Raised by Coth, when the value of the parameter X is zero.
- begin
- TC_Complex := Coth (Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Coth given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Coth given parameter value of complex zero");
- end;
-
- -- Raised by the exponentiation operator, when the value of the
- -- left operand is zero and the real component of the exponent
- -- is negative.
- begin
- TC_Complex := Complex_Zero**Complex_Negative_Real;
- Report.Failed("Constraint_Error not raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real component of " &
- "the exponent is negative");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real component of " &
- "the exponent is negative");
- end;
-
- -- Raised by the exponentiation operator, when the value of the
- -- left operand is zero and the exponent itself (when it is of
- -- type real) is negative.
- declare
- Negative_Exponent : constant Real_Type := -4.0;
- begin
- TC_Complex := Complex_Zero**Negative_Exponent;
- Report.Failed("Constraint_Error not raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real exponent is " &
- "negative");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real exponent is " &
- "negative");
- end;
-
- -- Raised by Arctan, when the value of the parameter is +i.
- begin
- TC_Complex := Arctan (Plus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctan is given parameter value +i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctan is given parameter value +i");
- end;
-
- -- Raised by Arctan, when the value of the parameter is -i.
- begin
- TC_Complex := Arctan (Minus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctan is given parameter value -i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctan is given parameter value -i");
- end;
-
- -- Raised by Arccot, when the value of the parameter is +i.
- begin
- TC_Complex := Arccot (Plus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccot is given parameter value +i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccot is given parameter value +i");
- end;
-
- -- Raised by Arccot, when the value of the parameter is -i.
- begin
- TC_Complex := Arccot (Minus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccot is given parameter value -i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccot is given parameter value -i");
- end;
-
- -- Raised by Arctanh, when the value of the parameter is +1.
- begin
- TC_Complex := Arctanh (Plus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctanh is given parameter value +1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctanh is given parameter value +1");
- end;
-
- -- Raised by Arctanh, when the value of the parameter is -1.
- begin
- TC_Complex := Arctanh (Minus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctanh is given parameter value -1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctanh is given parameter value -1");
- end;
-
- -- Raised by Arccoth, when the value of the parameter is +1.
- begin
- TC_Complex := Arccoth (Plus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccoth is given parameter value +1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccoth is given parameter value +1");
- end;
-
- -- Raised by Arccoth, when the value of the parameter is -1.
- begin
- TC_Complex := Arccoth (Minus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccoth is given parameter value -1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccoth is given parameter value -1");
- end;
-
- else
- Report.Comment
- ("Attribute Complex_Pack.Real'Machine_Overflows is False; " &
- "evaluation of the complex elementary functions under " &
- "specified circumstances was not performed");
- end if;
-
-
- exception
- when others =>
- Report.Failed ("Unexpected exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1004;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a
deleted file mode 100644
index 6faad4e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a
+++ /dev/null
@@ -1,393 +0,0 @@
--- CXG1005.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 subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Elementary_Functions provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test checks that specific subprograms defined in the generic
--- package Generic_Complex_Elementary_Functions are available, and that
--- they provide prescribed results given specific input values.
--- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
--- with a real type (new Float). The resulting new package is used as
--- the generic actual to package Complex_IO.
---
--- SPECIAL REQUIREMENTS:
--- Implementations for which Float'Signed_Zeros is True must provide
--- a body for ImpDef.Annex_G.Negative_Zero which returns a negative
--- zero.
---
--- APPLICABILITY CRITERIA
--- This test only applies to implementations that support the
--- numerics annex.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 21 Feb 96 SAIC Incorporated new structure for package Impdef.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with ImpDef.Annex_G;
-with Report;
-
-procedure CXG1005 is
-begin
-
- Report.Test ("CXG1005", "Check that the subprograms defined in " &
- "the package Generic_Complex_Elementary_" &
- "Functions provide correct results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- TC_Signed_Zeros : Boolean := Real_Type'Signed_Zeros;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package CEF is
- new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
-
- use Ada.Numerics, Complex_Pack, CEF;
-
- Complex_Zero : constant Complex := Compose_From_Cartesian( 0.0, 0.0);
- Plus_One : constant Complex := Compose_From_Cartesian( 1.0, 0.0);
- Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
- Plus_i : constant Complex := Compose_From_Cartesian(i);
- Minus_i : constant Complex := Compose_From_Cartesian(-i);
-
- Complex_Positive_Real : constant Complex :=
- Compose_From_Cartesian(4.0, 2.0);
- Complex_Positive_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, 5.0);
- Complex_Negative_Real : constant Complex :=
- Compose_From_Cartesian(-4.0, 2.0);
- Complex_Negative_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, -5.0);
-
-
- function A_Zero_Result (Z : Complex) return Boolean is
- begin
- return (Re(Z) = 0.0 and Im(Z) = 0.0);
- end A_Zero_Result;
-
-
- -- In order to evaluate complex elementary functions that are
- -- prescribed to return a "real" result (meaning that the imaginary
- -- component is zero), the Function A_Real_Result is defined.
-
- function A_Real_Result (Z : Complex) return Boolean is
- begin
- return Im(Z) = 0.0;
- end A_Real_Result;
-
-
- -- In order to evaluate complex elementary functions that are
- -- prescribed to return an "imaginary" result (meaning that the real
- -- component of the complex number is zero, and the imaginary
- -- component is non-zero), the Function An_Imaginary_Result is defined.
-
- function An_Imaginary_Result (Z : Complex) return Boolean is
- begin
- return (Re(Z) = 0.0 and Im(Z) /= 0.0);
- end An_Imaginary_Result;
-
-
- begin
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a zero result.
-
- if not A_Zero_Result( Sqrt(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sqrt with zero input");
- end if;
-
- if not A_Zero_Result( Sin(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sin with zero input");
- end if;
-
- if not A_Zero_Result( Arcsin(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arcsin with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Tan(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Tan with zero input");
- end if;
-
- if not A_Zero_Result( Arctan(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arctan with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Sinh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sinh with zero input");
- end if;
-
- if not A_Zero_Result( Arcsinh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arcsinh with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Tanh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Tanh with zero input");
- end if;
-
- if not A_Zero_Result( Arctanh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arctanh with zero " &
- "input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a result of one.
-
- if Exp(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Exp with zero input");
- end if;
-
- if Cos(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Cos with zero input");
- end if;
-
- if Cosh(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Cosh with zero input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a real result.
-
- if not A_Real_Result( Arccos(Complex_Zero) ) then
- Report.Failed("Non-real result from Function Arccos with zero input");
- end if;
-
- if not A_Real_Result( Arccot(Complex_Zero) ) then
- Report.Failed("Non-real result from Function Arccot with zero input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield an imaginary result.
-
- if not An_Imaginary_Result( Arccoth(Complex_Zero) ) then
- Report.Failed("Non-imaginary result from Function Arccoth with " &
- "zero input");
- end if;
-
-
- -- Check that when the input parameter value is one, the Sqrt function
- -- yields a result of one.
-
- if Sqrt(Plus_One) /= Plus_One then
- Report.Failed("Incorrect result from Function Sqrt with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is one, the following
- -- functions yield a result of zero.
-
- if not A_Zero_Result( Log(Plus_One) ) then
- Report.Failed("Non-zero result from Function Log with input " &
- "value of one");
- end if;
-
- if not A_Zero_Result( Arccos(Plus_One) ) then
- Report.Failed("Non-zero result from Function Arccos with input " &
- "value of one");
- end if;
-
- if not A_Zero_Result( Arccosh(Plus_One) ) then
- Report.Failed("Non-zero result from Function Arccosh with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is one, the Arcsin
- -- function yields a real result.
-
- if not A_Real_Result( Arcsin(Plus_One) ) then
- Report.Failed("Non-real result from Function Arcsin with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is minus one, the Sqrt
- -- function yields a result of "i", when the sign of the imaginary
- -- component of the input parameter is positive (and yields "-i", if
- -- the sign on the imaginary component is negative), and the
- -- Complex_Types.Real'Signed_Zeros attribute is True.
-
- if TC_Signed_Zeros then
-
- declare
- Minus_One_With_Pos_Zero_Im_Component : Complex :=
- Compose_From_Cartesian(-1.0, +0.0);
- Minus_One_With_Neg_Zero_Im_Component : Complex :=
- Compose_From_Cartesian
- (-1.0, Real_Type(ImpDef.Annex_G.Negative_Zero));
- begin
-
- if Sqrt(Minus_One_With_Pos_Zero_Im_Component) /= Plus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one with a positive " &
- "imaginary component, Signed_Zeros being True");
- end if;
-
- if Sqrt(Minus_One_With_Neg_Zero_Im_Component) /= Minus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one with a negative " &
- "imaginary component, Signed_Zeros being True");
- end if;
- end;
-
- else -- Signed_Zeros is False.
-
- -- Check that when the input parameter value is minus one, the Sqrt
- -- function yields a result of "i", when the
- -- Complex_Types.Real'Signed_Zeros attribute is False.
-
- if Sqrt(Minus_One) /= Plus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one, Signed_Zeros being " &
- "False");
- end if;
-
- end if;
-
-
- -- Check that when the input parameter value is minus one, the Log
- -- function yields an imaginary result.
-
- if not An_Imaginary_Result( Log(Minus_One) ) then
- Report.Failed("Non-imaginary result from Function Log with a " &
- "minus one input value");
- end if;
-
- -- Check that when the input parameter is minus one, the following
- -- functions yield a real result.
-
- if not A_Real_Result( Arcsin(Minus_One) ) then
- Report.Failed("Non-real result from Function Arcsin with a " &
- "minus one input value");
- end if;
-
- if not A_Real_Result( Arccos(Minus_One) ) then
- Report.Failed("Non-real result from Function Arccos with a " &
- "minus one input value");
- end if;
-
-
- -- Check that when the input parameter has a value of +i or -i, the
- -- Log function yields an imaginary result.
-
- if not An_Imaginary_Result( Log(Plus_i) ) then
- Report.Failed("Non-imaginary result from Function Log with an " &
- "input value of ""+i""");
- end if;
-
- if not An_Imaginary_Result( Log(Minus_i) ) then
- Report.Failed("Non-imaginary result from Function Log with an " &
- "input value of ""-i""");
- end if;
-
-
- -- Check that exponentiation by a zero exponent yields the value one.
-
- if "**"(Left => Compose_From_Cartesian(5.0, 3.0),
- Right => Complex_Zero) /= Plus_One or
- Complex_Negative_Real**0.0 /= Plus_One or
- 15.0**Complex_Zero /= Plus_One
- then
- Report.Failed("Incorrect result from exponentiation with a zero " &
- "exponent");
- end if;
-
-
- -- Check that exponentiation by a unit exponent yields the value of
- -- the left operand (as a complex value).
- -- Note: a "unit exponent" is considered the complex number (1.0, 0.0)
-
- if "**"(Complex_Negative_Real, Plus_One) /=
- Complex_Negative_Real or
- Complex_Negative_Imaginary**Plus_One /=
- Complex_Negative_Imaginary or
- 4.0**Plus_One /=
- Compose_From_Cartesian(4.0, 0.0)
- then
- Report.Failed("Incorrect result from exponentiation with a unit " &
- "exponent");
- end if;
-
-
- -- Check that exponentiation of the value one yields the value one.
-
- if "**"(Plus_One, Complex_Negative_Imaginary) /= Plus_One or
- Plus_One**9.0 /= Plus_One or
- 1.0**Complex_Negative_Real /= Plus_One
- then
- Report.Failed("Incorrect result from exponentiation of the value " &
- "One");
- end if;
-
-
- -- Check that exponentiation of the value zero yields the value zero.
- begin
- if not A_Zero_Result("**"(Complex_Zero,
- Complex_Positive_Imaginary)) or
- not A_Zero_Result(Complex_Zero**4.0) or
- not A_Zero_Result(0.0**Complex_Positive_Real)
- then
- Report.Failed("Incorrect result from exponentiation of the " &
- "value zero");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during the exponentiation of " &
- "the complex value zero");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1005;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a
deleted file mode 100644
index 0d7afa4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- CXG2001.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 floating point attributes Model_Mantissa,
--- Machine_Mantissa, Machine_Radix, and Machine_Rounds
--- are properly reported.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Machine_ attributes listed above. The
--- generic package is instantiated with the standard FLOAT
--- type and a floating point type for the maximum number
--- of digits of precision.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 26 JAN 96 SAIC Initial Release for 2.1
---
---!
-
--- References:
---
--- "Algorithms To Reveal Properties of Floating-Point Arithmetic"
--- Michael A. Malcolm; CACM November 1972; pgs 949-951.
---
--- Software Manual for Elementary Functions; W. J. Cody and W. Waite;
--- Prentice-Hall; 1980
------------------------------------------------------------------------
---
--- This test relies upon the fact that
--- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding
--- a small value to A does not change the value of A. Consider the case
--- where we have a decimal based floating point representation with 4
--- digits of precision. A floating point number would logically be
--- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9.
--- The first loop of the test starts A at 2.0 and doubles it until
--- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point
--- number this will be 1638 * 10**1 (the value 16384 rounded or truncated
--- to fit in 4 digits).
--- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is
--- no longer 0. This will keep looping until B is 8.0 because that is
--- the first value where rounding (assuming our machine rounds and addition
--- employs a guard digit) will change the upper 4 digits of the result:
--- 1638_
--- + 8
--- -------
--- 1639_
--- Without rounding the second loop will continue until
--- B is 16:
--- 1638_
--- + 16
--- -------
--- 1639_
---
--- The radix is then determined by (A+B)-A which will give 10.
---
--- The use of Tmp and ITmp in the test is to force values to be
--- stored into memory in the event that register precision is greater
--- than the stored precision of the floating point values.
---
---
--- The test for rounding is (ignoring the temporary variables used to
--- get the stored precision) is
--- Rounds := A + Radix/2.0 - A /= 0.0 ;
--- where A is the value determined in the first step that is the smallest
--- power of 2 such that A + 1.0 = A. This means that the true value of
--- A has one more digit in its value than 'Machine_Mantissa.
--- This check will detect the case where a value is always rounded.
--- There is an additional case where values are rounded to the nearest
--- even value. That is referred to as IEEE style rounding in the test.
---
------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2001 is
- Verbose : constant Boolean := False;
-
- -- if one of the attribute computation loops exceeds Max_Iterations
- -- it is most likely due to the compiler reordering an expression
- -- that should not be reordered.
- Illegal_Optimization : exception;
- Max_Iterations : constant := 10_000;
-
- generic
- type Real is digits <>;
- package Chk_Attrs is
- procedure Do_Test;
- end Chk_Attrs;
-
- package body Chk_Attrs is
- package EF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Log (X : Real) return Real renames EF.Log;
-
-
- -- names used in paper
- Radix : Integer; -- Beta
- Mantissa_Digits : Integer; -- t
- Rounds : Boolean; -- RND
-
- -- made global to Determine_Attributes to help thwart optimization
- A, B : Real := 2.0;
- Tmp, Tmpa, Tmp1 : Real;
- ITmp : Integer;
- Half_Radix : Real;
-
- -- special constants - not declared as constants so that
- -- the "stored" precision will be used instead of a "register"
- -- precision.
- Zero : Real := 0.0;
- One : Real := 1.0;
- Two : Real := 2.0;
-
-
- procedure Thwart_Optimization is
- -- the purpose of this procedure is to reference the
- -- global variables used by Determine_Attributes so
- -- that the compiler is not likely to keep them in
- -- a higher precision register for their entire lifetime.
- begin
- if Report.Ident_Bool (False) then
- -- never executed
- A := A + 5.0;
- B := B + 6.0;
- Tmp := Tmp + 1.0;
- Tmp1 := Tmp1 + 2.0;
- Tmpa := Tmpa + 2.0;
- One := 12.34; Two := 56.78; Zero := 90.12;
- end if;
- end Thwart_Optimization;
-
-
- -- determines values for Radix, Mantissa_Digits, and Rounds
- -- This is mostly a straight translation of the C code.
- -- The only significant addition is the iteration count
- -- to prevent endless looping if things are really screwed up.
- procedure Determine_Attributes is
- Iterations : Integer;
- begin
- Rounds := True;
-
- Iterations := 0;
- Tmp := Real'Machine (((A + One) - A) - One);
- while Tmp = Zero loop
- A := Real'Machine(A + A);
- Tmp := Real'Machine(A + One);
- Tmp1 := Real'Machine(Tmp - A);
- Tmp := Real'Machine(Tmp1 - One);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Iterations := 0;
- Tmp := Real'Machine(A + B);
- ITmp := Integer (Tmp - A);
- while ITmp = 0 loop
- B := Real'Machine(B + B);
- Tmp := Real'Machine(A + B);
- ITmp := Integer (Tmp - A);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Radix := ITmp;
-
- Mantissa_Digits := 0;
- B := 1.0;
- Tmp := Real'Machine(((B + One) - B) - One);
- Iterations := 0;
- while (Tmp = Zero) loop
- Mantissa_Digits := Mantissa_Digits + 1;
- B := B * Real (Radix);
- Tmp := Real'Machine(B + One);
- Tmp1 := Real'Machine(Tmp - B);
- Tmp := Real'Machine(Tmp1 - One);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Rounds := False;
- Half_Radix := Real (Radix) / Two;
- Tmp := Real'Machine(A + Half_Radix);
- Tmp1 := Real'Machine(Tmp - A);
- if (Tmp1 /= Zero) then
- Rounds := True;
- end if;
- Tmpa := Real'Machine(A + Real (Radix));
- Tmp := Real'Machine(Tmpa + Half_Radix);
- if not Rounds and (Tmp - TmpA /= Zero) then
- Rounds := True;
- if Verbose then
- Report.Comment ("IEEE style rounding");
- end if;
- end if;
-
- exception
- when others =>
- Thwart_Optimization;
- raise;
- end Determine_Attributes;
-
-
- procedure Do_Test is
- Show_Results : Boolean := Verbose;
- Min_Mantissa_Digits : Integer;
- begin
- -- compute the actual Machine_* attribute values
- Determine_Attributes;
-
- if Real'Machine_Radix /= Radix then
- Report.Failed ("'Machine_Radix incorrectly reports" &
- Integer'Image (Real'Machine_Radix));
- Show_Results := True;
- end if;
-
- if Real'Machine_Mantissa /= Mantissa_Digits then
- Report.Failed ("'Machine_Mantissa incorrectly reports" &
- Integer'Image (Real'Machine_Mantissa));
- Show_Results := True;
- end if;
-
- if Real'Machine_Rounds /= Rounds then
- Report.Failed ("'Machine_Rounds incorrectly reports " &
- Boolean'Image (Real'Machine_Rounds));
- Show_Results := True;
- end if;
-
- if Show_Results then
- Report.Comment ("computed Machine_Mantissa is" &
- Integer'Image (Mantissa_Digits));
- Report.Comment ("computed Radix is" &
- Integer'Image (Radix));
- Report.Comment ("computed Rounds is " &
- Boolean'Image (Rounds));
- end if;
-
- -- check the model attributes against the machine attributes
- -- G.2.2(3)/3;6.0
- if Real'Model_Mantissa > Real'Machine_Mantissa then
- Report.Failed ("model mantissa > machine mantissa");
- end if;
-
- -- G.2.2(3)/2;6.0
- -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1
- Min_Mantissa_Digits :=
- Integer (
- Real'Ceiling (
- Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix))
- ) ) + 1;
- if Real'Model_Mantissa < Min_Mantissa_Digits then
- Report.Failed ("Model_Mantissa [" &
- Integer'Image (Real'Model_Mantissa) &
- "] < minimum mantissa digits [" &
- Integer'Image (Min_Mantissa_Digits) &
- "]");
- end if;
-
- exception
- when Illegal_Optimization =>
- Report.Failed ("illegal optimization of" &
- " floating point expression");
- end Do_Test;
- end Chk_Attrs;
-
- package Chk_Float is new Chk_Attrs (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float);
-begin
- Report.Test ("CXG2001",
- "Check the attributes Model_Mantissa," &
- " Machine_Mantissa, Machine_Radix," &
- " and Machine_Rounds");
-
- Report.Comment ("checking Standard.Float");
- Chk_Float.Do_Test;
-
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2001;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a
deleted file mode 100644
index 6a1f322..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a
+++ /dev/null
@@ -1,468 +0,0 @@
--- CXG2002.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 complex "abs" or modulus function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the modulus function. In addition, a non-generic
--- copy of this package is used to check the non-generic package
--- Ada.Numerics.Complex_Types.
--- Of special interest is the case where either the real or
--- the imaginary part of the argument is very large while the
--- other part is very small or 0.
--- We want to check that the value is computed such that
--- an overflow does not occur. If computed directly from the
--- definition
--- abs (x+yi) = sqrt(x**2 + y**2)
--- then overflow or underflow is much more likely than if the
--- argument is normalized first.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 31 JAN 96 SAIC Initial release for 2.1
--- 02 JUN 98 EDS Add parens to intermediate calculations.
---!
-
---
--- Reference:
--- Problems and Methodologies in Mathematical Software Production;
--- editors: P. C. Messina and A Murli;
--- Lecture Notes in Computer Science
--- Volume 142
--- Springer Verlag 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-procedure CXG2002 is
- Verbose : constant Boolean := False;
- Maximum_Relative_Error : constant := 3.0;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Maximum_Relative_Error) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Expected - Actual) &
- " max_err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Do_Test is
- Z : Complex;
- X : Real;
- T : Real;
- begin
-
- --- test 1 ---
- begin
- T := Real'Safe_Last;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T, "test 1 -- abs(bigreal + 0i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- begin
- T := Real'Safe_Last;
- Z := 0.0 + T*i;
- X := Modulus (Z);
- Check (X, T, "test 2 -- abs(0 + bigreal*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- begin
- Z := 3.0 + 4.0*i;
- X := abs Z;
- Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- begin
- T := Real'Model_Small;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(small + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- begin
- T := Real'Model_Small;
- Z := 0.0 + T*i;
- X := abs Z;
- Check (X, T , "test 6 -- abs(0 + small*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
-
- --- test 8 ---
- declare
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- begin
- Z := 1.0 + 1.0*i;
- X := abs Z;
- Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 8");
- when others =>
- Report.Failed ("exception in test 8");
- end;
-
- --- test 9 ---
- begin
- T := 0.0;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(0 + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 9");
- when others =>
- Report.Failed ("exception in test 9");
- end;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- --- non generic copy of the above generic package
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
- use Ada.Numerics.Complex_Types;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Maximum_Relative_Error) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Expected - Actual) &
- " max_err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Do_Test is
- Z : Complex;
- X : Real;
- T : Real;
- begin
-
- --- test 1 ---
- begin
- T := Real'Safe_Last;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T, "test 1 -- abs(bigreal + 0i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- begin
- T := Real'Safe_Last;
- Z := 0.0 + T*i;
- X := Modulus (Z);
- Check (X, T, "test 2 -- abs(0 + bigreal*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- begin
- Z := 3.0 + 4.0*i;
- X := abs Z;
- Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- begin
- T := Real'Model_Small;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(small + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- begin
- T := Real'Model_Small;
- Z := 0.0 + T*i;
- X := abs Z;
- Check (X, T , "test 6 -- abs(0 + small*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
-
- --- test 8 ---
- declare
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- begin
- Z := 1.0 + 1.0*i;
- X := abs Z;
- Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 8");
- when others =>
- Report.Failed ("exception in test 8");
- end;
-
- --- test 9 ---
- begin
- T := 0.0;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(0 + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 9");
- when others =>
- Report.Failed ("exception in test 9");
- end;
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- --- end of "manual instantiation"
- -----------------------------------------------------------------------
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2002",
- "Check the accuracy of the complex modulus" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
- Non_Generic_Check.Do_Test;
- Report.Result;
-end CXG2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a
deleted file mode 100644
index d1a225a..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a
+++ /dev/null
@@ -1,701 +0,0 @@
--- CXG2003.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 sqrt function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- elementary functions package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 2 FEB 96 SAIC Initial release for 2.1
--- 18 AUG 96 SAIC Made Check consistent with other tests.
---
---!
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2003 is
- Verbose : constant Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check (A, B : Real;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Real;
- Expected : Real;
- Y : Real;
- C : Real := Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * Exp(C * Real (I) / Real (Max_Samples));
- X := Expected * Expected;
- Y := Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Real'Model_EMin + 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "8");
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
-
-
- package A_Long_Float_Check is
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check (A, B : Real;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Real;
- Expected : Real;
- Y : Real;
- C : Real := Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * Exp(C * Real (I) / Real (Max_Samples));
- X := Expected * Expected;
- Y := Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Real'Model_EMin + 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "8");
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
- package EF renames
- Ada.Numerics.Elementary_Functions;
- subtype Real is Float;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
-
- procedure Argument_Range_Check (A, B : Float;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Float;
- Expected : Float;
- Y : Float;
- C : Float := EF.Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples));
- X := Expected * Expected;
- Y := EF.Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Float'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Float'Machine_Radix) ** T;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Float'Model_EMin + 1) / 2;
- X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Float'Machine_Radix) ** T;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- EF.Sqrt(Float(Float'Machine_Radix)),
- "8");
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2003",
- "Check the accuracy of the sqrt function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a
deleted file mode 100644
index 2df296d..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a
+++ /dev/null
@@ -1,499 +0,0 @@
--- CXG2004.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 sin and cos functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both float and a long float type.
--- The test for each floating point type is divided into
--- the following parts:
--- Special value checks where the result is a known constant.
--- Checks using an identity relationship.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 13 FEB 96 SAIC Initial release for 2.1
--- 22 APR 96 SAIC Changed to generic implementation.
--- 18 AUG 96 SAIC Improvements to commentary.
--- 23 OCT 96 SAIC Exact results are not required unless the
--- cycle is specified.
--- 28 FEB 97 PWB.CTA Removed checks where cycle 2.0*Pi is specified
--- 02 JUN 98 EDS Revised calculations to ensure that X is exactly
--- three times Y per advice of numerics experts.
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
--- The sin and cos checks are translated directly from
--- the netlib FORTRAN code that was written by W. Cody.
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2004 is
- Verbose : constant Boolean := False;
- Number_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Sin (X : Real) return Real renames
- Elementary_Functions.Sin;
- function Cos (X : Real) return Real renames
- Elementary_Functions.Cos;
- function Sin (X, Cycle : Real) return Real renames
- Elementary_Functions.Sin;
- function Cos (X, Cycle : Real) return Real renames
- Elementary_Functions.Cos;
-
- Accuracy_Error_Reported : Boolean := False;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
-
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
-
- -- in addition to the relative error checks we apply the
- -- criteria of G.2.4(16)
- if abs (Actual) > 1.0 then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name & " result > 1.0");
- elsif abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" &
- Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Sin_Check (A, B : Real;
- Arg_Range : String) is
- -- test a selection of
- -- arguments selected from the range A to B.
- --
- -- This test uses the identity
- -- sin(x) = sin(x/3)*(3 - 4 * sin(x/3)**2)
- --
- -- Note that in this test we must take into account the
- -- error in the calculation of the expected result so
- -- the maximum relative error is larger than the
- -- accuracy required by the ARM.
-
- X, Y, ZZ : Real;
- Actual, Expected : Real;
- MRE : Real;
- Ran : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1 .. Number_Samples loop
- -- Evenly distributed selection of arguments
- Ran := Real (I) / Real (Number_Samples);
-
- -- make sure x and x/3 are both exactly representable
- -- on the machine. See "Implementation and Testing of
- -- Function Software" page 44.
- X := (B - A) * Ran + A;
- Y := Real'Leading_Part
- ( X/3.0,
- Real'Machine_Mantissa - Real'Exponent (3.0) );
- X := Y * 3.0;
-
- Actual := Sin (X);
-
- ZZ := Sin(Y);
- Expected := ZZ * (3.0 - 4.0 * ZZ * ZZ);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- -- See Cody pp 139-141.
- MRE := 4.0;
-
- Check (Actual, Expected,
- "sin test of range" & Arg_Range &
- Integer'Image (I),
- MRE);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in sin check");
- when others =>
- Report.Failed ("exception in sin check");
- end Sin_Check;
-
-
-
- procedure Cos_Check (A, B : Real;
- Arg_Range : String) is
- -- test a selection of
- -- arguments selected from the range A to B.
- --
- -- This test uses the identity
- -- cos(x) = cos(x/3)*(4 * cos(x/3)**2 - 3)
- --
- -- Note that in this test we must take into account the
- -- error in the calculation of the expected result so
- -- the maximum relative error is larger than the
- -- accuracy required by the ARM.
-
- X, Y, ZZ : Real;
- Actual, Expected : Real;
- MRE : Real;
- Ran : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1 .. Number_Samples loop
- -- Evenly distributed selection of arguments
- Ran := Real (I) / Real (Number_Samples);
-
- -- make sure x and x/3 are both exactly representable
- -- on the machine. See "Implementation and Testing of
- -- Function Software" page 44.
- X := (B - A) * Ran + A;
- Y := Real'Leading_Part
- ( X/3.0,
- Real'Machine_Mantissa - Real'Exponent (3.0) );
- X := Y * 3.0;
-
- Actual := Cos (X);
-
- ZZ := Cos(Y);
- Expected := ZZ * (4.0 * ZZ * ZZ - 3.0);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- -- See Cody pp 141-143.
- MRE := 6.0;
-
- Check (Actual, Expected,
- "cos test of range" & Arg_Range &
- Integer'Image (I),
- MRE);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in cos check");
- when others =>
- Report.Failed ("exception in cos check");
- end Cos_Check;
-
-
- procedure Special_Angle_Checks is
- type Data_Point is
- record
- Degrees,
- Radians,
- Sine,
- Cosine : Real;
- Sin_Result_Error,
- Cos_Result_Error : Boolean;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions to minimize any loss of precision. However,
- -- there are two sources of error that must be accounted for
- -- in the following tests.
- -- First, when a cycle is not specified there can be a roundoff
- -- error in the value of Pi used. This error does not apply
- -- when a cycle of 2.0 * Pi is explicitly provided.
- -- Second, the expected results that involve sqrt values also
- -- have a potential roundoff error.
- -- The amount of error due to error in the argument is computed
- -- as follows:
- -- sin(x+err) = sin(x)*cos(err) + cos(x)*sin(err)
- -- ~= sin(x) + err * cos(x)
- -- similarly for cos the error due to error in the argument is
- -- computed as follows:
- -- cos(x+err) = cos(x)*cos(err) - sin(x)*sin(err)
- -- ~= cos(x) - err * sin(x)
- -- In both cases the term "err" is bounded by 0.5 * argument.
-
- Test_Data : constant Test_Data_Type := (
--- degrees radians sine cosine sin_er cos_er test #
- ( 0.0, 0.0, 0.0, 1.0, False, False ), -- 1
- ( 30.0, Pi/6.0, 0.5, Sqrt3/2.0, False, True ), -- 2
- ( 60.0, Pi/3.0, Sqrt3/2.0, 0.5, True, False ), -- 3
- ( 90.0, Pi/2.0, 1.0, 0.0, False, False ), -- 4
- (120.0, 2.0*Pi/3.0, Sqrt3/2.0, -0.5, True, False ), -- 5
- (150.0, 5.0*Pi/6.0, 0.5, -Sqrt3/2.0, False, True ), -- 6
- (180.0, Pi, 0.0, -1.0, False, False ), -- 7
- (210.0, 7.0*Pi/6.0, -0.5, -Sqrt3/2.0, False, True ), -- 8
- (240.0, 8.0*Pi/6.0, -Sqrt3/2.0, -0.5, True, False ), -- 9
- (270.0, 9.0*Pi/6.0, -1.0, 0.0, False, False ), -- 10
- (300.0, 10.0*Pi/6.0, -Sqrt3/2.0, 0.5, True, False ), -- 11
- (330.0, 11.0*Pi/6.0, -0.5, Sqrt3/2.0, False, True ), -- 12
- (360.0, 2.0*Pi, 0.0, 1.0, False, False ), -- 13
- ( 45.0, Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 14
- (135.0, 3.0*Pi/4.0, Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 15
- (225.0, 5.0*Pi/4.0, -Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 16
- (315.0, 7.0*Pi/4.0, -Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 17
- (405.0, 9.0*Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ) ); -- 18
-
-
- Y : Real;
- Sin_Arg_Err,
- Cos_Arg_Err,
- Sin_Result_Err,
- Cos_Result_Err : Real;
- begin
- for I in Test_Data'Range loop
- -- compute error components
- Sin_Arg_Err := abs Test_Data (I).Cosine *
- abs Test_Data (I).Radians / 2.0;
- Cos_Arg_Err := abs Test_Data (I).Sine *
- abs Test_Data (I).Radians / 2.0;
-
- if Test_Data (I).Sin_Result_Error then
- Sin_Result_Err := 0.5;
- else
- Sin_Result_Err := 0.0;
- end if;
-
- if Test_Data (I).Cos_Result_Error then
- Cos_Result_Err := 1.0;
- else
- Cos_Result_Err := 0.0;
- end if;
-
-
-
- Y := Sin (Test_Data (I).Radians);
- Check (Y, Test_Data (I).Sine,
- "test" & Integer'Image (I) & " sin(r)",
- 2.0 + Sin_Arg_Err + Sin_Result_Err);
- Y := Cos (Test_Data (I).Radians);
- Check (Y, Test_Data (I).Cosine,
- "test" & Integer'Image (I) & " cos(r)",
- 2.0 + Cos_Arg_Err + Cos_Result_Err);
- Y := Sin (Test_Data (I).Degrees, 360.0);
- Check (Y, Test_Data (I).Sine,
- "test" & Integer'Image (I) & " sin(d,360)",
- 2.0 + Sin_Result_Err);
- Y := Cos (Test_Data (I).Degrees, 360.0);
- Check (Y, Test_Data (I).Cosine,
- "test" & Integer'Image (I) & " cos(d,360)",
- 2.0 + Cos_Result_Err);
---pwb-math Y := Sin (Test_Data (I).Radians, 2.0*Pi);
---pwb-math Check (Y, Test_Data (I).Sine,
---pwb-math "test" & Integer'Image (I) & " sin(r,2pi)",
---pwb-math 2.0 + Sin_Result_Err);
---pwb-math Y := Cos (Test_Data (I).Radians, 2.0*Pi);
---pwb-math Check (Y, Test_Data (I).Cosine,
---pwb-math "test" & Integer'Image (I) & " cos(r,2pi)",
---pwb-math 2.0 + Cos_Result_Err);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special angle test");
- when others =>
- Report.Failed ("exception in special angle test");
- end Special_Angle_Checks;
-
-
- -- check the rule of A.5.1(41);6.0 which requires that the
- -- result be exact if the mathematical result is 0.0, 1.0,
- -- or -1.0
- procedure Exact_Result_Checks is
- type Data_Point is
- record
- Degrees,
- Sine,
- Cosine : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
- Test_Data : constant Test_Data_Type := (
- -- degrees sine cosine test #
- ( 0.0, 0.0, 1.0 ), -- 1
- ( 90.0, 1.0, 0.0 ), -- 2
- (180.0, 0.0, -1.0 ), -- 3
- (270.0, -1.0, 0.0 ), -- 4
- (360.0, 0.0, 1.0 ), -- 5
- ( 90.0 + 360.0, 1.0, 0.0 ), -- 6
- (180.0 + 360.0, 0.0, -1.0 ), -- 7
- (270.0 + 360.0,-1.0, 0.0 ), -- 8
- (360.0 + 360.0, 0.0, 1.0 ) ); -- 9
-
- Y : Real;
- begin
- for I in Test_Data'Range loop
- Y := Sin (Test_Data(I).Degrees, 360.0);
- if Y /= Test_Data(I).Sine then
- Report.Failed ("exact result for sin(" &
- Real'Image (Test_Data(I).Degrees) &
- ", 360.0) is not" &
- Real'Image (Test_Data(I).Sine) &
- " Difference is " &
- Real'Image (Y - Test_Data(I).Sine) );
- end if;
-
- Y := Cos (Test_Data(I).Degrees, 360.0);
- if Y /= Test_Data(I).Cosine then
- Report.Failed ("exact result for cos(" &
- Real'Image (Test_Data(I).Degrees) &
- ", 360.0) is not" &
- Real'Image (Test_Data(I).Cosine) &
- " Difference is " &
- Real'Image (Y - Test_Data(I).Cosine) );
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in exact result check");
- when others =>
- Report.Failed ("exception in exact result check");
- end Exact_Result_Checks;
-
-
- procedure Do_Test is
- begin
- Special_Angle_Checks;
- Sin_Check (0.0, Pi/2.0, "0..pi/2");
- Sin_Check (6.0*Pi, 6.5*Pi, "6pi..6.5pi");
- Cos_Check (7.0*Pi, 7.5*Pi, "7pi..7.5pi");
- Exact_Result_Checks;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2004",
- "Check the accuracy of the sin and cos functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- Report.Result;
-end CXG2004;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a
deleted file mode 100644
index 4054b83..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a
+++ /dev/null
@@ -1,204 +0,0 @@
--- CXG2005.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 floating point addition and multiplication
--- have the required accuracy.
---
--- TEST DESCRIPTION:
--- The check for the required precision is essentially a
--- check that a guard digit is used for the operations.
--- This test uses a generic package to check the addition
--- and multiplication results. The
--- generic package is instantiated with the standard FLOAT
--- type and a floating point type for the maximum number
--- of digits of precision.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 14 FEB 96 SAIC Initial Release for 2.1
--- 16 SEP 99 RLB Repaired to avoid printing thousands of (almost)
--- identical failure messages.
---!
-
--- References:
---
--- Basic Concepts for Computational Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Vol 142
--- Springer Verlag, 1982
---
--- Software Manual for the Elementary Functions
--- William J. Cody and William Waite
--- Prentice-Hall, 1980
---
-
-with System;
-with Report;
-procedure CXG2005 is
- Verbose : constant Boolean := False;
-
- generic
- type Real is digits <>;
- package Guard_Digit_Check is
- procedure Do_Test;
- end Guard_Digit_Check;
-
- package body Guard_Digit_Check is
- -- made global so that the compiler will be more likely
- -- to keep the values in memory instead of in higher
- -- precision registers.
- X, Y, Z : Real;
- OneX : Real;
- Eps, BN : Real;
-
- -- special constants - not declared as constants so that
- -- the "stored" precision will be used instead of a "register"
- -- precision.
- Zero : Real := 0.0;
- One : Real := 1.0;
- Two : Real := 2.0;
-
- Failure_Count : Natural := 0;
-
- procedure Thwart_Optimization is
- -- the purpose of this procedure is to reference the
- -- global variables used by the test so
- -- that the compiler is not likely to keep them in
- -- a higher precision register for their entire lifetime.
- begin
- if Report.Ident_Bool (False) then
- -- never executed
- X := X + 5.0;
- Y := Y + 6.0;
- Z := Z + 1.0;
- Eps := Eps + 2.0;
- BN := BN + 2.0;
- OneX := X + Y;
- One := 12.34; Two := 56.78; Zero := 90.12;
- end if;
- end Thwart_Optimization;
-
-
- procedure Addition_Test is
- begin
- for K in 1..10 loop
- Eps := Real (K) * Real'Model_Epsilon;
- for N in 1.. Real'Machine_EMax - 1 loop
- BN := Real(Real'Machine_Radix) ** N;
- X := (One + Eps) * BN;
- Y := (One - Eps) * BN;
- Z := X - Y; -- true value for Z is 2*Eps*BN
-
- if Z /= Eps*BN + Eps*BN then
- Report.Failed ("addition check failed. K=" &
- Integer'Image (K) &
- " N=" & Integer'Image (N) &
- " difference=" & Real'Image (Z - 2.0*Eps*BN) &
- " Eps*BN=" & Real'Image (Eps*BN) );
- Failure_Count := Failure_Count + 1;
- exit when Failure_Count > K*4; -- Avoid displaying dozens of messages.
- end if;
- end loop;
- end loop;
- exception
- when others =>
- Thwart_Optimization;
- Report.Failed ("unexpected exception in addition test");
- end Addition_Test;
-
-
- procedure Multiplication_Test is
- begin
- X := Real (Real'Machine_Radix) ** (Real'Machine_EMax - 1);
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for large values");
- end if;
-
- X := Real (Real'Machine_Radix) ** (Real'Model_EMin + 1);
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for small values");
- end if;
-
- -- selection of "random" values between 1/radix and radix
- Y := One / Real (Real'Machine_Radix);
- Z := Real(Real'Machine_Radix) - One/Real(Real'Machine_Radix);
- for I in 0..100 loop
- X := Y + Real (I) / 100.0 * Z;
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for case" & Integer'Image (I));
- exit when Failure_Count > 40+8; -- Avoid displaying dozens of messages.
- end if;
- end loop;
- exception
- when others =>
- Thwart_Optimization;
- Report.Failed ("unexpected exception in multiplication test");
- end Multiplication_Test;
-
-
- procedure Do_Test is
- begin
- Addition_Test;
- Multiplication_Test;
- end Do_Test;
- end Guard_Digit_Check;
-
- package Chk_Float is new Guard_Digit_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Guard_Digit_Check (A_Long_Float);
-begin
- Report.Test ("CXG2005",
- "Check the accuracy of floating point" &
- " addition and multiplication");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2005;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a
deleted file mode 100644
index da15dc3..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- CXG2006.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 complex Argument function returns
--- results that are within the error bound allowed.
--- Check that Argument_Error is raised if the Cycle parameter
--- is less than or equal to zero.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Argument function.
--- Of special interest is the case where either the real or
--- the imaginary part of the parameter is very large while the
--- other part is very small or 0.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 15 FEB 96 SAIC Initial release for 2.1
--- 03 MAR 97 PWB.CTA Removed checks involving explicit cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- Reference:
--- Problems and Methodologies in Mathematical Software Production;
--- editors: P. C. Messina and A Murli;
--- Lecture Notes in Computer Science
--- Volume 142
--- Springer Verlag 1982
---
-
-with System;
-with Report;
-with ImpDef.Annex_G;
-with Ada.Numerics;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-procedure CXG2006 is
- Verbose : constant Boolean := False;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Cases is
- type Data_Point is
- record
- Re,
- Im,
- Radians,
- Degrees,
- Error_Bound : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions to minimize errors in precision introduced by the
- -- test. For cases where Pi is used in the argument we must
- -- allow an extra 1.0*MRE to account for roundoff error in the
- -- argument. Where the result involves a square root we allow
- -- an extra 0.5*MRE to allow for roundoff error.
- Test_Data : constant Test_Data_Type := (
--- Re Im Radians Degrees Err Test #
- (0.0, 0.0, 0.0, 0.0, 4.0 ), -- 1
- (1.0, 0.0, 0.0, 0.0, 4.0 ), -- 2
- (Real'Safe_Last, 0.0, 0.0, 0.0, 4.0 ), -- 3
- (Real'Model_Small, 0.0, 0.0, 0.0, 4.0 ), -- 4
- (1.0, 1.0, Pi/4.0, 45.0, 5.0 ), -- 5
- (1.0, -1.0, -Pi/4.0, -45.0, 5.0 ), -- 6
- (-1.0, -1.0, -3.0*Pi/4.0,-135.0, 5.0 ), -- 7
- (-1.0, 1.0, 3.0*Pi/4.0, 135.0, 5.0 ), -- 8
- (Sqrt3, 1.0, Pi/6.0, 30.0, 5.5 ), -- 9
- (-Sqrt3, 1.0, 5.0*Pi/6.0, 150.0, 5.5 ), -- 10
- (Sqrt3, -1.0, -Pi/6.0, -30.0, 5.5 ), -- 11
- (-Sqrt3, -1.0, -5.0*Pi/6.0,-150.0, 5.5 ), -- 12
- (Real'Model_Small, Real'Model_Small, Pi/4.0, 45.0, 5.0 ), -- 13
- (-Real'Safe_Last, 0.0, Pi, 180.0, 5.0 ), -- 14
- (-Real'Safe_Last, -Real'Model_Small, -Pi,-180.0, 5.0 ), -- 15
- (100000.0, 100000.0, Pi/4.0, 45.0, 5.0 )); -- 16
-
- X : Real;
- Z : Complex;
- begin
- for I in Test_Data'Range loop
- begin
- Z := (Test_Data(I).Re, Test_Data(I).Im);
- X := Argument (Z);
- Check (X, Test_Data(I).Radians,
- "test" & Integer'Image (I) & " argument(z)",
- Test_Data (I).Error_Bound);
---pwb-math X := Argument (Z, 2.0*Pi);
---pwb-math Check (X, Test_Data(I).Radians,
---pwb-math "test" & Integer'Image (I) & " argument(z, 2pi)",
---pwb-math Test_Data (I).Error_Bound);
- X := Argument (Z, 360.0);
- Check (X, Test_Data(I).Degrees,
- "test" & Integer'Image (I) & " argument(z, 360)",
- Test_Data (I).Error_Bound);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test" &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in test" &
- Integer'Image (I));
- end;
- end loop;
-
- if Real'Signed_Zeros then
- begin
- X := Argument ((-1.0, Real(ImpDef.Annex_G.Negative_Zero)));
- Check (X, -Pi, "test of arg((-1,-0)", 4.0);
- exception
- when others =>
- Report.Failed ("exception in signed zero test");
- end;
- end if;
- end Special_Cases;
-
-
- procedure Exception_Cases is
- -- check that Argument_Error is raised if Cycle is <= 0
- Z : Complex := (1.0, 1.0);
- X : Real;
- Y : Real;
- begin
- begin
- X := Argument (Z, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin
- Y := Argument (Z, Cycle => -3.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- if Report.Ident_Int (2) = 1 then
- -- optimization thwarting code - never executed
- Report.Failed("2=1" & Real'Image (X+Y));
- end if;
- end Exception_Cases;
-
-
- procedure Do_Test is
- begin
- Special_Cases;
- Exception_Cases;
- end Do_Test;
- end Generic_Check;
-
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2006",
- "Check the accuracy of the complex argument" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2006;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a
deleted file mode 100644
index ba07df2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXG2007.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 complex Compose_From_Polar function returns
--- results that are within the error bound allowed.
--- Check that Argument_Error is raised if the Cycle parameter
--- is less than or equal to zero.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Compose_From_Polar function.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 23 FEB 96 SAIC Initial release for 2.1
--- 23 APR 96 SAIC Fixed error checking
--- 03 MAR 97 PWB.CTA Deleted checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with System;
-with Report;
-with Ada.Numerics;
-with Ada.Numerics.Generic_Complex_Types;
-procedure CXG2007 is
- Verbose : constant Boolean := False;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- Maximum_Relative_Error : constant Real := 3.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Arg_Error : Real) is
- -- Arg_Error is additional absolute error that is allowed beyond
- -- the MRE to account for error in the result that can be
- -- attributed to error in the arguments.
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- Max_Error := Max_Error + Arg_Error;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real;
- Arg_Error : Real) is
- -- Arg_Error is additional absolute error that is allowed beyond
- -- the MRE to account for error in the result that can be
- -- attributed to error in the arguments.
- begin
- Check (Actual.Re, Expected.Re,
- Test_Name & " real part",
- MRE, Arg_Error);
- Check (Actual.Im, Expected.Im,
- Test_Name & " imaginary part",
- MRE, Arg_Error);
- end Check;
-
-
- procedure Special_Cases is
- type Data_Point is
- record
- Re,
- Im,
- Modulus,
- Radians,
- Degrees,
- Arg_Error : Real;
- end record;
-
- -- shorthand names for various constants
- P4 : constant := Pi/4.0;
- P6 : constant := Pi/6.0;
-
- MER2 : constant Real := Real'Model_Epsilon * Sqrt2;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions so no loss of precision occurs.
- Test_Data : constant Test_Data_Type := (
- --Re Im Modulus Radians Degrees Arg_Err
- ( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ), -- 1
- ( 0.0, 0.0, 0.0, Pi, 180.0, 0.0 ), -- 2
-
- ( 1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ), -- 3
- (-1.0, 0.0, -1.0, 0.0, 0.0, 0.0 ), -- 4
-
- ( 1.0, 1.0, Sqrt2, P4, 45.0, MER2), -- 5
- (-1.0, 1.0, -Sqrt2, -P4, -45.0, MER2), -- 6
- ( 1.0, -1.0, Sqrt2, -P4, -45.0, MER2), -- 7
- (-1.0, -1.0, -Sqrt2, P4, 45.0, MER2), -- 8
- (-1.0, -1.0, Sqrt2, -3.0*P4,-135.0, MER2), -- 9
- (-1.0, 1.0, Sqrt2, 3.0*P4, 135.0, MER2), -- 10
- ( 1.0, -1.0, -Sqrt2, 3.0*P4, 135.0, MER2), -- 11
-
- (-1.0, 0.0, 1.0, Pi, 180.0, 0.0 ), -- 12
- ( 1.0, 0.0, -1.0, Pi, 180.0, 0.0 ) ); -- 13
-
-
- Z : Complex;
- Exp : Complex;
- begin
- for I in Test_Data'Range loop
- begin
- Exp := (Test_Data (I).Re, Test_Data (I).Im);
-
- Z := Compose_From_Polar (Test_Data (I).Modulus,
- Test_Data (I).Radians);
- Check (Z, Exp,
- "test" & Integer'Image (I) & " compose_from_polar(m,r)",
- Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
---pwb-math Z := Compose_From_Polar (Test_Data (I).Modulus,
---pwb-math Test_Data (I).Radians,
---pwb-math 2.0*Pi);
---pwb-math Check (Z, Exp,
---pwb-math "test" & Integer'Image (I) & " compose_from_polar(m,r,2pi)",
---pwb-math Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
- Z := Compose_From_Polar (Test_Data (I).Modulus,
- Test_Data (I).Degrees,
- 360.0);
- Check (Z, Exp,
- "test" & Integer'Image (I) & " compose_from_polar(m,d,360)",
- Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test" &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in test" &
- Integer'Image (I));
- end;
- end loop;
- end Special_Cases;
-
-
- procedure Exception_Cases is
- -- check that Argument_Error is raised if Cycle is <= 0
- Z : Complex;
- W : Complex;
- begin
- begin
- Z := Compose_From_Polar (3.0, 0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin
- W := Compose_From_Polar (6.0, 1.0, Cycle => -10.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- if Report.Ident_Int (1) = 2 then
- -- not executed - used to make it appear that we use the
- -- results of the above computation
- Z := Z * W;
- Report.Failed(Real'Image (Z.Re + Z.Im));
- end if;
- end Exception_Cases;
-
-
- procedure Do_Test is
- begin
- Special_Cases;
- Exception_Cases;
- end Do_Test;
- end Generic_Check;
-
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2007",
- "Check the accuracy of the Compose_From_Polar" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2007;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a
deleted file mode 100644
index 58cf367f6..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a
+++ /dev/null
@@ -1,948 +0,0 @@
--- CXG2008.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 complex multiplication and division
--- operations return results that are within the allowed
--- error bound.
--- Check that all the required pure Numerics packages are pure.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- complex types package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 24 FEB 96 SAIC Initial release for 2.1
--- 03 JUN 98 EDS Correct the test program's incorrect assumption
--- that Constraint_Error must be raised by complex
--- division by zero, which is contrary to the
--- allowance given by the Ada 95 standard G.1.1(40).
--- 13 MAR 01 RLB Replaced commented out Pure check on non-generic
--- packages, as required by Defect Report
--- 8652/0020 and as reflected in Technical
--- Corrigendum 1.
---!
-
-------------------------------------------------------------------------------
--- Check that the required pure packages are pure by withing them from a
--- pure package. The non-generic versions of those packages are required to
--- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and
--- G.1.1(25/1)].
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with Ada.Numerics.Complex_Elementary_Functions;
-package CXG2008_0 is
- pragma Pure;
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-end CXG2008_0;
-
-------------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-with CXG2008_0; use CXG2008_0;
-procedure CXG2008 is
- Verbose : constant Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
-
- package A_Long_Float_Check is
- type A_Long_Float is digits System.Max_Digits;
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
-
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
-
- use Ada.Numerics.Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2008",
- "Check the accuracy of the complex multiplication and" &
- " division operators");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2008;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a
deleted file mode 100644
index 0b11ca5..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a
+++ /dev/null
@@ -1,421 +0,0 @@
--- CXG2009.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 real sqrt and complex modulus functions
--- return results that are within the allowed
--- error bound.
---
--- TEST DESCRIPTION:
--- This test checks the accuracy of the sqrt and modulus functions
--- by computing the norm of various vectors where the result
--- is known in advance.
--- This test uses real and complex math together as would an
--- actual application. Considerable use of generics is also
--- employed.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 26 FEB 96 SAIC Initial release for 2.1
--- 22 AUG 96 SAIC Revised Check procedure
---
---!
-
-------------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2009 is
- Verbose : constant Boolean := False;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Real_Norm_Check is
- procedure Do_Test;
- end Generic_Real_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Real_Norm_Check is
- type Vector is array (Integer range <>) of Real;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames GEF.Sqrt;
-
- function One_Norm (V : Vector) return Real is
- -- sum of absolute values of the elements of the vector
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- Result := Result + abs V(I);
- end loop;
- return Result;
- end One_Norm;
-
- function Inf_Norm (V : Vector) return Real is
- -- greatest absolute vector element
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- if abs V(I) > Result then
- Result := abs V(I);
- end if;
- end loop;
- return Result;
- end Inf_Norm;
-
- function Two_Norm (V : Vector) return Real is
- -- if greatest absolute vector element is 0 then return 0
- -- else return greatest * sqrt (sum((element / greatest) ** 2)))
- -- where greatest is Inf_Norm of the vector
- Inf_N : Real;
- Sum_Squares : Real;
- Term : Real;
- begin
- Inf_N := Inf_Norm (V);
- if Inf_N = 0.0 then
- return 0.0;
- end if;
- Sum_Squares := 0.0;
- for I in V'Range loop
- Term := V (I) / Inf_N;
- Sum_Squares := Sum_Squares + Term * Term;
- end loop;
- return Inf_N * Sqrt (Sum_Squares);
- end Two_Norm;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Vector_Length : Integer) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " VectLength:" &
- Integer'Image (Vector_Length) &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- Report.Comment (Test_Name & " vector length" &
- Integer'Image (Vector_Length));
- end if;
- end Check;
-
-
- procedure Do_Test is
- begin
- for Vector_Length in 1 .. 10 loop
- declare
- V : Vector (1..Vector_Length) := (1..Vector_Length => 0.0);
- V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0);
- begin
- Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
- Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
-
- for J in 1..Vector_Length loop
- V := (1..Vector_Length => 0.0);
- V (J) := 1.0;
- Check (One_Norm (V), 1.0, "one_norm (010)",
- 0.0, Vector_Length);
- Check (Inf_Norm (V), 1.0, "inf_norm (010)",
- 0.0, Vector_Length);
- Check (Two_Norm (V), 1.0, "two_norm (010)",
- 0.0, Vector_Length);
- end loop;
-
- Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)",
- 0.0, Vector_Length);
- Check (Inf_Norm (V1), 1.0, "inf_norm (1)",
- 0.0, Vector_Length);
-
- -- error in computing Two_Norm and expected result
- -- are as follows (ME is Model_Epsilon * Expected_Value):
- -- 2ME from expected Sqrt
- -- 2ME from Sqrt in Two_Norm times the error in the
- -- vector calculation.
- -- The vector calculation contains the following error
- -- based upon the length N of the vector:
- -- N*1ME from squaring terms in Two_Norm
- -- N*1ME from the division of each term in Two_Norm
- -- (N-1)*1ME from the sum of the terms
- -- This gives (2 + 2 * (N + N + (N-1)) ) * ME
- -- which simplifies to (2 + 2N + 2N + 2N - 2) * ME
- -- or 6*N*ME
- Check (Two_Norm (V1), Sqrt (Real(Vector_Length)),
- "two_norm (1)",
- (Real (6 * Vector_Length)),
- Vector_Length);
- exception
- when others => Report.Failed ("exception for vector length" &
- Integer'Image (Vector_Length) );
- end;
- end loop;
- end Do_Test;
- end Generic_Real_Norm_Check;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Complex_Norm_Check is
- procedure Do_Test;
- end Generic_Complex_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Complex_Norm_Check is
- package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
- type Vector is array (Integer range <>) of Complex;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames GEF.Sqrt;
-
- function One_Norm (V : Vector) return Real is
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- Result := Result + abs V(I);
- end loop;
- return Result;
- end One_Norm;
-
- function Inf_Norm (V : Vector) return Real is
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- if abs V(I) > Result then
- Result := abs V(I);
- end if;
- end loop;
- return Result;
- end Inf_Norm;
-
- function Two_Norm (V : Vector) return Real is
- Inf_N : Real;
- Sum_Squares : Real;
- Term : Real;
- begin
- Inf_N := Inf_Norm (V);
- if Inf_N = 0.0 then
- return 0.0;
- end if;
- Sum_Squares := 0.0;
- for I in V'Range loop
- Term := abs (V (I) / Inf_N );
- Sum_Squares := Sum_Squares + Term * Term;
- end loop;
- return Inf_N * Sqrt (Sum_Squares);
- end Two_Norm;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Vector_Length : Integer) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " VectLength:" &
- Integer'Image (Vector_Length) &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- Report.Comment (Test_Name & " vector length" &
- Integer'Image (Vector_Length));
- end if;
- end Check;
-
-
- procedure Do_Test is
- begin
- for Vector_Length in 1 .. 10 loop
- declare
- V : Vector (1..Vector_Length) :=
- (1..Vector_Length => (0.0, 0.0));
- X, Y : Vector (1..Vector_Length);
- begin
- Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
- Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
-
- for J in 1..Vector_Length loop
- X := (1..Vector_Length => (0.0, 0.0) );
- Y := X; -- X and Y are now both zeroed
- X (J).Re := 1.0;
- Y (J).Im := 1.0;
- Check (One_Norm (X), 1.0, "one_norm (0x0)",
- 0.0, Vector_Length);
- Check (Inf_Norm (X), 1.0, "inf_norm (0x0)",
- 0.0, Vector_Length);
- Check (Two_Norm (X), 1.0, "two_norm (0x0)",
- 0.0, Vector_Length);
- Check (One_Norm (Y), 1.0, "one_norm (0y0)",
- 0.0, Vector_Length);
- Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)",
- 0.0, Vector_Length);
- Check (Two_Norm (Y), 1.0, "two_norm (0y0)",
- 0.0, Vector_Length);
- end loop;
-
- V := (1..Vector_Length => (3.0, 4.0));
-
- -- error in One_Norm is 3*N*ME for abs computation +
- -- (N-1)*ME for the additions
- -- which gives (4N-1) * ME
- Check (One_Norm (V), 5.0 * Real (Vector_Length),
- "one_norm ((3,4))",
- Real (4*Vector_Length - 1),
- Vector_Length);
-
- -- error in Inf_Norm is from abs of single element (3ME)
- Check (Inf_Norm (V), 5.0,
- "inf_norm ((3,4))",
- 3.0,
- Vector_Length);
-
- -- error in following comes from:
- -- 2ME in sqrt of expected result
- -- 3ME in Inf_Norm calculation
- -- 2ME in sqrt of vector calculation
- -- vector calculation has following error
- -- 3N*ME for abs
- -- N*ME for squaring
- -- N*ME for division
- -- (N-1)ME for sum
- -- this results in [2 + 3 + 2(6N-1) ] * ME
- -- or (12N + 3)ME
- Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)),
- "two_norm ((3,4))",
- (12.0 * Real (Vector_Length) + 3.0),
- Vector_Length);
- exception
- when others => Report.Failed ("exception for complex " &
- "vector length" &
- Integer'Image (Vector_Length) );
- end;
- end loop;
- end Do_Test;
- end Generic_Complex_Norm_Check;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Norm_Check is
- procedure Do_Test;
- end Generic_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Norm_Check is
- package RNC is new Generic_Real_Norm_Check (Real);
- package CNC is new Generic_Complex_Norm_Check (Real);
- procedure Do_Test is
- begin
- RNC.Do_Test;
- CNC.Do_Test;
- end Do_Test;
- end Generic_Norm_Check;
-
- --=====================================================================
-
- package Float_Check is new Generic_Norm_Check (Float);
-
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2009",
- "Check the accuracy of the real sqrt and complex " &
- " modulus functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- Report.Result;
-end CXG2009;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a
deleted file mode 100644
index 4140a48..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a
+++ /dev/null
@@ -1,892 +0,0 @@
--- CXG2010.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 exp function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- elementary functions package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex and where the Machine_Radix is 2, 4, 8, or 16.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Mar 96 SAIC Initial release for 2.1
--- 2 Sep 96 SAIC Improved check routine
---
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
---
--- Notes on derivation of error bound for exp(p)*exp(-p)
---
--- Let a = true value of exp(p) and ac be the computed value.
--- Then a = ac(1+e1), where |e1| <= 4*Model_Epsilon.
--- Similarly, let b = true value of exp(-p) and bc be the computed value.
--- Then b = bc(1+e2), where |e2| <= 4*ME.
---
--- The product of x and y is (x*y)(1+e3), where |e3| <= 1.0ME
---
--- Hence, the computed ab is [ac(1+e1)*bc(1+e2)](1+e3) =
--- (ac*bc)[1 + e1 + e2 + e3 + e1e2 + e1e3 + e2e3 + e1e2e3).
---
--- Throwing away the last four tiny terms, we have (ac*bc)(1 + eta),
---
--- where |eta| <= (4+4+1)ME = 9.0Model_Epsilon.
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2010 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
- Accuracy_Error_Reported : Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
-
-
- package A_Long_Float_Check is
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- procedure Do_Test;
- subtype Real is Float;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
-
- package Elementary_Functions renames
- Ada.Numerics.Elementary_Functions;
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2010",
- "Check the accuracy of the exp function");
-
- -- the test only applies to machines with a radix of 2,4,8, or 16
- case Float'Machine_Radix is
- when 2 | 4 | 8 | 16 => null;
- when others =>
- Report.Not_Applicable ("only applicable to binary radix");
- Report.Result;
- return;
- end case;
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2010;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a
deleted file mode 100644
index 2c018b1..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a
+++ /dev/null
@@ -1,490 +0,0 @@
--- CXG2011.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 log function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks in a range where a Taylor series can be used to compute
--- the expected result.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Mar 96 SAIC Initial release for 2.1
--- 22 Aug 96 SAIC Improved Check routine
--- 02 DEC 97 EDS Log (0.0) must raise Constraint_Error,
--- not Argument_Error
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2011 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Handbook Page 738
- Ln10 : constant := 2.30258_50929_94045_68401_79914_54684_36420_76011_01489;
- Ln2 : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755_00134;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real'Base) return Real'Base renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real'Base) return Real'Base renames
- Elementary_Functions.Exp;
- function Log (X : Real'Base) return Real'Base renames
- Elementary_Functions.Log;
- function Log (X, Base : Real'Base) return Real'Base renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Log(1.0);
- Check (Y, 0.0, "special value test 1 -- log(1)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Log(10.0);
- Check (Y, Ln10, "special value test 2 -- log(10)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Log (2.0);
- Check (Y, Ln2, "special value test 3 -- log(2)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Log (2.0 ** 18, 2.0);
- Check (Y, 18.0, "special value test 4 -- log(2**18,2)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
- end Special_Value_Test;
-
-
- procedure Taylor_Series_Test is
- -- Use a 4 term taylor series expansion to check a selection of
- -- arguments very near 1.0.
- -- The range is chosen so that the 4 term taylor series will
- -- provide accuracy to machine precision. Cody pg 49-50.
- Half_Range : constant Real := Real'Model_Epsilon * 50.0;
- A : constant Real := 1.0 - Half_Range;
- B : constant Real := 1.0 + Half_Range;
- X : Real;
- Xm1 : Real;
- Expected : Real;
- Actual : Real;
-
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Xm1 := X - 1.0;
- -- The following is the first 4 terms of the taylor series
- -- that has been rearranged to minimize error in the calculation
- Expected := (Xm1 * (1.0/3.0 - Xm1/4.0) - 0.5) * Xm1 * Xm1 + Xm1;
-
- Actual := Log (X);
- Check (Actual, Expected,
- "Taylor Series Test -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Taylor Series Test");
- when others =>
- Report.Failed ("exception in Taylor Series Test");
- end Taylor_Series_Test;
-
-
-
- procedure Log_Difference_Identity is
- -- Check using the identity ln(x) = ln(17x/16) - ln(17/16)
- -- over the range A to B.
- -- The selected range assures that both X and 17x/16 will
- -- have the same exponents and neither argument gets too close
- -- to 1. Cody pg 50.
- A : constant Real := 1.0 / Sqrt (2.0);
- B : constant Real := 15.0 / 16.0;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- magic argument purification
- X := Real'Machine (Real'Machine (X+8.0) - 8.0);
-
- Expected := Log (X + X / 16.0) - Log (17.0/16.0);
-
- Actual := Log (X);
- Check (Actual, Expected,
- "Log Difference Identity -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log Difference Identity Test");
- when others =>
- Report.Failed ("exception in Log Difference Identity Test");
- end Log_Difference_Identity;
-
-
- procedure Log_Product_Identity is
- -- Check using the identity ln(x**2) = 2ln(x)
- -- over the range A to B.
- -- This large range is chosen to minimize the possibility of
- -- undetected systematic errors. Cody pg 53.
- A : constant Real := 16.0;
- B : constant Real := 240.0;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- magic argument purification
- X := Real'Machine (Real'Machine (X+8.0) - 8.0);
-
- Expected := 2.0 * Log (X);
-
- Actual := Log (X*X);
- Check (Actual, Expected,
- "Log Product Identity -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log Product Identity Test");
- when others =>
- Report.Failed ("exception in Log Product Identity Test");
- end Log_Product_Identity;
-
-
- procedure Log10_Test is
- -- Check using the identity log(x) = log(11x/10) - log(1.1)
- -- over the range A to B. See Cody pg 52.
- A : constant Real := 1.0 / Sqrt (10.0);
- B : constant Real := 0.9;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- if Real'Digits > 17 then
- -- constant used below is accuract to 17 digits
- Error_Low_Bound := 0.00000_00000_00000_01;
- Report.Comment ("log accuracy checked to 19 digits");
- end if;
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Expected := Log (X + X/10.0, 10.0)
- - 3.77060_15822_50407_5E-4 - 21.0 / 512.0;
-
- Actual := Log (X, 10.0);
- Check (Actual, Expected,
- "Log 10 Test -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
-
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- exit when Accuracy_Error_Reported;
- end loop;
- Error_Low_Bound := 0.0; -- reset
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log 10 Test");
- when others =>
- Report.Failed ("exception in Log 10 Test");
- end Log10_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4 : Real;
- begin
- begin
- X1 := Log (0.0);
- Report.Failed ("exception not raised for LOG(0)");
- exception
- -- Log (0.0) must raise Constraint_Error, not Argument_Error,
- -- as per A.5.1(28,29). Was incorrect in ACVC 2.1 release.
- when Ada.Numerics.Argument_Error =>
- Report.Failed ("Argument_Error raised instead of" &
- " Constraint_Error for LOG(0)--A.5.1(28,29)");
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for LOG(0)");
- end;
-
- begin
- X2 := Log ( 1.0, 0.0);
- Report.Failed ("exception not raised for LOG(1,0)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,0)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,0)");
- end;
-
- begin
- X3 := Log (1.0, 1.0);
- Report.Failed ("exception not raised for LOG(1,1)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,1)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,1)");
- end;
-
- begin
- X4 := Log (1.0, -10.0);
- Report.Failed ("exception not raised for LOG(1,-10)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,-10)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,-10)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Taylor_Series_Test;
- Log_Difference_Identity;
- Log_Product_Identity;
- Log10_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2011",
- "Check the accuracy of the log function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2011;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a
deleted file mode 100644
index 6a665d0..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a
+++ /dev/null
@@ -1,438 +0,0 @@
--- CXG2012.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 exponentiation operator returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
--- While this test concentrates on the "**" operator
--- defined in Generic_Elementary_Functions, a check is also
--- performed on the standard "**" operator.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 7 Mar 96 SAIC Initial release for 2.1
--- 2 Sep 96 SAIC Improvements as suggested by reviewers
--- 3 Jun 98 EDS Add parens to ensure that the expression is not
--- evaluated by multiplying its two large terms
--- together and overflowing.
--- 3 Dec 01 RLB Added 'Machine to insure that equality tests
--- are certain to work.
---
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2012 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function "**" (L, R : Real) return Real renames
- Elementary_Functions."**";
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- -- the following version of Check computes the allowed error bound
- -- using the operands
- procedure Check (Actual, Expected : Real;
- Left, Right : Real;
- Test_Name : String;
- MRE_Factor : Real := 1.0) is
- MRE : Real;
- begin
- MRE := MRE_Factor * (4.0 + abs (Right * Log(Left)) / 32.0);
- Check (Actual, Expected, Test_Name, MRE);
- end Check;
-
-
- procedure Real_To_Integer_Test is
- type Int_Check is
- record
- Left : Real;
- Right : Integer;
- Expected : Real;
- end record;
- type Int_Checks is array (Positive range <>) of Int_Check;
-
- -- the following tests use only model numbers so the result
- -- is expected to be exact.
- IC : constant Int_Checks :=
- ( ( 2.0, 5, 32.0),
- ( -2.0, 5, -32.0),
- ( 0.5, -5, 32.0),
- ( 2.0, 0, 1.0),
- ( 0.0, 0, 1.0) );
- begin
- for I in IC'Range loop
- declare
- Y : Real;
- begin
- Y := IC (I).Left ** IC (I).Right;
- Check (Y, IC (I).Expected,
- "real to integer test" &
- Real'Image (IC (I).Left) & " ** " &
- Integer'Image (IC (I).Right),
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in rtoi test " &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in rtoi test " &
- Integer'Image (I));
- end;
- end loop;
- end Real_To_Integer_Test;
-
-
- procedure Special_Value_Test is
- No_Error : constant := 0.0;
- begin
- Check (0.0 ** 1.0, 0.0, "0**1", No_Error);
- Check (1.0 ** 0.0, 1.0, "1**0", No_Error);
-
- Check ( 2.0 ** 5.0, 32.0, 2.0, 5.0, "2**5");
- Check ( 0.5**(-5.0), 32.0, 0.5, -5.0, "0.5**-5");
-
- Check (Sqrt2 ** 4.0, 4.0, Sqrt2, 4.0, "Sqrt2**4");
- Check (Sqrt3 ** 6.0, 27.0, Sqrt3, 6.0, "Sqrt3**6");
-
- Check (2.0 ** 0.5, Sqrt2, 2.0, 0.5, "2.0**0.5");
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Special Value Test");
- when others =>
- Report.Failed ("exception in Special Value Test");
- end Special_Value_Test;
-
-
- procedure Small_Range_Test is
- -- Several checks over the range 1/radix .. 1
- A : constant Real := 1.0 / Real (Real'Machine_Radix);
- B : constant Real := 1.0;
- X : Real;
- -- In the cases below where the expected result is
- -- inexact we allow an additional error amount of
- -- 1.0 * Model_Epsilon to account for that error.
- -- This is accomplished by the factor of 1.25 times
- -- the computed error bound (which is > 4.0) thus
- -- increasing the error bound by at least
- -- 1.0 * Model_Epsilon
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- X := Real'Machine((B - A) * Real (I) / Real (Max_Samples) + A);
-
- Check (X ** 1.0, X, -- exact result required
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 1.0",
- 0.0);
-
- Check ((X*X) ** 1.5, X**3, X*X, 1.5,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.5",
- 1.25);
-
- Check (X ** 13.5, 1.0 / (X ** (-13.5)), X, 13.5,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 13.5",
- 2.0); -- 2 ** computations
-
- Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.25",
- 2.0); -- 2 ** computations
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Small Range Test");
- when others =>
- Report.Failed ("exception in Small Range Test");
- end Small_Range_Test;
-
-
- procedure Large_Range_Test is
- -- Check over the range A to B where A is 1.0 and
- -- B is a large value.
- A : constant Real := 1.0;
- B : Real;
- X : Real;
- Iteration : Integer := 0;
- Subtest : Character := 'X';
- begin
- -- upper bound of range should be as large as possible where
- -- B**3 is still valid.
- B := Real'Safe_Last ** 0.333;
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- Iteration := I;
- Subtest := 'X';
- X := Real'Machine((B - A) * (Real (I) / Real (Max_Samples)) + A);
-
- Subtest := 'A';
- Check (X ** 1.0, X, -- exact result required
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 1.0",
- 0.0);
-
- Subtest := 'B';
- Check ((X*X) ** 1.5, X**3, X*X, 1.5,
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.5",
- 1.25); -- inexact expected result
-
- Subtest := 'C';
- Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.25",
- 2.0); -- two ** operators
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Large Range Test" &
- Integer'Image (Iteration) & Subtest);
- when others =>
- Report.Failed ("exception in Large Range Test" &
- Integer'Image (Iteration) & Subtest);
- end Large_Range_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4 : Real;
- begin
- begin
- X1 := 0.0 ** (-1.0);
- Report.Failed ("exception not raised for 0**-1");
- exception
- when Ada.Numerics.Argument_Error =>
- Report.Failed ("argument_error raised instead of" &
- " constraint_error for 0**-1");
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for 0**-1");
- end;
-
- begin
- X2 := 0.0 ** 0.0;
- Report.Failed ("exception not raised for 0**0");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for 0**0");
- when others =>
- Report.Failed ("wrong exception raised for 0**0");
- end;
-
- begin
- X3 := (-1.0) ** 1.0;
- Report.Failed ("exception not raised for -1**1");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for -1**1");
- when others =>
- Report.Failed ("wrong exception raised for -1**1");
- end;
-
- begin
- X4 := (-2.0) ** 2.0;
- Report.Failed ("exception not raised for -2**2");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for -2**2");
- when others =>
- Report.Failed ("wrong exception raised for -2**2");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Real_To_Integer_Test;
- Special_Value_Test;
- Small_Range_Test;
- Large_Range_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2012",
- "Check the accuracy of the ** operator");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2012;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a
deleted file mode 100644
index 94f180b..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- CXG2013.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 TAN and COT functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 11 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Commentary fixes.
--- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 02 DEC 97 EDS Change Max_Samples constant to 1001.
--- 29 JUN 98 EDS Deleted Special_Angle_Test as fatally flawed.
-
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2013 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1001;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Tan (X : Real) return Real renames
- Elementary_Functions.Tan;
- function Cot (X : Real) return Real renames
- Elementary_Functions.Cot;
- function Tan (X, Cycle : Real) return Real renames
- Elementary_Functions.Tan;
- function Cot (X, Cycle : Real) return Real renames
- Elementary_Functions.Cot;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- factor to be applied in computing MRE
- Maximum_Relative_Error : constant Real := 4.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Tan (0.0), 0.0, "tan(0)", No_Error);
-
- -- A.5.1(41);6.0
- Check (Tan (180.0, 360.0), 0.0, "tan(180,360)", No_Error);
- Check (Tan (360.0, 360.0), 0.0, "tan(360,360)", No_Error);
- Check (Tan (720.0, 360.0), 0.0, "tan(720,360)", No_Error);
-
- -- A.5.1(41);6.0
- Check (Cot ( 90.0, 360.0), 0.0, "cot( 90,360)", No_Error);
- Check (Cot (270.0, 360.0), 0.0, "cot(270,360)", No_Error);
- Check (Cot (810.0, 360.0), 0.0, "cot(810,360)", No_Error);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Tan_Test (A, B : Real) is
- -- Use identity Tan(X) = [2*Tan(x/2)]/[1-Tan(x/2) ** 2]
- -- checks over the range -pi/4 .. pi/4 require no argument reduction
- -- checks over the range 7pi/8 .. 9pi/8 require argument reduction
- X, Y : Real;
- Actual1, Actual2 : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- argument purification to insure x and x/2 are exact
- -- See Cody page 170.
- Y := Real'Machine (X*0.5);
- X := Real'Machine (Y + Y);
-
- Actual1 := Tan(X);
- Actual2 := (2.0 * Tan (Y)) / (1.0 - Tan (Y) ** 2);
-
- if abs (X - Pi) > ( (B-A)/Real(2*Max_Samples) ) then
- Check (Actual1, Actual2,
- "Tan_Test " & Integer'Image (I) & ": tan(" &
- Real'Image (X) & ") ",
- (1.0 + Sqrt2) * Maximum_Relative_Error);
- -- see Cody pg 165 for error bound info
- end if;
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Tan_Test");
- when others =>
- Report.Failed ("exception in Tan_Test");
- end Tan_Test;
-
-
-
- procedure Cot_Test is
- -- Use identity Cot(X) = [Cot(X/2)**2 - 1]/[2*Cot(X/2)]
- A : constant := 6.0 * Pi;
- B : constant := 25.0 / 4.0 * Pi;
- X, Y : Real;
- Actual1, Actual2 : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- argument purification to insure x and x/2 are exact.
- -- See Cody page 170.
- Y := Real'Machine (X*0.5);
- X := Real'Machine (Y + Y);
-
- Actual1 := Cot(X);
- Actual2 := (Cot (Y) ** 2 - 1.0) / (2.0 * Cot (Y));
-
- Check (Actual1, Actual2,
- "Cot_Test " & Integer'Image (I) & ": cot(" &
- Real'Image (X) & ") ",
- (1.0 + Sqrt2) * Maximum_Relative_Error);
- -- see Cody pg 165 for error bound info
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Cot_Test");
- when others =>
- Report.Failed ("exception in Cot_Test");
- end Cot_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4, X5 : Real := 0.0;
- begin
-
-
- begin -- A.5.1(20);6.0
- X1 := Tan (0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin -- A.5.1(20);6.0
- X2 := Cot (1.0, Cycle => -3.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- -- the remaining tests only apply to machines that overflow
- if Real'Machine_Overflows then -- A.5.1(28);6.0
-
- begin -- A.5.1(29);6.0
- X3 := Cot (0.0);
- Report.Failed ("exception not raised for cot(0)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for cot(0)");
- end;
-
- begin -- A.5.1(31);6.0
- X4 := Tan (90.0, 360.0);
- Report.Failed ("exception not raised for tan(90,360)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for tan(90,360)");
- end;
-
- begin -- A.5.1(32);6.0
- X5 := Cot (180.0, 360.0);
- Report.Failed ("exception not raised for cot(180,360)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for cot(180,360)");
- end;
- end if;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4+X5));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Exact_Result_Test;
- Tan_Test (-Pi/4.0, Pi/4.0);
- Tan_Test (7.0*Pi/8.0, 9.0*Pi/8.0);
- Cot_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2013",
- "Check the accuracy of the TAN and COT functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2013;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a
deleted file mode 100644
index 48499a2..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a
+++ /dev/null
@@ -1,399 +0,0 @@
--- CXG2014.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 SINH and COSH functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 15 Mar 96 SAIC Initial release for 2.1
--- 03 Jun 98 EDS In line 80, change 1000 to 1024, making it a model
--- number. Add Taylor Series terms in line 281.
--- 15 Feb 99 RLB Repaired Subtraction_Error_Test to avoid precision
--- problems.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2014 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1024;
-
- E : constant := Ada.Numerics.E;
- Cosh1 : constant := (E + 1.0 / E) / 2.0; -- cosh(1.0)
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sinh (X : Real) return Real renames
- Elementary_Functions.Sinh;
- function Cosh (X : Real) return Real renames
- Elementary_Functions.Cosh;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- Minimum_Error : constant := 8.0;
- begin
- Check (Sinh (1.0),
- (E - 1.0 / E) / 2.0,
- "sinh(1)",
- Minimum_Error);
- Check (Cosh (1.0),
- Cosh1,
- "cosh(1)",
- Minimum_Error);
- Check (Sinh (2.0),
- (E * E - (1.0 / (E * E))) / 2.0,
- "sinh(2)",
- Minimum_Error);
- Check (Cosh (2.0),
- (E * E + (1.0 / (E * E))) / 2.0,
- "cosh(2)",
- Minimum_Error);
- Check (Sinh (-1.0),
- (1.0 / E - E) / 2.0,
- "sinh(-1)",
- Minimum_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Sinh (0.0), 0.0, "sinh(0)", No_Error);
- Check (Cosh (0.0), 1.0, "cosh(0)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_1_Test is
- -- For the Sinh test use the identity
- -- 2 * Sinh(x) * Cosh(1) = Sinh(x+1) + Sinh (x-1)
- -- which is transformed to
- -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
- -- where C = 1/(2*Cosh(1))
- --
- -- For the Cosh test use the identity
- -- 2 * Cosh(x) * Cosh(1) = Cosh(x+1) + Cosh(x-1)
- -- which is transformed to
- -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
- -- where C is the same as above
- --
- -- see Cody pg 230-231 for details on the error analysis.
- -- The net result is a relative error bound of 16 * Model_Epsilon.
-
- A : constant := 3.0;
- -- large upper bound but not so large as to cause Cosh(B)
- -- to overflow
- B : constant Real := Log(Real'Safe_Last) - 2.0;
- X_Minus_1, X, X_Plus_1 : Real;
- Actual1, Actual2 : Real;
- C : constant := 1.0 / (2.0 * Cosh1);
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X_Plus_1 := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Plus_1 := Real'Machine (X_Plus_1);
- X := Real'Machine (X_Plus_1 - 1.0);
- X_Minus_1 := Real'Machine (X - 1.0);
-
- -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
- Actual1 := Sinh(X);
- Actual2 := C * (Sinh(X_Plus_1) + Sinh(X_Minus_1));
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": sinh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
- Actual1 := Cosh (X);
- Actual2 := C * (Cosh(X_Plus_1) + Cosh (X_Minus_1));
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": cosh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_1_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Identity_1_Test" &
- " for X=" & Real'Image (X));
- end Identity_1_Test;
-
-
-
- procedure Subtraction_Error_Test is
- -- This test detects the error resulting from subtraction if
- -- the obvious algorithm was used for computing sinh. That is,
- -- it it is computed as (e**x - e**-x)/2.
- -- We check the result by using a Taylor series expansion that
- -- will produce a result accurate to the machine precision for
- -- the range under test.
- --
- -- The maximum relative error bound for this test is
- -- 8 for the sinh operation and 7 for the Taylor series
- -- for a total of 15 * Model_Epsilon
- A : constant := 0.0;
- B : constant := 0.5;
- X : Real;
- X_Squared : Real;
- Actual, Expected : Real;
- begin
- if Real'digits > 15 then
- return; -- The approximation below is not accurate beyond
- -- 15 digits. Adding more terms makes the error
- -- larger, so it makes the test worse for more normal
- -- values. Thus, we skip this subtest for larger than
- -- 15 digits.
- end if;
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Squared := X * X;
-
- Actual := Sinh(X);
-
- -- The Taylor series regrouped a bit
- Expected :=
- X * (1.0 + (X_Squared / 6.0) *
- (1.0 + (X_Squared/20.0) *
- (1.0 + (X_Squared/42.0) *
- (1.0 + (X_Squared/72.0) *
- (1.0 + (X_Squared/110.0) *
- (1.0 + (X_Squared/156.0)
- ))))));
-
- Check (Actual, Expected,
- "Subtraction_Error_Test " & Integer'Image (I) & ": sinh(" &
- Real'Image (X) & ") ",
- 15.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Subtraction_Error_Test");
- when others =>
- Report.Failed ("exception in Subtraction_Error_Test");
- end Subtraction_Error_Test;
-
-
- procedure Exception_Test is
- X1, X2 : Real := 0.0;
- begin
- -- this part of the test is only applicable if 'Machine_Overflows
- -- is true.
- if Real'Machine_Overflows then
-
- begin
- X1 := Sinh (Real'Safe_Last / 2.0);
- Report.Failed ("no exception for sinh overflow");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed ("wrong exception sinh overflow");
- end;
-
- begin
- X2 := Cosh (Real'Safe_Last / 2.0);
- Report.Failed ("no exception for cosh overflow");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed ("wrong exception cosh overflow");
- end;
-
- end if;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Identity_1_Test;
- Subtraction_Error_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2014",
- "Check the accuracy of the SINH and COSH functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2014;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a
deleted file mode 100644
index 50fda5e..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a
+++ /dev/null
@@ -1,686 +0,0 @@
--- CXG2015.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 ARCSIN and ARCCOS functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks in a specific range where a Taylor series can be
--- used to compute an accurate result for comparison.
--- Exception checks.
--- The Taylor series tests are a direct translation of the
--- FORTRAN code found in the reference.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 18 Mar 96 SAIC Initial release for 2.1
--- 24 Apr 96 SAIC Fixed error bounds.
--- 17 Aug 96 SAIC Added reference information and improved
--- checking for machines with more than 23
--- digits of precision.
--- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 22 Dec 99 RLB Added model range checking to "exact" results,
--- in order to avoid too strictly requiring a specific
--- result, and too weakly checking results.
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- ACM Collected Algorithms number 714
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2015 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- -- relative error bound from G.2.4(7);6.0
- Minimum_Error : constant := 4.0;
-
- generic
- type Real is digits <>;
- Half_PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI/2.0.
- Half_PI_High : in Real;-- The machine number closest to, but not less
- -- than PI/2.0.
- PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI.
- PI_High : in Real; -- The machine number closest to, but not less
- -- than PI.
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Arcsin (X : Real) return Real renames
- Elementary_Functions.Arcsin;
- function Arcsin (X, Cycle : Real) return Real renames
- Elementary_Functions.Arcsin;
- function Arccos (X : Real) return Real renames
- Elementary_Functions.ArcCos;
- function Arccos (X, Cycle : Real) return Real renames
- Elementary_Functions.ArcCos;
-
- -- needed for support
- function Log (X, Base : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
-
- type Data_Point is
- record
- Degrees,
- Radians,
- Argument,
- Error_Bound : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following tables only involve static
- -- expressions so no loss of precision occurs. However,
- -- rounding can be an issue with expressions involving Pi
- -- and square roots. The error bound specified in the
- -- table takes the sqrt error into account but not the
- -- error due to Pi. The Pi error is added in in the
- -- radians test below.
-
- Arcsin_Test_Data : constant Test_Data_Type := (
- -- degrees radians sine error_bound test #
- --( 0.0, 0.0, 0.0, 0.0 ), -- 1 - In Exact_Result_Test.
- ( 30.0, Pi/6.0, 0.5, 4.0 ), -- 2
- ( 60.0, Pi/3.0, Sqrt3/2.0, 5.0 ), -- 3
- --( 90.0, Pi/2.0, 1.0, 4.0 ), -- 4 - In Exact_Result_Test.
- --(-90.0, -Pi/2.0, -1.0, 4.0 ), -- 5 - In Exact_Result_Test.
- (-60.0, -Pi/3.0, -Sqrt3/2.0, 5.0 ), -- 6
- (-30.0, -Pi/6.0, -0.5, 4.0 ), -- 7
- ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
- (-45.0, -Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
-
- Arccos_Test_Data : constant Test_Data_Type := (
- -- degrees radians cosine error_bound test #
- --( 0.0, 0.0, 1.0, 0.0 ), -- 1 - In Exact_Result_Test.
- ( 30.0, Pi/6.0, Sqrt3/2.0, 5.0 ), -- 2
- ( 60.0, Pi/3.0, 0.5, 4.0 ), -- 3
- --( 90.0, Pi/2.0, 0.0, 4.0 ), -- 4 - In Exact_Result_Test.
- (120.0, 2.0*Pi/3.0, -0.5, 4.0 ), -- 5
- (150.0, 5.0*Pi/6.0, -Sqrt3/2.0, 5.0 ), -- 6
- --(180.0, Pi, -1.0, 4.0 ), -- 7 - In Exact_Result_Test.
- ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
- (135.0, 3.0*Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
-
- Cycle_Error,
- Radian_Error : Real;
- begin
- for I in Arcsin_Test_Data'Range loop
-
- -- note exact result requirements A.5.1(38);6.0 and
- -- G.2.4(12);6.0
- if Arcsin_Test_Data (I).Error_Bound = 0.0 then
- Cycle_Error := 0.0;
- Radian_Error := 0.0;
- else
- Cycle_Error := Arcsin_Test_Data (I).Error_Bound;
- -- allow for rounding error in the specification of Pi
- Radian_Error := Cycle_Error + 1.0;
- end if;
-
- Check (Arcsin (Arcsin_Test_Data (I).Argument),
- Arcsin_Test_Data (I).Radians,
- "test" & Integer'Image (I) &
- " arcsin(" &
- Real'Image (Arcsin_Test_Data (I).Argument) &
- ")",
- Radian_Error);
---pwb-math Check (Arcsin (Arcsin_Test_Data (I).Argument, 2.0 * Pi),
---pwb-math Arcsin_Test_Data (I).Radians,
---pwb-math "test" & Integer'Image (I) &
---pwb-math " arcsin(" &
---pwb-math Real'Image (Arcsin_Test_Data (I).Argument) &
---pwb-math ", 2pi)",
---pwb-math Cycle_Error);
- Check (Arcsin (Arcsin_Test_Data (I).Argument, 360.0),
- Arcsin_Test_Data (I).Degrees,
- "test" & Integer'Image (I) &
- " arcsin(" &
- Real'Image (Arcsin_Test_Data (I).Argument) &
- ", 360)",
- Cycle_Error);
- end loop;
-
-
- for I in Arccos_Test_Data'Range loop
-
- -- note exact result requirements A.5.1(39);6.0 and
- -- G.2.4(12);6.0
- if Arccos_Test_Data (I).Error_Bound = 0.0 then
- Cycle_Error := 0.0;
- Radian_Error := 0.0;
- else
- Cycle_Error := Arccos_Test_Data (I).Error_Bound;
- -- allow for rounding error in the specification of Pi
- Radian_Error := Cycle_Error + 1.0;
- end if;
-
- Check (Arccos (Arccos_Test_Data (I).Argument),
- Arccos_Test_Data (I).Radians,
- "test" & Integer'Image (I) &
- " arccos(" &
- Real'Image (Arccos_Test_Data (I).Argument) &
- ")",
- Radian_Error);
---pwb-math Check (Arccos (Arccos_Test_Data (I).Argument, 2.0 * Pi),
---pwb-math Arccos_Test_Data (I).Radians,
---pwb-math "test" & Integer'Image (I) &
---pwb-math " arccos(" &
---pwb-math Real'Image (Arccos_Test_Data (I).Argument) &
---pwb-math ", 2pi)",
---pwb-math Cycle_Error);
- Check (Arccos (Arccos_Test_Data (I).Argument, 360.0),
- Arccos_Test_Data (I).Degrees,
- "test" & Integer'Image (I) &
- " arccos(" &
- Real'Image (Arccos_Test_Data (I).Argument) &
- ", 360)",
- Cycle_Error);
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
- procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
- Test_Name : String) is
- -- If the expected result is not a model number, then Expected_Low is
- -- the first machine number less than the (exact) expected
- -- result, and Expected_High is the first machine number greater than
- -- the (exact) expected result. If the expected result is a model
- -- number, Expected_Low = Expected_High = the result.
- Model_Expected_Low : Real := Expected_Low;
- Model_Expected_High : Real := Expected_High;
- begin
- -- Calculate the first model number nearest to, but below (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
- -- Try the next machine number lower:
- Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
- end loop;
- -- Calculate the first model number nearest to, but above (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_High) /= Model_Expected_High loop
- -- Try the next machine number higher:
- Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
- end loop;
-
- if Actual < Model_Expected_Low or Actual > Model_Expected_High then
- Accuracy_Error_Reported := True;
- if Actual < Model_Expected_Low then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Actual - Expected_Low));
- else
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Expected_High - Actual));
- end if;
- elsif Verbose then
- Report.Comment (Test_Name & " passed");
- end if;
- end Check_Exact;
-
-
- procedure Exact_Result_Test is
- begin
- -- A.5.1(38)
- Check_Exact (Arcsin (0.0), 0.0, 0.0, "arcsin(0)");
- Check_Exact (Arcsin (0.0, 45.0), 0.0, 0.0, "arcsin(0,45)");
-
- -- A.5.1(39)
- Check_Exact (Arccos (1.0), 0.0, 0.0, "arccos(1)");
- Check_Exact (Arccos (1.0, 75.0), 0.0, 0.0, "arccos(1,75)");
-
- -- G.2.4(11-13)
- Check_Exact (Arcsin (1.0), Half_PI_Low, Half_PI_High, "arcsin(1)");
- Check_Exact (Arcsin (1.0, 360.0), 90.0, 90.0, "arcsin(1,360)");
-
- Check_Exact (Arcsin (-1.0), -Half_PI_High, -Half_PI_Low, "arcsin(-1)");
- Check_Exact (Arcsin (-1.0, 360.0), -90.0, -90.0, "arcsin(-1,360)");
-
- Check_Exact (Arccos (0.0), Half_PI_Low, Half_PI_High, "arccos(0)");
- Check_Exact (Arccos (0.0, 360.0), 90.0, 90.0, "arccos(0,360)");
-
- Check_Exact (Arccos (-1.0), PI_Low, PI_High, "arccos(-1)");
- Check_Exact (Arccos (-1.0, 360.0), 180.0, 180.0, "arccos(-1,360)");
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("Exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Arcsin_Taylor_Series_Test is
- -- the following range is chosen so that the Taylor series
- -- used will produce a result accurate to machine precision.
- --
- -- The following formula is used for the Taylor series:
- -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
- -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
- -- where xsq = x * x
- --
- A : constant := -0.125;
- B : constant := 0.125;
- X : Real;
- Y, Y_Sq : Real;
- Actual, Sum, Xm : Real;
- -- terms in Taylor series
- K : constant Integer := Integer (
- Log (
- Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
- 10.0)) + 1;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Y := X;
- Y_Sq := Y * Y;
- Sum := 0.0;
- Xm := Real (K + K + 1);
- for M in 1 .. K loop
- Sum := Y_Sq * (Sum + 1.0/Xm);
- Xm := Xm - 2.0;
- Sum := Sum * (Xm /(Xm + 1.0));
- end loop;
- Sum := Sum * Y;
- Actual := Y + Sum;
- Sum := (Y - Actual) + Sum;
- if not Real'Machine_Rounds then
- Actual := Actual + (Sum + Sum);
- end if;
-
- Check (Actual, Arcsin (X),
- "Taylor Series test" & Integer'Image (I) & ": arcsin(" &
- Real'Image (X) & ") ",
- Minimum_Error);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Arcsin_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Arcsin_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- end Arcsin_Taylor_Series_Test;
-
-
-
- procedure Arccos_Taylor_Series_Test is
- -- the following range is chosen so that the Taylor series
- -- used will produce a result accurate to machine precision.
- --
- -- The following formula is used for the Taylor series:
- -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
- -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
- -- arccos(x) = pi/2 - TS(x)
- A : constant := -0.125;
- B : constant := 0.125;
- C1, C2 : Real;
- X : Real;
- Y, Y_Sq : Real;
- Actual, Sum, Xm, S : Real;
- -- terms in Taylor series
- K : constant Integer := Integer (
- Log (
- Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
- 10.0)) + 1;
- begin
- if Real'Digits > 23 then
- -- constants in this section only accurate to 23 digits
- Error_Low_Bound := 0.00000_00000_00000_00000_001;
- Report.Comment ("arctan accuracy checked to 23 digits");
- end if;
-
- -- C1 + C2 equals Pi/2 accurate to 23 digits
- if Real'Machine_Radix = 10 then
- C1 := 1.57;
- C2 := 7.9632679489661923132E-4;
- else
- C1 := 201.0 / 128.0;
- C2 := 4.8382679489661923132E-4;
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Y := X;
- Y_Sq := Y * Y;
- Sum := 0.0;
- Xm := Real (K + K + 1);
- for M in 1 .. K loop
- Sum := Y_Sq * (Sum + 1.0/Xm);
- Xm := Xm - 2.0;
- Sum := Sum * (Xm /(Xm + 1.0));
- end loop;
- Sum := Sum * Y;
-
- -- at this point we have arcsin(x).
- -- We compute arccos(x) = pi/2 - arcsin(x).
- -- The following code segment is translated directly from
- -- the CELEFUNT FORTRAN implementation
-
- S := C1 + C2;
- Sum := ((C1 - S) + C2) - Sum;
- Actual := S + Sum;
- Sum := ((S - Actual) + Sum) - Y;
- S := Actual;
- Actual := S + Sum;
- Sum := (S - Actual) + Sum;
-
- if not Real'Machine_Rounds then
- Actual := Actual + (Sum + Sum);
- end if;
-
- Check (Actual, Arccos (X),
- "Taylor Series test" & Integer'Image (I) & ": arccos(" &
- Real'Image (X) & ") ",
- Minimum_Error);
-
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- exit when Accuracy_Error_Reported;
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Arccos_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Arccos_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- end Arccos_Taylor_Series_Test;
-
-
-
- procedure Identity_Test is
- -- test the identity arcsin(-x) = -arcsin(x)
- -- range chosen to be most of the valid range of the argument.
- A : constant := -0.999;
- B : constant := 0.999;
- X : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Check (Arcsin(-X), -Arcsin (X),
- "Identity test" & Integer'Image (I) & ": arcsin(" &
- Real'Image (X) & ") ",
- 8.0); -- 2 arcsin evaluations => twice the error bound
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end Identity_Test;
-
-
- procedure Exception_Test is
- X1, X2 : Real := 0.0;
- begin
- begin
- X1 := Arcsin (1.1);
- Report.Failed ("no exception for Arcsin (1.1)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error instead of " &
- "Argument_Error for Arcsin (1.1)");
- when Ada.Numerics.Argument_Error =>
- null; -- expected result
- when others =>
- Report.Failed ("wrong exception for Arcsin(1.1)");
- end;
-
- begin
- X2 := Arccos (-1.1);
- Report.Failed ("no exception for Arccos (-1.1)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error instead of " &
- "Argument_Error for Arccos (-1.1)");
- when Ada.Numerics.Argument_Error =>
- null; -- expected result
- when others =>
- Report.Failed ("wrong exception for Arccos(-1.1)");
- end;
-
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Arcsin_Taylor_Series_Test;
- Arccos_Taylor_Series_Test;
- Identity_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- These expressions must be truly static, which is why we have to do them
- -- outside of the generic, and we use the named numbers. Note that we know
- -- that PI is not a machine number (it is irrational), and it should be
- -- represented to more digits than supported by the target machine.
- Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
- Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
- Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
- Float_PI_High : constant := Float'Adjacent(PI, 10.0);
- package Float_Check is new Generic_Check (Float,
- Half_PI_Low => Float_Half_PI_Low,
- Half_PI_High => Float_Half_PI_High,
- PI_Low => Float_PI_Low,
- PI_High => Float_PI_High);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
- A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
- A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
- A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
- package A_Long_Float_Check is new Generic_Check (A_Long_Float,
- Half_PI_Low => A_Long_Float_Half_PI_Low,
- Half_PI_High => A_Long_Float_Half_PI_High,
- PI_Low => A_Long_Float_PI_Low,
- PI_High => A_Long_Float_PI_High);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2015",
- "Check the accuracy of the ARCSIN and ARCCOS functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2015;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a
deleted file mode 100644
index 832b118..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a
+++ /dev/null
@@ -1,482 +0,0 @@
--- CXG2016.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 ARCTAN function returns a
--- result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 19 Mar 96 SAIC Initial release for 2.1
--- 30 APR 96 SAIC Fixed optimization issue
--- 17 AUG 96 SAIC Incorporated Reviewer's suggestions.
--- 12 OCT 96 SAIC Incorporated Reviewer's suggestions.
--- 02 DEC 97 EDS Remove procedure Identity_1_Test and calls to
--- procedure.
--- 29 JUN 98 EDS Replace -0.0 with call to ImpDef.Annex_G.Negative_Zero
--- 28 APR 99 RLB Replaced comma accidentally deleted in above change.
--- 15 DEC 99 RLB Added model range checking to "exact" results,
--- in order to avoid too strictly requiring a specific
--- result.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Impdef.Annex_G;
-procedure CXG2016 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- Half_PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI/2.0.
- Half_PI_High : in Real;-- The machine number closest to, but not less
- -- than PI/2.0.
- PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI.
- PI_High : in Real; -- The machine number closest to, but not less
- -- than PI.
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Arctan (Y : Real;
- X : Real := 1.0) return Real renames
- Elementary_Functions.Arctan;
- function Arctan (Y : Real;
- X : Real := 1.0;
- Cycle : Real) return Real renames
- Elementary_Functions.Arctan;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- If eta is very small, arctan(x + eta) ~= arctan(x) + eta/(1+x*x).
- --
- -- For tests 4 and 5, there is an error of 4.0ME for arctan + an
- -- additional error of 1.0ME because pi is not exact for a total of 5.0ME.
- --
- -- In test 3 there is the error for pi plus an additional error
- -- of (1.0ME)/4 since sqrt3 is not exact, for a total of 5.25ME.
- --
- -- In test 2 there is the error for pi plus an additional error
- -- of (3/4)(1.0ME) since sqrt3 is not exact, for a total of 5.75ME.
-
-
- type Data_Point is
- record
- Degrees,
- Radians,
- Tangent,
- Allowed_Error : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions so no additional loss of precision occurs.
- Test_Data : constant Test_Data_Type := (
- -- degrees radians tangent error test #
- ( 0.0, 0.0, 0.0, 4.0 ), -- 1
- ( 30.0, Pi/6.0, Sqrt3/3.0, 5.75), -- 2
- ( 60.0, Pi/3.0, Sqrt3, 5.25), -- 3
- ( 45.0, Pi/4.0, 1.0, 5.0 ), -- 4
- (-45.0, -Pi/4.0, -1.0, 5.0 ) ); -- 5
-
- begin
- for I in Test_Data'Range loop
- Check (Arctan (Test_Data (I).Tangent),
- Test_Data (I).Radians,
- "special value test" & Integer'Image (I) &
- " arctan(" &
- Real'Image (Test_Data (I).Tangent) &
- ")",
- Test_Data (I).Allowed_Error);
- Check (Arctan (Test_Data (I).Tangent, Cycle => 360.0),
- Test_Data (I).Degrees,
- "special value test" & Integer'Image (I) &
- " arctan(" &
- Real'Image (Test_Data (I).Tangent) &
- ", cycle=>360)",
- Test_Data (I).Allowed_Error);
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
- Test_Name : String) is
- -- If the expected result is not a model number, then Expected_Low is
- -- the first machine number less than the (exact) expected
- -- result, and Expected_High is the first machine number greater than
- -- the (exact) expected result. If the expected result is a model
- -- number, Expected_Low = Expected_High = the result.
- Model_Expected_Low : Real := Expected_Low;
- Model_Expected_High : Real := Expected_High;
- begin
- -- Calculate the first model number nearest to, but below (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
- -- Try the next machine number lower:
- Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
- end loop;
- -- Calculate the first model number nearest to, but above (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_High) /= Model_Expected_High loop
- -- Try the next machine number higher:
- Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
- end loop;
-
- if Actual < Model_Expected_Low or Actual > Model_Expected_High then
- Accuracy_Error_Reported := True;
- if Actual < Model_Expected_Low then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Actual - Expected_Low));
- else
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Expected_High - Actual));
- end if;
- elsif Verbose then
- Report.Comment (Test_Name & " passed");
- end if;
- end Check_Exact;
-
-
- procedure Exact_Result_Test is
- begin
- -- A.5.1(40);6.0
- Check_Exact (Arctan (0.0, 1.0), 0.0, 0.0, "arctan(0,1)");
- Check_Exact (Arctan (0.0, 1.0, 27.0), 0.0, 0.0, "arctan(0,1,27)");
-
- -- G.2.4(11-13);6.0
-
- Check_Exact (Arctan (1.0, 0.0), Half_PI_Low, Half_PI_High,
- "arctan(1,0)");
- Check_Exact (Arctan (1.0, 0.0, 360.0), 90.0, 90.0, "arctan(1,0,360)");
-
- Check_Exact (Arctan (-1.0, 0.0), -Half_PI_High, -Half_PI_Low,
- "arctan(-1,0)");
- Check_Exact (Arctan (-1.0, 0.0, 360.0), -90.0, -90.0,
- "arctan(-1,0,360)");
-
- if Real'Signed_Zeros then
- Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(+0,-1)");
- Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
- "arctan(+0,-1,360)");
- Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0),
- -PI_High, -PI_Low, "arctan(-0,-1)");
- Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0,
- 360.0), -180.0, -180.0, "arctan(-0,-1,360)");
- else
- Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(0,-1)");
- Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
- "arctan(0,-1,360)");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("Exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Taylor_Series_Test is
- -- This test checks the Arctan by using a taylor series expansion that
- -- will produce a result accurate to 19 decimal digits for
- -- the range under test.
- --
- -- The maximum relative error bound for this test is
- -- 4 for the arctan operation and 2 for the Taylor series
- -- for a total of 6 * Model_Epsilon
-
- A : constant := -1.0/16.0;
- B : constant := 1.0/16.0;
- X : Real;
- Actual, Expected : Real;
- Sum, Em, X_Squared : Real;
- begin
- if Real'Digits > 19 then
- -- Taylor series calculation produces result accurate to 19
- -- digits. If type being tested has more digits then set
- -- the error low bound to account for this.
- -- The error low bound is conservatively set to 6*10**-19
- Error_Low_Bound := 0.00000_00000_00000_0006;
- Report.Comment ("arctan accuracy checked to 19 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Squared := X * X;
- Em := 17.0;
- Sum := X_Squared / Em;
-
- for II in 1 .. 7 loop
- Em := Em - 2.0;
- Sum := (1.0 / Em - Sum) * X_Squared;
- end loop;
- Sum := -X * Sum;
- Expected := X + Sum;
- Sum := (X - Expected) + Sum;
- if not Real'Machine_Rounds then
- Expected := Expected + (Sum + Sum);
- end if;
-
- Actual := Arctan (X);
-
- Check (Actual, Expected,
- "Taylor_Series_Test " & Integer'Image (I) & ": arctan(" &
- Real'Image (X) & ") ",
- 6.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Taylor_Series_Test");
- when others =>
- Report.Failed ("exception in Taylor_Series_Test");
- end Taylor_Series_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3 : Real := 0.0;
- begin
-
- begin -- A.5.1(20);6.0
- X1 := Arctan(0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin -- A.5.1(20);6.0
- X2 := Arctan (0.0, Cycle => -1.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- begin -- A.5.1(25);6.0
- X3 := Arctan (0.0, 0.0);
- Report.Failed ("no exception for arctan(0,0)");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for arctan(0,0)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2 + X3));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Taylor_Series_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- These expressions must be truly static, which is why we have to do them
- -- outside of the generic, and we use the named numbers. Note that we know
- -- that PI is not a machine number (it is irrational), and it should be
- -- represented to more digits than supported by the target machine.
- Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
- Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
- Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
- Float_PI_High : constant := Float'Adjacent(PI, 10.0);
- package Float_Check is new Generic_Check (Float,
- Half_PI_Low => Float_Half_PI_Low,
- Half_PI_High => Float_Half_PI_High,
- PI_Low => Float_PI_Low,
- PI_High => Float_PI_High);
-
- -- check the Floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
- A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
- A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
- A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
- package A_Long_Float_Check is new Generic_Check (A_Long_Float,
- Half_PI_Low => A_Long_Float_Half_PI_Low,
- Half_PI_High => A_Long_Float_Half_PI_High,
- PI_Low => A_Long_Float_PI_Low,
- PI_High => A_Long_Float_PI_High);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2016",
- "Check the accuracy of the ARCTAN function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2016;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a
deleted file mode 100644
index 50add97..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a
+++ /dev/null
@@ -1,296 +0,0 @@
--- CXG2017.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 TANH function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 20 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 03 Jun 98 EDS Add parens to remove the potential for overflow.
--- Remove the invocation of Identity_Test that checks
--- Tanh values that are too close to zero for the
--- test's error bounds.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2017 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- E : constant := Ada.Numerics.E;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Tanh (X : Real) return Real renames
- Elementary_Functions.Tanh;
-
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- Minimum_Error : constant := 8.0;
- E2 : constant := E * E;
- begin
- Check (Tanh (1.0),
- (E - 1.0 / E) / (E + 1.0 / E),
- "tanh(1)",
- Minimum_Error);
- Check (Tanh (2.0),
- (E2 - 1.0 / E2) / (E2 + 1.0 / E2),
- "tanh(2)",
- Minimum_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Tanh (0.0), 0.0, "tanh(0)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (A, B : Real) is
- -- For this test we use the identity
- -- TANH(u+v) = [TANH(u) + TANH(v)] / [1 + TANH(u)*TANH(v)]
- -- which is transformed to
- -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
- -- where C = TANH(1/8) and y = x - 1/8
- --
- -- see Cody pg 248-249 for details on the error analysis.
- -- The net result is a relative error bound of 16 * Model_Epsilon.
- --
- -- The second part of this test checks the identity
- -- TANH(-x) = -TANH(X)
-
- X, Y : Real;
- Actual1, Actual2 : Real;
- C : constant := 1.2435300177159620805e-1;
- begin
- if Real'Digits > 20 then
- -- constant C is accurate to 20 digits. Set the low bound
- -- on the error to 16*10**-20
- Error_Low_Bound := 0.00000_00000_00000_00016;
- Report.Comment ("tanh accuracy checked to 20 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * (Real (I) / Real (Max_Samples)) + A;
- Actual1 := Tanh(X);
-
- -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
- Y := X - (1.0 / 8.0);
- Actual2 := (Tanh (Y) + C) / (1.0 + Tanh(Y) * C);
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": tanh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- -- TANH(-x) = -TANH(X)
- Actual2 := Tanh(-X);
- Check (-Actual1, Actual2,
- "Identity_2_Test " & Integer'Image (I) & ": tanh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=" & Real'Image (X));
- end Identity_Test;
-
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- cover a large range
- Identity_Test (1.0, Real'Safe_Last);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2017",
- "Check the accuracy of the TANH function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2017;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a
deleted file mode 100644
index be4f1a8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a
+++ /dev/null
@@ -1,355 +0,0 @@
--- CXG2018.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 complex EXP function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 21 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 27 Aug 99 RLB Repair on the error result of checks.
--- 02 Apr 03 RLB Added code to discard excess precision in the
--- construction of the test value for the
--- Identity_Test.
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2018 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Exp (X : Complex) return Complex renames CEF.Exp;
- function Exp (X : Imaginary) return Complex renames CEF.Exp;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- --
- -- The error bounds given assumed z is exact. When using
- -- pi there is an extra error of 1.0ME.
- -- The pi inside the exp call requires that the complex
- -- component have an extra error allowance of 1.0*angle*ME.
- -- Thus for pi/2,the Minimum_Error_I is
- -- (2.0 + 1.0(pi/2))ME <= 3.6ME.
- -- For pi, it is (2.0 + 1.0*pi)ME <= 5.2ME,
- -- and for 2pi, it is (2.0 + 1.0(2pi))ME <= 8.3ME.
-
- -- The addition of 1 or i to a result is so that neither of
- -- the components of an expected result is 0. This is so
- -- that a reasonable relative error is allowed.
- Minimum_Error_C : constant := 7.0; -- for exp(Complex)
- Minimum_Error_I : constant := 2.0; -- for exp(Imaginary)
- begin
- Check (Exp (1.0 + 0.0*i) + i,
- E + i,
- "exp(1+0i)",
- Minimum_Error_C);
- Check (Exp ((Pi / 2.0) * i) + 1.0,
- 1.0 + 1.0*i,
- "exp(pi/2*i)",
- 3.6);
- Check (Exp (Pi * i) + i,
- -1.0 + 1.0*i,
- "exp(pi*i)",
- 5.2);
- Check (Exp (Pi * 2.0 * i) + i,
- 1.0 + i,
- "exp(2pi*i)",
- 8.3);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Exp(0.0 + 0.0*i), 1.0 + 0.0 * i, "exp(0+0i)", No_Error);
- Check (Exp( 0.0*i), 1.0 + 0.0 * i, "exp(0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (A, B : Real) is
- -- For this test we use the identity
- -- Exp(Z) = Exp(Z-W) * Exp (W)
- -- where W = (1+i)/16
- --
- -- The second part of this test checks the identity
- -- Exp(Z) * Exp(-Z) = 1
- --
-
- X, Y : Complex;
- Actual1, Actual2 : Complex;
- W : constant Complex := (0.0625, 0.0625);
- -- the following constant was taken from the CELEFUNC EXP test.
- -- This is the value EXP(W) - 1
- C : constant Complex := (6.2416044877018563681e-2,
- 6.6487597751003112768e-2);
- begin
- if Real'Digits > 20 then
- -- constant ExpW is accurate to 20 digits.
- -- The low bound is 19 * 10**-20
- Error_Low_Bound := 0.00000_00000_00019;
- Report.Comment ("complex exp accuracy checked to 20 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X.Re := Real'Machine ((B - A) * Real (II) / Real (Max_Samples)
- + A);
- for J in 1..Max_Samples loop
- X.Im := Real'Machine ((B - A) * Real (J) / Real (Max_Samples)
- + A);
-
- Actual1 := Exp(X);
-
- -- Exp(X) = Exp(X-W) * Exp (W)
- -- = Exp(X-W) * (1 - (1-Exp(W))
- -- = Exp(X-W) * (1 + (Exp(W) - 1))
- -- = Exp(X-W) * (1 + C)
- Y := X - W;
- Actual2 := Exp(Y);
- Actual2 := Actual2 + Actual2 * C;
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Exp((" &
- Real'Image (X.Re) & ", " &
- Real'Image (X.Im) & ")) ",
- 20.0); -- 2 exp and 1 multiply and 1 add = 2*7+1*5+1
- -- Note: The above is not strictly correct, as multiply
- -- has a box error, rather than a relative error.
- -- Supposedly, the interval is chosen to avoid the need
- -- to worry about this.
-
- -- Exp(X) * Exp(-X) + i = 1 + i
- -- The addition of i is to allow a reasonable relative
- -- error in the imaginary part
- Actual2 := (Actual1 * Exp(-X)) + i;
- Check (Actual2, (1.0, 1.0),
- "Identity_2_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Exp((" &
- Real'Image (X.Re) & ", " &
- Real'Image (X.Im) & ")) ",
- 20.0); -- 2 exp and 1 multiply and one add = 2*7+1*5+1
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
- Error_Low_Bound := 0.0;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X.Re) &
- ", " & Real'Image (X.Im) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X.Re) &
- ", " & Real'Image (X.Im) & ")");
- end Identity_Test;
-
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions where we can avoid cancellation error problems
- -- See Cody page 10.
- Identity_Test (0.0625, 1.0);
- Identity_Test (15.0, 17.0);
- Identity_Test (1.625, 3.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2018",
- "Check the accuracy of the complex EXP function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2018;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a
deleted file mode 100644
index 0a4dddc..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXG2019.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 complex LOG function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception conditions.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Initial release for 2.1
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2019 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Log (X : Complex) return Complex renames CEF.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- --
- -- When using pi there is an extra error of 1.0ME.
- -- Although the real component has an error bound of 13.0,
- -- the complex component must take into account this error
- -- in the value for Pi.
- --
- -- One or i is added to the actual and expected results in
- -- order to prevent the expected result from having a
- -- real or imaginary part of 0. This is to allow a reasonable
- -- relative error for that component.
- Minimum_Error : constant := 13.0;
- begin
- Check (1.0 + Log (0.0 + i),
- 1.0 + Pi / 2.0 * i,
- "1+log(0+i)",
- Minimum_Error + 1.0);
- Check (1.0 + Log ((-1.0, 0.0)),
- 1.0 + (Pi * i),
- "log(-1+0i)+1 ",
- Minimum_Error + 1.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(37);6.0
- Check (Log(1.0 + 0.0*i), 0.0 + 0.0 * i, "log(1+0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part.
- --
- -- For this test we use the identity
- -- Log(Z*Z) = 2 * Log(Z)
- --
-
- Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
- W, X, Y, Z : Real;
- CX, CY : Complex;
- Actual1, Actual2 : Complex;
- begin
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 1..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- -- purify the arguments to minimize roundoff error.
- -- We construct the values so that the products X*X,
- -- Y*Y, and X*Y are all exact machine numbers.
- -- See Cody page 7 and CELEFUNT code.
- Z := X * Scale;
- W := Z + X;
- X := W - Z;
- Z := Y * Scale;
- W := Z + Y;
- Y := W - Z;
- CX := Compose_From_Cartesian(X,Y);
- Z := X*X - Y*Y;
- W := X*Y;
- CY := Compose_From_Cartesian(Z,W+W);
-
- -- The arguments are now ready so on with the
- -- identity computation.
- Actual1 := Log(CX);
-
- Actual2 := Log(CY) * 0.5;
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Log((" &
- Real'Image (CX.Re) & ", " &
- Real'Image (CX.Im) & ")) ",
- 26.0); -- 2 logs = 2*13. no error from this multiply
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- end Identity_Test;
-
-
- procedure Exception_Test is
- -- Check that log((0,0)) causes constraint_error.
- -- G.1.2(29);
-
- X : Complex := (0.0, 0.0);
- begin
- if not Real'Machine_Overflows then
- -- not applicable: G.1.2(28);6.0
- return;
- end if;
-
- begin
- X := Log ((0.0, 0.0));
- Report.Failed ("exception not raised for log(0,0)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for log(0,0)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool(False) then
- Report.Comment (Real'Image (X.Re + X.Im));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions that do not include the unit circle so that
- -- the real part of LOG(Z) does not vanish
- -- See Cody page 9.
- Identity_Test ( 2.0, 10.0, 0.0, 10.0);
- Identity_Test (1000.0, 2000.0, -4000.0, -1000.0);
- Identity_Test (Real'Model_Epsilon, 0.25,
- -0.25, -Real'Model_Epsilon);
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2019",
- "Check the accuracy of the complex LOG function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2019;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a
deleted file mode 100644
index 1aed4ca..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- CXG2020.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 complex SQRT function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 24 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 03 Jun 98 EDS Added parens to ensure that the expression is not
--- evaluated by multiplying its two large terms
--- together and overflowing.
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2020 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Sqrt (X : Complex) return Complex renames CEF.Sqrt;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- --
- -- One or i is added to the actual and expected results in
- -- order to prevent the expected result from having a
- -- real or imaginary part of 0. This is to allow a reasonable
- -- relative error for that component.
- Minimum_Error : constant := 6.0;
- Z1, Z2 : Complex;
- begin
- Check (Sqrt(9.0+0.0*i) + i,
- 3.0+1.0*i,
- "sqrt(9+0i)+i",
- Minimum_Error);
- Check (Sqrt (-2.0 + 0.0 * i) + 1.0,
- 1.0 + Sqrt2 * i,
- "sqrt(-2)+1 ",
- Minimum_Error);
-
- -- make sure no exception occurs when taking the sqrt of
- -- very large and very small values.
-
- Z1 := (Real'Safe_Last * 0.9, Real'Safe_Last * 0.9);
- Z2 := Sqrt (Z1);
- begin
- Check (Z2 * Z2,
- Z1,
- "sqrt((big,big))",
- Minimum_Error + 5.0); -- +5 for multiply
- exception
- when others =>
- Report.Failed ("unexpected exception in sqrt((big,big))");
- end;
-
- Z1 := (Real'Model_Epsilon * 10.0, Real'Model_Epsilon * 10.0);
- Z2 := Sqrt (Z1);
- begin
- Check (Z2 * Z2,
- Z1,
- "sqrt((little,little))",
- Minimum_Error + 5.0); -- +5 for multiply
- exception
- when others =>
- Report.Failed ("unexpected exception in " &
- "sqrt((little,little))");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Sqrt(0.0 + 0.0*i), 0.0 + 0.0 * i, "sqrt(0+0i)", No_Error);
-
- -- G.1.2(37);6.0
- Check (Sqrt(1.0 + 0.0*i), 1.0 + 0.0 * i, "sqrt(1+0i)", No_Error);
-
- -- G.1.2(38-39);6.0
- Check (Sqrt(-1.0 + 0.0*i), 0.0 + 1.0 * i, "sqrt(-1+0i)", No_Error);
-
- -- G.1.2(40);6.0
- if Real'Signed_Zeros then
- Check (Sqrt(-1.0-0.0*i), 0.0 - 1.0 * i, "sqrt(-1-0i)", No_Error);
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part of the result.
- --
- -- For this test we use the identity
- -- Sqrt(Z*Z) = Z
- --
-
- Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
- W, X, Y, Z : Real;
- CX : Complex;
- Actual, Expected : Complex;
- begin
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 1..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- -- purify the arguments to minimize roundoff error.
- -- We construct the values so that the products X*X,
- -- Y*Y, and X*Y are all exact machine numbers.
- -- See Cody page 7 and CELEFUNT code.
- Z := X * Scale;
- W := Z + X;
- X := W - Z;
- Z := Y * Scale;
- W := Z + Y;
- Y := W - Z;
- -- G.1.2(21);6.0 - real part of result is non-negative
- Expected := Compose_From_Cartesian( abs X,Y);
- Z := X*X - Y*Y;
- W := X*Y;
- CX := Compose_From_Cartesian(Z,W+W);
-
- -- The arguments are now ready so on with the
- -- identity computation.
- Actual := Sqrt(CX);
-
- Check (Actual, Expected,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Sqrt((" &
- Real'Image (CX.Re) & ", " &
- Real'Image (CX.Im) & ")) ",
- 8.5); -- 6.0 from sqrt, 2.5 from argument.
- -- See Cody pg 7-8 for analysis of additional error amount.
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- end Identity_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- ranges where the sign is the same and where it
- -- differs.
- Identity_Test ( 0.0, 10.0, 0.0, 10.0);
- Identity_Test ( 0.0, 100.0, -100.0, 0.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2020",
- "Check the accuracy of the complex SQRT function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2020;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a
deleted file mode 100644
index db49fc8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a
+++ /dev/null
@@ -1,386 +0,0 @@
--- CXG2021.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 complex SIN and COS functions return
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 27 Mar 96 SAIC Initial release for 2.1
--- 22 Aug 96 SAIC No longer skips test for systems with
--- more than 20 digits of precision.
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2021 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Sin (X : Complex) return Complex renames CEF.Sin;
- function Cos (X : Complex) return Complex renames CEF.Cos;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- -- the E_Factor is an additional amount added to the Expected
- -- value prior to computing the maximum relative error.
- -- This is needed because the error analysis (Cody pg 17-20)
- -- requires this additional allowance.
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- E_Factor : Real := 0.0) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * Real'Model_Epsilon * (abs Expected + E_Factor);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) &
- " efactor:" & Real'Image (E_Factor) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed" &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) &
- " efactor:" & Real'Image (E_Factor) );
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real;
- R_Factor, I_Factor : Real := 0.0) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part",
- MRE, R_Factor);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part",
- MRE, I_Factor);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- -- Since the argument involves Pi, we must allow for this
- -- inexact argument.
- Minimum_Error : constant := 11.0;
- begin
- Check (Sin (Pi/2.0 + 0.0*i),
- 1.0 + 0.0*i,
- "sin(pi/2+0i)",
- Minimum_Error + 1.0);
- Check (Cos (Pi/2.0 + 0.0*i),
- 0.0 + 0.0*i,
- "cos(pi/2+0i)",
- Minimum_Error + 1.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Sin(0.0 + 0.0*i), 0.0 + 0.0 * i, "sin(0+0i)", No_Error);
- Check (Cos(0.0 + 0.0*i), 1.0 + 0.0 * i, "cos(0+0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part.
- --
- -- For this test we use the identity
- -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
- -- and
- -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
- --
-
- X, Y : Real;
- Z : Complex;
- W : constant Complex := Compose_From_Cartesian(0.0625, 0.0625);
- ZmW : Complex; -- Z - W
- Sin_ZmW,
- Cos_ZmW : Complex;
- Actual1, Actual2 : Complex;
- R_Factor : Real; -- additional real error factor
- I_Factor : Real; -- additional imaginary error factor
- Sin_W : constant Complex := (6.2581348413276935585E-2,
- 6.2418588008436587236E-2);
- -- numeric stability is enhanced by using Cos(W) - 1.0 instead of
- -- Cos(W) in the computation.
- Cos_W_m_1 : constant Complex := (-2.5431314180235545803E-6,
- -3.9062493377261771826E-3);
-
-
- begin
- if Real'Digits > 20 then
- -- constants used here accurate to 20 digits. Allow 1
- -- additional digit of error for computation.
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("accuracy checked to 19 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for II in 0..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 0..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- Z := Compose_From_Cartesian(X,Y);
- ZmW := Z - W;
- Sin_ZmW := Sin (ZmW);
- Cos_ZmW := Cos (ZmW);
-
- -- now for the first identity
- -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
- -- = Sin(Z-W) * (1+(Cos(W)-1)) + Cos(Z-W) * Sin(W)
- -- = Sin(Z-W) + Sin(Z-W)*(Cos(W)-1) + Cos(Z-W)*Sin(W)
-
-
- Actual1 := Sin (Z);
- Actual2 := Sin_ZmW + (Sin_ZmW * Cos_W_m_1 + Cos_ZmW * Sin_W);
-
- -- The computation of the additional error factors are taken
- -- from Cody pages 17-20.
-
- R_Factor := abs (Re (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Im (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Re (Cos_ZmW) * Re (Sin_W)) +
- abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- I_Factor := abs (Re (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Im (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Re (Cos_ZmW) * Im (Sin_W)) +
- abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Sin((" &
- Real'Image (Z.Re) & ", " &
- Real'Image (Z.Im) & ")) ",
- 11.0, R_Factor, I_Factor);
-
- -- now for the second identity
- -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
- -- = Cos(Z-W) * (1+(Cos(W)-1) - Sin(Z-W) * Sin(W)
- Actual1 := Cos (Z);
- Actual2 := Cos_ZmW + (Cos_ZmW * Cos_W_m_1 - Sin_ZmW * Sin_W);
-
- -- The computation of the additional error factors are taken
- -- from Cody pages 17-20.
-
- R_Factor := abs (Re (Sin_ZmW) * Re (Sin_W)) +
- abs (Im (Sin_ZmW) * Im (Sin_W)) +
- abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Im (Cos_ZmW) * Im (1.0 - Cos_W_m_1));
-
- I_Factor := abs (Re (Sin_ZmW) * Im (Sin_W)) +
- abs (Im (Sin_ZmW) * Re (Sin_W)) +
- abs (Re (Cos_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- Check (Actual1, Actual2,
- "Identity_2_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Cos((" &
- Real'Image (Z.Re) & ", " &
- Real'Image (Z.Im) & ")) ",
- 11.0, R_Factor, I_Factor);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- Error_Low_Bound := 0.0; -- reset
- return;
- end if;
- end loop;
- end loop;
-
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for Z=(" & Real'Image (X) &
- ", " & Real'Image (Y) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for Z=(" & Real'Image (X) &
- ", " & Real'Image (Y) & ")");
- end Identity_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions where sin and cos have the same sign and
- -- about the same magnitude. This will minimize subtraction
- -- errors in the identities.
- -- See Cody page 17.
- Identity_Test (0.0625, 10.0, 0.0625, 10.0);
- Identity_Test ( 16.0, 17.0, 16.0, 17.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2021",
- "Check the accuracy of the complex SIN and COS functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2021;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a
deleted file mode 100644
index f9e4d1c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- CXG2022.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 multiplication and division of binary fixed point
--- numbers with compatible 'small values produce exact results.
---
--- TEST DESCRIPTION:
--- Signed, unsigned, and a mixture of signed and unsigned
--- binary fixed point values are multiplied and divided.
--- The result is checked against the expected "perfect result set"
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Apr 96 SAIC Initial release for 2.1
--- 29 Jan 1998 EDS Repaired fixed point errors ("**" and
--- assumptions about 'Small)
---!
-
-with System;
-with Report;
-procedure CXG2022 is
- Verbose : constant Boolean := False;
-
-procedure Check_Signed is
- type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
- 2.0 ** (System.Max_Mantissa) - 1.0;
- type Halves is delta 0.5 range -2.0 ** (System.Max_Mantissa-2) ..
- 2.0 ** (System.Max_Mantissa-2) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := -2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := -0.5;
- H2 := Halves'First;
- H3 := 1.0;
- P1 := 12.0;
- P2 := Pairs'First;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * -0.5
- if P4 /= -6.0 then
- Report.Failed ("12.0 * -0.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / -0.5
- if H4 /= -24.0 then
- Report.Failed ("12.0 / -0.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P2 * 0.25; -- Pairs'First * 0.25
- if P4 /= Pairs (-2.0 ** (System.Max_Mantissa - 2)) then
- Report.Failed ("Pairs'First * 0.25 = " & Pairs'Image (P4));
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / -0.5
- if P4 = -201.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and ( P4 = -200.0 or P4 = -202.0 ) then
- null; -- Allowed variation
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- " and 100.5/-0.5 = " & Pairs'Image (P4) );
- end if;
-
- H4 := H1 * H2; -- -0.5 * Halves'First
- if H4 /= Halves (2.0 ** (System.Max_Mantissa-3)) then
- Report.Failed ("-0.5 * Halves'First =" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-3))));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Signed");
-end Check_Signed;
-
-
-
-procedure Check_Unsigned is
- type Pairs is delta 2.0 range 0.0 .. 2.0 ** (System.Max_Mantissa+1) - 1.0;
- type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := 2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := 10.5;
- H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
- H3 := 1.0;
- P1 := 12.0;
- P2 := Pairs'Last / 2;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * 10.5
- if P4 /= 126.0 then
- Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / 10.5
- if H4 /= 1.0 and H4 /= 1.5 then
- Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P1 * 0.25; -- 12.0 * 0.25
- if P4 /= 2.0 and P4 /= 4.0 then
- Report.Failed ("12.0 * 0.25 = " & Pairs'Image (P4));
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
- if P4 /= 8.0 and P4 /= 10.0 then
- Report.Failed ("100.5/10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
- if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
- Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Unsigned");
-end Check_Unsigned;
-
-
-
-procedure Check_Mixed is
- type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
- 2.0 ** (System.Max_Mantissa) - 1.0;
- type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := 2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := 10.5;
- H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
- H3 := 1.0;
- P1 := 12.0;
- P2 := -4.0;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * 10.5
- if P4 /= 126.0 then
- Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / 10.5
- if H4 /= 1.0 and H4 /= 1.5 then
- Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P1 * 0.25; -- 12.0 * 0.25
- if P4 = 3.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and then ( P4 = 2.0 or P4 = 4.0 ) then
- null; -- Allowed deviation
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- "and 12.0 * 0.25 = " & Pairs'Image (P4) );
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
- if P4 = 9.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and then ( P4 = 8.0 or P4 = 10.0 ) then
- null; -- Allowed values
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- "and 100.5/10.5 = " & Pairs'Image (P4) );
- end if;
-
- H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
- if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
- Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
- end if;
-
- P4 := Pairs(P1 * 6) / P2; -- 12 * 6 / -4
- if (P4 /= -18.0) then
- Report.Failed ("12*6/-4 = " & Pairs'Image(P4));
- end if;
-
- P4 := Halves(P1 * 6.0) / P2; -- 12 * 6 / -4
- if (P4 /= -18.0) then
- Report.Failed ("Halves(12*6)/-4 = " & Pairs'Image(P4));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Mixed");
-end Check_Mixed;
-
-
-begin -- main
- Report.Test ("CXG2022",
- "Check the accuracy of multiplication and division" &
- " of binary fixed point numbers");
- if Verbose then
- Report.Comment ("starting signed test");
- end if;
- Check_Signed;
-
- if Verbose then
- Report.Comment ("starting unsigned test");
- end if;
- Check_Unsigned;
-
- if Verbose then
- Report.Comment ("starting mixed sign test");
- end if;
- Check_Mixed;
-
- Report.Result;
-end CXG2022;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a
deleted file mode 100644
index 0cdd557..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- CXG2023.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 multiplication and division of decimal fixed point
--- numbers produce exact results.
---
--- TEST DESCRIPTION:
--- Check that multiplication and division of decimal fixed point
--- numbers produce exact results.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
--- This test applies only to implementations supporting
--- decimal fixed point types of at least 9 digits.
---
---
--- CHANGE HISTORY:
--- 3 Apr 96 SAIC Initial release for 2.1
---
---!
-
-with System;
-with Report;
-procedure CXG2023 is
- Verbose : constant Boolean := False;
-
-procedure Check_1 is
- Num_Digits : constant := 6;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- P1 : Pennies;
- F1 : Franklins;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function F (X : Franklins) return Franklins is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 32100.0; -- never executed
- end if;
- end F;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
-begin
- -- multiplication where one operand is universal real
-
- P1 := P(0.05) * 200.0;
- if P1 /= 10.00 then
- Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * 100.0;
- if D1 /= 5.00 then
- Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(0.05) * 50_000.0;
- if F1 /= 2500.00 then
- Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- multiplication where both operands are decimal fixed
-
- P1 := P(0.05) * D(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * P(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(-0.05) * F(50_000.0);
- if F1 /= -2500.00 then
- Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- division where one operand is universal real
-
- P1 := P(0.05) / 0.001;
- if P1 /= 50.00 then
- Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := D(1000.0) / 3.0;
- if D1 /= 333.00 then
- Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(1234.56) / 0.0001;
- if F1 /= 12345600.00 then
- Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
- end if;
-
-
- -- division where both operands are decimal fixed
-
- P1 := P(0.05) / D(1.0);
- if P1 /= 0.05 then
- Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
- -- check for truncation toward 0
- D1 := P(-101.00) / P(2.0);
- if D1 /= -50.00 then
- Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(-102.03) / P(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
- F1 := P(876.54) / P(0.03);
- if F1 /= 29200.00 then
- Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_1");
-end Check_1;
-
-generic
- type Pennies is delta<> digits<>;
- type Dollars is delta<> digits<>;
- type Franklins is delta<> digits<>;
-procedure Generic_Check;
-procedure Generic_Check is
-
- -- the following code is copied directly from the
- -- above procedure Check_1
-
- P1 : Pennies;
- F1 : Franklins;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function F (X : Franklins) return Franklins is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 32100.0; -- never executed
- end if;
- end F;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
-begin
- -- multiplication where one operand is universal real
-
- P1 := P(0.05) * 200.0;
- if P1 /= 10.00 then
- Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * 100.0;
- if D1 /= 5.00 then
- Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(0.05) * 50_000.0;
- if F1 /= 2500.00 then
- Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- multiplication where both operands are decimal fixed
-
- P1 := P(0.05) * D(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * P(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(-0.05) * F(50_000.0);
- if F1 /= -2500.00 then
- Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- division where one operand is universal real
-
- P1 := P(0.05) / 0.001;
- if P1 /= 50.00 then
- Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := D(1000.0) / 3.0;
- if D1 /= 333.00 then
- Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(1234.56) / 0.0001;
- if F1 /= 12345600.00 then
- Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
- end if;
-
-
- -- division where both operands are decimal fixed
-
- P1 := P(0.05) / D(1.0);
- if P1 /= 0.05 then
- Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
- -- check for truncation toward 0
- D1 := P(-101.00) / P(2.0);
- if D1 /= -50.00 then
- Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(-102.03) / P(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
- F1 := P(876.54) / P(0.03);
- if F1 /= 29200.00 then
- Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
- end if;
-
-end Generic_Check;
-
-
-procedure Check_G6 is
- Num_Digits : constant := 6;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- procedure G is new Generic_Check (Pennies, Dollars, Franklins);
-begin
- G;
-end Check_G6;
-
-
-procedure Check_G9 is
- Num_Digits : constant := 9;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- procedure G is new Generic_Check (Pennies, Dollars, Franklins);
-begin
- G;
-end Check_G9;
-
-
-begin -- main
- Report.Test ("CXG2023",
- "Check the accuracy of multiplication and division" &
- " of decimal fixed point numbers");
-
- if Verbose then
- Report.Comment ("starting Check_1");
- end if;
- Check_1;
-
- if Verbose then
- Report.Comment ("starting Check_G6");
- end if;
- Check_G6;
-
- if Verbose then
- Report.Comment ("starting Check_G9");
- end if;
- Check_G9;
-
- Report.Result;
-end CXG2023;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a
deleted file mode 100644
index 5564828..0000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a
+++ /dev/null
@@ -1,191 +0,0 @@
--- CXG2024.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 multiplication and division of decimal
--- and binary fixed point numbers that result in a
--- decimal fixed point type produce acceptable results.
---
--- TEST DESCRIPTION:
--- Multiplication and division of mixed binary and decimal
--- values are performed. Identity functions are used so
--- that the operands of the expressions will not be seen
--- as static by the compiler.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
--- This test applies only to implementations supporting
--- decimal fixed point types of at least 9 digits.
---
---
--- CHANGE HISTORY:
--- 4 Apr 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Removed checks for close results
---
---!
-
-with System;
-with Report;
-procedure CXG2024 is
-
-procedure Do_Check is
- Num_Digits : constant := 9;
- type Pennies is delta 0.01 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- type Signed_Sixteenths is delta 0.0625
- range -2.0 ** (System.Max_Mantissa-5) ..
- 2.0 ** (System.Max_Mantissa-5) - 1.0;
- type Unsigned_Sixteenths is delta 0.0625
- range 0.0 .. 2.0 ** (System.Max_Mantissa-4) - 1.0;
-
- P1 : Pennies;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
- function US (X : Unsigned_Sixteenths) return Unsigned_Sixteenths is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end US;
-
-
- function SS (X : Signed_Sixteenths) return Signed_Sixteenths is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end SS;
-
-
-begin
-
- P1 := P(0.05) * SS(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("1 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * SS(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("2 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(0.05) * US(200.0);
- if P1 /= 10.00 then
- Report.Failed ("3 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(-0.05) * US(100.0);
- if D1 /= -5.00 then
- Report.Failed ("4 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
-
-
- P1 := P(0.05) / US(1.0);
- if P1 /= 0.05 then
- Report.Failed ("6 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
-
- -- check rounding
-
- D1 := Dollars'Round (Pennies (P(-101.00) / US(2.0)));
- if D1 /= -51.00 then
- Report.Failed ("11 - expected -51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (P(101.00) / US(2.0)));
- if D1 /= 51.00 then
- Report.Failed ("12 - expected 51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (SS(-101.00) / P(2.0)));
- if D1 /= -51.00 then
- Report.Failed ("13 - expected -51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (US(101.00) / P(2.0)));
- if D1 /= 51.00 then
- Report.Failed ("14 - expected 51.00 got " & Dollars'Image (D1));
- end if;
-
-
-
- P1 := P(-102.03) / SS(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("15 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Do_Check");
-end Do_Check;
-
-
-begin -- main
- Report.Test ("CXG2024",
- "Check the accuracy of multiplication and division" &
- " of mixed decimal and binary fixed point numbers");
-
- Do_Check;
-
- Report.Result;
-end CXG2024;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a
deleted file mode 100644
index 4ed41b4..0000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXH3001.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 pragma Reviewable.
--- Check that pragma Reviewable is accepted as a configuration pragma.
---
--- TEST DESCRIPTION
--- The test requires that the configuration pragma Reviewable
--- be processed. The following package contains a simple "one of each
--- construct in the language" to check that the configuration pragma has
--- not disallowed some feature of the language. This test should generate
--- no errors.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Safety and Security Annex.
---
--- PASS/FAIL CRITERIA:
--- This test passes if it correctly compiles, executes, and reports PASS.
--- It fails if the pragma is rejected. The effect of the pragma should
--- be to produce a listing with information, including warnings, as
--- required in H.3.1. Specific form and contents of this listing are not
--- required by this test and are not part of the PASS/FAIL criteria.
---
--- SPECIAL REQUIREMENTS
--- The implementation must process a configuration pragma which is not
--- part of any Compilation Unit; the method employed is implementation
--- defined.
---
--- Pragma Reviewable requires that the implementation provide the
--- following information for the compilation units in this test:
---
--- o Where compiler-generated run-time checks remain (6)
---
--- o Identification of any construct with a language-defined check
--- that is recognized prior to runtime as certain to fail if
--- executed (7)
---
--- o For each reference to a scalar object, an identification of
--- the reference as either "known to be initialized,"
--- or "possibly uninitialized" (8)
---
--- o Where run-time support routines are implicitly invoked (9)
---
--- o An object code listing including: (10)
---
--- o Machine instructions with relative offsets (11)
---
--- o Where each data object is stored during its lifetime (12)
---
--- o Correspondence with the source program (13)
---
--- o Identification of each construct for which the implementation
--- detects the possibility of erroneous execution (14)
---
--- o For each subprogram, block, task or other construct implemented by
--- reserving and subsequently freezing an area of the run-time stack,
--- an identification of the length of the fixed-size portion of
--- the area and an indication of whether the non-fixed size portion
--- is reserved on the stack or in a dynamically managed storage
--- region (15)
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1
--- 27 AUG 99 RLB Removed result dependence on uninitialized object.
--- 30 AUG 99 RLB Repaired the above.
---
---!
-
----------------------------- CONFIGURATION PRAGMAS -----------------------
-
-pragma Reviewable; -- OK
- -- configuration pragma
-
------------------------- END OF CONFIGURATION PRAGMAS --------------------
-
-
------------------------------------------------------------------ CXH3001_0
-
-package CXH3001_0 is
-
- type Enum is (Item,Stuff,Things);
-
- type Int is range 0..256;
-
- type Unt is mod 256;
-
- type Flt is digits 5;
-
- type Fix is delta 0.5 range -1.0..1.0;
-
- type Root(Disc: Enum) is tagged record
- I: Int; U:Unt;
- end record;
-
- type List is array(Unt) of Root(Stuff);
-
- type A_List is access List;
- type A_Proc is access procedure(R:Root);
-
- procedure P(R:Root);
-
- function F return A_Proc;
-
- protected PT is
- entry Set(Switch: Boolean);
- function Enquire return Boolean;
- private
- Toggle : Boolean;
- end PT;
-
- task TT is
- entry Release;
- end TT;
-
- Global_Variable : Boolean := False;
-
-end CXH3001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CXH3001_0 is
-
- procedure P(R:Root) is
- Warnable : Positive := 0; -- (7) -- OPTIONAL WARNING
- -- this would raise Constraint_Error if P were ever called, however
- -- this test never calls P.
- begin
- case R.Disc is
- when Item => Report.Comment("Got Item");
- when Stuff => Report.Comment("Got Stuff");
- when Things => Report.Comment("Got Things");
- end case;
- if Report.Ident_Int( Warnable ) = 0 then
- Global_Variable := not Global_Variable; -- (8) known to be initialized
- end if;
- end P;
-
- function F return A_Proc is
- begin
- return P'Access;
- end F;
-
- protected body PT is
-
- entry Set(Switch: Boolean) when True is
- begin
- Toggle := Switch;
- end Set;
-
- function Enquire return Boolean is
- begin
- return Toggle;
- end Enquire;
-
- end PT;
-
- task body TT is
- begin
- loop
- accept Release;
- exit when Global_Variable;
- end loop;
- end TT;
-
- -- (9) TT activation
-end CXH3001_0;
-
-------------------------------------------------------------------- CXH3001
-
-with Report;
-with CXH3001_0;
-procedure CXH3001 is
-begin
- Report.Test("CXH3001", "Check pragma Reviewable as a configuration pragma");
-
- Block: declare
- A_Truth : Boolean;
- Message : String := Report.Ident_Str( "Bad value encountered" );
- begin
- begin
- A_Truth := Report.Ident_Bool( True ) or A_Truth; -- (8) not initialized
- if not A_Truth then
- Report.Comment ("True or Uninit = False");
- A_Truth := Report.Ident_Bool (True);
- else
- A_Truth := Report.Ident_Bool (True);
- -- We do this separately on each branch in order to insure that a
- -- clever optimizer can find out little about this value. Ident_Bool
- -- is supposed to be opaque to any optimizer.
- end if;
- exception
- when Constraint_Error | Program_Error =>
- -- Possible results of accessing an uninitialized object.
- A_Truth := Report.Ident_Bool (True);
- end;
-
- CXH3001_0.PT.Set( A_Truth );
-
- CXH3001_0.Global_Variable := A_Truth;
-
- CXH3001_0.TT.Release; -- (9) rendezvous with TT
-
- while CXH3001_0.TT'Callable loop
- delay 1.0; -- wait for TT to become non-callable
- end loop;
-
- if not CXH3001_0.PT.Enquire
- or not CXH3001_0.Global_Variable
- or CXH3001_0.TT'Callable then
- Report.Failed(Message);
- end if;
-
- end Block;
-
- Report.Result;
-end CXH3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a
deleted file mode 100644
index 5e9f7b9..0000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a
+++ /dev/null
@@ -1,343 +0,0 @@
--- CXH3002.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 pragma Inspection_Point is allowed whereever a declarative
--- item or statement is allowed. Check that pragma Inspection_Point may
--- have zero or more arguments. Check that the execution of pragma
--- Inspection_Point has no effect.
---
--- TEST DESCRIPTION
--- Check pragma Inspection_Point applied to:
--- A no objects,
--- B one object,
--- C multiple objects.
--- Check pragma Inspection_Point applied to:
--- D Enumeration type objects,
--- E Integer type objects (signed and unsigned),
--- F access type objects,
--- G Floating Point type objects,
--- H Fixed point type objects,
--- I array type objects,
--- J record type objects,
--- K tagged type objects,
--- L protected type objects,
--- M controlled type objects,
--- N task type objects.
--- Check pragma Inspection_Point applied in:
--- O declarations (package, procedure)
--- P statements (incl package elaboration)
--- Q subprogram (procedure, function, finalization)
--- R package
--- S specification
--- T body (PO entry, task body, loop body, accept body, select body)
--- U task
--- V protected object
---
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Safety and Security Annex.
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1
---
---!
-
------------------------------------------------------------------ CXH3002_0
-
-package CXH3002_0 is
-
- type Enum is (Item,Stuff,Things);
-
- type Int is range 0..256;
-
- type Unt is mod 256;
-
- type Flt is digits 5;
-
- type Fix is delta 0.5 range -1.0..1.0;
-
- type Root(Disc: Enum) is record
- I: Int;
- U: Unt;
- end record;
-
- type List is array(Unt) of Root(Stuff);
-
- type A_List is access all List;
- type A_Proc is access procedure(R:Root);
-
- procedure Proc(R:Root);
- function Func return A_Proc;
-
- protected type PT is
- entry Prot_Entry(Switch: Boolean);
- private
- Toggle : Boolean := False;
- end PT;
-
- task type TT is
- entry Task_Entry(Items: in A_List);
- end TT;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AORS
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
-
-end CXH3002_0;
-
------------------------------------------------------------------ CXH3002_1
-
-with Ada.Finalization;
-package CXH3002_0.CXH3002_1 is
-
- type Final is new Ada.Finalization.Controlled with
- record
- Value : Natural;
- end record;
-
- procedure Initialize( F: in out Final );
- procedure Adjust( F: in out Final );
- procedure Finalize( F: in out Final );
-
-end CXH3002_0.CXH3002_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_0
-
-package body CXH3002_0 is
-
- Global_Variable : Character := 'A';
-
- procedure Proc(R:Root) is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Global_Variable ); -- BDPQT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- case R.Disc is
- when Item => Global_Variable := 'I';
- when Stuff => Global_Variable := 'S';
- when Things => Global_Variable := 'T';
- end case;
- end Proc;
-
- function Func return A_Proc is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APQT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- return Proc'Access;
- end Func;
-
- protected body PT is
- entry Prot_Entry(Switch: Boolean) when True is
- begin
- Toggle := Switch;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APVT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- end Prot_Entry;
- end PT;
-
- task body TT is
- List_Copy : A_List;
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- loop
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- select
- accept Task_Entry(Items: in A_List) do
- List_Copy := Items;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( List_Copy ); -- BFPUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- end Task_Entry;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- or terminate;
- end select;
- end loop;
- end TT;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point; -- ARTO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
-
-end CXH3002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_1
-
-with Report;
-package body CXH3002_0.CXH3002_1 is
-
- Embedded_Final_Object : Final
- := (Ada.Finalization.Controlled with Value => 1);
- -- attempt to call Initialize here would P_E!
-
- procedure Initialize( F: in out Final ) is
- begin
- F.Value := 1;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Embedded_Final_Object ); -- BKQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- end Initialize;
-
- procedure Adjust( F: in out Final ) is
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point; -- AQO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- begin
- F.Value := 2;
- end Adjust;
-
- procedure Finalize( F: in out Final ) is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- if F.Value not in 1..10 then
- Report.Failed("Bad value in controlled object at finalization");
- end if;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- end Finalize;
-
-begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
- pragma Inspection_Point( Embedded_Final_Object ); -- BKRTP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
- null;
-end CXH3002_0.CXH3002_1;
-
-------------------------------------------------------------------- CXH3002
-
-with Report;
-with CXH3002_0.CXH3002_1;
-procedure CXH3002 is
-
- use type CXH3002_0.Enum, CXH3002_0.Int, CXH3002_0.Unt, CXH3002_0.Flt,
- CXH3002_0.Fix, CXH3002_0.Root;
-
- Main_Enum : CXH3002_0.Enum := CXH3002_0.Item;
- Main_Int : CXH3002_0.Int;
- Main_Unt : CXH3002_0.Unt;
- Main_Flt : CXH3002_0.Flt;
- Main_Fix : CXH3002_0.Fix;
- Main_Rec : CXH3002_0.Root(CXH3002_0.Stuff)
- := (CXH3002_0.Stuff, I => 1, U => 2);
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Main_Rec ); -- BJQO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
-
- Main_List : CXH3002_0.List := ( others => Main_Rec );
-
- Main_A_List : CXH3002_0.A_List := new CXH3002_0.List'( others => Main_Rec );
- Main_A_Proc : CXH3002_0.A_Proc := CXH3002_0.Func;
- -- CXH3002_0.Proc'Access
- Main_PT : CXH3002_0.PT;
- Main_TT : CXH3002_0.TT;
-
- type Test_Range is (First, Second);
-
- procedure Assert( Truth : Boolean; Message : String ) is
- begin
- if not Truth then
- Report.Failed( "Unexpected value found in " & Message );
- end if;
- end Assert;
-
-begin -- Main test procedure.
-
- Report.Test ("CXH3002", "Check pragma Inspection_Point" );
-
- Enclosure:declare
- Main_Final : CXH3002_0.CXH3002_1.Final;
- Xtra_Final : CXH3002_0.CXH3002_1.Final;
- begin
- for Test_Case in Test_Range loop
-
-
- case Test_Case is
- when First =>
- Main_Final.Value := 5;
- Xtra_Final := Main_Final; -- call Adjust
- Main_Enum := CXH3002_0.Things;
- Main_Int := CXH3002_0.Int'First;
- Main_Unt := CXH3002_0.Unt'Last;
- Main_Flt := 3.14;
- Main_Fix := 0.5;
- Main_Rec := (CXH3002_0.Stuff, I => 3, U => 4);
- Main_List(Main_Unt) := Main_Rec;
- Main_A_List(CXH3002_0.Unt'First) := (CXH3002_0.Stuff, I => 5, U => 6);
- Main_A_Proc( Main_A_List(2) );
- Main_PT.Prot_Entry(True);
- Main_TT.Task_Entry( null );
-
- when Second =>
- Assert( Main_Final.Value = 5, "Main_Final" );
- Assert( Xtra_Final.Value = 2, "Xtra_Final" );
- Assert( Main_Enum = CXH3002_0.Things, "Main_Enum" );
- Assert( Main_Int = CXH3002_0.Int'First, "Main_Int" );
- Assert( Main_Unt = CXH3002_0.Unt'Last, "Main_Unt" );
- Assert( Main_Flt in 3.0..3.5, "Main_Flt" );
- Assert( Main_Fix = 0.5, "Main_Fix" );
- Assert( Main_Rec = (CXH3002_0.Stuff, I => 3, U => 4), "Main_Rec" );
- Assert( Main_List(Main_Unt) = Main_Rec, "Main_List" );
- Assert( Main_A_List(CXH3002_0.Unt'First)
- = (CXH3002_0.Stuff, I => 5, U => 6), "Main_A_List" );
-
- end case;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
- pragma Inspection_Point( -- CQP
- Main_Final, -- M
- Main_Enum, -- D
- Main_Int, -- E
- Main_Unt, -- E
- Main_Flt, -- G
- Main_Fix, -- H
- Main_Rec, -- J
- Main_List, -- I
- Main_A_List, -- F
- Main_A_Proc, -- F
- Main_PT, -- L
- Main_TT ); -- N
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
-
- end loop;
- end Enclosure;
-
- Report.Result;
-
-end CXH3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a b/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a
deleted file mode 100644
index 1b1399c..0000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- CXH30030.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
--- See CHX30031.AM
---
--- TEST DESCRIPTION
--- See CHX30031.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- => CXH30030.A
--- CXH30031.AM
---
--- APPLICABILITY CRITERIA:
--- See CHX30031.AM
---
--- SPECIAL REQUIREMENTS
--- See CHX30031.AM
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version for 2.1
--- 07 JUN 96 SAIC Revised by reviewer request, split to multifile
---
---!
-
- pragma Reviewable;
-
--- This test requires that this configuration pragma be applied to all
--- following compilation units in the environment; specifically the ones
--- in file CXH30031.AM
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am b/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am
deleted file mode 100644
index 91bf3e8..0000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am
+++ /dev/null
@@ -1,215 +0,0 @@
--- CXH30031.AM
---
--- 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 pragma Reviewable.
--- Check that pragma Reviewable is accepted as a configuration pragma.
---
--- TEST DESCRIPTION
--- This test checks that pragma Reviewable is processed as a
--- configuration pragma. See CXH3001 for testing pragma Reviewable as
--- other than a configuration pragma.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CXH30030.A
--- => CXH30031.AM
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Safety and Security Annex.
---
--- SPECIAL REQUIREMENTS
--- The implementation must process a configuration pragma which is not
--- part of any Compilation Unit; the method employed is implementation
--- defined.
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version for 2.1
--- 07 JUN 96 SAIC Revised by reviewer request
--- 03 NOV 96 SAIC Documentation revision
---
--- 03 NOV 96 Keith Documentation revision
--- 27 AUG 99 RLB Removed result dependence on uninitialized object.
--- 30 AUG 99 RLB Repaired the above.
---
---!
-
- pragma Reviewable;
-
------------------------------------------------------------------ CXH3003_0
-
-package CXH3003_0 is
-
- type Enum is (Item,Stuff,Things);
-
- type Int is range 0..256;
-
- type Unt is mod 256;
-
- type Flt is digits 5;
-
- type Fix is delta 0.5 range -1.0..1.0;
-
- type Root(Disc: Enum) is tagged record
- I: Int; U:Unt;
- end record;
-
- type List is array(Unt) of Root(Stuff);
-
- type A_List is access List;
- type A_Proc is access procedure(R:Root);
-
- procedure P(R:Root);
-
- function F return A_Proc;
-
- Global_Variable : Boolean := False;
-
-end CXH3003_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-with Report;
-package body CXH3003_0 is
-
- procedure P(R:Root) is
- Warnable : Positive := 0; -- OPTIONAL WARNING
- begin
- case R.Disc is
- when Item => Report.Comment("Got Item");
- when Stuff => Report.Comment("Got Stuff");
- when Things => Report.Comment("Got Things");
- end case;
- if Report.Ident_Int( Warnable ) = 0 then
- Global_Variable := not Global_Variable; -- known to be initialized
- end if;
- end P;
-
- function F return A_Proc is
- begin
- return P'Access;
- end F;
-
-end CXH3003_0;
-
------------------------------------------------------------------ CXH3003_1
-
-package CXH3003_0.CXH3003_1 is
-
- protected PT is
- entry Set(Switch: Boolean);
- function Enquire return Boolean;
- private
- Toggle : Boolean;
- end PT;
-
- task TT is
- entry Release;
- end TT;
-
-end CXH3003_0.CXH3003_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body CXH3003_0.CXH3003_1 is
-
- protected body PT is
-
- entry Set(Switch: Boolean) when True is
- begin
- Toggle := Switch;
- end Set;
-
- function Enquire return Boolean is
- begin
- return Toggle;
- end Enquire;
-
- end PT;
-
- task body TT is
- begin
- loop
- accept Release;
- exit when Global_Variable;
- end loop;
- end TT;
-
- -- TT activation
-
-end CXH3003_0.CXH3003_1;
-
-------------------------------------------------------------------- CXH3003
-
-with Report;
-with CXH3003_0.CXH3003_1;
-procedure CXH30031 is
-begin
-
- Report.Test("CXH3003", "Check pragma Reviewable as a configuration pragma");
-
- Block: declare
- A_Truth : Boolean;
- Message : String := Report.Ident_Str( "Bad value encountered" );
- begin
- begin
- A_Truth := Report.Ident_Bool( True ) or A_Truth; -- not initialized
- if not A_Truth then
- Report.Comment ("True or Uninit = False");
- A_Truth := Report.Ident_Bool (True);
- else
- A_Truth := Report.Ident_Bool (True);
- -- We do this separately on each branch in order to insure that a
- -- clever optimizer can find out little about this value. Ident_Bool
- -- is supposed to be opaque to any optimizer.
- end if;
- exception
- when Constraint_Error | Program_Error =>
- -- Possible results of accessing an uninitialized object.
- A_Truth := Report.Ident_Bool (True);
- end;
-
- CXH3003_0.CXH3003_1.PT.Set( A_Truth );
-
- CXH3003_0.Global_Variable := A_Truth;
-
- CXH3003_0.CXH3003_1.TT.Release; -- rendezvous with TT
-
- while CXH3003_0.CXH3003_1.TT'Callable loop -- wait for TT to complete
- delay 1.0;
- end loop;
-
- if not CXH3003_0.CXH3003_1.PT.Enquire
- or not CXH3003_0.Global_Variable then
- Report.Failed(Message);
- end if;
-
- end Block;
-
- Report.Result;
-
-end CXH30031;
diff --git a/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada b/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada
deleted file mode 100644
index 394575f..0000000
--- a/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- CZ1101A.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 REPORT ROUTINES OF THE REPORT PACKAGE WORK
--- CORRECTLY.
---
--- PASS/FAIL CRITERIA:
--- THIS TEST PASSES IF THE OUTPUT MATCHES THAT SUPPLIED IN THE
--- APPLICABLE VERSION OF THE ACVC USERS' GUIDE. THE EXPECTED
--- TEST RESULT IS "TENTATIVELY PASSED."
-
--- HISTORY:
--- JRK 08/07/81 CREATED ORIGINAL TEST.
--- JRK 10/27/82
--- JRK 06/01/84
--- JET 01/13/88 ADDED TESTS OF SPECIAL_ACTION AND UPDATED HEADER.
--- PWB 06/24/88 CORRECTED LENGTH OF ONE OUTPUT STRING AND ADDED
--- PASS/FAIL CRITERIA.
--- BCB 05/17/90 CORRECTED LENGTH OF 'MAX_LEN LONG' OUTPUT STRING.
--- ADDED CODE TO CREATE REPFILE.
--- LDC 05/17/90 REMOVED DIRECT_IO REFERENCES.
--- PWN 12/03/94 REMOVED ADA 9X INCOMPATIBILITIES.
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CZ1101A IS
-
-
- DATE_AND_TIME : STRING(1..17);
-
- DATE, TIME : STRING(1..7);
-
-BEGIN
-
- COMMENT ("(CZ1101A) CHECK REPORT ROUTINES");
- COMMENT (" INITIAL VALUES SHOULD BE 'NO_NAME' AND 'FAILED'");
- RESULT;
-
- TEST ("PASS_TEST", "CHECKING 'TEST' AND 'RESULT' FOR 'PASSED'");
- COMMENT ("THIS LINE IS EXACTLY 'MAX_LEN' LONG. " &
- "...5...60....5...70");
- COMMENT ("THIS COMMENT HAS A WORD THAT SPANS THE FOLD " &
- "POINT. THIS COMMENT FITS EXACTLY ON TWO LINES. " &
- "..5...60....5...70");
- COMMENT ("THIS_COMMENT_IS_ONE_VERY_LONG_WORD_AND_SO_" &
- "IT_SHOULD_BE_SPLIT_AT_THE_FOLD_POINT");
- RESULT;
-
- COMMENT ("CHECK THAT 'RESULT' RESETS VALUES TO 'NO_NAME' " &
- "AND 'FAILED'");
- RESULT;
-
- TEST ("FAIL_TEST", "CHECKING 'FAILED' AND 'RESULT' FOR 'FAILED'");
- FAILED ("'RESULT' SHOULD NOW BE 'FAILED'");
- RESULT;
-
- TEST ("NA_TEST", "CHECKING 'NOT-APPLICABLE'");
- NOT_APPLICABLE ("'RESULT' SHOULD NOW BE 'NOT-APPLICABLE'");
- RESULT;
-
- TEST ("FAIL_NA_TEST", "CHECKING 'NOT_APPLICABLE', 'FAILED', " &
- "'NOT_APPLICABLE'");
- NOT_APPLICABLE ("'RESULT' BECOMES 'NOT-APPLICABLE'");
- FAILED ("'RESULT' BECOMES 'FAILED'");
- NOT_APPLICABLE ("CALLING 'NOT_APPLICABLE' DOESN'T CHANGE " &
- "'RESULT'");
- RESULT;
-
- TEST ("SPEC_NA_TEST", "CHECKING 'SPEC_ACT', 'NOT_APPLICABLE', " &
- "'SPEC_ACT'");
- SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'");
- NOT_APPLICABLE ("'RESULT' BECOMES 'NOT APPLICABLE'");
- SPECIAL_ACTION("CALLING 'SPECIAL_ACTION' DOESN'T CHANGE 'RESULT'");
- RESULT;
-
- TEST ("SPEC_FAIL_TEST", "CHECKING 'SPEC_ACT', 'FAILED', " &
- "'SPEC_ACT'");
- SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'");
- FAILED ("'RESULT' BECOMES 'FAILED'");
- SPECIAL_ACTION("CALLING 'SPECIAL_ACTION' DOESN'T CHANGE 'RESULT'");
- RESULT;
-
- TEST ("CZ1101A", "CHECKING 'SPECIAL_ACTION' ALONE");
- SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'");
- RESULT;
-
-END CZ1101A;
diff --git a/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada b/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada
deleted file mode 100644
index 0255bb4..0000000
--- a/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada
+++ /dev/null
@@ -1,75 +0,0 @@
--- CZ1102A.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 DYNAMIC VALUE ROUTINES OF THE REPORT PACKAGE WORK
--- CORRECTLY.
-
--- JRK 8/7/81
--- JRK 10/27/82
--- RLB 03/20/00 - Added checks for Integer'First and Integer'Last.
-
-WITH REPORT;
-USE REPORT;
-
-PROCEDURE CZ1102A IS
-
-BEGIN
-
- TEST ("CZ1102A", "CHECK THAT THE DYNAMIC VALUE ROUTINES OF " &
- "THE REPORT PACKAGE WORK CORRECTLY");
-
- IF NOT EQUAL (0, 0) OR
- EQUAL (0, 1) OR
- NOT EQUAL (1, 1) OR
- NOT EQUAL (3, 3) OR
- NOT EQUAL (4, 4) OR
- NOT EQUAL (-1, -1) OR
- NOT EQUAL (INTEGER'FIRST, INTEGER'FIRST) OR
- NOT EQUAL (INTEGER'LAST, INTEGER'LAST) OR
- EQUAL (-1, 0) THEN
- FAILED ("'EQUAL' NOT WORKING");
- END IF;
-
- IF IDENT_INT (5) /= 5 THEN
- FAILED ("'IDENT_INT' NOT WORKING");
- END IF;
-
- IF IDENT_CHAR ('E') /= 'E' THEN
- FAILED ("'IDENT_CHAR' NOT WORKING");
- END IF;
-
- IF IDENT_BOOL (TRUE) /= TRUE THEN
- FAILED ("'IDENT_BOOL' NOT WORKING");
- END IF;
-
- IF IDENT_STR ("") /= "" OR
- IDENT_STR ("K") /= "K" OR
- IDENT_STR ("PQRS") /= "PQRS" THEN
- FAILED ("'IDENT_STR' NOT WORKING");
- END IF;
-
- RESULT;
-
-END CZ1102A;
diff --git a/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada b/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada
deleted file mode 100644
index 87756c8..0000000
--- a/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada
+++ /dev/null
@@ -1,232 +0,0 @@
--- CZ1103A.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 PROCEDURE CHECK_FILE WORKS CORRECTLY, IN
--- PARTICULAR, THAT IT WILL REPORT INCORRECT FILE CONTENTS
--- AS TEST FAILURES.
-
--- THIS TEST INTENTIONALLY CONTAINS MISMATCHES BETWEEN FILE
--- CONTENTS AND THE 'CONTENTS' STRING PARAMETER OF PROCEDURE
--- CHECK_FILE.
-
--- PASS/FAIL CRITERIA:
--- IF AN IMPLEMENTATION SUPPORTS EXTERNAL FILES, IT PASSES THIS TEST
--- IF TEST EXECUTION REPORTS THE FOLLOWING FOUR FAILURES, REPORTS AN
--- INTERMEDIATE "FAILED" RESULT, REPORTS A FINAL "TENTATIVELY PASSED"
--- RESULT, AND REPORTS NO OTHER FAILURES.
--- * CZ1103A FROM CHECK_FILE: END OF LINE EXPECTED - E
--- ENCOUNTERED.
--- * CZ1103A FROM CHECK_FILE: END_OF_PAGE NOT WHERE EXPECTED.
--- * CZ1103A FROM CHECK_FILE: END_OF_FILE NOT WHERE EXPECTED.
--- * CZ1103A FROM CHECK_FILE: FILE DOES NOT CONTAIN CORRECT
--- OUTPUT - EXPECTED C - GOT I.
---
--- IF AN IMPLEMENTATION DOES NOT SUPPORT EXTERNAL FILES, IT PASSES THIS
--- TEST IF TEST EXECUTION REPORTS NINE FAILURES FOR INCOMPLETE SUBTESTS
--- SIMILAR TO THE SAMPLE BELOW, REPORTS AN INTERMEDIATE "FAILED" RESULT,
--- REPORTS A FINAL "TENTATIVELY PASSED" RESULT, AND REPORTS NO OTHER
--- FAILURES.
--- * CZ1103A TEST WITH EMPTY FILE INCOMPLETE.
-
--- HISTORY:
--- SPS 12/09/82 CREATED ORIGINAL TEST.
--- JRK 11/18/85 ADDED COMMENTS ABOUT PASS/FAIL CRITERIA.
--- JET 01/13/88 UPDATED HEADER FORMAT, ADDED FINAL CALL TO
--- SPECIAL_ACTION.
--- PWB 06/24/88 CORRECTED PASS/FAIL CRITERIA TO INDICATE THE
--- EXPECTED RESULT (TENTATIVELY PASSED).
--- RLB 03/20/00 CORRECTED PASS/FAIL CRITERIA TO REFLECT PROPER RESULT
--- FOR AN IMPLEMENTATION THAT DOES NOT SUPPORT EXTERNAL FILES.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE CZ1103A IS
-
- NULL_FILE : FILE_TYPE;
- FILE_WITH_BLANK_LINES : FILE_TYPE;
- FILE_WITH_BLANK_PAGES : FILE_TYPE;
- FILE_WITH_TRAILING_BLANKS : FILE_TYPE;
- FILE_WITHOUT_TRAILING_BLANKS : FILE_TYPE;
- FILE_WITH_END_OF_LINE_ERROR : FILE_TYPE;
- FILE_WITH_END_OF_PAGE_ERROR : FILE_TYPE;
- FILE_WITH_END_OF_FILE_ERROR : FILE_TYPE;
- FILE_WITH_DATA_ERROR : FILE_TYPE;
-
-BEGIN
-
- TEST ("CZ1103A", "CHECK THAT PROCEDURE CHECK_FILE WORKS");
-
--- THIS SECTION TESTS CHECK_FILE WITH AN EMPTY FILE.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH AN EMPTY FILE");
- CREATE (NULL_FILE, OUT_FILE);
- CHECK_FILE (NULL_FILE, "#@%");
- CLOSE (NULL_FILE);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH EMPTY FILE INCOMPLETE");
-
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH BLANK LINES.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH A FILE WITH BLANK LINES");
- CREATE (FILE_WITH_BLANK_LINES, OUT_FILE);
- NEW_LINE (FILE_WITH_BLANK_LINES, 20);
- CHECK_FILE (FILE_WITH_BLANK_LINES, "####################@%");
- CLOSE (FILE_WITH_BLANK_LINES);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH FILE WITH BLANK LINES INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH BLANK LINES AND PAGES.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH A FILE WITH BLANK LINES " &
- "AND PAGES");
- CREATE (FILE_WITH_BLANK_PAGES, OUT_FILE);
- NEW_LINE (FILE_WITH_BLANK_PAGES, 3);
- NEW_PAGE (FILE_WITH_BLANK_PAGES);
- NEW_LINE (FILE_WITH_BLANK_PAGES, 2);
- NEW_PAGE (FILE_WITH_BLANK_PAGES);
- NEW_PAGE (FILE_WITH_BLANK_PAGES);
- CHECK_FILE (FILE_WITH_BLANK_PAGES, "###@##@#@%");
- CLOSE (FILE_WITH_BLANK_PAGES);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH FILE WITH BLANK PAGES INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH TRAILING BLANKS.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH A FILE WITH TRAILING BLANKS");
- CREATE (FILE_WITH_TRAILING_BLANKS, OUT_FILE);
- FOR I IN 1 .. 3 LOOP
- PUT_LINE (FILE_WITH_TRAILING_BLANKS,
- "LINE WITH TRAILING BLANKS ");
- END LOOP;
- CHECK_FILE(FILE_WITH_TRAILING_BLANKS, "LINE WITH TRAILING" &
- " BLANKS#LINE WITH TRAILING BLANKS#LINE" &
- " WITH TRAILING BLANKS#@%");
- CLOSE (FILE_WITH_TRAILING_BLANKS);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH FILE WITH TRAILING BLANKS " &
- "INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITHOUT TRAILING BLANKS.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH A FILE WITHOUT TRAILING BLANKS");
- CREATE (FILE_WITHOUT_TRAILING_BLANKS, OUT_FILE);
- FOR I IN 1 .. 3 LOOP
- PUT_LINE (FILE_WITHOUT_TRAILING_BLANKS,
- "LINE WITHOUT TRAILING BLANKS");
- END LOOP;
- CHECK_FILE(FILE_WITHOUT_TRAILING_BLANKS, "LINE WITHOUT " &
- "TRAILING BLANKS#LINE WITHOUT TRAILING BLANKS#" &
- "LINE WITHOUT TRAILING BLANKS#@%");
- CLOSE (FILE_WITHOUT_TRAILING_BLANKS);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH FILE WITHOUT TRAILING BLANKS " &
- "INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF LINE ERROR.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH A FILE WITH AN END OF LINE ERROR");
- CREATE (FILE_WITH_END_OF_LINE_ERROR, OUT_FILE);
- PUT_LINE (FILE_WITH_END_OF_LINE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN END OF LINE IN THE WRONG PLACE");
- CHECK_FILE (FILE_WITH_END_OF_LINE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN # IN THE WRONG PLACE#@%");
- CLOSE (FILE_WITH_END_OF_LINE_ERROR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH END_OF_LINE ERROR INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF PAGE ERROR.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH FILE WITH END OF PAGE ERROR");
- CREATE (FILE_WITH_END_OF_PAGE_ERROR, OUT_FILE);
- PUT_LINE (FILE_WITH_END_OF_PAGE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN END OF PAGE IN THE WRONG PLACE");
- CHECK_FILE (FILE_WITH_END_OF_PAGE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN @ IN THE WRONG PLACE#@%");
- CLOSE (FILE_WITH_END_OF_PAGE_ERROR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH END_OF_PAGE ERROR INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF FILE ERROR.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH FILE WITH END OF FILE ERROR");
- CREATE (FILE_WITH_END_OF_FILE_ERROR, OUT_FILE);
- PUT_LINE (FILE_WITH_END_OF_FILE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN END OF FILE IN THE WRONG PLACE");
- CHECK_FILE (FILE_WITH_END_OF_FILE_ERROR, "THIS LINE WILL " &
- "CONTAIN AN % IN THE WRONG PLACE#@%");
- CLOSE (FILE_WITH_END_OF_FILE_ERROR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH END_OF_FILE ERROR INCOMPLETE");
- END;
-
--- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH INCORRECT DATA.
-
- BEGIN
- COMMENT ("BEGIN TEST WITH FILE WITH INCORRECT DATA");
- CREATE (FILE_WITH_DATA_ERROR, OUT_FILE);
- PUT_LINE (FILE_WITH_DATA_ERROR, "LINE WITH INCORRECT " &
- "DATA");
- CHECK_FILE (FILE_WITH_DATA_ERROR, "LINE WITH CORRECT " &
- "DATA#@%");
- CLOSE (FILE_WITH_DATA_ERROR);
- EXCEPTION
- WHEN OTHERS =>
- FAILED ("TEST WITH INCORRECT DATA INCOMPLETE");
- END;
-
- RESULT;
-
- TEST ("CZ1103A", "THE LINE ABOVE SHOULD REPORT FAILURE");
- SPECIAL_ACTION ("COMPARE THIS OUTPUT TO THE EXPECTED RESULT");
- RESULT;
-
-END CZ1103A;
diff --git a/gcc/testsuite/ada/acats/tests/d/d4a002a.ada b/gcc/testsuite/ada/acats/tests/d/d4a002a.ada
deleted file mode 100644
index a2ec008..0000000
--- a/gcc/testsuite/ada/acats/tests/d/d4a002a.ada
+++ /dev/null
@@ -1,54 +0,0 @@
--- D4A002A.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.
---*
--- LARGE LITERALS IN NUMBER DECLARATIONS, BUT WITH RESULTING
--- SMALLER VALUE OBTAINED BY SUBTRACTION. THIS TEST LIMITS VALUES
--- TO 32 BINARY PLACES.
-
--- BAW 29 SEPT 80
--- JBG 12/6/84
-
-WITH REPORT;
-PROCEDURE D4A002A IS
-
- USE REPORT;
-
- X : CONSTANT := 1_034_567_890 - 1_034_567_891;
- Y : CONSTANT := 107 * (10 ** 7) - 1_069_999_999;
- Z : CONSTANT := (1024 ** 3) - (2 ** 30);
- D : CONSTANT := 1_073_741_823 / 32_769;
- E : CONSTANT := 536_870_912 REM 2_304_167;
- F : CONSTANT := (-134_217_728) MOD (-262_657);
-
-BEGIN TEST("D4A002A","LARGE INTEGER RANGE (WITH CANCELLATION) IN " &
- "NUMBER DECLARATIONS; LONGEST INTEGER IS 32 BITS");
-
- IF X /= -1 OR Y /= 1 OR Z /= 0 OR D /= 32_767 OR E /= 1 OR F /= -1
- THEN FAILED("EXPRESSIONS WITH A LARGE INTEGER RANGE (WITH " &
- "CANCELLATION) ARE NOT EXACT ");
- END IF;
-
- RESULT;
-
-END D4A002A;
diff --git a/gcc/testsuite/ada/acats/tests/d/d4a002b.ada b/gcc/testsuite/ada/acats/tests/d/d4a002b.ada
deleted file mode 100644
index 6278254..0000000
--- a/gcc/testsuite/ada/acats/tests/d/d4a002b.ada
+++ /dev/null
@@ -1,56 +0,0 @@
--- D4A002B.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.
---*
--- LARGER LITERALS IN NUMBER DECLARATIONS, BUT WITH RESULTING
--- SMALLER VALUE OBTAINED BY SUBTRACTION. THIS TEST LIMITS VALUES
--- TO 64 BINARY PLACES.
-
--- BAW 29 SEPT 80
--- JBG 05/02/85 RENAMED TO -B. REVISED SO THAT ALL RESULTS FIT IN
--- 16 BITS.
-
-WITH REPORT;
-PROCEDURE D4A002B IS
-
- USE REPORT;
-
- X : CONSTANT := 4123456789012345678 - 4123456789012345679;
- Y : CONSTANT := 4 * (10 ** 18) - 3999999999999999999;
- Z : CONSTANT := (1024 ** 6) - (2 ** 60);
- D : CONSTANT := 9_223_372_036_854_775_807 / 994_862_694_084_217;
- E : CONSTANT := 36_028_790_976_242_271 REM 17_600_175_361;
- F : CONSTANT := ( - 2 ** 51 ) MOD ( - 131_071 );
-
-BEGIN TEST("D4A002B","LARGE INTEGER RANGE (WITH CANCELLATION) IN " &
- "NUMBER DECLARATIONS; LONGEST INTEGER IS 64 BITS ");
-
- IF X /= -1 OR Y /= 1 OR Z /= 0
- OR D /= 9271 OR E /= 1 OR F /= -1
- THEN FAILED("EXPRESSIONS WITH A LARGE INTEGER RANGE (WITH " &
- "CANCELLATION) ARE NOT EXACT ");
- END IF;
-
- RESULT;
-
-END D4A002B;
diff --git a/gcc/testsuite/ada/acats/tests/d/d4a004a.ada b/gcc/testsuite/ada/acats/tests/d/d4a004a.ada
deleted file mode 100644
index 7c744d7..0000000
--- a/gcc/testsuite/ada/acats/tests/d/d4a004a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- D4A004A.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.
---*
--- 32 BIT INTEGERS IN NUMBER DECLARATIONS. UNLIKE TEST D4A002A,
--- NO CANCELLATION IS INVOLVED.
-
--- A COMPILER MAY REFUSE TO COMPILE THIS TEST BECAUSE THE NUMBERS
--- INVOLVED ARE TOO BIG.
-
--- BAW 29 SEPT 80
--- JBG 12/6/84
-
-WITH REPORT;
-PROCEDURE D4A004A IS
-
- USE REPORT;
-
- X : CONSTANT := 511_111_111 + 501_111_111;
- Y : CONSTANT := -599_999_999 - 411_111_112;
- Z : CONSTANT := 10 * (10 ** 8);
- D : CONSTANT := 2 ** 30 / 1;
- E : CONSTANT := ( 2 ** 29 - 1) REM 233;
- F : CONSTANT := ABS(( - 2 ** 27 + 1) MOD 511);
-
-BEGIN TEST("D4A004A","LARGE INTEGER VALUES IN NUMBER DECLARATIONS; " &
- "LONGEST INTEGER IS 32 BITS ");
-
- IF X /= 1_012_222_222 OR Y /= -1_011_111_111
- THEN FAILED("ADDITION OR SUBTRACTION NOT EXACT");
- END IF;
-
- IF Z /= 1_000_000_000 OR D /= 1_073_741_824 OR E /= 0 OR F /= 0
- THEN FAILED("INTEGER ** IS NOT EXACT");
- END IF;
-
- RESULT;
-
-END D4A004A;
diff --git a/gcc/testsuite/ada/acats/tests/d/d4a004b.ada b/gcc/testsuite/ada/acats/tests/d/d4a004b.ada
deleted file mode 100644
index f2e2b75..0000000
--- a/gcc/testsuite/ada/acats/tests/d/d4a004b.ada
+++ /dev/null
@@ -1,72 +0,0 @@
--- D4A004B.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.
---*
--- INTEGERS TO 64 BITS IN NUMBER DECLARATIONS. UNLIKE TEST C4A002B,
--- NO CANCELLATION IS INVOLVED.
-
--- BAW 29 SEPT 80
--- JWC 7/8/85 RENAMED TO -AB
-
-WITH REPORT;
-PROCEDURE D4A004B IS
-
- USE REPORT;
-
- X : CONSTANT := 2200000000000000000 + 2199999999999999999;
- Y : CONSTANT := -2200000000000000001 - 2199999999999999998;
- Z : CONSTANT := 4 * (10 ** 18);
- D : CONSTANT := 2 ** 63 / 1;
- E : CONSTANT := ( 2 ** 63 - 1 ) REM 454_279;
- F : CONSTANT := ABS(( -2 ** 55 + 1 ) MOD 2047 );
-
-BEGIN TEST("D4A004B","LARGE INTEGER VALUES IN NUMBER DECLARATIONS; " &
- "LONGEST INTEGER IS 64 BITS ");
-
- IF X /= 4399999999999999999 THEN
- FAILED ("ERROR X");
- END IF;
-
- IF Y /= -4399999999999999999 THEN
- FAILED ("ERROR Y");
- END IF;
-
- IF Z /= 4000000000000000000 THEN
- FAILED ("ERROR Z");
- END IF;
-
- IF E /= 0 THEN
- FAILED ("ERROR E");
- END IF;
-
- IF F /= 0 THEN
- FAILED ("ERROR F");
- END IF;
-
- IF D /= 9_223_372_036_854_775_808 THEN
- FAILED ("ERROR D");
- END IF;
-
- RESULT;
-
-END D4A004B;
diff --git a/gcc/testsuite/ada/acats/tests/e/e28002b.ada b/gcc/testsuite/ada/acats/tests/e/e28002b.ada
deleted file mode 100644
index d7c7869..0000000
--- a/gcc/testsuite/ada/acats/tests/e/e28002b.ada
+++ /dev/null
@@ -1,111 +0,0 @@
--- E28002B.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 PREDEFINED OR AN UNRECOGNIZED PRAGMA MAY HAVE
--- ARGUMENTS INVOLVING OVERLOADED IDENTIFIERS WITHOUT ENOUGH
--- CONTEXTUAL INFORMATION TO RESOLVE THE OVERLOADING.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT REPORTS "TENTATIVELY PASSED" AND
--- THE STARRED COMMENT DOES NOT APPEAR IN THE LISTING.
-
--- AN IMPLEMENTATION FAILS THIS TEST IF THE STARRED COMMENT
--- LINE APPEARS IN THE COMPILATION LISTING.
-
--- HISTORY:
--- TBN 02/24/86 CREATED ORIGINAL TEST.
--- JET 01/13/88 ADDED CALLS TO SPECIAL_ACTION AND UPDATED HEADER.
--- EDS 10/28/97 ADDED DECLARATIONS FOR PROCEDURES XYZ.
-
-WITH REPORT, SYSTEM; USE REPORT, SYSTEM;
-PROCEDURE E28002B IS
-
- FUNCTION OFF RETURN INTEGER IS
- BEGIN
- RETURN 1;
- END OFF;
-
- FUNCTION OFF RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END OFF;
-
- PRAGMA LIST (OFF);
---***** THIS LINE MUST NOT APPEAR IN COMPILATION LISTING.
- PRAGMA LIST (ON);
-
- FUNCTION ELABORATION_CHECK RETURN INTEGER IS
- BEGIN
- RETURN 1;
- END ELABORATION_CHECK;
-
- FUNCTION ELABORATION_CHECK RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END ELABORATION_CHECK;
-
- PRAGMA SUPPRESS (ELABORATION_CHECK, ELABORATION_CHECK);
-
- FUNCTION TIME RETURN INTEGER IS
- BEGIN
- RETURN 1;
- END TIME;
-
- FUNCTION TIME RETURN BOOLEAN IS
- BEGIN
- RETURN TRUE;
- END TIME;
-
- PRAGMA OPTIMIZE (TIME);
-
- PROCEDURE XYZ;
- PROCEDURE XYZ (COUNT : INTEGER);
-
- PRAGMA INLINE (XYZ);
- PRAGMA PHIL_BRASHEAR (XYZ);
-
- PROCEDURE XYZ IS
- BEGIN
- NULL;
- END XYZ;
-
- PROCEDURE XYZ (COUNT : INTEGER) IS
- BEGIN
- NULL;
- END XYZ;
-
-BEGIN
- TEST ("E28002B", "CHECK THAT A PREDEFINED OR AN UNRECOGNIZED " &
- "PRAGMA MAY HAVE ARGUMENTS INVOLVING " &
- "OVERLOADED IDENTIFIERS WITHOUT ENOUGH " &
- "CONTEXTUAL INFORMATION TO RESOLVE THE " &
- "OVERLOADING");
-
- SPECIAL_ACTION ("CHECK THAT THE COMPILATION LISTING DOES NOT " &
- "SHOW THE STARRED COMMENT LINE");
-
- RESULT;
-
-END E28002B;
diff --git a/gcc/testsuite/ada/acats/tests/e/e28005d.ada b/gcc/testsuite/ada/acats/tests/e/e28005d.ada
deleted file mode 100644
index a6632d6..0000000
--- a/gcc/testsuite/ada/acats/tests/e/e28005d.ada
+++ /dev/null
@@ -1,55 +0,0 @@
-PRAGMA PAGE;
--- E28005D.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 WHEN PRAGMA PAGE IS USED AT THE BEGINNING OR END OF A
--- COMPILATION, THERE IS NO PROBLEM.
-
--- PASS/FAIL CRITERIA:
--- THE TEST MUST COMPILE TO EXECUTE WITH A 'TENTATIVELY PASSED'
--- RESULT. THERE IS A PAGE BREAK BEFORE THE TEST NAME AND A
--- PAGE BREAK AFTER THE END OF THE TEST.
-
--- HISTORY:
--- RJW 04/16/86 CREATED ORIGINAL TEST.
--- JET 01/13/88 ADDED CALLS TO SPECIAL_ACTION AND UPDATED HEADER.
-
-WITH REPORT; USE REPORT;
-
-PROCEDURE E28005D IS
-BEGIN
- TEST ( "E28005D", "CHECK THAT WHEN PRAGMA PAGE IS USED AT THE " &
- "BEGINNING OR END OF A COMPILATION, THERE " &
- "IS NO PROBLEM");
-
- SPECIAL_ACTION ("CHECK THAT THE PAGE PRAGMAS AT THE BEGINNING " &
- "AND END OF THE PROGRAM CAUSE THE TEXT " &
- "FOLLOWING THE PRAGMAS TO APPEAR AT THE START " &
- "OF A NEW PAGE OF THE COMPILATION LISTING");
- RESULT;
-
-END E28005D;
-
-PRAGMA PAGE;
diff --git a/gcc/testsuite/ada/acats/tests/e/e52103y.ada b/gcc/testsuite/ada/acats/tests/e/e52103y.ada
deleted file mode 100644
index e2a7a95..0000000
--- a/gcc/testsuite/ada/acats/tests/e/e52103y.ada
+++ /dev/null
@@ -1,132 +0,0 @@
--- E52103Y.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 NULL ARRAY WITH ONE DIMENSION OF LENGTH GREATER THAN
--- INTEGER'LAST RAISES CONSTRAINT_ERROR OR NO EXCEPTION,
--- EITHER WHEN DECLARED OR ASSIGNED.
-
--- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS.
--- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING
--- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND
--- ARE PERFORMED CORRECTLY.
--- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT
--- ARE TREATED ELSEWHERE.)
-
-
--- THIS IS A SPECIAL CASE IN
-
--- DIVISION D : NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE
--- STATICALLY
-
--- WHICH (THE SPECIAL CASE) TREATS TWO-DIMENSIONAL ARRAYS WHOSE LENGTH
--- ALONG ONE DIMENSION IS GREATER THAN INTEGER'LAST AND WHOSE
--- LENGTH ALONG THE OTHER DIMENSION IS 0 .
-
-
--- *** 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
-
--- RM 07/31/81
--- SPS 03/22/83
--- JBG 05/02/83
--- JBG 06/01/85
--- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
--- AI-00387.
--- LDC 06/01/88 CHANGED HEADER COMMENT TO INDICATE CONSTRAINT_ERROR
--- IS ALLOWED. ADDED CODE TO PREVENT DEAD VARIABLE
--- OPTIMIZATION.
--- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
-
-WITH REPORT;
-PROCEDURE E52103Y IS
-
- USE REPORT ;
-
-BEGIN
-
- TEST( "E52103Y","CHECK WHETHER CONSTRAINT_ERROR " &
- "OR NO EXCEPTION IS RAISED WHEN DIMENSION OF " &
- "AN ARRAY HAS LENGTH > INTEGER'LAST");
- BEGIN
-
- DECLARE
-
- TYPE TA42 IS ARRAY(
- INTEGER RANGE IDENT_INT( 13 )..IDENT_INT( 12 ),
- INTEGER RANGE IDENT_INT(-2)..IDENT_INT(INTEGER'LAST)
- ) OF BOOLEAN ;
-
- SUBTYPE TA41 IS TA42 ;
-
- ARR41 : TA41 ;
- ARR42 : TA42 ;
-
- BEGIN
-
- COMMENT ("NO EXCEPTION FOR ARRAY DECLARATION");
-
- -- NULL ARRAY ASSIGNMENT:
-
- ARR42 := ARR41 ;
- IF ARR42'LENGTH(1) /= 0 THEN
- FOR I IN TA42'RANGE(2) LOOP
- ARR41(13,I) := IDENT_BOOL(ARR42(13,I));
- END LOOP;
- END IF;
-
- COMMENT ("NO EXCEPTION RAISED FOR NULL ARRAY " &
- "ASSIGNMENT");
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED IN LENGTH " &
- "COMPARISON");
-
- WHEN OTHERS =>
- FAILED( "OTHER EXCEPTION RAISED - SUBTEST 2" );
-
- END ;
-
- EXCEPTION
-
- WHEN CONSTRAINT_ERROR =>
- COMMENT ("CONSTRAINT_ERROR RAISED BY DECLARATION OF " &
- "NULL ARRAY TYPE WITH ONE DIMENSION > " &
- "INTEGER'LAST");
-
- WHEN OTHERS =>
- FAILED ("SOME OTHER EXCEPTION RAISED");
-
- END;
-
- -------------------------------------------------------------------
-
-
- RESULT ;
-
-
-END E52103Y;
diff --git a/gcc/testsuite/ada/acats/tests/e/eb4011a.ada b/gcc/testsuite/ada/acats/tests/e/eb4011a.ada
deleted file mode 100644
index 24705ba..0000000
--- a/gcc/testsuite/ada/acats/tests/e/eb4011a.ada
+++ /dev/null
@@ -1,79 +0,0 @@
--- EB4011A.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 UNHANDLED EXCEPTIONS RAISED IN PACKAGE SUBUNITS ARE
--- PROPAGATED TO THE ENVIRONMENT STATICALLY ENCLOSING THE
--- CORRESPONDING BODY STUB (DECLARER OF THE PARENT UNIT).
-
--- PASS/FAIL CRITERIA:
--- THIS TEST MUST EXECUTE AND REPORT "TENTATIVELY PASSED". IN
--- ADDITION, THE OUTPUT/LOG FILE MUST INDICATE THAT THE PROGRAM
--- TERMINATED WITH AN UNHANDLED EXCEPTION.
-
--- HISTORY:
--- DHH 03/29/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE EB4011A IS
-
- PACKAGE EB4011A_OUTSIDE IS
- END EB4011A_OUTSIDE;
-
- PACKAGE EB4011A1 IS
- END EB4011A1;
-
- PACKAGE BODY EB4011A1 IS
- BEGIN
-
- TEST("EB4011A", "CHECK THAT UNHANDLED EXCEPTIONS RAISED IN " &
- "PACKAGE SUBUNITS ARE PROPAGATED TO THE " &
- "ENVIRONMENT STATICALLY ENCLOSING THE" &
- "CORRESPONDING BODY STUB (DECLARER OF THE " &
- "PARENT UNIT)");
-
- SPECIAL_ACTION("CHECK THE OUTPUT FILE TO SEE IF THIS " &
- "PROGRAM TERMINATED WITH AN UNHANDLED " &
- "EXCEPTION");
-
- RESULT;
-
- END EB4011A1;
-
- PACKAGE BODY EB4011A_OUTSIDE IS SEPARATE;
-
-BEGIN
-
- TEST("EB4011A", "THIS LINE SHOULD NOT PRINT OUT");
-
- FAILED("EXCEPTION DID NOT CAUSE MAIN PROGRAM TERMINATION");
- RESULT;
-
-END EB4011A;
-
-SEPARATE (EB4011A)
-PACKAGE BODY EB4011A_OUTSIDE IS
-BEGIN
- RAISE CONSTRAINT_ERROR;
-END EB4011A_OUTSIDE;
diff --git a/gcc/testsuite/ada/acats/tests/e/eb4012a.ada b/gcc/testsuite/ada/acats/tests/e/eb4012a.ada
deleted file mode 100644
index 7166c0b..0000000
--- a/gcc/testsuite/ada/acats/tests/e/eb4012a.ada
+++ /dev/null
@@ -1,59 +0,0 @@
--- EB4012A.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 WHEN AN UNHANDLED EXCEPTION IS RAISED IN THE MAIN
--- PROGRAM, THE MAIN PROGRAM IS ABANDONED.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST MUST EXECUTE AND PRINT "TENTATIVELY PASSED". IN
--- ADDITION, THE OUTPUT/LOG FILE MUST SHOW THAT THE PROGRAM
--- WAS ABANDONED DUE TO AN UNHANDLED EXCEPTION.
-
--- HISTORY:
--- DHH 03/29/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-PROCEDURE EB4012A IS
-
-BEGIN
- TEST("EB4012A", "CHECK THAT WHEN AN UNHANDLED EXCEPTION IS " &
- "RAISED IN THE MAIN PROGRAM, THE MAIN PROGRAM " &
- "IS ABANDONED");
- SPECIAL_ACTION("CHECK THE OUTPUT/LOG FILE TO SEE THAT THIS " &
- "PROGRAM WAS ABANDONED BECAUSE OF AN UNHANDLED " &
- "EXCEPTION");
-
- RESULT;
-
- IF EQUAL(3,3) THEN
- RAISE CONSTRAINT_ERROR;
- END IF;
-
- TEST("EB4012A", "SHOULD NOT PRINT OUT");
- FAILED("CONSTRAINT_ERROR NOT RAISED");
-
- RESULT;
-
-END EB4012A;
diff --git a/gcc/testsuite/ada/acats/tests/e/eb4014a.ada b/gcc/testsuite/ada/acats/tests/e/eb4014a.ada
deleted file mode 100644
index d520bd0..0000000
--- a/gcc/testsuite/ada/acats/tests/e/eb4014a.ada
+++ /dev/null
@@ -1,87 +0,0 @@
--- EB4014A.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 WHEN EXCEPTIONS ARE RAISED DURING THE ELABORATION OF
--- A LIBRARY UNIT, EXECUTION OF THE MAIN PROGRAM IS ABANDONED.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST MUST EXECUTE AND REPORT "TENTATIVELY PASSED". IN
--- ADDITION, THE OUTPUT/LOG FILE MUST INDICATE THAT THE PROGRAM
--- TERMINATED WITH AN UNHANDLED EXCEPTION.
-
--- HISTORY:
--- DHH 03/29/88 CREATED ORIGINAL TEST.
--- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-
-WITH REPORT; USE REPORT;
-FUNCTION EB4014A1 RETURN INTEGER IS
-BEGIN
-
- TEST("EB4014A", "THIS LINE SHOULD NOT BE PRINTED");
-
- FAILED("THE MAIN PROGRAM BODY WAS ENTERED");
- RESULT;
-
- RETURN IDENT_INT(1);
-
-END EB4014A1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PACKAGE EB4014A_OUTSIDE IS
- PROCEDURE REQUIRE_BODY;
-END EB4014A_OUTSIDE;
-
-PACKAGE BODY EB4014A_OUTSIDE IS
- PROCEDURE REQUIRE_BODY IS
- BEGIN
- NULL;
- END;
-BEGIN
- TEST("EB4014A", "CHECK THAT WHEN EXCEPTIONS ARE RAISED DURING " &
- "THE ELABORATION OF A LIBRARY UNIT, EXECUTION " &
- "OF THE MAIN PROGRAM IS ABANDONED");
-
- SPECIAL_ACTION("CHECK THE OUTPUT/LOG FILE TO SEE IF THIS " &
- "PROGRAM TERMINATED WITH AN UNHANDLED " &
- "EXCEPTION");
-
- RESULT;
-
- RAISE CONSTRAINT_ERROR;
-END EB4014A_OUTSIDE;
-
-WITH EB4014A1; WITH EB4014A_OUTSIDE;
-WITH REPORT; USE REPORT;
-PROCEDURE EB4014A IS
- X : INTEGER := EB4014A1;
-BEGIN
-
- TEST("EB4014A", "THIS LINE SHOULD NOT PRINT OUT");
-
- FAILED("EXCEPTION DID NOT CAUSE MAIN PROGRAM TERMINATION");
- RESULT;
- X := IDENT_INT(X);
-END EB4014A;
diff --git a/gcc/testsuite/ada/acats/tests/e/ee3203a.ada b/gcc/testsuite/ada/acats/tests/e/ee3203a.ada
deleted file mode 100644
index a31887d..0000000
--- a/gcc/testsuite/ada/acats/tests/e/ee3203a.ada
+++ /dev/null
@@ -1,168 +0,0 @@
--- EE3203A.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 SET_INPUT AND SET_OUTPUT CAN BE USED, AND THAT THEY
--- DO NOT REDEFINE OR CLOSE THE CORRESPONDING STANDARD FILES.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT EXECUTES AND THE STANDARD OUTPUT FILE
--- CONTAINS THE LINE "INITIAL TEXT OF STANDARD_OUTPUT".
-
--- HISTORY:
--- ABW 08/25/82
--- SPS 11/19/82
--- VKG 02/15/83
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/19/87 CORRECTED EXCEPTION HANDLING, REMOVED DEPENDENCE
--- ON RESET, AND ADDED CHECKS FOR USE_ERROR ON DELETE.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE EE3203A IS
-
- INCOMPLETE : EXCEPTION;
- FILE_IN, FILE_OUT : FILE_TYPE;
- LST : NATURAL;
- IN_STR : STRING (1 .. 50);
-
-BEGIN
-
- TEST ("EE3203A", "CHECK THAT SET_INPUT AND SET_OUTPUT " &
- "CAN BE USED, AND THAT CORRESPONDING " &
- "STANDARD FILES ARE UNCHANGED");
-
- BEGIN
- CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE - 1");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- BEGIN
- CREATE (FILE_OUT, OUT_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " &
- "OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE - 2");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- PUT (FILE_IN, "INITIAL TEXT OF FILE_IN");
- PUT (FILE_OUT, "INITIAL TEXT OF FILE_OUT");
- PUT ("INITIAL TEXT OF STANDARD_OUTPUT");
-
- CLOSE (FILE_IN);
-
- BEGIN
- OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " &
- "IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE_IN);
- SET_OUTPUT (FILE_OUT);
-
- IF NOT IS_OPEN (STANDARD_INPUT) THEN
- FAILED ("STANDARD_INPUT NOT OPEN");
- END IF;
-
- IF NOT IS_OPEN (FILE_IN) THEN
- FAILED ("FILE_IN NOT OPEN");
- END IF;
-
- IF NOT IS_OPEN (STANDARD_OUTPUT) THEN
- FAILED ("STANDARD_OUTPUT NOT OPEN");
- END IF;
-
- IF NOT IS_OPEN (FILE_OUT) THEN
- FAILED ("FILE_OUT NOT OPEN");
- END IF;
-
- NEW_LINE;
- PUT ("SECOND LINE OF OUTPUT");
-
- GET_LINE (IN_STR, LST);
- IF IN_STR (1 .. LST) /= "INITIAL TEXT OF FILE_IN" THEN
- FAILED ("DEFAULT INPUT INCORRECT");
- END IF;
-
- CHECK_FILE (FILE_IN, "INITIAL TEXT OF FILE_IN#@%");
- SET_OUTPUT (FILE => STANDARD_OUTPUT);
- SET_INPUT (FILE => STANDARD_INPUT);
- CHECK_FILE (FILE_OUT, "INITIAL TEXT OF FILE_OUT#" &
- "SECOND LINE OF OUTPUT#@%");
-
- SPECIAL_ACTION ("THE STANDARD OUTPUT FILE SHOULD CONTAIN " &
- "THE LINE : INITIAL TEXT OF STANDARD_OUTPUT");
-
- BEGIN
- DELETE (FILE_IN);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- BEGIN
- DELETE (FILE_OUT);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END EE3203A;
diff --git a/gcc/testsuite/ada/acats/tests/e/ee3204a.ada b/gcc/testsuite/ada/acats/tests/e/ee3204a.ada
deleted file mode 100644
index 2482b19..0000000
--- a/gcc/testsuite/ada/acats/tests/e/ee3204a.ada
+++ /dev/null
@@ -1,128 +0,0 @@
--- EE3204A.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 AFTER THE DEFAULT FILES HAVE BEEN REDEFINED,
--- OUTPUT ON THE STANDARD FILES IS STILL PROPERLY HANDLED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED,
--- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT.
-
--- HISTORY:
--- JLH 07/08/88 CREATED ORIGINAL TEST.
-
-WITH REPORT; USE REPORT;
-WITH TEXT_IO; USE TEXT_IO;
-
-PROCEDURE EE3204A IS
-
- FILE1, FILE2 : FILE_TYPE;
- ITEM : CHARACTER := 'B';
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("EE3204A", "CHECK THAT AFTER THE DEFAULT FILES HAVE BEEN " &
- "REDEFINED, OUTPUT ON THE STANDARD " &
- "FILES IS STILL PROPERLY HANDLED");
-
- BEGIN
-
- BEGIN
- CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " &
- "WITH MODE OUT_FILE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2));
- PUT (FILE2, 'A');
- NEW_LINE (FILE2);
- PUT (FILE2, 'B');
-
- CLOSE (FILE2);
-
- BEGIN
- OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2));
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " &
- "WITH MODE IN_FILE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (FILE2);
-
- GET (ITEM);
- IF ITEM /= 'A' THEN
- FAILED ("INCORRECT VALUE READ FROM DEFAULT FILE");
- END IF;
-
- SET_OUTPUT (FILE1);
-
- PUT ("THIS TEST FAILS IF THIS APPEARS IN STANDARD OUTPUT");
- NEW_LINE;
- PUT ("THIS TEST FAILS IF THIS APPEARS IN STANDARD OUTPUT");
-
- PUT (STANDARD_OUTPUT, "FIRST LINE OF INPUT");
- NEW_LINE (STANDARD_OUTPUT);
- PUT (STANDARD_OUTPUT, "SECOND LINE OF INPUT");
-
- SPECIAL_ACTION ("CHECK THAT THE CONTENTS OF THE STANDARD " &
- "OUTPUT FILE ARE CORRECT");
- SPECIAL_ACTION ("IT SHOULD CONTAIN:");
- SPECIAL_ACTION ("TEST HEADER LINES");
- SPECIAL_ACTION ("FIRST LINE OF INPUT");
- SPECIAL_ACTION ("SECOND LINE OF INPUT");
-
- BEGIN
- DELETE (FILE1);
- DELETE (FILE2);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END EE3204A;
diff --git a/gcc/testsuite/ada/acats/tests/e/ee3402b.ada b/gcc/testsuite/ada/acats/tests/e/ee3402b.ada
deleted file mode 100644
index ee6660b..0000000
--- a/gcc/testsuite/ada/acats/tests/e/ee3402b.ada
+++ /dev/null
@@ -1,118 +0,0 @@
--- EE3402B.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 NEW_LINE HAS AN OPTIONAL SPACING PARAMETER WITH
--- DEFAULT VALUE ONE, AND CHECK THAT NEW_LINE OPERATES ON THE
--- CURRENT DEFAULT OUTPUT FILE IF NO FILE IS SPECIFIED.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED,
--- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/16/82
--- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- DWC 08/19/87 ADDED SPECIAL ACTION FUNCTION AND REMOVED
--- EXCEPTION HANDLERS. CHANGED TO AN E TEST.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-WITH CHECK_FILE;
-
-PROCEDURE EE3402B IS
-
- INCOMPLETE : EXCEPTION;
- FILE, FILE_OUT : FILE_TYPE;
- SPAC : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- TWO : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2));
- FOUR : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4));
- CUR_LINE : COUNT;
-
-BEGIN
-
- TEST ("EE3402B", "CHECK THAT NEW_LINE HAS AN OPTIONAL " &
- "SPACING PARAMETER WITH DEFAULT VALUE ONE, " &
- "AND CHECK THAT NEW_LINE OPERATES ON THE " &
- "CURRENT DEFAULT OUTPUT FILE IF NO FILE IS " &
- "SPECIFIED.");
-
- BEGIN
- CREATE (FILE);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE - 1");
- RAISE INCOMPLETE;
- END;
-
- CREATE (FILE_OUT);
-
- SPECIAL_ACTION ("CHECK OUTPUT FOR FOUR BLANK LINES");
-
- NEW_LINE (FILE);
- IF LINE (FILE) /= TWO THEN
- FAILED ("SPACING DEFAULT NOT ONE");
- END IF;
-
- SPECIAL_ACTION ("FOUR BLANK LINES SHOULD FOLLOW THIS COMMENT");
- CUR_LINE := LINE (STANDARD_OUTPUT);
- NEW_LINE (SPAC);
- IF LINE (STANDARD_OUTPUT) /= CUR_LINE + 4 THEN
- FAILED ("FILE DEFAULT NOT CORRECT FOR STANDARD_OUTPUT");
- END IF;
-
- SET_OUTPUT (FILE_OUT);
- NEW_LINE (SPAC);
- IF LINE (CURRENT_OUTPUT) /= FOUR + 1 THEN
- FAILED ("FILE DEFAULT NOT CORRECT FOR CURRENT_OUTPUT");
- END IF;
-
- SET_OUTPUT (STANDARD_OUTPUT); -- RESET STANDARD OUTPUT
- COMMENT ("CHECKING FILE");
- CHECK_FILE (FILE, "#@%");
- COMMENT ("CHECKING FILE_OUT");
- CHECK_FILE (FILE_OUT, "####@%");
-
- CLOSE (FILE);
- CLOSE (FILE_OUT);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END EE3402B;
diff --git a/gcc/testsuite/ada/acats/tests/e/ee3409f.ada b/gcc/testsuite/ada/acats/tests/e/ee3409f.ada
deleted file mode 100644
index 8460c46..0000000
--- a/gcc/testsuite/ada/acats/tests/e/ee3409f.ada
+++ /dev/null
@@ -1,103 +0,0 @@
--- EE3409F.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 FILE PARAMETER FOR SET_COL IS OPTIONAL, AND
--- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT
--- OUTPUT FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED,
--- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT.
-
--- HISTORY:
--- ABW 08/26/82
--- SPS 09/20/82
--- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE
--- RESULT WHEN FILES ARE NOT SUPPORTED.
--- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, CHECKED FOR
--- USE_ERROR ON DELETE, AND RENAMED FROM
--- CE3409F.ADA.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE EE3409F IS
-
- INCOMPLETE : EXCEPTION;
- FILE_OUT : FILE_TYPE;
- TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2));
- THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3));
-
-BEGIN
-
- TEST ("EE3409F", "CHECK DEFAULT FILE FOR SET_COL");
-
- BEGIN
- CREATE (FILE_OUT);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "FOR TEMPORARY FILES WITH " &
- "OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN OTHERS =>
- FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE");
- RAISE INCOMPLETE;
- END;
-
- SPECIAL_ACTION ("THE NEXT LINE SHOULD BEGIN IN COLUMN TWO");
-
- SET_COL (TWO);
- PUT ("SHOULD BEGIN IN COLUMN TWO");
-
- IF COL (STANDARD_OUTPUT) /= 28 THEN
- FAILED ("SET_COL DOES NOT OPERATE ON THE DEFAULT " &
- "STANDARD_OUTPUT");
- END IF;
-
- NEW_LINE;
-
- SET_OUTPUT (FILE_OUT);
- SET_COL (THREE);
- IF COL (CURRENT_OUTPUT) /= THREE THEN
- FAILED ("SET_COL DOES NOT OPERATE ON THE DEFAULT " &
- "CURRENT_OUTPUT");
- END IF;
-
- CLOSE (FILE_OUT);
-
- RESULT;
-
-EXCEPTION
- WHEN INCOMPLETE =>
- RESULT;
-
-END EE3409F;
diff --git a/gcc/testsuite/ada/acats/tests/e/ee3412c.ada b/gcc/testsuite/ada/acats/tests/e/ee3412c.ada
deleted file mode 100644
index b5c10ab..0000000
--- a/gcc/testsuite/ada/acats/tests/e/ee3412c.ada
+++ /dev/null
@@ -1,144 +0,0 @@
--- EE3412C.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 LINE OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN
--- NO FILE IS SPECIFIED. CHECK THAT LINE CAN OPERATE ON FILES OF
--- MODE IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT
--- INPUT_FILE.
-
--- APPLICABILITY CRITERIA:
--- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT
--- TEXT FILES.
-
--- PASS/FAIL CRITERIA:
--- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED,
--- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT.
-
--- HISTORY:
--- SPS 09/29/82
--- JBG 08/30/83
--- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY
--- CODE, CHECKED FOR USE_ERROR ON DELETE, AND RENAMED
--- FROM CE3412C.ADA.
-
-WITH REPORT;
-USE REPORT;
-WITH TEXT_IO;
-USE TEXT_IO;
-
-PROCEDURE EE3412C IS
- INCOMPLETE : EXCEPTION;
-
-BEGIN
-
- TEST ("EE3412C", "CHECK THAT LINE OPERATES ON DEFAULT IN_FILE " &
- "AND OUT_FILE FILES");
-
- DECLARE
- F1, F2 : FILE_TYPE;
- C : POSITIVE_COUNT;
- X : CHARACTER;
- ITEM : STRING (1..6);
- BEGIN
- C := LINE (STANDARD_OUTPUT);
- NEW_LINE (STANDARD_OUTPUT);
- SPECIAL_ACTION ("ONE BLANK LINE SHOULD PRECEDE THIS COMMENT");
- IF LINE /= C+2 THEN
- FAILED ("DEFAULT FOR LINE NOT STANDARD_OUTPUT");
- END IF;
-
- BEGIN
- CREATE (F1, OUT_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " &
- "WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- WHEN NAME_ERROR =>
- NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " &
- "CREATE WITH OUT_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- CREATE (F2, OUT_FILE);
-
- SET_OUTPUT (F2);
-
- FOR I IN 1 .. 6 LOOP
- PUT (F1, "STRING");
- NEW_LINE (F1);
- END LOOP;
- IF LINE (F1) /= 7 THEN
- FAILED ("LINE INCORRECT SUBTEST 1");
- END IF;
-
- SET_LINE_LENGTH (3);
- PUT ("OUTPUT STRING");
- IF LINE /= LINE(F2) THEN
- FAILED ("LINE INCORRECT SUBTEST 2");
- END IF;
-
- CLOSE (F1);
-
- BEGIN
- OPEN (F1, IN_FILE, LEGAL_FILE_NAME);
- EXCEPTION
- WHEN USE_ERROR =>
- NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " &
- "WITH IN_FILE MODE");
- RAISE INCOMPLETE;
- END;
-
- SET_INPUT (F1);
-
- GET (F1, ITEM);
- IF ITEM /= "STRING" THEN
- FAILED ("INCORRECT VALUE READ");
- END IF;
-
- SKIP_LINE(F1);
- SKIP_LINE(F1);
- SKIP_LINE(F1);
- IF LINE (CURRENT_INPUT) /= 4 AND LINE (F1) /= 4 THEN
- FAILED ("LINE INCORRECT SUBTEST 3");
- END IF;
-
- BEGIN
- DELETE (F1);
- EXCEPTION
- WHEN USE_ERROR =>
- NULL;
- END;
-
- CLOSE (F2);
-
- EXCEPTION
- WHEN INCOMPLETE =>
- NULL;
- END;
-
- RESULT;
-
-END EE3412C;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140010.a b/gcc/testsuite/ada/acats/tests/l/la140010.a
deleted file mode 100644
index 58ba661..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140010.a
+++ /dev/null
@@ -1,51 +0,0 @@
--- LA140010.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:
--- See LA140011.AM.
---
--- TEST DESCRIPTION:
--- See LA140011.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140010.A
--- LA140011.AM
--- LA140012.A
---
--- PASS/FAIL CRITERIA:
--- See LA140011.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA140010_0 is
- TC_Var : integer := 100;
-end LA140010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140011.am b/gcc/testsuite/ada/acats/tests/l/la140011.am
deleted file mode 100644
index 7fd722d..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140011.am
+++ /dev/null
@@ -1,104 +0,0 @@
--- LA140011.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level function body depends
--- on a unit that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package, a function that withs the
--- package, and a procedure that withs the function. Then,
--- a new version of the package is compiled (in a separate
--- file, simulating an editing modification to the package).
--- Unless automatic recompilation is supported, this
--- test should fail to link. Otherwise, the test should
--- recompile and link the correct version of the withed package
--- and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140010 (and include the results in the
--- program library).
--- 2) Compile the file LA140011 (and include the results in the
--- program library).
--- 3) Compile the file LA140012 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140010.A
--- -> LA140011.AM
--- LA140012.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140011_0 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007I baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Changed unit and file names to conform to
--- coding standards. Modified prologue.
--- 07 DEC 96 SAIC Moved LA140010_0 to a separate file.
---
---!
-
-function LA140011_0 return integer;
-
-with LA140010_0;
-function LA140011_0 return integer is
-begin
- return LA140010_0.TC_Var;
-end LA140011_0;
-
-with Report; use Report;
-with LA140011_0;
-procedure LA140011 is
- TC_Val : integer := 0;
-begin
- Test ("LA14001", "Check that a compilation unit " &
- "may not depend semantically on " &
- "two different versions of the same " &
- "compilation unit. Check the case " &
- "where a library level function body " &
- "depends on a unit that is changed");
-
- TC_Val := LA140011_0;
- if TC_Val = 100 then
- Failed ("Revised package not used");
- elsif TC_Val /= -10 then
- Failed ("Incorrect test value returned");
- end if;
-
- Result;
-end LA140011;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140012.a b/gcc/testsuite/ada/acats/tests/l/la140012.a
deleted file mode 100644
index 1dc8a7c..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140012.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140012.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:
--- See LA140011.AM.
---
--- TEST DESCRIPTION:
--- See LA140011.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140010.A
--- LA140011.AM
--- -> LA140012.A
---
--- PASS/FAIL CRITERIA:
--- See LA140011.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007I baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to standards.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-package LA140010_0 is
- TC_Var : integer := -10;
-end LA140010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140020.a b/gcc/testsuite/ada/acats/tests/l/la140020.a
deleted file mode 100644
index 6b49ca2..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140020.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140020.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:
--- See LA140021.AM.
---
--- TEST DESCRIPTION:
--- See LA140021.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140020.A
--- LA140021.AM
--- LA140022.A
---
--- PASS/FAIL CRITERIA:
--- See LA140021.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA140020_0 is
- procedure P (TC_change : out integer);
-
- TC_Var : integer := 100;
-end LA140020_0;
-
-package body LA140020_0 is
- procedure P (TC_change : out integer) is
- begin
- TC_change := TC_Var;
- end P;
-end LA140020_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140021.am b/gcc/testsuite/ada/acats/tests/l/la140021.am
deleted file mode 100644
index 963e171..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140021.am
+++ /dev/null
@@ -1,98 +0,0 @@
--- LA140021.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a unit depends on a package whose
--- declaration is changed.
---
--- TEST DESCRIPTION:
--- This test compiles the specification of a package containing
--- the specification of a procedure. Then it compiles the body
--- of the package containing the body of the procedure and the
--- main test procedure. The main procedure withs the first
--- package and calls the procedure in the first package. Then,
--- the withed package specification is changed and recompiled.
--- Unless automatic recompilation is supported, this test should
--- fail to link. Otherwise, the test should recompile the package
--- body and main procedure, link the correct versions of the unit,
--- and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140020 (and include the results in the
--- program library).
--- 2) Compile the file LA140021 (and include the results in the
--- program library).
--- 3) Compile the file LA140022 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140020.A
--- -> LA140021.AM
--- LA140022.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140020_0 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007J baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Changed unit and file names to conform to
--- coding conventions.
--- 07 DEC 96 SAIC Moved LA140020_0 to a separate file.
---
---!
-
-with Report; use Report;
-with LA140020_0;
-
-procedure LA140021 is
- TC_Val : integer := 0;
-begin
- Test ("LA14002", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a unit depends on a package whose " &
- "declaration is changed");
-
- LA140020_0.P (TC_Val);
- if TC_Val = 100 then
- Failed ("Changed unit not used");
- elsif TC_Val /= -10 then
- Failed ("Incorrect test value");
- end if;
-
- Result;
-end LA140021;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140022.a b/gcc/testsuite/ada/acats/tests/l/la140022.a
deleted file mode 100644
index 75a4c44..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140022.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140022.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:
--- See LA140021.AM.
---
--- TEST DESCRIPTION:
--- See LA140021.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140020.A
--- LA140021.AM
--- -> LA140022.A
---
--- PASS/FAIL CRITERIA:
--- See LA140021.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007J baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization. Added body for unit to
--- allow automatic recompilation.
---
---!
-
-package LA140020_0 is
- procedure P (TC_change : out integer);
-
- TC_Var : integer := -10;
-end LA140020_0;
-
-package body LA140020_0 is
- procedure P (TC_change : out integer) is
- begin
- TC_change := TC_Var;
- end P;
-end LA140020_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140030.a b/gcc/testsuite/ada/acats/tests/l/la140030.a
deleted file mode 100644
index 82d97e7..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140030.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140030.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:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- => LA140030.A
--- LA140031.A
--- LA140032.AM
--- LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140030 is
- TC_named_number : constant := 100;
- TC_Var : integer := 100;
-end LA140030;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140031.a b/gcc/testsuite/ada/acats/tests/l/la140031.a
deleted file mode 100644
index 250162b..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140031.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140031.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:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140030.A
--- => LA140031.A
--- LA140032.AM
--- LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140031 is
- procedure P (TC_Change : out integer);
-end LA140031;
-
-with LA140030; -- when LA140030 is revised and recompiled,
- -- this semantic dependency has to be handled
-
-package body LA140031 is
- procedure P (TC_Change : out integer) is
- begin
- TC_Change := LA140030.TC_Var;
- end P;
-end LA140031;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140032.am b/gcc/testsuite/ada/acats/tests/l/la140032.am
deleted file mode 100644
index 89984be..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140032.am
+++ /dev/null
@@ -1,101 +0,0 @@
--- LA140032.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a package body depends on a package
--- specification that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package specification, then a second
--- package specification and body that withs the first package,
--- followed by a procedure that makes a call to a procedure
--- contained inside the second package. Then, the first
--- package specification is recompiled, making the body of
--- package LA140031 obsolete. Unless automatic recompilation
--- is supported this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140030 (and include the results in the
--- program library).
--- 2) Compile the file LA140031 (and include the results in the
--- program library).
--- 3) Compile the file LA140032 (and include the results in the
--- program library).
--- 4) Compile the file LA140033 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140030.A
--- LA140031.A
--- => LA140032.AM
--- LA140033.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140031 is missing or obsolete, and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Changed main program name and prologue
--- to conform to coding conventions.
---
---!
-
-
-with Report; use Report;
-with LA140031;
-procedure LA140032 is
- TC_Val : integer := 0;
-begin
- Test ("LA14003", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a package body " &
- "depends on a package specification that " &
- "is changed");
-
- LA140031.P (TC_Val);
-
- if TC_Val = 100 then
- Failed ("Obsolete unit elaborated");
- elsif TC_Val /= -10 then
- Failed ("Incorrect test value");
- end if;
-
- Result;
-end LA140032;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140033.a b/gcc/testsuite/ada/acats/tests/l/la140033.a
deleted file mode 100644
index 9d7f133..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140033.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140033.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:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140030.A
--- LA140031.A
--- LA140032.AM
--- => LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140030 is
- TC_Var : integer := -10;
-end LA140030;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140040.a b/gcc/testsuite/ada/acats/tests/l/la140040.a
deleted file mode 100644
index eef6d98..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140040.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140040.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:
--- See LA140041.AM.
---
--- TEST DESCRIPTION:
--- See LA140041.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140041.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140040.A
--- LA140041.AM
--- LA140042.A
---
--- PASS/FAIL CRITERIA:
--- See LA140041.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14004_0 is
- TC_Var : integer := 100;
-end LA14004_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140041.am b/gcc/testsuite/ada/acats/tests/l/la140041.am
deleted file mode 100644
index 00470b2..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140041.am
+++ /dev/null
@@ -1,108 +0,0 @@
--- LA140041.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic function depends on a
--- library level package.
---
--- TEST DESCRIPTION:
--- This test compiles a package specification, then a generic
--- function specification and body that withs the package,
--- followed by a procedure that makes a call to an instance of
--- the generic function. Then, the package specification is
--- recompiled, making the body of function LA14004_1 obsolete.
--- Unless automatic recompilation is supported this test should fail
--- to link. Otherwise, the test should recompile and link
--- the correct version of the withed package and report
--- "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140040 (and include the results in the
--- program library).
--- 2) Compile the file LA140041 (and include the results in the
--- program library).
--- 3) Compile the file LA140042 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140040.A
--- -> LA140041.AM
--- LA140042.A
---
--- PASS/FAIL CRITERIA:
--- Expect a link-time error message that the body of generic
--- function LA14004_1 is missing or obsolete. If automatic
--- recompilation is supported, and an executable image is
--- built, expect a "PASSED" message from execution.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-generic
-function LA14004_1 return integer;
-
-with LA14004_0; -- Revision and recompilation of LA14004_0
- -- will require resolution of this semantic
- -- dependency
-function LA14004_1 return integer is
-begin
- return LA14004_0.TC_Var;
-end LA14004_1;
-
-
-
-with Report; use Report;
-with LA14004_1;
-procedure LA140041 is
- TC_Val : integer := 0;
-
- function F_LA14004_1 is new LA14004_1;
-begin
- Test ("LA14004", "Check that a compilation unit may " &
- "not depend semantically on two " &
- "different versions of the same " &
- "compilation unit. Check the case " &
- "where a generic function depends on a "&
- "library level package");
-
- TC_Val := F_LA14004_1;
-
- if TC_Val = 100 then
- Failed ("Obsolete unit used in elaboration");
- elsif TC_Val /= -10 then
- Failed ("Incorrect test value returned");
- end if;
-
- Result;
-end LA140041;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140042.a b/gcc/testsuite/ada/acats/tests/l/la140042.a
deleted file mode 100644
index bb4ba6c..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140042.a
+++ /dev/null
@@ -1,53 +0,0 @@
--- LA140042.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:
--- See LA140041.AM.
---
--- TEST DESCRIPTION:
--- See LA140041.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140041.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140040.A
--- LA140041.AM
--- -> LA140042.A
---
--- PASS/FAIL CRITERIA:
--- See LA140041.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14004_0 is
- Small_array : array (1..15) of integer;
- TC_Var : integer := -10;
-end LA14004_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140050.a b/gcc/testsuite/ada/acats/tests/l/la140050.a
deleted file mode 100644
index 542c1ff..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140050.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140050.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:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140050.A
--- LA140051.A
--- LA140052.AM
--- LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- hi : integer;
- lo : integer;
- type flt is digits <>;
-package LA14005_0 is
- TC_var : flt := flt(lo);
- type gen_flt is new flt range flt(lo)..flt(hi);
- max : integer := hi;
- min : integer := lo;
- avg : integer := (hi + lo)/ (integer(2.0));
-end LA14005_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140051.a b/gcc/testsuite/ada/acats/tests/l/la140051.a
deleted file mode 100644
index 6af550a..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140051.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140051.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:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- -> LA140051.A
--- LA140052.AM
--- LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14005_0;
-generic
- with package types is new LA14005_0 (<>);
-package LA14005_1 is
- TC_constant_flt : constant types.gen_flt := types.gen_flt(types.avg);
- function return_flt return types.gen_flt;
-end LA14005_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140052.am b/gcc/testsuite/ada/acats/tests/l/la140052.am
deleted file mode 100644
index 8e6c59e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140052.am
+++ /dev/null
@@ -1,110 +0,0 @@
--- LA140052.AM
---
--- 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 compilation unit may not depend semantically on two
--- different versions of the same compilation unit. Check the case
--- where a generic package body depends on a generic package
--- specification.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package specification and body,
--- followed by a procedure that makes a call to a procedure
--- contained inside the generic package. Then, the generic package
--- specification is recompiled, making the body of the generic
--- package obsolete. Unless automatic recompilation is
--- supported this test should fail to link. Otherwise, the test should
--- recompile and link the correct version of the units and report
--- "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140050 (and include the results in the
--- program library).
--- 2) Compile the file LA140051 (and include the results in the
--- program library).
--- 3) Compile the file LA140052 (and include the results in the
--- program library).
--- 4) Compile the file LA140053 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- LA140051.A
--- -> LA140052.AM
--- LA140053.A
---
--- PASS/FAIL CRITERIA:
--- Expect a link-time error message that the body of generic
--- package LA14005_1 is missing or obsolete. If automatic
--- recompilation is supported, and an executable image is
--- built, expect a "PASSED" message from execution.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008I baseline version
--- 09 MAY 95 SAIC Initial version
--- 08 NOV 96 SAIC Unit naming correction
--- 07 DEC 96 SAIC Moved spec of LA14005_1 to a separate file.
---
---!
-
-package body LA14005_1 is
- function return_flt return types.gen_flt is
- begin
- return types.gen_flt(types.TC_var);
- end return_flt;
-begin
- types.TC_var := types.flt(TC_constant_flt);
-end LA14005_1;
-
- ---------------------------------------------------------
-
-with Report; use Report;
-with LA14005_0;
-with LA14005_1;
-procedure LA140052 is
- subtype TC_flt is float digits 5;
-
- package Y is new LA14005_0 (integer(100.0), integer(0.0), TC_flt);
- package inst is new LA14005_1 (Y);
- TC_var : TC_flt;
-begin
- Test ("LA14005", "Check that a compilation unit may not depend " &
- "semantically on two different versions of the same " &
- "compilation unit. Check the case where a generic package " &
- "body depends on a generic package specification");
-
- TC_var := TC_flt(inst.return_flt);
-
- if TC_Var /= TC_flt(Y.min) then
- Failed ("Obsolete unit used in elaboration");
- end if;
-
- Result;
-end LA140052;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140053.a b/gcc/testsuite/ada/acats/tests/l/la140053.a
deleted file mode 100644
index 406b3ab..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140053.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140053.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:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- LA140051.A
--- LA140052.AM
--- -> LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008I baseline version
--- 09 MAY 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14005_0;
-generic
- with package types is new LA14005_0 (<>);
-package LA14005_1 is
- TC_constant_flt : constant
- types.gen_flt := types.gen_flt(types.min); --changed line
- function return_flt return types.gen_flt;
-end LA14005_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140060.a b/gcc/testsuite/ada/acats/tests/l/la140060.a
deleted file mode 100644
index 4f54da1..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140060.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140060.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:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140060.A
--- LA140061.A
--- LA140062.AM
--- LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14006_types is
- type t_type is tagged record
- f : integer := 87;
- end record;
-end LA14006_types;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140061.a b/gcc/testsuite/ada/acats/tests/l/la140061.a
deleted file mode 100644
index 40ff151..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140061.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140061.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:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140060.A
--- -> LA140061.A
--- LA140062.AM
--- LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14006_types;
-use LA14006_types;
-generic
- type t is new t_type with private;
-package LA14006_0 is
-
- type T2 is new t with record
- g : integer := 100;
- end record;
-
- TC_var : T2;
-
-private
- type type_t is new t with record
- g2 : integer := 99;
- end record;
-end LA14006_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140062.am b/gcc/testsuite/ada/acats/tests/l/la140062.am
deleted file mode 100644
index 9cfb8dd..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140062.am
+++ /dev/null
@@ -1,135 +0,0 @@
--- LA140062.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic package depends on another
--- generic package specification.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package specification, then
--- compiles a generic package specification and body,
--- followed by a procedure that makes a call to a procedure
--- contained inside the second generic package. Then, the
--- first generic package specification is recompiled,
--- making the body of the generic package LA140060 obsolete.
--- Unless automatic recompilation is supported this test should
--- fail to link. Otherwise, the test should recompile and link
--- the correct version of the units and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140060 (and include the results in the
--- program library).
--- 2) Compile the file LA140061 (and include the results in the
--- program library).
--- 3) Compile the file LA140062 (and include the results in the
--- program library).
--- 4) Compile the file LA140063 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140060.A
--- LA140061.A
--- -> LA140062.AM
--- LA140063.A
---
--- PASS/FAIL CRITERIA:
--- Expect a link-time error message that the body of generic
--- package LA14006_1 is missing or obsolete. If automatic
--- recompilation is supported, and an executable image is
--- built, expect a "PASSED" message from execution.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008K baseline version
--- 09 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved LA14006_0 to a separate file. Added
--- pragma Elaborate to context clause of LA14006_2.
---
---!
-
-with LA14006_0;
-with LA14006_types;
-use LA14006_types;
-generic
- type additional is (<>);
- add_val : additional;
-package LA14006_1 is
- type T3 is new t_type with record
- h: additional := add_val;
- end record;
-
- procedure P (TC_Change : out integer);
-
- package inst is new LA14006_0 (T3);
-end LA14006_1;
-
-----------------------------------------------------------------
-
-package body LA14006_1 is
- procedure P (TC_Change : out integer) is
- begin
- TC_Change := inst.TC_Var.g;
- end P;
-end LA14006_1;
-
-----------------------------------------------------------------
-
-with LA14006_1;
-pragma Elaborate (LA14006_1);
-package LA14006_2 is new LA14006_1 (integer, 300);
-
-----------------------------------------------------------------
-
-with Report; use Report;
-with LA14006_2;
-procedure LA140062 is
- TC_Val : integer := 0;
-begin
- Test ("LA14006", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a generic package " &
- "depends on another generic package " &
- "specification");
-
- LA14006_2.P (TC_Val);
-
- if TC_Val = 100 then
- Failed ("Obsolete unit used in elaboration");
- elsif TC_Val /= -10 then
- Failed ("Incorrect test value received");
- end if;
-
- Result;
-end LA140062;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140063.a b/gcc/testsuite/ada/acats/tests/l/la140063.a
deleted file mode 100644
index e4e6457..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140063.a
+++ /dev/null
@@ -1,70 +0,0 @@
--- LA140063.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:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140060.A
--- LA140061.A
--- LA140062.AM
--- -> LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14006_types;
-use LA14006_types;
-generic
- type t is new t_type with private;
-package LA14006_0 is
- type T2 is new t with record
- g : integer := -10;
- end record;
-
- TC_var : T2;
- Other_var : integer := 12;
-
- private
- type type_t is new t with record
- g2 : integer := 88;
- end record;
-end LA14006_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140070.a b/gcc/testsuite/ada/acats/tests/l/la140070.a
deleted file mode 100644
index e3c864a..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140070.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- LA140070.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:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140070.A
--- LA140071.A
--- LA140072.AM
--- LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14007_0 is -- this will be modified and recompiled
- type mod_16 is new integer;
- type rec is tagged record
- f: mod_16 := 12;
- end record;
- type t_rec is new rec with record
- g : mod_16 := -2;
- end record;
- TC_Var : t_rec;
-end LA14007_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140071.a b/gcc/testsuite/ada/acats/tests/l/la140071.a
deleted file mode 100644
index e895b87..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140071.a
+++ /dev/null
@@ -1,72 +0,0 @@
--- LA140071.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:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140070.A
--- -> LA140071.A
--- LA140072.AM
--- LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform to coding
--- conventions. Deleted extraneous procedure
--- specification.
---
---!
-
-procedure LA14007_1 (TC_Parent : in out integer);
-
- --================================================================--
-
-procedure LA14007_1 (TC_Parent : in out integer) is
- procedure LA14007_2 (TC_Local : in out integer) is separate;
-begin
- LA14007_2 (TC_Parent);
-end LA14007_1;
-
- --================================================================--
-
-with LA14007_0;
-
-separate (LA14007_1)
-procedure LA14007_2 (TC_Local : in out integer) is
-begin
- TC_Local := integer (LA14007_0.TC_Var.f);
-end LA14007_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140072.am b/gcc/testsuite/ada/acats/tests/l/la140072.am
deleted file mode 100644
index 86ef201..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140072.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- LA140072.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a separate procedure body depends on
--- a non-generic package specification that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package specification, a procedure,
--- the separate procedure body and a main procedure that
--- withs the first package. Then, a new version of the
--- first package specification is compiled (in a separate
--- file, simulating editing and modification of the unit).
--- Unless automatic recompilation is supported, this test
--- should fail to link. Otherwise, the test should
--- recompile and link the correct version of the withed
--- package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140070 (and include the results in the
--- program library).
--- 2) Compile the file LA140071 (and include the results in the
--- program library).
--- 3) Compile the file LA140072 (and include the results in the
--- program library).
--- 4) Compile the file LA140073 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140070.A
--- LA140071.A
--- -> LA140072.AM
--- LA140073.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14007_1.LA14007_2 is missing or obsolete and no executable
--- image results. The test also passes if an executable image is
--- produced and reports "PASSED" (in the case where the implementation
--- supports automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-
-with Report; use Report;
-with LA14007_1;
-
-procedure LA140072 is
- TC_Val : integer := 0;
-begin
- Test ("LA14007", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a separate procedure " &
- "body depends on a non-generic package " &
- "specification that is changed");
-
- LA14007_1 (TC_Val);
-
- if TC_Val = 12 then
- Failed ("Obsolete unit used in elaboration");
- elsif TC_Val /= 3 then
- Failed ("Incorrect test value returned");
- end if;
-
- Result;
-end LA140072;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140073.a b/gcc/testsuite/ada/acats/tests/l/la140073.a
deleted file mode 100644
index 01e0715..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140073.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140073.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:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140070.A
--- LA140071.A
--- LA140072.AM
--- -> LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14007_0 is -- this is the corrected version
- extra_integer : integer;
- type mod_16 is new integer;
- type rec is tagged record
- f: mod_16 := 3;
- end record;
- type t_rec is new rec with record
- null;
- end record;
- TC_Var : t_rec;
-end LA14007_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140080.a b/gcc/testsuite/ada/acats/tests/l/la140080.a
deleted file mode 100644
index 506c182..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140080.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140080.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:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140080.A
--- LA140081.A
--- LA140082.AM
--- LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-function LA14008_0 return integer;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140081.a b/gcc/testsuite/ada/acats/tests/l/la140081.a
deleted file mode 100644
index b800da7..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140081.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140081.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:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140080.A
--- -> LA140081.A
--- LA140082.AM
--- LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-function LA14008_0 return integer is
- TC_local : integer := 0;
- TC_var : integer := 100;
-
- function LA14008_1 return integer is separate;
- -- when LA14008_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-begin
- TC_local := LA14008_1;
- return TC_local;
-end LA14008_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140082.am b/gcc/testsuite/ada/acats/tests/l/la140082.am
deleted file mode 100644
index fc34a46..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140082.am
+++ /dev/null
@@ -1,106 +0,0 @@
--- LA140082.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a subunit function body depends
--- on a unit that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a function, separate subunit function
--- body, and a procedure that withs the function. Then,
--- a new version of the parent function is compiled (in a separate
--- file, simulating and editing modification to the package).
--- Unless automatic recompilation is supported, this
--- test should fail to link. Otherwise, the test should
--- recompile and link the correct version of the withed package
--- and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140080 (and include the results in the
--- program library).
--- 2) Compile the file LA140081 (and include the results in the
--- program library).
--- 3) Compile the file LA140082 (and include the results in the
--- program library).
--- 4) Compile the file LA140083 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140080.A
--- LA140081.A
--- -> LA140082.AM
--- LA140083.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14008_0.LA14008_1 is missing or obsolete and no executable image
--- results. The test passes if an executable image is produced
--- and reports "PASSED" (in case the implementation supports
--- automatic recompilation).
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-separate (LA14008_0)
-
-function LA14008_1 return integer is
-begin
- return LA14008_0.TC_var;
-end LA14008_1;
-
- --==================================================================--
-
-with Report; use Report;
-with LA14008_0;
-
-procedure LA140082 is
- TC_val : integer := 0;
-begin
- Test ("LA14008", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a subunit function body depends on a " &
- "unit that is changed");
-
- TC_val := LA14008_0;
-
- if TC_val = 100 then
- Failed ("Revised unit not used");
- elsif TC_val /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140082;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140083.a b/gcc/testsuite/ada/acats/tests/l/la140083.a
deleted file mode 100644
index cad1cf3..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140083.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140083.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:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140080.A
--- LA140081.A
--- LA140082.AM
--- -> LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
-
-function LA14008_0 return integer is
- Another_var : integer := 1000;
- TC_local : integer := 0;
- TC_var : integer := -10;
-
- function LA14008_1 return integer is separate;
-
-begin
- TC_local := LA14008_1;
- return TC_local;
-end LA14008_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140090.a b/gcc/testsuite/ada/acats/tests/l/la140090.a
deleted file mode 100644
index d2e02c7..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140090.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140090.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:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140090.A
--- LA140091.A
--- LA140092.AM
--- LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14009_0 is
-
- package LA14009_1 is
-
- procedure P (TC_local : in out integer);
-
- end LA14009_1;
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140091.a b/gcc/testsuite/ada/acats/tests/l/la140091.a
deleted file mode 100644
index 550b908..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140091.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140091.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:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140090.A
--- -> LA140091.A
--- LA140092.AM
--- LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package body LA14009_0 is
- TC_var : integer := 100;
-
- package body LA14009_1 is separate;
- -- when LA14009_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140092.am b/gcc/testsuite/ada/acats/tests/l/la140092.am
deleted file mode 100644
index a4f248f..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140092.am
+++ /dev/null
@@ -1,110 +0,0 @@
--- LA140092.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a subunit package body depends
--- on a unit that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package, separate subunit package
--- body, and a procedure that withs the package. Then,
--- a new version of the package is compiled (in a separate
--- file, simulating and editing modification to the package).
--- Unless automatic recompilation is supported, this
--- test should fail to link. Otherwise, the test should
--- recompile and link the correct version of the withed package
--- and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140090 (and include the results in the
--- program library).
--- 2) Compile the file LA140091 (and include the results in the
--- program library).
--- 3) Compile the file LA140092 (and include the results in the
--- program library).
--- 4) Compile the file LA140093 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140090.A
--- LA140091.A
--- -> LA140092.AM
--- LA140093.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14009_0.LA14009_1 is missing or obsolete and no executable image
--- results. The test passes if an executable image is produced
--- and reports "PASSED" (in case the implementation supports
--- automatic recompilation).
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-separate (LA14009_0)
-
-package body LA14009_1 is
-
- procedure P (TC_local : in out integer) is
- begin
- TC_local := LA14009_0.TC_var;
- end P;
-
-end LA14009_1;
-
-
-
-with Report; use Report;
-with LA14009_0;
-
-procedure LA140092 is
- TC_val : integer := 0;
-begin
- Test ("LA14009", "Check that a compilation unit may not depend " &
- "semantically on two different versions of the " &
- "same compilation unit. Check the case where " &
- "a subunit package body depends on a unit that " &
- "is changed");
-
- LA14009_0.LA14009_1.P(TC_Val);
-
- if TC_val = 100 then
- Failed ("Revised package body not used");
- elsif TC_val /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140092;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140093.a b/gcc/testsuite/ada/acats/tests/l/la140093.a
deleted file mode 100644
index 3755706..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140093.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140093.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:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140090.A
--- LA140091.A
--- LA140092.AM
--- -> LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package body LA14009_0 is
- New_TC_var : integer := 50;
- Dummy_array : array (1..100) of boolean := (others => False);
- TC_var : constant integer := -10;
-
- package body LA14009_1 is separate;
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140100.a b/gcc/testsuite/ada/acats/tests/l/la140100.a
deleted file mode 100644
index dfa7869..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140100.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140100.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:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140100.A
--- LA140101.A
--- LA140102.AM
--- LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14010_0 is
- delta_v : integer := 1;
-end LA14010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140101.a b/gcc/testsuite/ada/acats/tests/l/la140101.a
deleted file mode 100644
index 332f5ff..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140101.a
+++ /dev/null
@@ -1,89 +0,0 @@
--- LA140101.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:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140100.A
--- -> LA140101.A
--- LA140102.AM
--- LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform to coding
--- conventions. Changed task to task type.
---
---!
-
-generic
- type scalar is range <>;
-package LA14010_1 is
- procedure inc (param : in out scalar);
-end LA14010_1;
-
-with LA14010_0;
-use LA14010_0;
-
-package body LA14010_1 is
- procedure inc (param : in out scalar) is
- begin
- for i in 1..delta_v loop
- param := param + 1;
- end loop;
- end inc;
-
- task type inc_task is
- entry increment (param : in out scalar);
- end inc_task;
-
- task body inc_task is separate;
-end LA14010_1;
-
-
-separate (LA14010_1)
-
-task body inc_task is
- static_zero : integer := 0;
-begin
- accept increment (param : in out scalar) do
- static_zero := LA14010_0.delta_v + static_zero;
- static_zero := static_zero - LA14010_0.delta_v;
- inc (param);
- end increment;
-end inc_task;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140102.am b/gcc/testsuite/ada/acats/tests/l/la140102.am
deleted file mode 100644
index 7feb2ef..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140102.am
+++ /dev/null
@@ -1,104 +0,0 @@
--- LA140102.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a task body depends on a package
--- specification.
---
--- TEST DESCRIPTION:
--- This test compiles a package spec, a generic package
--- with a body containing a task with a body that withs the
--- first package spec, and a main procedure that withs the
--- generic package and calls the task. Then, a new version
--- of the package spec is compiled (in a separate file, simulating
--- editing and modification of the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the package spec and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140100 (and include the results in the
--- program library).
--- 2) Compile the file LA140101 (and include the results in the
--- program library).
--- 3) Compile the file LA140102 (and include the results in the
--- program library).
--- 4) Compile the file LA140103 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140100.A
--- LA140101.A
--- -> LA140102.AM
--- LA140103.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14010_1.INC_TASK is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14010_1;
-
-procedure LA140102 is
- subtype scalar_type is integer range 0..100;
- TC_val : scalar_type := 0;
- package Gen_pack is new LA14010_1(scalar_type);
-begin
- Test ("LA14010", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a task body depends " &
- "on a package specification");
-
- Gen_pack.inc(TC_val);
-
- if TC_val = 1 then
- Failed ("Old package specification used");
- elsif TC_val /= 10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140102;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140103.a b/gcc/testsuite/ada/acats/tests/l/la140103.a
deleted file mode 100644
index a16d7de..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140103.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140103.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:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140100.A
--- LA140101.A
--- LA140102.AM
--- -> LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14010_0 is
- New_var : integer := 100;
- Local_array : array (1..51) of integer;
- delta_v : constant integer := 10;
-end LA14010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140110.a b/gcc/testsuite/ada/acats/tests/l/la140110.a
deleted file mode 100644
index 3f69c92..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140110.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140110.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:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140110.A
--- LA140111.A
--- LA140112.AM
--- LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-procedure LA14011_0 (Change_this : in out integer);
-
-
-procedure LA14011_0 (Change_this : in out integer) is
-begin
- if Change_this = 10 then
- Change_this := 100;
- else
- Change_this := 50;
- end if;
-end LA14011_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140111.a b/gcc/testsuite/ada/acats/tests/l/la140111.a
deleted file mode 100644
index c3a1cf1..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140111.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- LA140111.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:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140110.A
--- -> LA140111.A
--- LA140112.AM
--- LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-with LA14011_0;
-
-procedure LA14011_1 (Change_this1 : in out integer);
-
-
-procedure LA14011_1 (Change_this1 : in out integer) is
-begin
- LA14011_0(Change_this1);
-end LA14011_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140112.am b/gcc/testsuite/ada/acats/tests/l/la140112.am
deleted file mode 100644
index 36dc8ff..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140112.am
+++ /dev/null
@@ -1,103 +0,0 @@
--- LA140112.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library procedure depends
--- on a unit that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a procedure, a procedure that withs
--- the first procedure, and a procedure that withs the second
--- procedure. Then, a new version of the first procedure is
--- compiled (in a separate file, simulating an editing
--- modification to the package). Unless automatic recompilation
--- is supported, this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140110 (and include the results in the
--- program library).
--- 2) Compile the file LA140111 (and include the results in the
--- program library).
--- 3) Compile the file LA140112 (and include the results in the
--- program library).
--- 4) Compile the file LA140113 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140110.A
--- LA140111.A
--- -> LA140112.AM
--- LA140113.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14011_1 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-
-with Report; use Report;
-with LA14011_1; -- when LA14011_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-
-procedure LA140112 is
- TC_val : integer := 10;
-begin
- Test ("LA14011", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a library procedure depends on a unit " &
- "that is changed");
-
- LA14011_1(TC_val);
-
- if TC_val = 100 then
- Failed ("Revised procedure not used");
- elsif TC_val /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140112;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140113.a b/gcc/testsuite/ada/acats/tests/l/la140113.a
deleted file mode 100644
index 8dd9683..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140113.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140113.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:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140110.A
--- LA140111.A
--- LA140112.AM
--- -> LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14011_0 (Change_this : in out integer);
-
-
-procedure LA14011_0 (Change_this : in out integer) is
-begin
- Change_this := -Change_this;
-end LA14011_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140120.a b/gcc/testsuite/ada/acats/tests/l/la140120.a
deleted file mode 100644
index d21525e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140120.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140120.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:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140120.A
--- LA140121.A
--- LA140122.AM
--- LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14012_0 (Parm_1 : integer) return integer;
-
-
-function LA14012_0 (Parm_1 : integer) return integer is
-begin
- if Parm_1 >= 0 then
- return 100;
- else
- return 200;
- end if;
-end LA14012_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140121.a b/gcc/testsuite/ada/acats/tests/l/la140121.a
deleted file mode 100644
index e4ea3ed..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140121.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140121.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:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140120.A
--- -> LA140121.A
--- LA140122.AM
--- LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-with LA14012_0;
-
-function LA14012_1 return integer;
-
-
-function LA14012_1 return integer is
- Local_val : integer := 5;
-begin
- Local_val := LA14012_0 (Parm_1 => Local_val);
- return Local_val;
-end LA14012_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140122.am b/gcc/testsuite/ada/acats/tests/l/la140122.am
deleted file mode 100644
index 06cacb3..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140122.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- LA140122.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level function depends
--- on a unit that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a function, a function that withs
--- the first function, and a procedure that withs the second
--- function. Then, a new version of the first function is
--- compiled (in a separate file, simulating an editing
--- modification to the package). Unless automatic recompilation
--- is supported, this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140120 (and include the results in the
--- program library).
--- 2) Compile the file LA140121 (and include the results in the
--- program library).
--- 3) Compile the file LA140122 (and include the results in the
--- program library).
--- 4) Compile the file LA140123 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140120.A
--- LA140121.A
--- -> LA140122.AM
--- LA140123.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14012_1 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14012_1; -- when LA14012_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-
-procedure LA140122 is
- TC_local : integer := 5;
-begin
- Test ("LA14012", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a library level function depends on a " &
- "unit that is changed");
-
- TC_local := LA14012_1;
-
- if TC_local = 100 then
- Failed ("Revised function not used");
- elsif TC_local /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140122;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140123.a b/gcc/testsuite/ada/acats/tests/l/la140123.a
deleted file mode 100644
index cacbf64..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140123.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140123.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:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140120.A
--- LA140121.A
--- LA140122.AM
--- -> LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14012_0 (Parm_1 : integer) return integer;
-
-
-function LA14012_0 (Parm_1 : integer) return integer is
-begin
- return -(2 * Parm_1);
-end LA14012_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140130.a b/gcc/testsuite/ada/acats/tests/l/la140130.a
deleted file mode 100644
index a65ce80..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140130.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140130.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:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140130.A
--- LA140131.A
--- LA140132.AM
--- LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA140130 is
- subtype TC_type is integer range 0..100;
- TC_var : TC_type := TC_type'last;
-end LA140130;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140131.a b/gcc/testsuite/ada/acats/tests/l/la140131.a
deleted file mode 100644
index fe03f67..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140131.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140131.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:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140130.A
--- -> LA140131.A
--- LA140132.AM
--- LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA140130;
-
-package LA140131 is
- TC_local : LA140130.TC_type := LA140130.TC_var;
-end LA140131;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140132.am b/gcc/testsuite/ada/acats/tests/l/la140132.am
deleted file mode 100644
index fe39257..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140132.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- LA140132.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level package depends
--- on a package specification that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package spec., a package that withs
--- the first package, and a procedure that withs the second
--- package. Then, a new version of the first package spec. is
--- compiled (in a separate file, simulating an editing
--- modification to the package). Unless automatic recompilation
--- is supported, this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140130 (and include the results in the
--- program library).
--- 2) Compile the file LA140131 (and include the results in the
--- program library).
--- 3) Compile the file LA140132 (and include the results in the
--- program library).
--- 4) Compile the file LA140133 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140130.A
--- LA140131.A
--- -> LA140132.AM
--- LA140133.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140131 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA140131; -- when LA140130 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-
-procedure LA140132 is
- TC_val : integer := 0;
-begin
- Test ("LA14013", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a library level package depends on a " &
- "package specification that is changed");
-
- TC_val := LA140131.TC_local;
-
- if TC_val = 100 then
- Failed ("Revised package specification not used");
- elsif TC_val /= -49 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140132;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140133.a b/gcc/testsuite/ada/acats/tests/l/la140133.a
deleted file mode 100644
index 4d1451e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140133.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140133.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:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140130.A
--- LA140131.A
--- LA140132.AM
--- -> LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA140130 is
- subtype TC_type is integer range -49..50;
- TC_const : constant TC_type := TC_type'first;
- TC_var : TC_type := TC_const;
-end LA140130;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140140.a b/gcc/testsuite/ada/acats/tests/l/la140140.a
deleted file mode 100644
index 2116891..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140140.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140140.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:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140140.A
--- LA140141.A
--- LA140142.AM
--- LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-procedure LA14014_0 (Change_one : in out integer) is
-begin
- Change_one := Change_one * 5;
-end LA14014_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140141.a b/gcc/testsuite/ada/acats/tests/l/la140141.a
deleted file mode 100644
index d0406e6..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140141.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140141.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:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140140.A
--- -> LA140141.A
--- LA140142.AM
--- LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-with LA14014_0;
-procedure LA14014_1 (Change_this : out integer) is
-begin
- Change_this := 10;
- LA14014_0(Change_one => Change_this);
-end LA14014_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140142.am b/gcc/testsuite/ada/acats/tests/l/la140142.am
deleted file mode 100644
index 39b70dd..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140142.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- LA140142.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level procedure depends
--- on another library level procedure that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a procedure, a procedure that withs
--- the first procedure, and a procedure that withs the second
--- procedure. Then, a new version of the first procedure is
--- compiled (in a separate file, simulating and editing
--- modification to the procedure). Unless automatic recompilation
--- is supported, this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140140 (and include the results in the
--- program library).
--- 2) Compile the file LA140141 (and include the results in the
--- program library).
--- 3) Compile the file LA140142 (and include the results in the
--- program library).
--- 4) Compile the file LA140143 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140140.A
--- LA140141.A
--- -> LA140142.AM
--- LA140143.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14014_1 is missing or obsolete and no executable image
--- results. The test passes if an executable image is produced
--- and reports "PASSED" (in case the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-with Report; use Report;
-with LA14014_1; -- when LA14014_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-procedure LA140142 is
- TC_val : integer := 0;
-begin
- Test ("LA14014", "Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a library level procedure depends on " &
- "another library level procedure that is changed");
-
- LA14014_1(TC_val);
-
- if TC_val = 50 then
- Failed ("Revised procedure not used");
- elsif TC_val = 70 then
- Failed ("Revised procedure not used");
- elsif TC_val /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140142;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140143.a b/gcc/testsuite/ada/acats/tests/l/la140143.a
deleted file mode 100644
index 2c21b1b..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140143.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140143.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:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140140.A
--- LA140141.A
--- LA140142.AM
--- -> LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-procedure LA14014_0 (Change_two : in integer := 0;
- Change_one : out integer) is
-begin
-
- if Change_two = 10 then
- Change_one := 70;
- elsif Change_two = 0 then
- Change_one := -10;
- else
- Change_one := 30;
- end if;
-
-end LA14014_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140150.a b/gcc/testsuite/ada/acats/tests/l/la140150.a
deleted file mode 100644
index 77a5a21..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140150.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140150.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:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140150.A
--- LA140151.A
--- LA140152.AM
--- LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14015_0 (Param_1 : integer) return boolean is
-begin
- return Param_1 = 5;
-end LA14015_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140151.a b/gcc/testsuite/ada/acats/tests/l/la140151.a
deleted file mode 100644
index 6cd0d1a..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140151.a
+++ /dev/null
@@ -1,65 +0,0 @@
--- LA140151.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:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140150.A
--- -> LA140151.A
--- LA140152.AM
--- LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA14015_0; -- when LA140150 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-
-function LA14015_1 (P : integer) return integer is
-begin
- if LA14015_0 (Param_1 => P) then
- return 100;
- else
- return -10;
- end if;
-end LA14015_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140152.am b/gcc/testsuite/ada/acats/tests/l/la140152.am
deleted file mode 100644
index bc98470..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140152.am
+++ /dev/null
@@ -1,101 +0,0 @@
--- LA140152.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level function depends
--- on another library level function that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a function, a function that withs and
--- calls the first, and a procedure that withs the second
--- function. Then, a new version of the first function is
--- compiled (in a separate file, simulating an editing
--- modification to the function). Unless automatic recompilation
--- is supported, this test should fail to link. Otherwise, the
--- test should recompile and link the correct version of the
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140150 (and include the results in the
--- program library).
--- 2) Compile the file LA140151 (and include the results in the
--- program library).
--- 3) Compile the file LA140152 (and include the results in the
--- program library).
--- 4) Compile the file LA140153 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140150.A
--- LA140151.A
--- -> LA140152.AM
--- LA140153.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14015_1 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14015_1;
-
-procedure LA140152 is
- TC_local : integer := 5;
-begin
- Test ("LA14015", "Check that a compilation unit may " &
- "not depend semantically on two " &
- "different versions of the same " &
- "compilation unit. Check the case " &
- "where a library level function " &
- "depends on another library level " &
- "function that is changed");
-
- TC_local := LA14015_1 (5);
-
- if TC_local = 100 then
- Failed ("Revised unit not used");
- elsif TC_local /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140152;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140153.a b/gcc/testsuite/ada/acats/tests/l/la140153.a
deleted file mode 100644
index 8126445..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140153.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140153.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:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140150.A
--- LA140151.A
--- LA140152.AM
--- -> LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14015_0 (Param_2 : boolean := false;
- Param_1 : integer := 10) return boolean is
-begin
- if Param_2 then
- return true;
- else
- return Param_1 = 10;
- end if;
-end LA14015_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140160.a b/gcc/testsuite/ada/acats/tests/l/la140160.a
deleted file mode 100644
index 38c396d..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140160.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140160.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:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140160.A
--- LA140161.A
--- LA140162.AM
--- LA140163.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14016_0 is
- subtype status_code is integer range 0..10;
- type tagged_type is abstract tagged null record;
- function status (param : tagged_type) return status_code is abstract;
-end LA14016_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140161.a b/gcc/testsuite/ada/acats/tests/l/la140161.a
deleted file mode 100644
index 4be9f1d..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140161.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140161.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:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140160.A
--- -> LA140161.A
--- LA140162.AM
--- LA140162.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14016_0;
-generic
- type T is new LA14016_0.tagged_type with private;
- type count_type is range <>;
-package LA14016_1 is
- default_status : constant LA14016_0.status_code := 0;
- type new_t is new T with
- record
- count : count_type;
- end record;
- function status (param : new_t) return LA14016_0.status_code;
-
- procedure inc (param : in out new_t);
-end LA14016_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140162.am b/gcc/testsuite/ada/acats/tests/l/la140162.am
deleted file mode 100644
index fd985c2..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140162.am
+++ /dev/null
@@ -1,196 +0,0 @@
--- LA140162.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a separate procedure depends
--- on a withed generic package that is changed.
---
--- TEST DESCRIPTION:
--- This test declares a package which contains a generic procedure GP,
--- the body of which is a subunit. The package also contains a procedure
--- P which instantiates GP and calls the instance. The instance itself
--- calls a procedure which is declared within the instance of a generic
--- package X. The test compiles each of these compilation units and the
--- main procedure, then compiles a new version of the generic package X
--- (in a separate file, simulating an editing modification to the unit).
--- Unless automatic recompilation is supported, this test should fail to
--- link. Otherwise, the test should recompile and link the correct
--- version of the generic package X and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140160 (and include the results in the
--- program library).
--- 2) Compile the file LA140161 (and include the results in the
--- program library).
--- 3) Compile the file LA140162 (and include the results in the
--- program library).
--- 4) Compile the file LA140163 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140160.A
--- LA140161.A
--- -> LA140162.AM
--- LA140163.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14016_4.gen_def is missing or obsolete and no executable
--- image results. The test also passes if an executable image is
--- produced and reports "PASSED" (in the case where the implementation
--- supports automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008L baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions. Restructured subunits
--- to prevent potential Program_Error due to
--- premature instantiation of gen_def. Moved
--- LA14016_1 to a separate file. Added pragma
--- Elaborate to context clause of LA14016_3.
---
---
---!
-
-package body LA14016_1 is
- procedure inc (param : in out new_t) is
- begin
- param.count := param.count + 1;
- end inc;
- function status (param : new_t) return LA14016_0.status_code is
- begin
- return LA14016_0.status_code(param.count);
- end status;
-end LA14016_1;
-
----------------------------------------------------------
-
-with LA14016_0;
-package LA14016_2 is
- type extended is new LA14016_0.tagged_type with
- record
- status : LA14016_0.status_code := 10;
- end record;
- function status (param : extended) return LA14016_0.status_code;
-end LA14016_2;
-
----------------------------------------------------------
-
-package body LA14016_2 is
- function status (param : extended) return LA14016_0.status_code is
- begin
- return param.status;
- end status;
-end LA14016_2;
-
----------------------------------------------------------
-
-with LA14016_0;
-with LA14016_1;
-with LA14016_2;
-pragma Elaborate (LA14016_1);
-package LA14016_3 is new LA14016_1 (LA14016_2.extended,
- LA14016_0.status_code);
-
----------------------------------------------------------
-
-with LA14016_3;
-package LA14016_4 is
-
- procedure gen_caller (p1 : in out LA14016_3.new_t);
-
- generic
- new_max : integer;
- procedure gen_def (param : in out LA14016_3.new_t);
-
-end LA14016_4;
-
----------------------------------------------------------
-
-package body LA14016_4 is
- procedure gen_def (param : in out LA14016_3.new_t) is separate;
- procedure gen_caller (p1 : in out LA14016_3.new_t) is separate;
-end LA14016_4;
-
----------------------------------------------------------
-
-separate (LA14016_4)
-procedure gen_def (param : in out LA14016_3.new_t) is
-begin
- param.status := LA14016_3.default_status; --originally 0
- --later change to 5
- param.count := param.status;
- LA14016_3.inc (param);
-end gen_def;
-
----------------------------------------------------------
-
-separate (LA14016_4)
-procedure gen_caller (p1 : in out LA14016_3.new_t) is
- procedure default is new gen_def (101);
-begin
- default (p1);
-end gen_caller;
-
----------------------------------------------------------
-
-with Report; use Report;
-with LA14016_3;
-with LA14016_4;
-with LA14016_2;
-
-procedure LA140162 is
- E : LA14016_3.new_t; --status defaults to 10
-begin
- Test ("LA14016","Check that a compilation unit may not depend " &
- "semantically on two different versions of the " &
- "same compilation unit. Check the case where a " &
- "separate procedure depends on a withed generic " &
- "package that is changed");
-
- LA14016_4.gen_caller (E);
-
- if E.status = 0 then
- Failed ("Old generic used");
- elsif E.status = 10 then
- Failed ("Status not updated");
- elsif E.status /= 5 then
- Failed ("Wrong status value used");
- end if;
-
- if E.count /= 6 then
- Failed ("Count not properly handled");
- end if;
-
- Result;
-end LA140162;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140163.a b/gcc/testsuite/ada/acats/tests/l/la140163.a
deleted file mode 100644
index d91923a..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140163.a
+++ /dev/null
@@ -1,67 +0,0 @@
--- LA140163.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:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140160.A
--- LA140161.A
--- LA140162.AM
--- -> LA140163.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008L baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions and to reflect new
--- test file organization.
---
---!
-
-with LA14016_0;
-generic
- type T is new LA14016_0.tagged_type with private;
- type count_type is range <>;
-package LA14016_1 is
- default_status : constant LA14016_0.status_code := 5;
- type new_t is new T with
- record
- count : count_type;
- end record;
- function status (param : new_t) return LA14016_0.status_code;
-
- procedure inc (param : in out new_t);
-end LA14016_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140170.a b/gcc/testsuite/ada/acats/tests/l/la140170.a
deleted file mode 100644
index 0c041d0..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140170.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140170.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:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140170.A
--- LA140171.A
--- LA140172.AM
--- LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14017_0 is
- type swap_type_ptr is record
- p_all : integer;
- end record;
- subtype count_type is integer;
-end LA14017_0;
-
------------------------------------------------------
-
-with LA14017_0;
-use LA14017_0;
-generic
- type swap_type is private;
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140171.a b/gcc/testsuite/ada/acats/tests/l/la140171.a
deleted file mode 100644
index d7f3766..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140171.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140171.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:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140170.A
--- -> LA140171.A
--- LA140172.AM
--- LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type is
- temp : integer := 0;
- count_factor : count_type := 10;
-
- function Inc (Param : integer) return integer;
-
- function Inc (Param : integer) return integer is separate;
-
- procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is
- temp : integer := 0;
- begin
- temp := P1.p_all;
- P1.p_all := P2.p_all;
- P2.p_all := temp;
- end Swap_Ptrs;
-
-begin
- return count_type (Inc (integer(count)));
-end LA14017_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140172.am b/gcc/testsuite/ada/acats/tests/l/la140172.am
deleted file mode 100644
index 67c970e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140172.am
+++ /dev/null
@@ -1,121 +0,0 @@
--- LA140172.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a separate function semantically
--- depends on a library level generic function that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic function, and a procedure that
--- withs the function. Then, a new version of the generic
--- function body is compiled (in a separate file, simulating
--- and editing modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed function and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140170 (and include the results in the
--- program library).
--- 2) Compile the file LA140171 (and include the results in the
--- program library).
--- 3) Compile the file LA140172 (and include the results in the
--- program library).
--- 4) Compile the file LA140173 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140170.A
--- LA140171.A
--- -> LA140172.AM
--- LA140173.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14017_1.Inc is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008M baseline version
--- 16 JUN 95 SAIC Initial version
--- 03 MAR 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved LA14017_1 to a separate file.
---
---!
-
-separate (LA14017_1) -- This dependency must be resolved
- -- after LA140171.A is compiled.
-
-function Inc (Param : integer) return integer is
-begin
- return Param + integer (count_factor);
-end Inc;
-
------------------------------------------------------
-
-
-with Report; use Report;
-with LA14017_1;
-with LA14017_0;
-
-procedure LA140172 is
- type Access_integer is access integer;
- TC_local : integer := 0;
- P1, P2 : LA14017_0.swap_type_ptr;
-
- function New_swap is new LA14017_1(swap_type => integer);
-begin
- Test ("LA14017", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a separate " &
- "function semantically depends on a " &
- "library level generic function that is " &
- "changed");
-
- P1.p_all := 0;
- P2 := P1;
- TC_local := integer (New_swap(P1,P2,0));
-
- if TC_local = 10 then
- Failed ("Revised library level function not used");
- elsif TC_local /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140172;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140173.a b/gcc/testsuite/ada/acats/tests/l/la140173.a
deleted file mode 100644
index 73f382e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140173.a
+++ /dev/null
@@ -1,75 +0,0 @@
--- LA140173.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:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140170.A
--- LA140171.A
--- LA140172.AM
--- -> LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008M baseline version
--- 16 JUN 95 SAIC Initial version
--- 03 MAR 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type is
- count_factor : count_type := -10;
-
- procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is
- temp : integer := 0;
- begin
- temp := P1.p_all;
- P1.p_all := P2.p_all;
- P2.p_all := temp;
- end Swap_Ptrs;
-
- function Inc (Param : integer) return integer;
-
- function Inc (Param : integer) return integer is separate;
-
- temp : integer := 0;
-begin
- return count_type (Inc (integer(count)));
-end LA14017_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140180.a b/gcc/testsuite/ada/acats/tests/l/la140180.a
deleted file mode 100644
index 185ca21..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140180.a
+++ /dev/null
@@ -1,65 +0,0 @@
--- LA140180.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:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140180.A
--- LA140181.A
--- LA140182.AM
--- LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type unsigned is mod <>;
- mod_value : unsigned := 1;
-package LA14018_0 is
- --types declared locally
-
- generic
- type discrete is (<>);
- package utils_18 is
- procedure Dec (Param : in out unsigned);
-
- -- other utilities
- end utils_18;
-
- --routines that make this generic useful
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140181.a b/gcc/testsuite/ada/acats/tests/l/la140181.a
deleted file mode 100644
index 3d9847a..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140181.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140181.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:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140180.A
--- -> LA140181.A
--- LA140182.AM
--- LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package body LA14018_0 is
- offset : constant unsigned := mod_value;
-
- package body utils_18 is separate;
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140182.am b/gcc/testsuite/ada/acats/tests/l/la140182.am
deleted file mode 100644
index c27bb54..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140182.am
+++ /dev/null
@@ -1,118 +0,0 @@
--- LA140182.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a separate generic package body depends
--- on a library level generic package body that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package and its body, and a
--- procedure that withs the generic package. Then a new
--- version of the generic package body is compiled (in a
--- separate file, simulating and editing modification to the
--- unit). Unless automatic recompilation is supported, this
--- test should fail to link. Otherwise, the test should
--- recompile and link the correct version of the with package
--- withed package and report "PASSED" at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140180 (and include the results in the
--- program library).
--- 2) Compile the file LA140181 (and include the results in the
--- program library).
--- 3) Compile the file LA140182 (and include the results in the
--- program library).
--- 4) Compile the file LA140183 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140180.A
--- LA140181.A
--- -> LA140182.AM
--- LA140183.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14018_0.utils_18 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008N baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions. Moved instantiation
--- of utils_18 to avoid potential Program_Error.
--- Moved LA14018_0 to a separate file.
---
---!
-
-separate (LA14018_0) -- This dependency must be resolved
- -- after LA140181.A is compiled.
-package body utils_18 is
- procedure Dec (Param : in out unsigned) is
- begin
- Param := Param - offset;
- end Dec;
-end utils_18;
-
---------------------------------------------------------
-
-with Report; use Report;
-with LA14018_0;
-procedure LA140182 is
- type mod_4 is mod 4; -- 0, 1, 2, 3, 0, 1,...
- TC_var : mod_4 := 2;
-
- package Mod_stuff is new LA14018_0 (mod_4);
- package unsigned_utils is new Mod_stuff.utils_18 (mod_4);
-begin
- Test ("LA14018", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. "&
- "Check the case where a separate package " &
- "body depends on a library level generic " &
- "package body that is changed");
-
- unsigned_utils.Dec (TC_var);
-
- if TC_var = 2 then
- Failed ("Dec routine did not work");
- elsif TC_var = 1 then
- Failed ("New body for LA14018_0 not used");
- elsif TC_var /= 3 then
- Failed ("Unexpected result produced");
- end if;
-
- Result;
-end LA140182;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140183.a b/gcc/testsuite/ada/acats/tests/l/la140183.a
deleted file mode 100644
index f50ae15..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140183.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140183.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:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140180.A
--- LA140181.A
--- LA140182.AM
--- -> LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008N baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions, and to reflect new test
--- file organization.
---
---!
-
-package body LA14018_0 is
- New_TC_var : integer := 101;
- New_array : array (1..101) of integer := (others => 0);
- offset : constant unsigned := mod_value + 2;
-
- package body utils_18 is separate;
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140190.a b/gcc/testsuite/ada/acats/tests/l/la140190.a
deleted file mode 100644
index 0c4c3a9..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140190.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140190.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:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140190.A
--- LA140191.A
--- LA140192.AM
--- LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14019_0 (Param : in out integer);
-
-
-procedure LA14019_0 (Param : in out integer) is
- TC_offset : constant integer := 1;
-begin
- Param := Param + TC_offset;
-end LA14019_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140191.a b/gcc/testsuite/ada/acats/tests/l/la140191.a
deleted file mode 100644
index 8b7af2e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140191.a
+++ /dev/null
@@ -1,74 +0,0 @@
--- LA140191.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:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140190.A
--- -> LA140191.A
--- LA140192.AM
--- LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-generic
- type integer_type is range <>;
-procedure LA14019_1 (Test_val : in out integer);
-
-with LA14019_0;
-procedure LA14019_1 (Test_val : in out integer) is
- arr : array (1..5) of integer;
- sum : integer := 0;
- temp_val : integer := 0;
-begin
- arr(1) := Test_val;
- for i in 2..arr'last loop
- temp_val := arr(i-1);
- LA14019_0 (temp_val);
- arr(i) := temp_val;
- end loop;
- for i in 1..arr'last loop
- sum := sum + arr(i);
- end loop;
- Test_val := sum;
-end LA14019_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140192.am b/gcc/testsuite/ada/acats/tests/l/la140192.am
deleted file mode 100644
index c5f3290..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140192.am
+++ /dev/null
@@ -1,107 +0,0 @@
--- LA140192.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level generic procedure
--- depends on library level procedure that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a procedure, a generic procedure that
--- withs the first procedure and a main procedure that withs
--- the generic procedure. Then, a new version of the
--- procedure is compiled (in a separate file, simulating
--- and editing modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed function and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140190 (and include the results in the
--- program library).
--- 2) Compile the file LA140191 (and include the results in the
--- program library).
--- 3) Compile the file LA140192 (and include the results in the
--- program library).
--- 4) Compile the file LA140193 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140190.A
--- LA140191.A
--- -> LA140192.AM
--- LA140193.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140192 is missing or obsolete, or that LA14019_1 is
--- missing or obsolete (optional) and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14019_1; -- This dependency must be resolved
- -- after LA140193 is compiled.
-
-procedure LA140192 is
- subtype count is integer range 0..100;
- procedure Gen_proc is new LA14019_1 (count);
- TC_local : count := 0;
-begin
- Test ("LA14019", "Check that a compilation unit may " &
- "not depend semantically on two " &
- "different versions of the same " &
- "compilation unit. Check the case " &
- "where a library level generic " &
- "procedure depends on library level " &
- "procedure that is changed.");
-
- Gen_proc (TC_local);
-
- if TC_local = 10 then
- Failed ("Revised library level procedure not used");
- elsif TC_local /= 52 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140192;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140193.a b/gcc/testsuite/ada/acats/tests/l/la140193.a
deleted file mode 100644
index 717cc63..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140193.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140193.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:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140190.A
--- LA140191.A
--- LA140192.AM
--- -> LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14019_0 (Param : in out integer);
-
-
-procedure LA14019_0 (Param : in out integer) is
- Local_array : array (1..10) of float := (others => 0.0);
- Local_var : integer := 0;
- TC_var : constant integer := -9;
-
-begin
- Param := (1 + Param) * 2;
-end LA14019_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140200.a b/gcc/testsuite/ada/acats/tests/l/la140200.a
deleted file mode 100644
index 9adf75e..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140200.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- LA140200.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:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140200.A
--- LA140201.A
--- LA140202.AM
--- LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-package LA14020_0 is
-
- subtype apples is integer range 0..100;
- subtype oranges is integer range 0..200;
-
- type Fruit_Basket is tagged record
- App : apples;
- Ora : oranges;
- end record;
-
-end LA14020_0;
-
- --==================================================================--
-
-package LA14020_0.LA14020_1 is
-
- type Bigger_Basket is new Fruit_Basket with record
- Total : integer;
- end record;
-
-end LA14020_0.LA14020_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140201.a b/gcc/testsuite/ada/acats/tests/l/la140201.a
deleted file mode 100644
index 6682255..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140201.a
+++ /dev/null
@@ -1,71 +0,0 @@
--- LA140201.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:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140200.A
--- -> LA140201.A
--- LA140202.AM
--- LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-with LA14020_0;
-generic
- type Basket is new LA14020_0.Fruit_Basket with private;
-function LA14020_2 (Left, Right : Basket) return Basket;
-
- --==================================================================--
-
-function LA14020_2 (Left, Right : Basket) return Basket is
- Result : Basket;
-begin
- Result.App := Left.App + Left.App;
- Result.Ora := Right.Ora + Right.Ora;
- -- wrong algorithm, to be corrected later
-
- return Result;
-end LA14020_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140202.am b/gcc/testsuite/ada/acats/tests/l/la140202.am
deleted file mode 100644
index 1a4ed76..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140202.am
+++ /dev/null
@@ -1,144 +0,0 @@
--- LA140202.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a library level instance depends on
--- a library level generic function whose body is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic function, an instance of a generic
--- function that withs the first function and a main procedure that
--- withs the instance. Then a new version of the first generic function
--- is compiled (in a separate file, simulating editing and modification
--- of the unit). Unless automatic recompilation is supported, this
--- test should fail to link. Otherwise, the test should recompile and
--- link the correct version of the withed function and report "PASSED"
--- at execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140200 (and include the results in the
--- program library).
--- 2) Compile the file LA140201 (and include the results in the
--- program library).
--- 3) Compile the file LA140202 (and include the results in the
--- program library).
--- 4) Compile the file LA140203 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140200.A
--- LA140201.A
--- -> LA140202.AM
--- LA140203.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140202 is missing or obsolete, or that LA14020_3 or LA14020_4
--- is missing or obsolete (optional) and no executable image
--- results. The test passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation
--- supports automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-with LA14020_0.LA14020_1;
-with LA14020_2;
-pragma Elaborate (LA14020_2);
-function LA14020_3 is new LA14020_2 (LA14020_0.LA14020_1.Bigger_Basket);
-
- --==================================================================--
-
-with LA14020_0.LA14020_1;
-generic
- type Market_Basket is new LA14020_0.LA14020_1.Bigger_Basket with private;
- with function "+" (L,R: Market_Basket) return Market_Basket is <>;
-function LA14020_4 (B1, B2 : Market_Basket) return Market_Basket;
-
- --==================================================================--
-
-with LA14020_3;
-function LA14020_4 (B1, B2 : Market_Basket) return Market_Basket is
- Result : Market_Basket;
-begin
- Result := B1 + B2;
- Result.Total := integer (Result.App) + integer (Result.Ora);
- return Result;
-end LA14020_4;
-
- --==================================================================--
-
-with Report;
-
-with LA14020_0.LA14020_1;
-with LA14020_3;
-with LA14020_4;
-
-procedure LA140202 is
- package Child renames LA14020_0.LA14020_1;
-
- Basket_1 : Child.Bigger_Basket := (App => 5, Ora => 20, Total => 0);
- Basket_2 : Child.Bigger_Basket := (App => 7, Ora => 3, Total => 0);
-
- function Total is new LA14020_4 (Child.Bigger_Basket, LA14020_3);
-begin
- Report.Test ("LA14020", "Check that a compilation unit may " &
- "not depend semantically on two " &
- "different versions of the same " &
- "compilation unit. Check the case " &
- "where a library level instance " &
- "depends on a library level generic " &
- "function whose body is changed");
-
- Basket_1 := Total (Basket_1, Basket_2);
-
- if Basket_1.App = 10 or
- Basket_1.Ora = 6 or
- Basket_1.Total = 16
- then
- Report.Failed ("Revised generic function not used");
- elsif Basket_1.App /= 12 or
- Basket_1.Ora /= 23 or
- Basket_1.Total /= 35 then
- Report.Failed ("Incorrect result returned");
- end if;
-
- Report.Result;
-end LA140202;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140203.a b/gcc/testsuite/ada/acats/tests/l/la140203.a
deleted file mode 100644
index f2965b4..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140203.a
+++ /dev/null
@@ -1,71 +0,0 @@
--- LA140203.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:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140200.A
--- LA140201.A
--- LA140202.AM
--- -> LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-with LA14020_0;
-generic
- type Basket is new LA14020_0.Fruit_Basket with private;
-function LA14020_2 (Left, Right : Basket) return Basket;
-
- --==================================================================--
-
-function LA14020_2 (Left, Right : Basket) return Basket is
- Result : Basket;
-begin
- Result.App := Left.App + Right.App;
- Result.Ora := Left.Ora + Right.Ora;
- -- correct algorithm
-
- return Result;
-end LA14020_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140210.a b/gcc/testsuite/ada/acats/tests/l/la140210.a
deleted file mode 100644
index ab3ad5f..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140210.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140210.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:
--- See LA140211.AM.
---
--- TEST DESCRIPTION:
--- See LA140211.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140211.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140210.A
--- LA140211.AM
--- LA140212.A
---
--- PASS/FAIL CRITERIA:
--- See LA140211.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type swap_type is private;
- type int_type is range <>;
- times : int_type :=1;
-package LA14021_0 is
- procedure swap (this, for_that : in out swap_type);
-end LA14021_0;
-
----------------------------------------------------------
-
-package body LA14021_0 is
- procedure swap (this, for_that : in out swap_type) is
- temp : swap_type;
- begin
- for i in int_type'first..times loop
- temp := this;
- this := for_that;
- for_that := temp;
- end loop;
- end swap;
-end LA14021_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140211.am b/gcc/testsuite/ada/acats/tests/l/la140211.am
deleted file mode 100644
index f6b1757..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140211.am
+++ /dev/null
@@ -1,134 +0,0 @@
--- LA140211.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic package depends on another
--- generic package that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package, a second generic
--- package that withs the first and a main procedure that
--- withs the second package. Then, a new version of the
--- first package is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed function and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140210 (and include the results in the
--- program library).
--- 2) Compile the file LA140211 (and include the results in the
--- program library).
--- 3) Compile the file LA140212 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140210.A
--- -> LA140211.AM
--- LA140212.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14021_1 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008R baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved LA14021_0 to a separate file.
---
---!
-
-package LA14021_1 is
- type data_record is tagged
- record
- info : character;
- end record;
- subtype loop_count is integer range 1..100;
- type data_type is new data_record with
- record
- serial : integer := 0;
- end record;
-end LA14021_1;
-
----------------------------------------------------------
-
-with LA14021_1;
-with LA14021_0;
-generic
- type data_rec is new LA14021_1.data_record with private;
-package LA14021_2 is
- package util is new LA14021_0 (character, LA14021_1.loop_count);
- procedure flip_flop (rec1, rec2 : in out data_rec);
-end LA14021_2;
-
----------------------------------------------------------
-
-package body LA14021_2 is
- procedure flip_flop (rec1, rec2 : in out data_rec) is
- begin
- util.swap (rec1.info, rec2.info);
- end flip_flop;
-end LA14021_2;
-
----------------------------------------------------------
-
-with Report; use Report;
-with LA14021_1;
-with LA14021_2;
-
-procedure LA140211 is
- package util is new LA14021_2 (LA14021_1.data_type);
- datum_1 : LA14021_1.data_type := LA14021_1.data_type'('a', 1);
- datum_2 : LA14021_1.data_type := LA14021_1.data_type'('b', 2);
-begin
- Test ("LA14021", "Check that a compilation unit may " &
- "not depend semantically on two " &
- "different versions of the same " &
- "compilation unit. Check the case " &
- "where a generic package depends on " &
- "another generic package that is changed");
-
- util.flip_flop (datum_1, datum_2);
- if datum_1.info = 'b' then
- Failed ("Revised unit not used");
- elsif datum_1.info /= 'a' then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140211;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140212.a b/gcc/testsuite/ada/acats/tests/l/la140212.a
deleted file mode 100644
index 0c689b9..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140212.a
+++ /dev/null
@@ -1,74 +0,0 @@
--- LA140212.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:
--- See LA140211.AM.
---
--- TEST DESCRIPTION:
--- See LA140211.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140211.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140210.A
--- LA140211.AM
--- -> LA140212.A
---
--- PASS/FAIL CRITERIA:
--- See LA140211.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008R baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-generic
- type swap_type is private;
- type int_type is range <>;
- times : int_type :=2; --this line contains the change
-package LA14021_0 is
- procedure swap (this, for_that : in out swap_type);
-end LA14021_0;
-
----------------------------------------------------------
-
-package body LA14021_0 is
- procedure swap (this, for_that : in out swap_type) is
- temp : swap_type;
- begin
- for i in int_type'first..times loop
- temp := this;
- this := for_that;
- for_that := temp;
- end loop;
- end swap;
-end LA14021_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140220.a b/gcc/testsuite/ada/acats/tests/l/la140220.a
deleted file mode 100644
index c5e4c65..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140220.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140220.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:
--- See LA140221.AM.
---
--- TEST DESCRIPTION:
--- See LA140221.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140221.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140220.A
--- LA140221.AM
--- LA140222.A
---
--- PASS/FAIL CRITERIA:
--- See LA140221.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type stuff is private;
- type ptr is access stuff;
- type return_result is range <>;
- delta_val : return_result := 1;
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result);
-
--------------------------------------------------------
-
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result) is
-begin
- pointer := new stuff;
- result := result + delta_val;
-end LA14022_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140221.am b/gcc/testsuite/ada/acats/tests/l/la140221.am
deleted file mode 100644
index 84003a6..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140221.am
+++ /dev/null
@@ -1,128 +0,0 @@
--- LA140221.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic instantiation depends on
--- a generic procedure that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic procedure, a second generic
--- procedure, a generic instantiation of the second procedure
--- that depends on both the first and second generic
--- procedures, and a main procedure that withs the instantiated
--- procedure. Then, a new version of the first generic
--- procedure is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed function and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140220 (and include the results in the
--- program library).
--- 2) Compile the file LA140221 (and include the results in the
--- program library).
--- 3) Compile the file LA140222 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140220.A
--- -> LA140221.AM
--- LA140222.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14022_2 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008S baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved LA14022_0 to a separate file. Added
--- pragma Elaborate to context clause of
--- LA14022_2.
---
---!
-
-package LA14022_1 is
- type rec_ptr;
- type rec is record
- data : integer;
- end record;
- type rec_ptr is access rec;
- subtype data_int is integer range 0..100;
-end LA14022_1;
-
-
-with LA14022_0;
-with LA14022_1;
-pragma Elaborate (LA14022_0);
-procedure LA14022_2 is new
- LA14022_0 (stuff => LA14022_1.rec,
- ptr => LA14022_1.rec_ptr,
- return_result => LA14022_1.data_int,
- delta_val => 50);
-
-with Report;
-use Report;
-with LA14022_2;
-with LA14022_1;
-use LA14022_1;
-procedure LA140221 is
- TC_val : LA14022_1.data_int := 10;
- P, Q : LA14022_1.rec_ptr;
-begin
- Test ("LA14022", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a generic " &
- "instantiation depends on a generic " &
- "procedure that is changed");
-
- Q := P;
- LA14022_2 (Q, TC_val);
-
- if Q /= P then
- Failed ("Wrong procedure result");
- end if;
- if TC_val = 60 then
- Failed ("Old instantiation used");
- elsif TC_val /= 10 then
- Failed ("Wrong result");
- end if;
-
- Result;
-end LA140221;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140222.a b/gcc/testsuite/ada/acats/tests/l/la140222.a
deleted file mode 100644
index 424236b..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140222.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140222.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:
--- See LA140221.AM.
---
--- TEST DESCRIPTION:
--- See LA140221.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140221.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140220.A
--- LA140221.AM
--- -> LA140222.A
---
--- PASS/FAIL CRITERIA:
--- See LA140221.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008S baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-generic
- type stuff is private;
- type ptr is access stuff;
- type return_result is range <>;
- delta_val : return_result := 1;
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result);
-
--------------------------------------------------------
-
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result) is
-begin
- pointer := null;
- result := result + return_result'first;
-end LA14022_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140240.a b/gcc/testsuite/ada/acats/tests/l/la140240.a
deleted file mode 100644
index e554100..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140240.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140240.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:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140240.A
--- LA140241.A
--- LA140242.AM
--- LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-generic
- Local_max : positive;
- type Thing is private;
-package LA14024_0 is
- type Goodies is tagged
- record
- X, Y : integer := 100;
- end record;
-end LA14024_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140241.a b/gcc/testsuite/ada/acats/tests/l/la140241.a
deleted file mode 100644
index dde3b3d..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140241.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140241.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:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140240.A
--- -> LA140241.A
--- LA140242.AM
--- LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA14024_0;
-
-package LA14024_1 is new LA14024_0 (100, integer);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140242.am b/gcc/testsuite/ada/acats/tests/l/la140242.am
deleted file mode 100644
index a156465..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140242.am
+++ /dev/null
@@ -1,104 +0,0 @@
--- LA140242.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic instantiation depends on
--- a generic package that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package, a generic
--- instantiation of the generic package, and a main
--- procedure that withs the instantiated generic
--- package. Then, a new version of the first generic
--- package is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed package and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140240 (and include the results in the
--- program library).
--- 2) Compile the file LA140241 (and include the results in the
--- program library).
--- 3) Compile the file LA140242 (and include the results in the
--- program library).
--- 4) Compile the file LA140243 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140240.A
--- LA140241.A
--- -> LA140242.AM
--- LA140243.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140242 is missing or obsolete, or that LA14024_1 is
--- missing or obsolete (optional) and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14024_1;
-
-procedure LA140242 is
- TC_val : integer := 0;
- Local_goodies : LA14024_1.Goodies;
-begin
- Test ("LA14024", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a generic " &
- "instantiation depends on a generic " &
- "package that is changed");
-
- TC_val := Local_goodies.X;
-
- if TC_val = 100 then
- Failed ("Revised generic package not used");
- elsif TC_val /= -10 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140242;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140243.a b/gcc/testsuite/ada/acats/tests/l/la140243.a
deleted file mode 100644
index 98b0343..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140243.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140243.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:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140240.A
--- LA140241.A
--- LA140242.AM
--- -> LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-generic
- Local_max : positive;
- type Thing is private;
-package LA14024_0 is
- type Goodies is tagged
- record
- Y, X : integer := -10;
- end record;
-end LA14024_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140250.a b/gcc/testsuite/ada/acats/tests/l/la140250.a
deleted file mode 100644
index 44477df..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140250.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140250.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:
--- See LA140251.AM.
---
--- TEST DESCRIPTION:
--- See LA140251.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140251.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140050.A
--- LA140051.AM
--- LA140052.A
---
--- PASS/FAIL CRITERIA:
--- See LA140251.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14025_0 is
- subtype byte is integer range 0..511;
- byte_val : constant byte := 128;
- type Data_rec is tagged record
- Id : integer := 1;
- Val: byte := byte_val;
- end record;
-end LA14025_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140251.am b/gcc/testsuite/ada/acats/tests/l/la140251.am
deleted file mode 100644
index 7f7a479..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140251.am
+++ /dev/null
@@ -1,141 +0,0 @@
--- LA140251.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic instantiation depends on
--- a non-generic package that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a package, a generic package, a
--- generic instantiation that withs both of the first two
--- packages, and a main procedure that withs the instantiated
--- generic package. Then, a new version of the first
--- package is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the withed package and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140250 (and include the results in the
--- program library).
--- 2) Compile the file LA140251 (and include the results in the
--- program library).
--- 3) Compile the file LA140252 (and include the results in the
--- program library).
--- 4) Attempt to build an executable image.
--- 5) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140250.A
--- -> LA140251.AM
--- LA140252.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14025 is missing or obsolete, or that LA14025_2 is
--- missing or obsolete (optional) and no executable image
--- results. The test passes if an executable image is produced
--- and reports "PASSED" (in case the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008V baseline version
--- 06 JUL 95 SAIC Initial version
--- 08 NOV 96 SAIC Unit naming correction
--- 07 DEC 96 SAIC Moved LA14025_0 to a separate file. Added
--- pragma Elaborate to context clause of
--- LA14025_2.
---
---!
-
-with LA14025_0;
-generic
- type your_addition is (<>);
-package LA14025_1 is --extensions, utilities
- type extended_record is new LA14025_0.data_rec with record
- new_data : your_addition;
- end record;
- procedure stuff (param : your_addition);
- function fetch (param : LA14025_0.byte) return LA14025_0.byte;
-private
- obj : extended_record;
-end LA14025_1;
-
----------------------------------------------
-
-package body LA14025_1 is
- procedure stuff (param : your_addition) is
- begin
- obj.new_data := param;
- end stuff;
-
- function fetch (param : LA14025_0.byte) return LA14025_0.byte is
- begin
- return (param + obj.val);
- end fetch;
-end LA14025_1;
-
----------------------------------------------
-
-with LA14025_0;
-with LA14025_1;
-pragma Elaborate (LA14025_1);
-package LA14025_2 is new LA14025_1 (LA14025_0.byte);
-
----------------------------------------------
-
-with Report; use Report;
-with LA14025_2;
-with LA14025_0;
-procedure LA140251 is
- TC_val : LA14025_0.byte := 0;
- Temp_var : LA14025_2.extended_record;
-begin
- Test ("LA14025", "Check that a compilation unit may not " &
- "depend semantically on two different " &
- "versions of the same compilation unit. " &
- "Check the case where a generic " &
- "instantiation depends on a non-generic " &
- "package that is changed");
-
- LA14025_2.stuff(10);
-
- TC_val := LA14025_2.fetch (Temp_var.val);
-
- if TC_val = 256 then
- Failed ("Old version of package used");
- elsif TC_val /= 128 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140251;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140252.a b/gcc/testsuite/ada/acats/tests/l/la140252.a
deleted file mode 100644
index 2fce76c..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140252.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140252.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:
--- See LA140251.AM.
---
--- TEST DESCRIPTION:
--- See LA140251.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140251.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- LA140051.AM
--- -> LA140052.A
---
--- PASS/FAIL CRITERIA:
--- See LA140251.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008V baseline version
--- 06 JUL 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-package LA14025_0 is
- subtype byte is integer range 0..511;
- byte_val : constant byte := 64;
- type Data_rec is tagged record
- Id : integer := 1;
- Val: byte := byte_val;
- end record;
-end LA14025_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140260.a b/gcc/testsuite/ada/acats/tests/l/la140260.a
deleted file mode 100644
index fae1736..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140260.a
+++ /dev/null
@@ -1,98 +0,0 @@
--- LA140260.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:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140260.A
--- LA140261.A
--- LA140262.AM
--- LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14026_0 is
- type basic_rec is tagged
- record
- null;
- end record;
-end LA14026_0;
-
----------------------------------------------------------
-
-with LA14026_0;
-generic
- type data_type is private;
- type serial_type is range <>;
- serial_init : serial_type;
-package LA14026_1 is
-
- pragma Elaborate_Body;
-
- function get_serial_num return serial_type;
-
- type node_type is new LA14026_0.basic_rec with
- record
- data_field : data_type;
- serial_no : serial_type := get_serial_num;
- end record;
-end LA14026_1;
-
----------------------------------------------------------
-
-package body LA14026_1 is
- serial : serial_type := serial_init;
- function get_serial_num return serial_type is
- begin
- serial := serial + 1;
- return serial;
- end;
-end LA14026_1;
-
----------------------------------------------------------
-
-package LA14026_2 is
- subtype serial_type is integer range 0..5;
- subtype data_type is integer range 0..100;
-
- type data_rec is record
- F1 : data_type := data_type'first;
- F2 : data_type := data_type'last;
- end record;
-end LA14026_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140261.a b/gcc/testsuite/ada/acats/tests/l/la140261.a
deleted file mode 100644
index 73cd334..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140261.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140261.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:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140260.A
--- -> LA140261.A
--- LA140262.AM
--- LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14026_2, LA14026_1;
-package LA14026_3 is new LA14026_1 (LA14026_2.data_rec,
- LA14026_2.serial_type, 0);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140262.am b/gcc/testsuite/ada/acats/tests/l/la140262.am
deleted file mode 100644
index 1150947..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140262.am
+++ /dev/null
@@ -1,140 +0,0 @@
--- LA140262.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a generic instantiation depends on
--- a generic package instantiation that is changed.
---
--- TEST DESCRIPTION:
--- This test compiles a generic package, a generic
--- instantiation of the generic package, another generic
--- package, a generic instantiation of the second generic
--- package that withs the first generic instantiation
--- packages, and a main procedure that withs the instantiated
--- generic package. Then, a new version of the first generic
--- package is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the instantiation and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140260 (and include the results in the
--- program library).
--- 2) Compile the file LA140261 (and include the results in the
--- program library).
--- 3) Compile the file LA140262 (and include the results in the
--- program library).
--- 4) Compile the file LA140263 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140260.A
--- LA140261.A
--- -> LA140262.AM
--- LA140263.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA140260 is missing or obsolete, or that LA14026_5 is
--- missing or obsolete (optional) and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008W baseline version
--- 06 JUL 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Moved LA14026_3 to a separate file. Added
--- pragma Elaborate to context clause of LA14026_5.
---
---!
-
-with LA14026_0;
-generic
- type rec is new LA14026_0.basic_rec with private;
-package LA14026_4 is
- type extended_node;
- type extended_node_ptr is access extended_node;
- type extended_node is new rec with
- record
- next : extended_node_ptr := null;
- end record;
- procedure add_next (node : in out extended_node; ptr : extended_node_ptr);
-end LA14026_4;
-
----------------------------------------------------------
-
-package body LA14026_4 is
- procedure add_next (node : in out extended_node;
- ptr : extended_node_ptr) is
- begin
- node.next := ptr;
- end add_next;
-end LA14026_4;
-
----------------------------------------------------------
-
-with LA14026_3, LA14026_4;
-pragma Elaborate (LA14026_4);
-package LA14026_5 is new LA14026_4 (LA14026_3.node_type);
-
----------------------------------------------------------
-
-with Report;
-use Report;
-with LA14026_5;
-
-procedure LA140262 is
- root : LA14026_5.extended_node_ptr := new LA14026_5.extended_node;
- next : LA14026_5.extended_node_ptr := new LA14026_5.extended_node;
-begin
- Test ("LA14026","Check that a compilation unit may not depend " &
- "semantically on two different versions of " &
- "the same compilation unit. Check the case " &
- "where a generic instantiation depends on " &
- "a generic package instantiation that is " &
- "changed");
-
-
- LA14026_5.add_next (root.all, next);
-
- if root.all.next.serial_no = 2 then
- Failed ("Old version of unit used");
- elsif root.all.next.serial_no /= 5 then
- Failed ("Wrong value returned");
- end if;
-
- Result;
-end LA140262;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140263.a b/gcc/testsuite/ada/acats/tests/l/la140263.a
deleted file mode 100644
index c022489..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140263.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140263.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:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140260.A
--- LA140261.A
--- LA140262.AM
--- -> LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008W baseline version
--- 06 JUL 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14026_2, LA14026_1;
-package LA14026_3 is new LA14026_1 (LA14026_2.data_rec,
- LA14026_2.serial_type, 3);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140270.a b/gcc/testsuite/ada/acats/tests/l/la140270.a
deleted file mode 100644
index dab574c..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140270.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140270.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:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140270.A
--- LA140271.A
--- LA140272.AM
--- LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14027_0 is
- Sample_value : integer := 100;
-end LA14027_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140271.a b/gcc/testsuite/ada/acats/tests/l/la140271.a
deleted file mode 100644
index 703b1b8..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140271.a
+++ /dev/null
@@ -1,93 +0,0 @@
--- LA140271.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:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140270.A
--- -> LA140271.A
--- LA140272.AM
--- LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions. Removed loop from
--- task body to prevent hang.
---
---!
-
-package LA14027_1 is
- procedure Random (Number : out integer);
-end LA14027_1;
-
- --------------------------------------------
-
-package body LA14027_1 is
- task LA14027_2 is
- entry Get (Value : out integer);
- end LA14027_2;
-
- task body LA14027_2 is separate;
-
- procedure Random (Number : out integer) is
- begin
- -- get a random number from sampling task
- LA14027_2.Get (Number);
- -- massage it
- Number := Number + 10;
- -- and return it
- end;
-end LA14027_1;
-
- --------------------------------------------
-
-with LA14027_0; -- must resolve this
-
-separate (LA14027_1)
-
-task body LA14027_2 is
- begin
- select
- accept Get (Value : out integer) do
- -- sample some random physical process
- Value := LA14027_0.Sample_value;
- -- and return it
- end Get;
- end select;
-end LA14027_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140272.am b/gcc/testsuite/ada/acats/tests/l/la140272.am
deleted file mode 100644
index a8cd1c9..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140272.am
+++ /dev/null
@@ -1,102 +0,0 @@
--- LA140272.AM
---
--- 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 compilation unit may not depend semantically
--- on two different versions of the same compilation unit.
--- Check the case where a task body depends on non-generic
--- package specification.
---
--- TEST DESCRIPTION:
--- This test compiles a package spec, another package
--- with a body containing a task with a body that withs the
--- first package spec, and a main procedure that withs the
--- second package. Then, a new version of the first package
--- spec is compiled (in a separate file, simulating
--- editing and modification to the unit). Unless automatic
--- recompilation is supported, this test should fail to link.
--- Otherwise, the test should recompile and link the correct
--- version of the package spec and report "PASSED" at
--- execution time.
---
--- SPECIAL REQUIREMENTS:
--- To build this test:
--- 1) Compile the file LA140270 (and include the results in the
--- program library).
--- 2) Compile the file LA140271 (and include the results in the
--- program library).
--- 3) Compile the file LA140272 (and include the results in the
--- program library).
--- 4) Compile the file LA140273 (and include the results in the
--- program library).
--- 5) Attempt to build an executable image.
--- 6) If an executable image results, run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140270.A
--- LA140271.A
--- -> LA140272.AM
--- LA140273.A
---
--- PASS/FAIL CRITERIA:
--- The test passes if a link time error message reports that
--- LA14027_1.LA14027_2 is missing or obsolete and no executable image
--- results. The test also passes if an executable image is produced
--- and reports "PASSED" (in the case where the implementation supports
--- automatic recompilation).
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-with Report; use Report;
-with LA14027_1;
-
-procedure LA140272 is
- TC_val : integer := 0;
-begin
- Test ("LA14027", "Check that a compilation unit may not depend " &
- "semantically on two different versions of the " &
- "same compilation unit. Check the case where " &
- "a task body depends on non-generic package " &
- "specification");
-
- LA14027_1.Random (TC_val);
-
- if TC_val = 110 then
- Failed ("Old version used");
- elsif TC_val /= 0 then
- Failed ("Incorrect value returned");
- end if;
-
- Result;
-end LA140272;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140273.a b/gcc/testsuite/ada/acats/tests/l/la140273.a
deleted file mode 100644
index 0e535f1..0000000
--- a/gcc/testsuite/ada/acats/tests/l/la140273.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140273.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:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140270.A
--- LA140271.A
--- LA140272.AM
--- -> LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14027_0 is
- New_var : integer := 100;
- Local_array : array (1..51) of integer;
- Sample_value : constant integer := -10;
-end LA14027_0;